Класс для асинхронного ожидания объектов ядра.

Здесь можно найти готовые «кирпичики» — части кода, пригодные для построения более крупных проектов, а также решения различных типовых и не очень задач на VB.

Модератор: Brickgroup

The trick
Постоялец
Постоялец
 
Сообщения: 774
Зарегистрирован: 26.06.2010 (Сб) 23:08

Класс для асинхронного ожидания объектов ядра.

Сообщение The trick » 11.11.2014 (Вт) 16:26

ОПИСАНИЕ УСТАРЕЛО. АКТУАЛЬНОЕ ОПИСАНИЕ НА GITHUB.

На момент создания этого класса я не знал о Waiter'е GSerg'а. Решил выложить свой класс для тех же целей. Разработал класс для асинхронного ожидания объектов ядра. Класс генерирует событие при установке объекта в сигнальное состояние или при таймауте. Работает с любыми объектами.
Класс имеет 3 метода vbWaitForSingleObject, vbWaitForMultipleObjects, IsActive, Abort. Первые два аналогичны вызову одноименных API функций без префикса "vb" и запускают ожидание объекта в новом потоке. Методы завершаются немедленно. При завершении функций в новом потоке генерируется событие OnWait, в параметрах которого содержится описатель объекта и возвращенное значение. При удачном завершении методы возвращают True, иначе False, также генерируются исключения.
IsActive - возвращает True, если идет ожидание, иначе False.
Abort - прерывает ожидание, при удачном выполнении возвращает True.
Экземпляр класса может обрабатывать только один вызов за раз.
В примере я подготовил 3 случая использования данного класса: отслеживание тика ожидающего таймера, отслеживание завершения приложения, отслеживание файловых операций в любой папке.
Код: Выделить всё
' Класс clsTrickWait - класс для асинхронного ожидания объектов ядра
' © Кривоус Анатолий Анатольевич (The trick), 2014

Option Explicit

Private Type WNDCLASSEX
    cbSize          As Long
    style           As Long
    lpfnwndproc     As Long
    cbClsextra      As Long
    cbWndExtra2     As Long
    hInstance       As Long
    hIcon           As Long
    hCursor         As Long
    hbrBackground   As Long
    lpszMenuName    As Long
    lpszClassName   As Long
    hIconSm         As Long
End Type

Private Type SThreadArg
    hHandle         As Long
    dwTime          As Long
    hwnd            As Long
    pObj            As Long
    idEvent         As Long
    numOfParams     As Long
    pResult         As Variant
    pHandle         As Variant
End Type
Private Type MThreadArg
    hHandle         As Long
    dwTime          As Long
    WaitAll         As Long
    nCount          As Long
    hwnd            As Long
    pObj            As Long
    idEvent         As Long
    numOfParams     As Long
    pHandle         As Variant
    pResult         As Variant
End Type

Private Declare Function GetClassLong Lib "user32" Alias "GetClassLongW" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetClassLong Lib "user32" Alias "SetClassLongW" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetClassInfoEx Lib "user32" Alias "GetClassInfoExW" (ByVal hInstance As Long, ByVal lpClassName As Long, lpWndClassEx As WNDCLASSEX) As Long
Private Declare Function UnregisterClass Lib "user32" Alias "UnregisterClassW" (ByVal lpClassName As Long, ByVal hInstance As Long) As Long
Private Declare Function RegisterClassEx Lib "user32" Alias "RegisterClassExW" (pcWndClassEx As WNDCLASSEX) As Integer
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExW" (ByVal dwExStyle As Long, ByVal lpClassName As Long, ByVal lpWindowName As Long, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleW" (ByVal lpModuleName As Long) As Long
Private Declare Function CreateThread Lib "kernel32" (lpThreadAttributes As Any, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, lpParameter As Any, ByVal dwCreationFlags As Long, lpThreadId As Long) As Long
Private Declare Function TerminateThread Lib "kernel32" (ByVal hThread As Long, ByVal dwExitCode As Long) As Long
Private Declare Function GetExitCodeThread Lib "kernel32" (ByVal hThread As Long, lpExitCode As Long) As Long
Private Declare Function VirtualAlloc Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Private Declare Function VirtualFree Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
Private Declare Function GetMem4 Lib "msvbvm60" (pSrc As Any, pDst As Any) As Long
Private Declare Function GetMem2 Lib "msvbvm60" (pSrc As Any, pDst As Any) As Long
Private Declare Function ArrPtr Lib "msvbvm60" Alias "VarPtr" (pArr() As Any) As Long
Private Declare Function SafeArrayAllocDescriptor Lib "oleaut32.dll" (ByVal cDims As Long, ppsaOut() As Any) As Long
Private Declare Function SafeArrayDestroyDescriptor Lib "oleaut32.dll" (psa() As Any) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function HeapAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function HeapFree Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal lpMem As Long) As Long
Private Declare Function GetProcessHeap Lib "kernel32" () As Long
Private Declare Sub memcpy Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long

