Всем привет. Сейчас у меня мало времени, поэтому я уже не так часто уделяю внимание бейсику и реже появляюсь на форумах. Сегодня я опять буду говорить о многопоточности, на этот раз в Standart EXE. Сразу скажу что все о чем я пишу является моим личным исследованием и может в чем-то не соответствовать действительности; также из-за моего недостатка времени я буду дополнять этот пост по мере дальнейшего прогресса в исследовании данного вопроса. Итак начнем.
Как я говорил до этого для того чтобы многопоточность работала нужно инициализировать рантайм. Без инициализации мы можем работать очень ограниченно, в том смысле что COM не будет работать, т.е. грубо говоря вся мощь бейсика будет недоступна. Можно работать с API, объявленными в tlb, некоторыми функциями, также убирая проверку __vbaSetSystemError, можно использовать Declared-функции. Все предыдущие публикации показывали работу в отдельных DLL, и мы легко могли инициализировать рантайм используя VBDllGetClassObject функцию для этого. Сегодня мы попытаемся инициализировать рантайм в обычном EXE, т.е. не используя внешние зависимости. Не для кого не секрет что любое приложение написанное в VB6 состоит из хидера проекта, в котором содержится очень много информации о проекте которую рантайм использует для работы:
- Код: Выделить всё
Type VbHeader
szVbMagic As String * 4
wRuntimeBuild As Integer
szLangDll As String * 14
szSecLangDll As String * 14
wRuntimeRevision As Integer
dwLCID As Long
dwSecLCID As Long
lpSubMain As Long
lpProjectInfo As Long
fMdlIntCtls As Long
fMdlIntCtls2 As Long
dwThreadFlags As Long
dwThreadCount As Long
wFormCount As Integer
wExternalCount As Integer
dwThunkCount As Long
lpGuiTable As Long
lpExternalCompTable As Long
lpComRegisterData As Long
bszProjectDescription As Long
bszProjectExeName As Long
bszProjectHelpFile As Long
bszProjectName As Long
End Type
В этой структуре большое количество полей описывать все я не буду, отмечу только что эта структура ссылается на множество других структур. Некоторые из них нам понадобятся в дальнейшем, например поле lpSubMain, в котором содержится адрес процедуры Main, если она определена, иначе там 0.
Подавляющее большинство EXE файлов начинаются со следующего кода:
- Код: Выделить всё
PUSH xxxxxxxx
CALL MSVBVM60.ThunRTMain
Как раз xxxxxxxx указывает на структуру VBHeader. Эта особенность позволит найти эту структуру внутри EXE для инициализации рантайма. В одной из предыдущих частей я описывал как достать из ActiveX DLL эту структуру - для этого нужно было считать данные в одной из экспортируемых функций (к примеру DllGetClassObject). Для получения из EXE - мы также воспользуемся тем-же методом. Для начала нужно найти точку входа (entry point), т.е. адрес с которого начинается выполнение EXE. Этот адрес можно получить из структуры IMAGE_OPTIONAL_HEADER - поле AddressOfEntryPoint. Сама структура IMAGE_OPTIONAL_HEADER расположена в PE заголовке, а PE заголовок находится по смещению заданному в поле e_lfanew структуры IMAGE_DOS_HEADER, ну а структура IMAGE_DOS_HEADER расположена по адресу App.hInstance (или GetModuleHandle). Указатель на VbHeader будет лежать по смещению AddressOfEntryPoint + 1, т.к. опкод команды push в данном случае 0x68h. Итак, собирая все вместе, получим функцию для получения хидера:
- Код: Выделить всё
' // Get VBHeader structure
Private Function GetVBHeader() As Long
Dim ptr As Long
' Get e_lfanew
GetMem4 ByVal hModule + &H3C, ptr
' Get AddressOfEntryPoint
GetMem4 ByVal ptr + &H28 + hModule, ptr
' Get VBHeader
GetMem4 ByVal ptr + hModule + 1, GetVBHeader
End Function
Теперь если передать эту структуру функции VBDllGetClassObject в новом потоке, то, грубо говоря, эта функция запустит наш проект на выполнение согласно переданной структуре. Конечно смысла в этом мало - это тоже самое что начать выполнение приложения заново в новом потоке. Например если была задана функция Main, то и выполнение начнется опять с нее, а если была форма, то с нее. Нужно как-то сделать так, чтобы проект выполнялся с другой, нужной нам, функции. Для этого можно изменить поле lpSubMain структуры vbHeader. Я тоже сначала сделал так, но это ничего не дало. Как выяснилось, внутри рантайма есть один глобальный объект, который хранит ссылки на проекты и связанные с ними объекты и если передать тот же самый хидер в VBDllGetClassObject, то рантайм проверит, не загружался ли такой проект, и если загружался, то просто запустит новую копию без разбора структуры vbHeader, на основании предыдущего разбора. Поэтому я решил поступить так - можно скопировать структуру vbHeader в другое место и использовать ее. Сразу замечу, что в этой структуре последние 4 поля - это смещения относительно начала структуры, поэтому при копировании струкутуры их нужно будет скорректировать. Если теперь попробовать передать эту структуру в VBDllGetClassObject, то все будет отлично если в качестве стартапа установлена Sub Main, если же форма, то будет запущена и форма и после нее Main. Для исключения такого поведения нужно поправить кое-какие данные на которые ссылается хидер. Я пока точно не знаю что это за данные, т.к. не разбирался в этом, но "поковырявшись" внутри рантайма я нашел их место положение. Поле lpGuiTable структуры vbHeader ссылается на список структур tGuiTable, которые описывают формы в проекте. Структуры идут последовательно, число структур соответствует полю wFormCount структуры vbHeader. В сети я так и не нашел нормальное описание структуры tGuiTable, вот что есть:
- Код: Выделить всё
Type tGuiTable
lStructSize As Long
uuidObjectGUI As uuid
Unknown1 As Long
Unknown2 As Long
Unknown3 As Long
Unknown4 As Long
lObjectID As Long
Unknown5 As Long
fOLEMisc As Long
uuidObject As uuid
Unknown6 As Long
Unknown7 As Long
aFormPointer As Long
Unknown8 As Long
End Type
Как выяснилось внутри рантайма есть код, который проверяет поле Unknown5 каждой структуры:
Я проставил комментарии; из них видно что Unknown5 содержит флаги и если установлен 5-й бит, то происходит запись ссылки на какой-то объект, заданный регистром EAX, в поле со смещением 0x30 объекта заданного регистром EDX. Что за объекты - я не знаю, возможно позже разберусь с этим, нам важен сам факт записи какого-то значения в поле со смещением 0x30. Теперь, если дальше начать исследовать код то можно наткнутся на такой фрагмент:
Скажу что объект на который указывает ESI, тот же самый объект что в предыдущей рассматриваемой процедуре (регистр EDX). Видно что тестируется значение этого поля на -1 и на 0, и если там любое из этих чисел то запускается процедура Main (если она задана); иначе запускается первая форма.
Итак, теперь чтобы гарантированно запускать только Sub Main, мы изменяем флаг lpGuiTable.Unknown5, сбрасывая пятый бит. Для установки новой Sub Main и модификации флага я создал отдельную процедуру:
- Код: Выделить всё
' // Modify VBHeader to replace Sub Main
Private Sub ModifyVBHeader(ByVal newAddress As Long)
Dim ptr As Long
Dim old As Long
Dim flag As Long
Dim count As Long
Dim size As Long
ptr = lpVBHeader + &H2C
' Are allowed to write in the page
VirtualProtect ByVal ptr, 4, PAGE_READWRITE, old
' Set a new address of Sub Main
GetMem4 newAddress, ByVal ptr
VirtualProtect ByVal ptr, 4, old, 0
' Remove startup form
GetMem4 ByVal lpVBHeader + &H4C, ptr
' Get forms count
GetMem4 ByVal lpVBHeader + &H44, count
Do While count > 0
' Get structure size
GetMem4 ByVal ptr, size
' Get flag (unknown5) from current form
GetMem4 ByVal ptr + &H28, flag
' When set, bit 5,
If flag And &H10 Then
' Unset bit 5
flag = flag And &HFFFFFFEF
' Are allowed to write in the page
VirtualProtect ByVal ptr, 4, PAGE_READWRITE, old
' Write changet flag
GetMem4 flag, ByVal ptr + &H28
' Restoring the memory attributes
VirtualProtect ByVal ptr, 4, old, 0
End If
count = count - 1
ptr = ptr + size
Loop
End Sub
Теперь, если попробовать запустить эту процедуру перед передачей хидера в VBDllGetClassObject, то будет запускаться процедура, определенная нами. Впрочем многопоточность уже будет работать, но это не удобно, т.к. отсутствует механизм передачи параметра в поток как это реализовано в CreateThread. Для того чтобы сделать полный аналог CreateThread я решил создать аналогичную функцию, которая будет проводить все инициализации и после выполнять вызов переданной функции потока вместе с параметром. Для того чтобы была возможность передать параметр в Sub Main, я использовал локальное хранилище потока (TLS). Мы выделяем индекс для TLS. После выделения индекса мы сможем задавать значение этого индекса, специфичное для каждого потока. В общем идея такова, создаем новый поток, где стартовой функцией будет специальная функция ThreadProc, в параметр которой передаем структуру из двух полей - адреса пользовательской функции и адреса параметра. В этой процедуре мы будем инициализировать рантайм для нового потока и сохранять в TLS переданный параметр. В качестве процедуры Main создадим бинарный код, который будет доставать данные из TLS, формировать стек и прыгать на пользовательскую функцию. В итоге получился такой модуль:
modMultiThreading.bas
- Код: Выделить всё
' modMultiThreading.bas - The module provides support for multi-threading.
' © Кривоус Анатолий Анатольевич (The trick), 2015
Option Explicit
Private Type uuid
data1 As Long
data2 As Integer
data3 As Integer
data4(7) As Byte
End Type
Private Type threadData
lpParameter As Long
lpAddress As Long
End Type
Private tlsIndex As Long ' Index of the item in the TLS. There will be data specific to the thread.
Private lpVBHeader As Long ' Pointer to VBHeader structure.
Private hModule As Long ' Base address.
Private lpAsm As Long ' Pointer to a binary code.
' // Create a new thread
Public Function vbCreateThread(ByVal lpThreadAttributes As Long, _
ByVal dwStackSize As Long, _
ByVal lpStartAddress As Long, _
ByVal lpParameter As Long, _
ByVal dwCreationFlags As Long, _
lpThreadId As Long) As Long
Dim InIDE As Boolean
Debug.Assert MakeTrue(InIDE)
If InIDE Then
Dim ret As Long
ret = MsgBox("Multithreading not working in IDE." & vbNewLine & "Run it in the same thread?", vbQuestion Or vbYesNo)
If ret = vbYes Then
' Run function in main thread
ret = DispCallFunc(ByVal 0&, lpStartAddress, CC_STDCALL, vbEmpty, 1, vbLong, VarPtr(CVar(lpParameter)), CVar(0))
If ret Then
Err.Raise ret
End If
End If
Exit Function
End If
' Alloc new index from thread local storage
If tlsIndex = 0 Then
tlsIndex = TlsAlloc()
If tlsIndex = 0 Then Exit Function
End If
' Get module handle
If hModule = 0 Then
hModule = GetModuleHandle(ByVal 0&)
End If
' Create assembler code
If lpAsm = 0 Then
lpAsm = CreateAsm()
If lpAsm = 0 Then Exit Function
End If
' Get pointer to VBHeader and modify
If lpVBHeader = 0 Then
lpVBHeader = GetVBHeader()
If lpVBHeader = 0 Then Exit Function
ModifyVBHeader lpAsm
End If
Dim lpThreadData As Long
Dim tmpData As threadData
' Alloc thread-specific memory for threadData structure
lpThreadData = HeapAlloc(GetProcessHeap(), 0, Len(tmpData))
If lpThreadData = 0 Then Exit Function
' Set parameters
tmpData.lpAddress = lpStartAddress
tmpData.lpParameter = lpParameter
' Copy parameters to thread-specific memory
GetMem8 tmpData, ByVal lpThreadData
' Create thread
vbCreateThread = CreateThread(ByVal lpThreadAttributes, _
dwStackSize, _
AddressOf ThreadProc, _
ByVal lpThreadData, _
dwCreationFlags, _
lpThreadId)
End Function
' // Initialize runtime for new thread and run procedure
Private Function ThreadProc(lpParameter As threadData) As Long
Dim iid As uuid
Dim clsid As uuid
Dim lpNewHdr As Long
Dim hHeap As Long
' Initialize COM
vbCoInitialize ByVal 0&
' IID_IUnknown
iid.data4(0) = &HC0: iid.data4(7) = &H46
' Store parameter to thread local storage
TlsSetValue tlsIndex, lpParameter
' Create the copy of VBHeader
hHeap = GetProcessHeap()
lpNewHdr = HeapAlloc(hHeap, 0, &H6A)
CopyMemory ByVal lpNewHdr, ByVal lpVBHeader, &H6A
' Adjust offsets
Dim names() As Long
Dim diff As Long
Dim Index As Long
ReDim names(3)
diff = lpNewHdr - lpVBHeader
CopyMemory names(0), ByVal lpVBHeader + &H58, &H10
For Index = 0 To 3
names(Index) = names(Index) - diff
Next
CopyMemory ByVal lpNewHdr + &H58, names(0), &H10
' This line calls the binary code that runs the asm function.
VBDllGetClassObject VarPtr(hModule), 0, lpNewHdr, clsid, iid, 0
' Free memeory
HeapFree hHeap, 0, ByVal lpNewHdr
HeapFree hHeap, 0, lpParameter
End Function
' // Get VBHeader structure
Private Function GetVBHeader() As Long
Dim ptr As Long
' Get e_lfanew
GetMem4 ByVal hModule + &H3C, ptr
' Get AddressOfEntryPoint
GetMem4 ByVal ptr + &H28 + hModule, ptr
' Get VBHeader
GetMem4 ByVal ptr + hModule + 1, GetVBHeader
End Function
' // Modify VBHeader to replace Sub Main
Private Sub ModifyVBHeader(ByVal newAddress As Long)
Dim ptr As Long
Dim old As Long
Dim flag As Long
Dim count As Long
Dim size As Long
ptr = lpVBHeader + &H2C
' Are allowed to write in the page
VirtualProtect ByVal ptr, 4, PAGE_READWRITE, old
' Set a new address of Sub Main
GetMem4 newAddress, ByVal ptr
VirtualProtect ByVal ptr, 4, old, 0
' Remove startup form
GetMem4 ByVal lpVBHeader + &H4C, ptr
' Get forms count
GetMem2 ByVal lpVBHeader + &H44, count
Do While count > 0
' Get structure size
GetMem4 ByVal ptr, size
' Get flag (unknown5) from current form
GetMem4 ByVal ptr + &H28, flag
' When set, bit 5,
If flag And &H10 Then
' Unset bit 5
flag = flag And &HFFFFFFEF
' Are allowed to write in the page
VirtualProtect ByVal ptr, 4, PAGE_READWRITE, old
' Write changet flag
GetMem4 flag, ByVal ptr + &H28
' Restoring the memory attributes
VirtualProtect ByVal ptr, 4, old, 0
End If
count = count - 1
ptr = ptr + size
Loop
End Sub
' // Create binary code.
Private Function CreateAsm() As Long
Dim hMod As Long
Dim lpProc As Long
Dim ptr As Long
hMod = GetModuleHandle(ByVal StrPtr("kernel32"))
lpProc = GetProcAddress(hMod, "TlsGetValue")
If lpProc = 0 Then Exit Function
ptr = VirtualAlloc(ByVal 0&, &HF, MEM_RESERVE Or MEM_COMMIT, PAGE_EXECUTE_READWRITE)
If ptr = 0 Then Exit Function
' push tlsIndex
' call TLSGetValue
' pop ecx
' push DWORD [eax]
' push ecx
' jmp DWORD [eax + 4]
GetMem4 &H68, ByVal ptr + &H0: GetMem4 &HE800, ByVal ptr + &H4
GetMem4 &HFF590000, ByVal ptr + &H8: GetMem4 &H60FF5130, ByVal ptr + &HC
GetMem4 &H4, ByVal ptr + &H10: GetMem4 tlsIndex, ByVal ptr + 1
GetMem4 lpProc - ptr - 10, ByVal ptr + 6
CreateAsm = ptr
End Function
Private Function MakeTrue(value As Boolean) As Boolean
MakeTrue = True: value = True
End Function
Все API декларации я сделал в отдельной библиотеке типов - EXEInitialize.tlb. Пока найден один недостаток - не работают формы с приватными контролами, если разберусь в чем причина - исправлю. Работает только в скомпилированном варианте.
В архиве содержится несколько тестов.
1-й: создание формы в новом потоке, с возможностью блокировки ввода посредством длинного цикла.
2-й: обработка событий от объекта, метод которого вызван в другом потоке. Сразу скажу так делать нельзя и неправильно, т.к. передавать между потоками ссылку без маршаллинга опасно и может привести к глюкам, к тому же обработка события выполняется в другом потоке. Этот пример я оставил в качестве демонстрации работы многопоточности, а не для использования в повседневных задачах.
3-й: демонстрация изменения значения общей переменной в одном потоке и считывание его из другого.
Всем удачи!
Update: 27.05.2015
В IDE запуск осуществляется в главном потоке по желанию.
Добавлен 4-й тест - получение списка простых чисел в отдельном потоке.
Update: 01.06.2015
Добавлена нативная DLL которая экспортирует vbCreateThread.
Внесены изменения в код чтобы поддерживать эту возможность.
Скачать материалы.