
oThreads=0  && just in case some threads still alive, fire destructor before anything else gets released
CLEAR ALL
CLEAR
#define WAIT_TIMEOUT                     258
#define WM_USER 0x400
 
SET EXCLUSIVE OFF
SET SAFETY OFF
SET ASSERTS ON
CREATE TABLE ThreadLog (threadid i, timestamp t,misc c(80)) && A table into which each thread will insert results
USE ThreadLog && open shared
TEXT TO cstrVFPCode TEXTMERGE NOSHOW && generate the task to run: MyThreadFunc
      PROCEDURE MyThreadFunc(p2)    && p2 is the 2nd param to MyDoCmd
            TRY   && use exception handling
                  DECLARE integer GetCurrentThreadId in WIN32API
                  DECLARE integer PostMessage IN WIN32API integer hWnd, integer nMsg, integer wParam, integer lParam
                  cPath=SUBSTR(p2,AT(",",p2)+1)
                  hWnd=INT(VAL(p2))
                  CREATEOBJECT("SearchDisk",cPath)
                  PostMessage(hWnd, WM_USER, 0, GetCurrentThreadId())   && Tell main thread we're just about done!
            CATCH TO oex
                  INSERT INTO <<DBF()>> VALUES (GetCurrentThreadId(), DATETIME(),p2+" Error: "+oex.message+" "+oex.details+" "+TRANSFORM(oex.lineno))
            ENDTRY
DEFINE CLASS SearchDisk as Session
      hAbortEvent=0
      PROCEDURE init(cPath)
            DECLARE integer CreateEvent IN WIN32API integer lpEventAttributes, integer bManualReset, integer bInitialState, string lpName
            DECLARE integer WaitForSingleObject IN WIN32API integer hHandle, integer dwMilliseconds
            DECLARE integer GetLastError IN WIN32API
            this.hAbortEvent = CreateEvent(0,0,0,"VFPAbortThreadEvent") && Get the existing event
            IF this.hAbortEvent = 0
                  THROW "Creating event error:"+TRANSFORM(GetLastError())
            ENDIF
            DECLARE integer Sleep in WIN32API integer
            DECLARE integer CloseHandle IN WIN32API integer
            nStart=SECONDS()
            fUseCritSects=.t. && try with .f.
            IF fUseCritSects
                  SYS(2336,1) && Enter a critical section. First thread in wins
            ENDIF
            IF !FILE("files.dbf")
                  IF !fUseCritSects      
                        Sleep(1000) && give a chance for other threads to come in here!
                  ENDIF
                  CREATE TABLE files (path c(100), size n(10))
            ENDIF
            USE files SHARED && reopen shared
            IF fUseCritSects
                  SYS(2336,2) && Exit the critical section
            ENDIF
            cResult = TRANSFORM(this.RecurPath(cPath))      && search disk to gather files into table. Returns file count
            nDuration = SECONDS()-nStart
            nDesiredDuration=5      && # secs
            IF nDuration < nDesiredDuration     && let's make the thread proc last longer: OS caches disk results
*                 Sleep((nDesiredDuration - nDuration)*1000)
            ENDIF
            IF this.IsThreadAborted()     && if main thread said to abort
                  cResult=cResult+ " Aborted"
            ENDIF
            INSERT INTO <<DBF()>> VALUES (GetCurrentThreadId(), DATETIME(),TRANSFORM(cPath)+":"+cResult)
      PROCEDURE IsThreadAborted as Boolean
            IF WaitForSingleObject(this.hAbortEvent,0) = WAIT_TIMEOUT
                  RETURN .f.
            ENDIF
            RETURN .t.
      PROCEDURE RecurPath(cPath as String) as Integer
            LOCAL n,i,aa[1],nRetval
            nRetval=0
            n = ADIR(aa,cPath+"*.*","D")
            FOR i = 1 TO n
                  IF "D"$aa[i,5]    && if it's a dir
                        IF aa[i,1] != '.'