Private Const STILL_ACTIVE              As Long = &H103&
Private Const PAGE_EXECUTE_READWRITE    As Long = &H40&
Private Const MEM_COMMIT                As Long = &H1000&
Private Const MEM_RESERVE               As Long = &H2000&
Private Const MEM_RELEASE               As Long = &H8000&
Private Const HWND_MESSAGE              As Long = -3
Private Const WM_USER                   As Long = &H400
Private Const WM_ONWAIT                 As Long = WM_USER
Private Const HEAP_NO_SERIALIZE         As Long = &H1

Private Const MsgClass                  As String = "TrickWaitClass"
Private Const ErrInit                   As String = "Object not Initialized"
Private Const ErrAlloc                  As String = "Error allocating data"
Private Const ErrThrd                   As String = "Error creating thread"

Public Event OnWait(ByVal Handle As Long, ByVal Result As Long)

Dim hThread     As Long
Dim lpSThrd     As Long
Dim lpMThrd     As Long
Dim lpWndProc   As Long
Dim lpParam     As Long
Dim hwnd        As Long
Dim isInit      As Boolean

' // Запустить ожидание
Public Function vbWaitForSingleObject(ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Boolean

    Dim param   As SThreadArg
   
    If Not isInit Then Err.Raise vbObjectError + 513, , ErrInit: Exit Function
    If IsActive Then Exit Function

    param.hHandle = hHandle
    param.dwTime = dwMilliseconds
    param.hwnd = hwnd
    param.pObj = ObjPtr(Me)
    param.numOfParams = 2
    param.idEvent = 1
    param.pHandle = CVar(hHandle)
    param.pResult = CVar(0&)
   
    If lpParam = 0 Then
        lpParam = HeapAlloc(GetProcessHeap(), HEAP_NO_SERIALIZE, Len(param) + 8)
        If lpParam = 0 Then Err.Raise vbObjectError + 514, , ErrAlloc: Exit Function
    End If
   
    memcpy ByVal lpParam, param, Len(param)
   
    hThread = CreateThread(ByVal 0&, 0, lpSThrd, ByVal lpParam, 0, 0)
    If hThread = 0 Then Err.Raise vbObjectError + 515, , ErrThrd: Exit Function
   
    vbWaitForSingleObject = True
   
End Function

' // Запустить ожидание
Public Function vbWaitForMultipleObjects(ByVal nCount As Long, ByVal lpHandles As Long, ByVal bWaitAll As Long, ByVal dwMilliseconds As Long) As Boolean

    Dim param   As MThreadArg
   
    If Not isInit Then Err.Raise vbObjectError + 513, , ErrInit: Exit Function
    If IsActive Then Exit Function

    param.hHandle = lpHandles
    param.dwTime = dwMilliseconds
    param.numOfParams = nCount
    param.WaitAll = bWaitAll
    param.hwnd = hwnd
    param.pObj = ObjPtr(Me)
    param.numOfParams = 2
    param.idEvent = 1
    param.pHandle = CVar(lpHandles)
    param.pResult = CVar(0&)
   
    If lpParam = 0 Then
        lpParam = HeapAlloc(GetProcessHeap(), HEAP_NO_SERIALIZE, Len(param))
        If lpParam = 0 Then Err.Raise vbObjectError + 514, , ErrAlloc: Exit Function
    End If
   
    memcpy ByVal lpParam, param, Len(param)
   
    hThread = CreateThread(ByVal 0&, 0, lpMThrd, ByVal lpParam, 0, 0)
    If hThread = 0 Then Err.Raise vbObjectError + 515, , ErrThrd: Exit Function
   
    vbWaitForMultipleObjects = True
   
End Function

' // Активно ли ожидание
Public Function IsActive() As Boolean
   
    If Not isInit Then Err.Raise vbObjectError + 513, , ErrInit: Exit Function
   
    If hThread Then
        Dim code    As Long
       
        If GetExitCodeThread(hThread, code) Then
            If code = STILL_ACTIVE Then IsActive = True: Exit Function
        End If
       
        hThread = 0
    End If
End Function

' // Завершить ожидание
Public Function Abort() As Boolean

    If Not isInit Then Err.Raise vbObjectError + 513, , ErrInit: Exit Function

    If IsActive Then
        Abort = TerminateThread(hThread, 0)
        If Abort Then WaitForSingleObject hThread, -1
    End If
End Function

Private Sub Class_Initialize()

    Dim cls     As WNDCLASSEX
    Dim isFirst As Boolean
    Dim count   As Long
   
    cls.cbSize = Len(cls)
   
    If GetClassInfoEx(App.hInstance, StrPtr(MsgClass), cls) = 0 Then
       
        If Not CreateAsm Then Exit Sub
       
        cls.hInstance = App.hInstance
        cls.lpfnwndproc = lpWndProc
        cls.lpszClassName = StrPtr(MsgClass)
        cls.cbClsextra = 8
       
        If RegisterClassEx(cls) = 0 Then Exit Sub
       
        isFirst = True

    End If
   
    hwnd = CreateWindowEx(0, StrPtr(MsgClass), 0, 0, 0, 0, 0, 0, HWND_MESSAGE, 0, App.hInstance, ByVal 0&)
    If hwnd = 0 Then Exit Sub
   
    If isFirst Then
       
        SetClassLong hwnd, 0, lpSThrd: count = 1
    Else
       
        lpSThrd = GetClassLong(hwnd, 0):    lpMThrd = lpSThrd + &H28:   lpWndProc = lpSThrd + &H56
        count = GetClassLong(hwnd, 4) + 1
       
    End If
   
    SetClassLong hwnd, 4, count
   
    isInit = True
   
End Sub

Private Sub Class_Terminate()
   
    Dim count   As Long
   
    If Not isInit Then Exit Sub
       
    Abort
    If lpParam Then HeapFree GetProcessHeap(), HEAP_NO_SERIALIZE, lpParam
   
    count = GetClassLong(hwnd, 4) - 1
   
    DestroyWindow hwnd
   
    If count = 0 Then
       
        VirtualFree lpSThrd, 100, MEM_RELEASE
        UnregisterClass StrPtr(MsgClass), App.hInstance
       
    End If
   
End Sub

Private Function CreateAsm() As Boolean
    Dim lpWFSO  As Long
    Dim lpWFMO  As Long
    Dim lpSend  As Long
    Dim lpDef   As Long
    Dim lpEbMod As Long
    Dim lpDestr As Long
    Dim lpRaise As Long
    Dim hLib    As Long
    Dim isIDE   As Boolean
    Dim ptr     As Long
   
    Debug.Assert InIDE(isIDE)

    hLib = GetModuleHandle(StrPtr("kernel32")):                 If hLib = 0 Then Exit Function
    lpWFSO = GetProcAddress(hLib, "WaitForSingleObject"):       If lpWFSO = 0 Then Exit Function
    lpWFMO = GetProcAddress(hLib, "WaitForMultipleObjects"):    If lpWFMO = 0 Then Exit Function
    hLib = GetModuleHandle(StrPtr("user32")):                   If hLib = 0 Then Exit Function
    lpSend = GetProcAddress(hLib, "SendMessageW"):              If lpSend = 0 Then Exit Function
    lpDef = GetProcAddress(hLib, "DefWindowProcW"):             If lpDef = 0 Then Exit Function
   
    If isIDE Then
   
        lpDestr = GetProcAddress(hLib, "DestroyWindow"):        If lpDestr = 0 Then Exit Function
        hLib = GetModuleHandle(StrPtr("vba6")):                 If hLib = 0 Then Exit Function
        lpEbMod = GetProcAddress(hLib, "EbMode"):               If lpEbMod = 0 Then Exit Function
       
    End If
   
    hLib = GetModuleHandle(StrPtr("msvbvm60")):                 If hLib = 0 Then Exit Function
    lpRaise = GetProcAddress(hLib, "__vbaRaiseEvent"):          If lpRaise = 0 Then Exit Function
   
    ptr = VirtualAlloc(0, 100, MEM_RESERVE Or MEM_COMMIT, PAGE_EXECUTE_READWRITE)
    If ptr = 0 Then Exit Function
   
    Dim Dat()   As Long
    Dim i       As Long
    Dim lpArr   As Long
       
    SafeArrayAllocDescriptor 1, Dat
    lpArr = Not Not Dat

    GetMem4 ptr, ByVal lpArr + &HC: GetMem4 100&, ByVal lpArr + &H10
   
    Dat(0) = &H4244C8B:     Dat(1) = &H471FF51:     Dat(2) = &H69E831FF:    Dat(3) = &H59123456:    Dat(4) = &H8D204189:
    Dat(5) = &H50500C41:    Dat(6) = &H40068:       Dat(7) = &H871FF00:     Dat(8) = &H345653E8:    Dat(9) = &H4C212:
    Dat(10) = &H4244C8B:    Dat(11) = &H471FF51:    Dat(12) = &HFF0871FF:   Dat(13) = &HC71FF31:    Dat(14) = &H34563BE8:
    Dat(15) = &H41895912:   Dat(16) = &H14418D28:   Dat(17) = &H685050:     Dat(18) = &HFF000004:   Dat(19) = &H25E81071:
    Dat(20) = &HC2123456:   Dat(21) = &H81660004:   Dat(22) = &H8247C:      Dat(23) = &HE9057404:   Dat(24) = &H12345614
   
    GetMem4 lpWFSO - ptr - &HF, ByVal ptr + &HB     ' call WaitForSingleObject
    GetMem4 lpSend - ptr - &H25, ByVal ptr + &H21   ' call PostMessageW
    GetMem4 lpWFMO - ptr - &H3D, ByVal ptr + &H39   ' call WaitForMultipleObjects
    GetMem4 lpSend - ptr - &H53, ByVal ptr + &H4F   ' call PostMessageW
    GetMem4 lpDef - ptr - &H64, ByVal ptr + &H60    ' jmp  DefWindowProcW
   
    lpSThrd = ptr:          lpMThrd = ptr + &H28:   lpWndProc = ptr + &H56
   
    i = 25
   
    If isIDE Then

        Dat(i) = &H34560BE8:        Dat(i + 1) = &H74C08412: Dat(i + 2) = &H74013C09: Dat(i + 3) = &H55FEE913
        Dat(i + 4) = &H74FF1234:    Dat(i + 5) = &HF5E80424: Dat(i + 6) = &HE9123455: Dat(i + 7) = &H123455F0
   
        GetMem4 lpEbMod - ptr - &H69, ByVal ptr + &H65       ' call EbMode
        GetMem4 lpDestr - ptr - &H7F, ByVal ptr + &H7B       ' call DestroyWindow
        GetMem4 lpDef - ptr - &H76, ByVal ptr + &H72         ' jmp  DefWindowProcW
        GetMem4 lpDef - ptr - &H84, ByVal ptr + &H80         ' jmp  DefWindowProcW
       
        i = i + 8
       
    End If
   
    Dat(i) = &HC24748B:         Dat(i + 1) = &H892CEC83:    Dat(i + 2) = &HC931FCE7:    Dat(i + 3) = &HA5F30BB1
    Dat(i + 4) = &H3455DFE8:    Dat(i + 5) = &H2CC48312:    Dat(i + 6) = &H10C2

    GetMem4 lpRaise - ptr - (i * 4 + &H15), ByVal ptr + (i * 4 + &H11)   ' call __vbaRaiseEvent
   
    SafeArrayDestroyDescriptor Dat
    GetMem4 0&, ByVal ArrPtr(Dat)
   
    CreateAsm = True
   
End Function

Private Function InIDE(Value As Boolean) As Boolean: Value = True: InIDE = True: End Function

Как это работает.
Создается окно для приема уведомлений в главном потоке. При вызове метода ожидания создается новый поток с одноименной API функцией. Когда функция отрабатывает (по сигнальному состоянию, таймауту или ошибке) она передает сообщение нашему окну, которое обрабатывая его генерирует событие для текущего экземпляра объекта. Все манипуляции сделаны на ассемблере, что позволило обойтись одним классом (без модулей), к тому же для всех экземпляров используется один код. Также сделал небольшие проверки в IDE (в скомпилированном виде они отсутствуют), поэтому можно останавливать кнопкой "в среде", жать паузы без последствий (события просто не будут вызваны). Единственный способ "вылета" может произойти если запустить ожидание, остановить его кнопкой стоп (не вызвать деструктор). Потом опять запустить среду - если в этот момент отработает событие из прошлого запуска - будет вылет, т.к. того объекта уже нет.
Код на ассемблере (NASM):
Код: Выделить всё
[BITS 32]

WAITFORSINGLEOBJECT:
mov     ecx, [esp+4]
push    ecx
push    dword [ecx+4]          ; dwTime
push    dword [ecx]            ; hHandle
call    0x12345678             ; WaitForSingleObject
pop     ecx
mov     dword [ecx+32], eax    ; Long -> Variant
lea     eax, [ecx+12]
push    eax                    ; Параметры в RAISE (lParam)
push    eax                    ; ---               (wParam)
push    0x400                  ; WM_ONWAIT         (uMsg)
push    dword [ecx+8]          ; hWnd
call    0x12345678             ; PostMessage
ret     0x4

WAITFORMULTIPLEOBJECTS:
mov     ecx, [esp+4]
push    ecx
push    dword [ecx+4]          ; dwTime
push    dword [ecx+8]          ; WaitAll
push    dword [ecx]            ; lpHandles
push    dword [ecx+12]         ; nCount
call    0x12345678             ; WaitForMultipleObjects
pop     ecx
mov     dword [ecx+40], eax    ; Long -> Variant
lea     eax, [ecx+20]
push    eax                    ; Параметры в RAISE (lParam)
push    eax                    ; ---           (wParam)
push    0x400                  ; WM_ONWAIT         (uMsg)
push    dword [ecx+16]         ; hWnd
call    0x12345678             ; PostMessage
ret     0x4

WINDOWPROC:
cmp     word [esp+8], 0x400    ; If Msg = WM_ONWAIT
jz      WM_ONWAIT
jmp     0x12345678             ; DefWindowProc

WM_ONWAIT:

; Процедура для исключения падения в IDE

call    0x12345678             ; call EbMode
test    al,al                  ; Если остановлен
jz      CLEAR
cmp     al,1                   ; Если запущен
jz      RAISE
jmp     0x12345678             ; DefWindowProc

CLEAR:                         ; Очистка
push    dword [esp+4]          ; hwnd
call    0x12345678             ; DestroyWindow
jmp     0x12345678             ; DefWindowProc

; Конец заглушки

RAISE:                         ; Возбуждение события
mov     esi, dword [esp+0xc]   ; Указатель на источник
sub     esp, 44                ; 44 байт параметров
mov     edi, esp               ; Указатель на стек
cld                            ; df = 0 (увеличение счетчиков)
xor     ecx,ecx
mov     cl,11                  ; 44 Байт (параметры _vbaRaiseEvent и аргументы
rep     movsd
call    0x12345678             ; __vbaRaiseEvent
add     esp, 44
ret     0x10


Последняя версия.
Вложения
TrickWait.rar
Класс и тест.
(18.78 Кб) Скачиваний: 346
Последний раз редактировалось The trick 21.11.2021 (Вс) 2:37, всего редактировалось 1 раз.
UA6527P

Adam Smith
Бывалый
Бывалый
Аватара пользователя
 
Сообщения: 219
Зарегистрирован: 25.04.2008 (Пт) 9:04
Откуда: ЧР. Грозный

Re: Класс для асинхронного ожидания объектов ядра.

Сообщение Adam Smith » 09.12.2015 (Ср) 23:41

Из другой темы:
The trick писал(а):
Адская_Капча писал(а):Просто ее зациклить от начала до конца, а также убрать подпроцедуру CLEAR, правильно думаю?

Да, для ожидающих таймеров есть такой параметр как bManualReset, его нужно выставлять в False.


Напишите пожалуйста исправленную вставку, чтоб оставалось скопипастить фрагмент в класс вместо оригинала:
Код: Выделить всё
    Dat(0) = &H4244C8B:     Dat(1) = &H471FF51:     Dat(2) = &H69E831FF:    Dat(3) = &H59123456:    Dat(4) = &H8D204189:
    Dat(5) = &H50500C41:    Dat(6) = &H40068:       Dat(7) = &H871FF00:     Dat(8) = &H345653E8:    Dat(9) = &H4C212:
    Dat(10) = &H4244C8B:    Dat(11) = &H471FF51:    Dat(12) = &HFF0871FF:   Dat(13) = &HC71FF31:    Dat(14) = &H34563BE8:
    Dat(15) = &H41895912:   Dat(16) = &H14418D28:   Dat(17) = &H685050:     Dat(18) = &HFF000004:   Dat(19) = &H25E81071:
    Dat(20) = &HC2123456:   Dat(21) = &H81660004:   Dat(22) = &H8247C:      Dat(23) = &HE9057404:   Dat(24) = &H12345614

The trick
Постоялец
Постоялец
 
Сообщения: 774
Зарегистрирован: 26.06.2010 (Сб) 23:08

Re: Класс для асинхронного ожидания объектов ядра.

Сообщение The trick » 10.12.2015 (Чт) 0:11

Это был просто очень частный случай для функции с параметром False. По уму нужно делать не просто бесконечный цикл, а дополнительно его засинхронизировать для внешнего управления. Т.е. добавить эвент и ждать его, если эвент всегда установлен, цикл будет крутиться не останавливаясь, иначе функция будет ждать следующео вызова vbWaitForSingleObject. Пока нет возможности этим заниматься, но я уже планировал такой класс в DirectSound, потому что там довольно часто приходят уведомления о достижении определенной позиции в звуковых буферах. Тоже самое с DirectInput.
UA6527P

The trick
Постоялец
Постоялец
 
Сообщения: 774
Зарегистрирован: 26.06.2010 (Сб) 23:08

Re: Класс для асинхронного ожидания объектов ядра.

Сообщение The trick » 21.11.2021 (Вс) 2:39

Новая версия.

  1. Более стабильная работа;
  2. Исправлена утечка памяти;
  3. Оптимизирован и полностью переписан код;
  4. Проект переехал на GitHub.
UA6527P


Вернуться в Кирпичный завод

Кто сейчас на конференции

Сейчас этот форум просматривают: нет зарегистрированных пользователей и гости: 10

    TopList