Ссылка скрыта от гостей
[DOUBLEPOST=1437742101,1437741896][/DOUBLEPOST]код либы допиленный мной до кроссплатформенности (на маке не проверял, КМК)
Код:
Option Public
Option Declare
Use "ErrorHandling"
%REM Библиотека MQ, версия 1.1
http://www-12.lotus.com/ldd/doc/tools/c/6.5/api65ug.nsf/0/05faf7d6737bf1d085256368005a7b9d?OpenDocument
Кратко, очереди сообщений - это межтредовый (т.е в пределах одного инстанса клиента или сервера) асинхронный механизм передачи коротких, до 240 байт строковых сообщений.
Перезагрузка клиента или сервера закрывает и убивает все очереди и сообщения. это очень кратко.
Предлагаемые два класса LScript'а реализуют (инкапсулируют) достаточный, но не полный набор MQxxx апишных функций. Отлаживались они только под win32- R5, но в R6 , думаю, должны работать, т.к. никаких противопоказаний нет.
Первый, базовый класс NotesMessageQueue
Свойства:
QueueName ro String название очереди
isOwner ro Integer флаг, что очередь создана этим объектом
AutoClose rw Integer флаг, очередь закрывает владелец, в деструкторе
Messages ro Integer число сообщений в очереди
Message rw String запись и чтение сообщений из очереди, чтение удаляет сообщение, чтение из пустой очереди вызывает rt ошибку
Конструктор:
set mq=New NotesMessageQueue("QueueName") - создает или открывает уже существующую очередь, выставляет свойство-флаг isOwner
Второй, derived класс NotesUIMessageQueue, отличается от базового, тем, что может работать только на клиенте, т.к создает\использует NotesTimer.
Объект этого класса создавать не имеет смысла, его надо наследовать и переписать его конструктор и метод OnMessageAction.
Конструктор:
set mq=New NotesUIMessageQueue("QueueName",CheckIntervalInSeconds) - второй параметр конструктора это интервал проверки сообщений в секундах.
Свойства:
MessageList ro Variant список (list as string) принятых сообщений
MessageListCount ro Integer число сообщений в списке MessageList
Методы:
OnMessageAction - метод, который надо переписать в наследуемом классе, для каких-либо осознанных действий с сообщениями.
В коде, наверняка есть ошибки, его можно улучшать и улучшать, но для прототипа\идеи он сгодится
%END REM
'ДА (с) 2004. копирайт ест, их двое мальчик и девочка, они всегда хотят есть...
' за бубликацию ссылка обязательна
' использовать данный код можно везде, где вам позволит совесть.
Private Const MQ_MAX_MSGSIZE = &HF0 '(MAXONESEGSIZE - 0x40)
Private Const NOPRIORITY = &HFFFF ' MAXWORD
'Private Const ERR_MQ_POOLFULL = 1024 + 94 '"Insufficient memory - Message Queue pool is full."
'Private Const ERR_MQ_TIMEOUT = 1024 + 95 '"Timeout occurred waiting for message.")
'Private Const ERR_MQSCAN_ABORT = 1024 + 96 'Message Queue scan was aborted.")
Private Const ERR_DUPLICATE_MQ = 1024 + 97 '"Message Queue name already in use.")
'Private Const ERR_NO_SUCH_MQ = 1024 + 98 '"No Message Queue with that name.")
'Private Const ERR_MQ_EXCEEDED_QUOTA = 1024 + 99 '"Message Queue is full.")
Private Const ERR_MQ_EMPTY = 1024 + 100 '"Message Queue is empty.")
'Private Const ERR_MQ_BFR_TOO_SMALL = 1024 + 101 '"Message is larger than the buffer provided.")
Private Const ERR_MQ_QUITTING = 1024 + 102 '"Quit is pending on the Message Queue")
' Routine definitions
'Private Declare Function apiMQPutQuitMsg Lib "nnotes.dll" Alias "MQPutQuitMsg" (ByVal Queue As Long)
'Private Declare Function apiMQIsQuitPending Lib "nnotes.dll" Alias "MQIsQuitPending" (ByVal Queue As Long) As Integer
'
' функция обработки ошибок CAPI, содрана и переделана у D. Katz
Declare Function apiMQCreate Lib "nnotes.dll" Alias "MQCreate" (ByVal QueueName As String, ByVal Quota As Integer, ByVal Options As Long) As Integer
Declare Function apiMQOpen Lib "nnotes.dll" Alias "MQOpen" (ByVal QueueName As String, ByVal Options As Long, RetQueue As Long) As Integer
Declare Function apiMQClose Lib "nnotes.dll" Alias "MQClose" (ByVal Queue As Long, ByVal Options As Long) As Integer
Declare Function apiMQPut Lib "nnotes.dll" Alias "MQPut" (ByVal Queue As Long, ByVal Priority As Integer, ByVal Buffer As LMBCS String, ByVal Length As Integer, ByVal Options As Long) As Integer
Declare Function apiMQGet Lib "nnotes.dll" Alias "MQGet" (ByVal Queue As Long, ByVal Buffer As LMBCS String, ByVal BufLength As Integer, ByVal Options As Long, ByVal timeout As Long, retMsgLength As Integer) As Integer
Declare Function apiMQGetCount Lib "nnotes.dll" Alias "MQGetCount" (ByVal Queue As Long) As Integer
Declare Function apiOSLoadString Lib "nnotes.dll" Alias "OSLoadString" (ByVal hModule As Long, ByVal StringCode As Integer, ByVal retBuffer As LMBCS String, ByVal BufferLength As Integer) As Integer
'*nix
Declare Function apiMQCreateU Lib "libnotes.so" Alias "MQCreate" (ByVal QueueName As String, ByVal Quota As Integer, ByVal Options As Long) As Integer
Declare Function apiMQOpenU Lib "libnotes.so" Alias "MQOpen" (ByVal QueueName As String, ByVal Options As Long, RetQueue As Long) As Integer
Declare Function apiMQCloseU Lib "libnotes.so" Alias "MQClose" (ByVal Queue As Long, ByVal Options As Long) As Integer
Declare Function apiMQPutU Lib "libnotes.so" Alias "MQPut" (ByVal Queue As Long, ByVal Priority As Integer, ByVal Buffer As LMBCS String, ByVal Length As Integer, ByVal Options As Long) As Integer
Declare Function apiMQGetU Lib "libnotes.so" Alias "MQGet" (ByVal Queue As Long, ByVal Buffer As LMBCS String, ByVal BufLength As Integer, ByVal Options As Long, ByVal timeout As Long, retMsgLength As Integer) As Integer
Declare Function apiMQGetCountU Lib "libnotes.so" Alias "MQGetCount" (ByVal Queue As Long) As Integer
Declare Function apiOSLoadStringU Lib "libnotes.so" Alias "OSLoadString" (ByVal hModule As Long, ByVal StringCode As Integer, ByVal retBuffer As LMBCS String, ByVal BufferLength As Integer) As Integer
'mac os x
Declare Private Function apiMQCreateM Lib "libnotes.dylib" Alias "MQCreate" (ByVal QueueName As String, ByVal Quota As Integer, ByVal Options As Long) As Integer
Declare Private Function apiMQOpenM Lib "libnotes.dylib" Alias "MQOpen" (ByVal QueueName As String, ByVal Options As Long, RetQueue As Long) As Integer
Declare Private Function apiMQCloseM Lib "libnotes.dylib" Alias "MQClose" (ByVal Queue As Long, ByVal Options As Long) As Integer
Declare Private Function apiMQPutM Lib "libnotes.dylib" Alias "MQPut" (ByVal Queue As Long, ByVal Priority As Integer, ByVal Buffer As LMBCS String, ByVal Length As Integer, ByVal Options As Long) As Integer
Declare Private Function apiMQGetM Lib "libnotes.dylib" Alias "MQGet" (ByVal Queue As Long, ByVal Buffer As LMBCS String, ByVal BufLength As Integer, ByVal Options As Long, ByVal timeout As Long, retMsgLength As Integer) As Integer
Declare Private Function apiMQGetCountM Lib "libnotes.dylib" Alias "MQGetCount" (ByVal Queue As Long) As Integer
Declare Private Function apiOSLoadStringM Lib "libnotes.dylib" Alias "OSLoadString" (ByVal hModule As Long, ByVal StringCode As Integer, ByVal retBuffer As LMBCS String, ByVal BufferLength As Integer) As Integer
Private ses As NotesSession
Public Class NotesMessageQueueBase
Private hMQ As Long
Private mName As String
Private misOwner As Integer
Private mAutoClose As Integer
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Property Get QueueName As String
QueueName = mName
End Property
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Property Get isOwner As Integer
isOwner = misOwner
End Property
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Property Get AutoClose As Integer
AutoClose = mAutoClose
End Property
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Property Set AutoClose As Integer
mAutoClose = AutoClose
End Property
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Property Get Messages As Integer
End Property
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
%REM
*--------------------------------------------
Function MQGet
Description: Comments for Function
%END REM
Private Function MQGet() As String
Dim routineName As String
routineName="MQGet"
On Error GoTo ErrH
'your code here
MQGet={}
Quit:
Exit Function
ErrH:
Error Err, RaiseError
Resume Quit
End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Property Get Message As String
Message=Me.MQGet()
End Property
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Property Set Message As String
End Property
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub New(MQName As String)
If UCase(TypeName(Me))Like{*BASE} Then Error 1024,"Class Should be inherited"
End Sub
End Class
Public Class NotesMessageQueueW32 As NotesMessageQueueBase
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Property Get Messages As Integer
If hMQ<>0 Then Messages=apiMQGetCount(hMQ)
End Property
%REM
*--------------------------------------------
Function MQGet
Description: Comments for Function
%END REM
Private Function MQGet() As String
Dim routineName As String
routineName="MQGet"
On Error GoTo ErrH
'your code here
Dim msg As String
Dim ret As Integer
Dim status As Integer
msg = Space(MQ_MAX_MSGSIZE-1) + Chr(0)
apiCall "MQGet:"+mName, apiMQGet(hMQ, msg, MQ_MAX_MSGSIZE, 0, 0, ret)
MQGet=Left(msg,ret)
Quit:
Exit Function
ErrH:
Error Err, RaiseError
Resume Quit
End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Property Set Message As String
If Message<>"" Then apiCall "MQPut:"+mName, apiMQPut(hMQ, NOPRIORITY, Message, LenB(Message), 0 )
End Property
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub New(MQName As String)
Dim status As Integer
misOwner=True
mAutoClose=True
mName=Trim( mqName)
If Len(mName)>0 Then
status= apiMQCreate(mName,NOPRIORITY,0)
If status=ERR_DUPLICATE_MQ Then misOwner=False
apiCall "MQOpen", apiMQOpen(mName,0,hMQ)
Else
Error 1024+110,"MessageQueue name is empty string…"
End If
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub Delete
If misOwner And mAutoClose And hMQ<>0 Then Call apiMQClose(hMQ,0)
End Sub
End Class
Public Class NotesMessageQueueU As NotesMessageQueueBase
%REM
*--------------------------------------------
Property Get Message
Description: Comments for Property Get
%END REM
Property Set Message As String
Dim routineName As String
routineName="Message"
On Error GoTo ErrH
'your code here
If Message<>"" Then apiCall "MQPut:"+mName, apiMQPutU(hMQ, NOPRIORITY, Message, LenB(Message), 0 )
Quit:
Exit Property
ErrH:
Error Err, RaiseError
Resume Quit
End Property
%REM
*--------------------------------------------
Property Get Messages
Description: Comments for Property Get
%END REM
Property Get Messages As Integer
Dim routineName As String
routineName="Messages"
On Error GoTo ErrH
'your code here
If hMQ<>0 Then Messages=apiMQGetCountU(hMQ)
Quit:
Exit Property
ErrH:
Error Err, RaiseError
Resume Quit
End Property
%REM
*--------------------------------------------
Function MQGet
Description: Comments for Function
%END REM
Private Function MQGet() As String
Dim routineName As String
routineName="MQGet"
On Error GoTo ErrH
'your code here
Dim msg As String
Dim ret As Integer
Dim status As Integer
msg = Space(MQ_MAX_MSGSIZE-1) + Chr(0)
apiCall "MQGet:"+mName, apiMQGetU(hMQ, msg, MQ_MAX_MSGSIZE, 0, 0, ret)
MQGet=Left(msg,ret)
Quit:
Exit Function
ErrH:
Error Err, RaiseError
Resume Quit
End Function
%REM
*--------------------------------------------
Sub New
Description: Comments for Sub
%END REM
Sub New(MQName As String)
Dim routineName As String
routineName="New"
On Error GoTo ErrH
'your code here
Dim status As Integer
misOwner=True
mAutoClose=True
mName=Trim( mqName)
If Len(mName)>0 Then
status= apiMQCreateU(mName,NOPRIORITY,0)
If status=ERR_DUPLICATE_MQ Then misOwner=False
apiCall "MQOpen", apiMQOpenU(mName,0,hMQ)
Else
Error 1024+110,"MessageQueue name is empty string…"
End If
Quit:
Exit Sub
ErrH:
Error Err, RaiseError
Resume Quit
End Sub
%REM
*--------------------------------------------
Sub Delete
Description: Comments for Sub
%END REM
Sub Delete
Dim routineName As String
routineName="Delete"
On Error GoTo ErrH
'your code here
If misOwner And mAutoClose And hMQ<>0 Then Call apiMQCloseU(hMQ,0)
Quit:
Exit Sub
ErrH:
Error Err, RaiseError
Resume Quit
End Sub
End Class
'***********************************
Public Class NotesUIMessageQueue
Private nTimer As NotesTimer
Private mList List As String
Private mListCount As Integer
Private MQ As NotesMessageQueueBase
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Property Get Message As String
Dim msg As String
msg=MQ.Message
If msg<>"" Then
mList(CStr(mListCount))=msg
mListCount=mListCount+1
End If
Message=msg
End Property
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Property Get MessageList As Variant
MessageList=mList
End Property
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Property Get MessageListCount As Integer
MessageListCount=mListCount
End Property
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Method for overloading
Public Sub OnMessageAction
Print me.MQ.QueueName &{:} &MQ.Message
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub New(xMQ As NotesMessageQueueBase, checkInterval As Integer)
Set nTimer = New NotesTimer(checkInterval)
Set MQ=xMQ
On Event Alarm From nTimer Call nAlarm
End Sub
Private Sub nAlarm(pTimer As NotesTimer)
pTimer.Enabled=False
If MQ.Messages>0 Then Call Me.OnMessageAction
' While NotesMessageQueue..Messages>0
' mList(Cstr(mListCount))=NotesMessageQueue..Message
' mListCount=mListCount+1
' Wend
pTimer.Enabled=True
End Sub
End Class
Public Class NotesMessageQueueM As NotesMessageQueueBase
%REM
*--------------------------------------------
Property Get Message
Description: Comments for Property Get
%END REM
Property Set Message As String
Dim routineName As String
routineName="Message"
On Error GoTo ErrH
'your code here
If Message<>"" Then apiCall "MQPut:"+mName, apiMQPutM(hMQ, NOPRIORITY, Message, LenB(Message), 0 )
Quit:
Exit Property
ErrH:
Error Err, RaiseError
Resume Quit
End Property
%REM
*--------------------------------------------
Property Get Messages
Description: Comments for Property Get
%END REM
Property Get Messages As Integer
Dim routineName As String
routineName="Messages"
On Error GoTo ErrH
'your code here
If hMQ<>0 Then Messages=apiMQGetCountM(hMQ)
Quit:
Exit Property
ErrH:
Error Err, RaiseError
Resume Quit
End Property
%REM
*--------------------------------------------
Function MQGet
Description: Comments for Function
%END REM
Private Function MQGet() As String
Dim routineName As String
routineName="MQGet"
On Error GoTo ErrH
'your code here
Dim msg As String
Dim ret As Integer
Dim status As Integer
msg = Space(MQ_MAX_MSGSIZE-1) + Chr(0)
apiCall "MQGet:"+mName, apiMQGetM(hMQ, msg, MQ_MAX_MSGSIZE, 0, 0, ret)
MQGet=Left(msg,ret)
Quit:
Exit Function
ErrH:
Error Err, RaiseError
Resume Quit
End Function
%REM
*--------------------------------------------
Sub New
Description: Comments for Sub
%END REM
Sub New(MQName As String)
Dim routineName As String
routineName="New"
On Error GoTo ErrH
'your code here
Dim status As Integer
misOwner=True
mAutoClose=True
mName=Trim( mqName)
If Len(mName)>0 Then
status= apiMQCreateM(mName,NOPRIORITY,0)
If status=ERR_DUPLICATE_MQ Then misOwner=False
apiCall "MQOpen", apiMQOpenM(mName,0,hMQ)
Else
Error 1024+110,"MessageQueue name is empty string…"
End If
Quit:
Exit Sub
ErrH:
Error Err, RaiseError
Resume Quit
End Sub
%REM
*--------------------------------------------
Sub Delete
Description: Comments for Sub
%END REM
Sub Delete
Dim routineName As String
routineName="Delete"
On Error GoTo ErrH
'your code here
If misOwner And mAutoClose And hMQ<>0 Then Call apiMQCloseM(hMQ,0)
Quit:
Exit Sub
ErrH:
Error Err, RaiseError
Resume Quit
End Sub
End Class
%REM
*********************************************
Class NotesMessageQueue
Description: Comments for Class
%END REM
Class NotesMessageQueue As NotesMessageQueueBase
Private Queue As NotesMessageQueueBase
Private platform As String
%REM
*--------------------------------------------
Sub New
Description: Comments for Sub
%END REM
Sub New(MQName As String)
Dim routineName As String
routineName="New"
On Error GoTo ErrH
'your code here
platform=ses.Platform
Select Case UCase(platform)
Case {UNIX}:
Set Queue=New NotesMessageQueueU(MQName)
Case "WINDOWS/32":
Set Queue=New NotesMessageQueueW32(MQName)
Case "MACINTOSH"
Set Queue=New NotesMessageQueueM(MQName)
Case Else
Error 1024, {code is not implemented for platfom:} &platform
End Select
Quit:
Exit Sub
ErrH:
Error Err, RaiseError
Resume Quit
End Sub
%REM
*--------------------------------------------
Property Get Message
Description: Comments for Property Get
%END REM
Property Set Message As String
Dim routineName As String
routineName="Message"
On Error GoTo ErrH
'your code here
me.Queue.Message=Message
Quit:
Exit Property
ErrH:
Error Err, RaiseError
Resume Quit
End Property
%REM
*--------------------------------------------
Property Get Messages
Description: Comments for Property Get
%END REM
Property Get Messages As Integer
Dim routineName As String
routineName="Messages"
On Error GoTo ErrH
'your code here
Messages=me.Queue.Messages
Quit:
Exit Property
ErrH:
Error Err, RaiseError
Resume Quit
End Property
%REM
*--------------------------------------------
Property Get Message
Description: Comments for Property Get
%END REM
Property Get Message As String
Dim routineName As String
routineName="Message"
On Error GoTo ErrH
'your code here
Message=me.Queue.MQGet()
Quit:
Exit Property
ErrH:
Error Err, RaiseError
Resume Quit
End Property
End Class
Sub Initialize
Set ses=New NotesSession
End Sub
Private Sub apiCall(apiCallName As String, Status As Integer)
'This function takes the 16-bit status value (set by returning from most api function calls), and returns the "english" version of the error.
Dim Err_Mask As Integer
Dim errorStr As String
If Status = 0 Then Exit Sub
'Strip the two highest-order bits from status (remember, status is only 16 bits total). Those two bits show location of the error (local or remote server, etc.)
'They should be stripped so that the reference number of the error can be looked up appropriately.
Err_Mask = &H3FFF
Status = Status And Err_Mask
'We need to pass the C function a string it can overwrite (so that the memory for the string is already allocated when the OSLoadString is called)
errorStr =String(255,CLng(0))
Dim platform As String:platform=ses.Platform
Select Case UCase(platform)
Case {UNIX}:
Status = apiOSLoadStringU(0, Status, errorStr, Len(errorStr) - 1)
Case "WINDOWS/32":
Status = apiOSLoadString(0, Status, errorStr, Len(errorStr) - 1)
Case "MACINTOSH"
Status = apiOSLoadStringM(0, Status, errorStr, Len(errorStr) - 1)
Case Else
Error 1024, {code is not implemented for platfom:} &platform _
&{Status:} &CStr(Status)
End Select
Error Status, apiCallName + "::"+errorStr
End Sub