*                             nRetval=nRetval + this.RecurPath(cPath+aa[i,1]+"\")   && be careful!
                        ENDIF
                  ELSE
                        INSERT INTO files VALUES (cPath+aa[i,1], aa[i,2])
                        nRetval=nRetval+1
                        IF this.IsThreadAborted()     && Did main thread request abort
                              EXIT
                        ENDIF
                  ENDIF
            ENDFOR
            RETURN nRetval
      PROCEDURE Destroy
            CloseHandle(this.hAbortEvent)
ENDDEFINE
ENDTEXT
STRTOFILE(cstrVFPCode,"MyThreadFunc.prg")
COMPILE MyThreadFunc.prg
 
ERASE files.dbf   && reinit
?"Starting Threads",SECONDS()
PUBLIC nThreadsAlive    && Track # of threads still around
nThreadsAlive=3
PUBLIC oThreads
oThreads=CREATEOBJECT("ThreadManager")
oThreads.CreateThread("MyThreadFunc","c:\","ThreadDone(1)")
oThreads.CreateThread("MyThreadFunc","c:\Windows\","ThreadDone(2)")
oThreads.CreateThread("MyThreadFunc","c:\Windows\System\","ThreadDone(3)")
INKEY(.1)   && idle a bit: lets see how many files we get, before we stop the threads
TRY
      oThreads.SendMsgToStopThreads()     && might have already been released
CATCH TO oEx
      ?oEx.message
ENDTRY
 
RETURN
 
PROCEDURE ThreadDone(nThread)
      nThreadsAlive=nThreadsAlive-1
      IF nThreadsAlive=0      && If all threads done
            ACTIVATE screen   && in case user activated a form
            ?"All threads done",SECONDS()
            nDatasession =SET("Datasession")
            SET DATASESSION TO 1
            SELECT ThreadLog
            FLOCK()     && make sure we refresh results from other threads
            LIST
            SELECT 0
            USE  files
            ?TRANSFORM(RECCOUNT())+" files found "
            SET DATASESSION TO (nDataSession)
            RELEASE oThreads
      ENDIF
RETURN
 
 
#define CREATE_SUSPENDED                  0x00000004
#define INFINITE            0xFFFFFFFF 
#define WAIT_TIMEOUT                     258
#define ERROR_ALREADY_EXISTS             183
#define CLSCTX_INPROC_SERVER 1
#define CLSCTX_LOCAL_SERVER 4
#define     VT_BSTR  8
 
DEFINE CLASS ThreadClass as session
      hProcHeap =0
      nThreads=0
      DIMENSION hThreads[1]   && Handle to each thread
      DIMENSION hThreadIds[1] && ID for each thread
      cThreadHandles="" && Handle to each thread as a string rep of an int array
      PROCEDURE Init
            DECLARE integer LoadLibrary IN WIN32API string
            DECLARE integer FreeLibrary IN WIN32API integer
            DECLARE integer GetProcAddress IN WIN32API integer hModule, string procname
            DECLARE integer CreateThread IN WIN32API integer lpThreadAttributes, ;
                  integer dwStackSize, integer lpStartAddress, integer lpParameter, integer dwCreationFlags, integer @ lpThreadId
            DECLARE integer ResumeThread IN WIN32API integer thrdHandle
            DECLARE integer CloseHandle IN WIN32API integer Handle
            DECLARE integer GetProcessHeap IN WIN32API
            DECLARE integer HeapAlloc IN WIN32API integer hHeap, integer dwFlags, integer dwBytes
            DECLARE integer HeapFree IN WIN32API integer hHeap, integer dwFlags, integer lpMem
            DECLARE integer WaitForSingleObject IN WIN32API integer hHandle, integer dwMilliseconds
            DECLARE integer WaitForMultipleObjects IN WIN32API integer nCount, string pHandles, integer bWaitAll, integer dwMsecs
            DECLARE integer CLSIDFromProgID IN ole32 string lpszProgID, string @ strClSID
            DECLARE integer CLSIDFromString IN ole32 string lpszProgID, string @ strClSID
            DECLARE integer SysAllocString IN oleaut32 string wstr
            DECLARE integer SysFreeString IN oleaut32 integer bstr
            CREATE CURSOR memAllocs (memPtr i, AllocType c(1))    && track mem allocs that need to be freed: H=Heap,B=BSTR,L=Library
            this.hProcHeap = GetProcessHeap()
      PROCEDURE StartThreads(nThreads as Integer, ThreadCmd as String, ThreadProcParam as String,cStrIid as String )
            this.nThreads = nThreads
            cClsId=SPACE(16)
            IF CLSIDFromProgID(STRCONV("t1.c1"+CHR(0),5),@cClsId)!= 0   && dual interface
                  ?"Error: class not found"
                  RETURN
            ENDIF
            cIid=SPACE(16)
            CLSIDFromString(STRCONV(cStrIid+CHR(0),5),@cIid)
            nLocals = 30      && sufficiently large for local vars
            sCode=""          && generate machine code for thread procedure into a string
*           sCode = sCode + CHR(0xcc)     && int 3    DebugBreak() to attach a debugger
            sCode = sCode + CHR(0x55)                                                                 && push ebp
            sCode = sCode + CHR(0x8b) + CHR(0xec)                                               && mov ebp, esp
            sCode = sCode + CHR(0x81) + CHR(0xec)+BINTOC(nLocals * 4, "4rs") && sub esp, nLocals
 
            sCode = sCode + CHR(0x6a) + CHR(0x00)     && push 0
            sCode = sCode + this.CallDllFunction("CoInitialize", "ole32")
     
            sCode = sCode + this.GenCodeAtPoint("BeforeStart")
            sCode = sCode + CHR(0x8d) + CHR(0x45)+CHR(0xf0) && lea eax, [ebp-10h]   && addr to put COM ptr
            sCode = sCode + CHR(0x50)     && push eax
            sCode = sCode + CHR(0xb8) + BINTOC(this.MakeStr(cIid),"4rs")      && mov eax, str
            sCode = sCode + CHR(0x50)     && push eax
            sCode = sCode + CHR(0xb8) + BINTOC(CLSCTX_INPROC_SERVER+CLSCTX_LOCAL_SERVER,"4rs")      && mov eax, val
            sCode = sCode + CHR(0x50)     && push eax
            sCode = sCode + CHR(0x6a) + CHR(0x00)     && push 0
            sCode = sCode + CHR(0xb8) + BINTOC(this.MakeStr(cClsId),"4rs")    && mov eax, str
            sCode = sCode + CHR(0x50)     && push eax
            sCode = sCode + this.CallDllFunction("CoCreateInstance", "ole32")
            sCode = sCode + this.GenCodeAtPoint("AfterCreating")
 
            sCode = sCode + CHR(0x8d) + CHR(0x45)+CHR(0xe0) && lea eax, [ebp-20h]   && local var to get the vtResult of the COM call
            sCode = sCode + CHR(0x50)     && push eax
            sCode = sCode + this.CallDllFunction("VariantInit", "oleaut32")   && Initialize the vtResult
 
            *call MyDoCmd via early binding. First push the parms
            sCode = sCode + CHR(0x8d) + CHR(0x45)+CHR(0xe0) && lea eax, [ebp-20h]   && pass the address of vtResult for return value
            sCode = sCode + CHR(0x50)     && push eax
            *Now we need to push 3 empty variants, each of which is 4 DWORDS
            sCode = sCode + CHR(0x33) + CHR(0xc0)     && xor eax,eax
            sCode = sCode + REPLICATE(CHR(0x50),12)   && push eax 12 times
           
            *2nd param is P2:
            sCode = sCode + CHR(0x33) + CHR(0xc0)     && xor eax,eax
            sCode = sCode + CHR(0x50)     && push eax
            sCode = sCode + CHR(0x8b) + CHR(0x45) + CHR(0x8)      && mov eax,[ebp+8]      && Form the P2 param as a Variant from the BSTR arg from the parent thread
            sCode = sCode + CHR(0x50)     && push eax
            sCode = sCode + CHR(0x33) + CHR(0xc0)     && xor eax,eax
            sCode = sCode + CHR(0x50)     && push eax
            sCode = sCode + CHR(0xb8) + BINTOC(VT_BSTR,"4rs")     && mov eax, VT_BSTR
            sCode = sCode + CHR(0x50)     && push eax
           
            *1st param is the expr for VFP to Exec.
            sCode = sCode + CHR(0xb8)+BINTOC(this.MakeStr(ThreadCmd,.t.,.t.),"4rs") && mov eax, cExpr (p2 is 2nd param to MyDoCmd)
            sCode = sCode + CHR(0x50)     && push eax
 
            *Now make the call
            sCode = sCode + CHR(0x8b) + CHR(0x45) + CHR(0xf0)     && mov eax, [ebp-10h]   && the COM ptr
            sCode = sCode + CHR(0x50)     && push eax
            sCode = sCode + CHR(0x8b) + CHR(0)  && mov eax, [eax] && et the vTable
            sCode = sCode + CHR(0xff) + CHR(0x50) + CHR(0x1c)     && call  [eax+1ch] && call indirect the function at 1ch in the vTable
            sCode = sCode + this.GenCodeAtPoint("AfterCalling")
 
            *Free the return value with VariantClear because it's ignored
            sCode = sCode + CHR(0x8d) + CHR(0x45)+CHR(0xe0) && lea eax, [ebp-20h]
            sCode = sCode + CHR(0x50)     && push eax
            sCode = sCode + this.CallDllFunction("VariantClear", "oleaut32")
 
            sCode = sCode + this.GenEndCode(.t.)
 
            AdrCode=this.memAlloc(LEN(sCode),sCode)   && allocate memory for the code
            DIMENSION this.hThreads[nThreads]
            this.cThreadHandles=""
            FOR i = 1 TO nThreads
                  bstrArg=this.MakeStr(STRTRAN(ThreadProcParam,"%threadnum",TRANSFORM(i)),.t.,.t.)
                  dwThreadId=0
                  this.hThreads[i] = CreateThread(0,8192, AdrCode, bstrArg, CREATE_SUSPENDED, @dwThreadId)      && create suspended
                  this.hThreadIds[i]=dwThreadId
                  this.cThreadHandles = this.cThreadHandles+BINTOC(this.hThreads[i],"4rs")      && put the handles into a string rep of an int array
                  ResumeThread(this.hThreads[i])      && now start thread once all data is stored so no race condition
            ENDFOR
      PROCEDURE GenCodeAtPoint(nPoint as String) as String  && derived classes can override to gen code to exec at various points
            RETURN ""
      PROCEDURE GenEndCode(fRelease as Boolean) as String   && generate code to end thread
            LOCAL sCode
            sCode=""
            IF fRelease && do we also release COM obj?
                  *ptr->Release()
                  sCode = sCode + CHR(0x8b) + CHR(0x45) + CHR(0xf0)     && mov eax, [ebp-10h]
                  sCode = sCode + CHR(0x50)     && push eax             && push the THIS ptr
                  sCode = sCode + CHR(0x8b) + CHR(0)  && mov eax, [eax] && get the vTable
                  sCode = sCode + CHR(0xff) + CHR(0x50) + CHR(0x8)      && call  [eax+8h]
            ENDIF
           
            sCode = sCode + this.GenCodeAtPoint("BeforeEnd")
            sCode = sCode + this.CallDllFunction("CoUninitialize", "ole32")
 
            sCode = sCode + CHR(0x33) + CHR(0xc0)     && xor eax,eax    && make ExitCodeThread= 0
            sCode = sCode + CHR(0x8b) + CHR(0xe5)     && mov esp, ebp
            sCode = sCode + CHR(0x5d)                       && pop ebp       
            sCode = sCode + CHR(0xc2)+CHR(0x04)+CHR(0x00)   && ret 4
            RETURN sCode
 
      PROCEDURE WaitForThreads(cExpr as String)
            DO WHILE WaitForMultipleObjects(this.nThreads, this.cThreadHandles, 1, 500) = WAIT_TIMEOUT      && wait msecs for the threads to finish
                  &cExpr      && execute any passed in param while waiting
            ENDDO
      PROCEDURE MemAlloc(nSize as Integer, cStr as String) as Integer
            LOCAL nAddr
            nAddr = HeapAlloc(this.hProcHeap, 0, nSize)     && allocate memory
            ASSERT nAddr != 0 MESSAGE "Out of memory"
            INSERT INTO memAllocs VALUES (nAddr,"H") && track them for freeing later
            SYS(2600,nAddr, LEN(cStr),cStr)           && copy the string into the mem
            RETURN nAddr
      PROCEDURE CallDllFunction(strExport as String, strDllName as String) as String
            *Create a string of machine code that calls a function in a DLL. Parms should already be pushed
            LOCAL nAddr as Integer, hModule as Integer
            hModule = LoadLibrary(strDllName)
            INSERT INTO memAllocs VALUES (hModule,"L")      && track loads for freeing later
            nAddr=GetProcAddress(hModule,strExport)
            ASSERT nAddr != 0 MESSAGE "Error: Export not found "+ strExport+" "+ strDllName
            RETURN CHR(0xb8)+BINTOC(nAddr,"4rs") + CHR(0xff) + CHR(0xd0)      && mov eax, addr; call eax
      PROCEDURE MakeStr(str as String, fConvertToUnicode as Logical, fMakeBstr as Logical) as Integer
            * converts a string into a memory allocation and returns a pointer
            LOCAL nRetval as Integer
            IF fConvertToUnicode
                  str=STRCONV(str+CHR(0),5)
            ELSE
                  str = str + CHR(0)      && null terminate
            ENDIF
            IF fMakeBstr
                  nRetval= SysAllocString(str)
                  ASSERT nRetval != 0 MESSAGE "Out of memory"
                  INSERT INTO memAllocs VALUES (nRetval,"B")      && track them for freeing later
            ELSE
                  nRetval= this.MemAlloc(LEN(str),str)
            ENDIF
            RETURN nRetval
      PROCEDURE Destroy
            LOCAL i
*           ?PROGRAM()
            SELECT memAllocs
            SCAN
                  DO CASE
                  CASE AllocType="B"      && BSTR
                        SysFreeString(memPtr)
                  CASE AllocType="H"      && Heap
                        HeapFree(this.hProcHeap,0,memPtr)
                  CASE AllocType="L"      && LoadLibrary
                        FreeLibrary(memPtr)
                  ENDCASE
            ENDSCAN
            FOR i = 1 TO this.nThreads
                  CloseHandle(this.hThreads[i])
            ENDFOR
ENDDEFINE
 
DEFINE CLASS ThreadClassEx as ThreadClass
      cDoneCmd =""
      PROCEDURE GenCodeAtPoint(sPoint as String) as String
            LOCAL sCode,nPatch
            sCode=""
            DO CASE
            CASE sPoint = "BeforeStart"
*                 sCode = sCode + CHR(0x6a) + CHR(0x00)     && push 0
*                 sCode = sCode + this.CallDllFunction("MessageBeep", "user32")     && MessageBeep(0)
            CASE sPoint = "BeforeEnd"
*                 sCode = sCode + this.GenMessageBox("BeforeThreadEnd","Thread Proc")
            CASE sPoint = "AfterCreating"
*           sCode = sCode + CHR(0xcc)     && int 3    DebugBreak() to attach a debugger
                  sCode = sCode + CHR(0x83) + CHR(0xf8) + CHR(0x00)     && cmp eax, 0     && check return value
                  sCode = sCode + CHR(0x74)+CHR(0x00) && je nBytes && nBytes calc'd below. je= Jump if Equal
                  nPatch = LEN(sCode)     && track the byte that needs patching
                  sCode = sCode + this.GenMessageBox("Error "+sPoint+" COM object","Thread Proc")
                  sCode = sCode + this.GenEndCode(.f.)      && generate end thread code, without release
                  sCode=LEFT(sCode,nPatch-1) + CHR(LEN(sCode)-nPatch)+ SUBSTR(sCode,nPatch+1)      && now fix up the jump location to jump around GenEndcode
            CASE sPoint = "AfterCalling"
*           sCode = sCode + CHR(0xcc)     && int 3    DebugBreak() to attach a debugger
                  sCode = sCode + CHR(0x83) + CHR(0xf8) + CHR(0x00)     && cmp eax, 0     && check return value
                  sCode = sCode + CHR(0x74)+CHR(0x00) && je nBytes && nBytes calc'd below. je= Jump if Equal
                  nPatch = LEN(sCode)     && track the byte that needs patching
                  sCode = sCode + this.GenMessageBox("Error "+sPoint+" COM object","Thread Proc")
                  sCode = sCode + this.GenEndCode(.t.)      && generate end thread code, with release
                  sCode=LEFT(sCode,nPatch-1) + CHR(LEN(sCode)-nPatch)+ SUBSTR(sCode,nPatch+1)      && now fix up the jump location to jump around GenEndcode
            OTHERWISE
                  ASSERT .f. MESSAGE "Unknown GenCodeCase "+sPoint
            ENDCASE
      RETURN sCode
      PROCEDURE GenMessageBox(strMessage as String, strCaption as String) as String
            LOCAL sCode
            * MessageBox: call the Unicode (Wide char) version
            sCode = CHR(0x6a) + CHR(0x00) && push 0
            sCode = sCode + CHR(0xb8)+BINTOC(this.MakeStr(strCaption,.t.),"4rs")    && mov eax, str
            sCode = sCode + CHR(0x50)     && push eax
            sCode = sCode + CHR(0xb8)+BINTOC(this.MakeStr(strMessage,.t.),"4rs")    && mov eax, str
            sCode = sCode + CHR(0x50)     && push eax
            sCode = sCode + CHR(0x6a) + CHR(0x00)     && push 0
            sCode = sCode + this.CallDllFunction("MessageBoxW", "user32")
      RETURN sCode
ENDDEFINE
 
DEFINE CLASS ThreadManager AS Session
      nThreads = 0
      nLiveThreads=0
      hAbortEvent=0
      DIMENSION aoThread[1]
      PROCEDURE init
            DECLARE integer CreateEvent IN WIN32API integer lpEventAttributes, integer bManualReset, integer bInitialState, string lpName
            DECLARE integer GetLastError IN WIN32API
            DECLARE integer SetEvent IN WIN32API integer
            DECLARE integer ResetEvent IN WIN32API integer
            DECLARE integer Sleep in WIN32API integer
            this.hAbortEvent = CreateEvent(0,1,0,"VFPAbortThreadEvent")
            IF this.hAbortEvent = 0
                  ?"Creating event error:",GetLastError()
            ELSE
                  IF GetLastError()=ERROR_ALREADY_EXISTS
                        ResetEvent(this.hAbortEvent)
                  ENDIF
            ENDIF
      PROCEDURE CreateThread(ThreadProc as String, ThreadProcParam as String,cDoneCmd as string)
            IF VARTYPE(ThreadProc)='C'    && with parms on constructor, create a single thread per class instance
                  DIMENSION this.aoThread[this.nThreads+1]
                  oThread=CREATEOBJECT("ThreadClassEx")
                  this.aoThread[this.nThreads+1]=oThread
                  cStrIid="{00020400-0000-0000-C000-000000000046}"      && IID_IDispatch
                  IF VARTYPE(cDoneCmd)='C'      && user specified a cmd to exec after thread done
                        oThread.cDoneCmd = cDoneCmd
                        BINDEVENT(_screen.HWnd, WM_USER, this,"ThreadAlmostFinishedEvent")
                  ENDIF
                  oThread.StartThreads(1, "do "+SYS(5)+CURDIR()+ThreadProc+" WITH p2",TRANSFORM(_screen.hWnd)+","+ThreadProcParam,cStrIid)
                  this.nLiveThreads=this.nLiveThreads+1
                  this.nThreads = this.nThreads+1     && increment as last step after threads created
            ENDIF
      PROCEDURE SendMsgToStopThreads
            SetEvent(this.hAbortEvent)
      PROCEDURE ThreadAlmostFinishedEvent(hWnd as Integer, Msg as Integer, wParam as Integer, lParam as Integer)
            LOCAL i,hThread  
            FOR i = 1 TO this.nThreads    && Which thread is almost finished?
                  IF TYPE("this.aoThread[i]")='O' AND lParam = this.aoThread[i].hThreadIds[1]
                        hThread = this.aoThread[i].hThreads[1]
                        cDoneCmd =this.aoThread[i].cDoneCmd
                        EXIT
                  ENDIF
            ENDFOR
            DO WHILE  WaitForSingleObject(hThread,0)=WAIT_TIMEOUT && wait til it's totally done
                  Sleep(100)
            ENDDO 
            this.aoThread[i]=0      && release the thread object
            &cDoneCmd   && Execute caller's done command
            this.nLiveThreads=this.nLiveThreads-1
      PROCEDURE destroy
            *Danger: don't release threads if still alive! Watch out for race condition waiting for them to finish               
            DO WHILE this.nLiveThreads>0
                  ?"Waiting for threads in destroy"        
                  Sleep(1000)
            ENDDO
            UNBINDEVENTS(_screen.HWnd,WM_USER)
            IF this.hAbortEvent>0
                  CloseHandle(this.hAbortEvent)
            ENDIF
ENDDEFINE
 