home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 9 Archive / 09-Archive.zip / lxlt121s.zip / lxLite_src / common / SysLib.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-08-17  |  23.9 KB  |  821 lines
  1. {$A-,B-,D+,E-,F-,G-,I-,L+,N-,O-,P+,Q-,R-,S-,T-,V-,X+,Y+}
  2. {&AlignCode-,AlignData-,AlignRec-,Asm-,Cdecl-,Delphi+,W-,Frame-,G3+}
  3. {&LocInfo+,Optimise+,OrgName-,SmartLink+,Speed-,Z-,ZD-}
  4. Unit SysLib;
  5.  
  6. Interface uses use32, Dos, miscUtil, Collect
  7. {$ifDef OS2}, os2def {$endIf};
  8.  
  9. const
  10.  fMaskDelim1 = ':'; {fileMask delimiter char}
  11.  fMaskDelim2 = '/'; {fileMask delimiter char}
  12.  
  13. type
  14. {$ifDef OS2}
  15.  pFileMatch = ^tFileMatch;
  16.  tFileMatch = object(tObject)
  17.   matchStrings : pZTstrCollection;
  18.   constructor Create(const fMasks : string);
  19.   procedure   AddMask(const fMasks : string);
  20.   function    Matches(const fName : string) : boolean;
  21.   destructor  Destroy; virtual;
  22.  end;
  23.  
  24.  pEAcollection = ^tEAcollection;
  25.  tEAcollection = object(tCollection)
  26.   constructor Fetch(const fName : string);
  27.   function    Attach(const fName : string) : boolean;
  28.   procedure   FreeItem(Item: Pointer); virtual;
  29.  end;
  30.  
  31. { Fast MUTEX semaphore type }
  32.  tMutexSem = record
  33.   Next  : Pointer;                { Next thread ID requesting ownership }
  34.   Owner : TID;     { Current semaphore owner; bit 31 = semaphore in use }
  35.   Count : Longint;                   { For recursive semaphore requests }
  36.  end;
  37. {$endIf}
  38.  
  39.  pCommandLineParser = ^tCommandLineParser;
  40.  tCommandLineParser = object(tObject)
  41.   procedure   Parse(var S : string);
  42.   procedure   ParseCommandLine;
  43.   function    GetWord(var ParmStr : string; StartChar : Word; var DestStr : string) : Word;
  44.   function    GetOpt(const parmStr : string; StartChar : Word; const OptChars : string;
  45.                OptFlags : array of Longint; var Option : Longint) : Word;
  46.   function    ParmHandler(var ParmStr : string) : Word; virtual;
  47.   function    NameHandler(var ParmStr : string) : Word; virtual;
  48.   procedure   PreProcess(var ParmStr : string); virtual;
  49.   procedure   PostProcess; virtual;
  50.  end;
  51.  
  52. {Return TRUE if file exists; FALSE otherwise}
  53.  Function fileExist(const fName : string) : Boolean;
  54.  
  55. {Try to rename file sName into dName. Returns TRUE if succesful}
  56.  Function fileRename(const sName,dName : string) : Boolean;
  57.  
  58. {Try to erase file fName and returns TRUE if succesful}
  59.  Function fileErase(const fName : string) : Boolean;
  60.  
  61. {Returns file length in bytes or -1 if no such file}
  62.  Function fileLength(const fName : string) : Longint;
  63.  
  64. {Copy file srcName into dstName; return TRUE if o.k.}
  65.  Function fileCopy(const sName,dName : string) : boolean;
  66.  
  67. {Create an entire directory tree structure}
  68.  Function makeDirTree(const dirName : string) : boolean;
  69.  
  70. {Create an unique temporary filename by given filemask: replace '?' by}
  71. {unique characters; if no path is given uses TEMP or TMP environment var}
  72.  Function tempFileName(const fName : string) : string;
  73.  
  74. {Return a string containing executable`s source path including last '\' or '/'}
  75.  Function SourcePath : string;
  76.  
  77. {An replacement for standard fSplit which handles correctly forvard slashes}
  78.  procedure fSplit(const Path : PathStr; var Dir : DirStr; var Name : NameStr;
  79.                   var Ext : ExtStr);
  80.  
  81. {$ifDef OS2 ---------}
  82. { Open an [F]ast [M]utex [S]emaphore }
  83.  Function  fmsInit(var Sem : tMutexSem) : boolean;
  84. { Request a semaphore; wait until semaphore is available }
  85.  Function  fmsRequest(var Sem : tMutexSem) : boolean;
  86. { Release semaphore; return TRUE if o.k.; FALSE if caller is not owner }
  87.  Function  fmsRelease(var Sem : tMutexSem) : boolean;
  88. { Check if semaphore is owned; DO NOT RELY ON THIS! }
  89.  Function  fmsCheck(var Sem : tMutexSem) : boolean;
  90.  
  91. { Unlock a executable module if it is already in use }
  92.  Function  unlockModule(const fName : string) : boolean;
  93.  
  94. { Return an string from resourse (from string table) }
  95.  Function  GetResourceString(ID : Longint) : string;
  96. {$endIf}
  97.  
  98. Implementation uses strOp, Streams, strings
  99. {$ifDef OS2}, os2base {$endIf};
  100.  
  101. {$ifDef OS2}
  102. constructor tFileMatch.Create;
  103. begin
  104.  New(matchStrings, Create(4, 4));
  105.  AddMask(fMasks);
  106. end;
  107.  
  108. procedure tFileMatch.AddMask;
  109. var
  110.  I,oPos,
  111.  Pos1,Pos2 : Word;
  112.  iDone     : boolean;
  113.  nP        : pChar;
  114. begin
  115.  oPos := 1; I := 1; iDone := FALSE;
  116.  repeat
  117.   Pos1 := ScanFwd(fMaskDelim1, fMasks, I);
  118.   Pos2 := ScanFwd(fMaskDelim2, fMasks, I);
  119.   if (Pos2 > 0)
  120.    then if Pos1 = 0
  121.          then Pos1 := Pos2
  122.          else Pos1 := MinI(Pos1, Pos2);
  123.   Inc(I);
  124.   if (Pos1 = 0)
  125.    then begin
  126.          Pos1 := succ(length(fMasks));
  127.          iDone := TRUE;
  128.         end;
  129.   if Pos1 > oPos
  130.    then begin
  131.          GetMem(nP, succ(Pos1 - oPos));
  132.          strUpper(strPcopy(nP, copy(fMasks, oPos, Pos1 - oPos)));
  133.          if matchStrings^.IndexOf(nP) >= 0
  134.           then FreeMem(nP, succ(Pos1 - oPos))
  135.           else matchStrings^.Insert(nP);
  136.         end;
  137.   oPos := succ(Pos1);
  138.  until iDone;
  139. end;
  140.  
  141. function tFileMatch.Matches;
  142. var I      : Integer;
  143.     Source,
  144.     Target : array[0..255] of Char;
  145. begin
  146.  Matches := TRUE;
  147.  StrUpper(StrPcopy(Source, fName));
  148.  For I := 0 to pred(matchStrings^.Count) do
  149.   if (DosEditName(1, Source, matchStrings^.At(I), Target, sizeOf(Target)) = 0) and
  150.      (StrComp(Source, Target) = 0)
  151.    then exit;
  152.  Matches := FALSE;
  153. end;
  154.  
  155. destructor tFileMatch.Destroy;
  156. begin
  157.  Dispose(matchStrings, Destroy);
  158.  inherited Destroy;
  159. end;
  160.  
  161. constructor tEAcollection.Fetch;
  162. const
  163.  eaNameBfSz = 1024;
  164.  secureSize = 256; {F$#%^k! Bug in DosEnumAttribute}
  165. var
  166.  fN         : array[0..255] of char;
  167.  sV,oV,
  168.  I,eaCn     : Longint;
  169.  Buff       : pByteArray;
  170.  eaN        : pStringCollection;
  171.  pS         : pString;
  172.  pEA,nEA    : pFea2;
  173.  eaBuf      : EAop2;
  174.  fStat      : FileStatus4;
  175.  
  176. procedure resFree;
  177. begin
  178.  if eaBuf.fpFEA2List <> nil
  179.   then FreeMem(eaBuf.fpFEA2List, fStat.cbList);
  180.  if eaN <> nil
  181.   then Dispose(eaN, Destroy);
  182.  if Buff <> nil then FreeMem(Buff, eaNameBfSz + secureSize);
  183. end;
  184.  
  185. begin
  186.  inherited Create(8, 8);
  187.  GetMem(Buff, eaNameBfSz + secureSize);
  188.  New(eaN, Create(8, 8));
  189.  fillChar(fStat, sizeOf(fStat), 0);
  190.  fillChar(eaBuf, sizeOf(eaBuf), 0);
  191.  if (Buff = nil) or (eaN = nil)
  192.   then begin resFree; Fail; end;
  193.  StrPCopy(@fN, fName);
  194.  sV := 1;
  195.  repeat
  196.   eaCn := -1; FillChar(Buff^, eaNameBfSz, 0); {F&^#$@%&k! Really not needed}
  197.   if DosEnumAttribute(EnumEA_RefType_Path, @fN, sV, Buff^, eaNameBfSz, eaCn, EnumEA_Level_No_Value) <> 0
  198.    then begin resFree; Fail; end;
  199.   if eaCn = 0 then break;
  200.   pEA := @Buff^;
  201.   For I := 1 to eaCn do
  202.    begin
  203.     eaN^.Insert(NewStr(StrPas(@pEA^.szName)));
  204.     Inc(Longint(pEA), pEA^.oNextEntryOffset);
  205.     Inc(sV);
  206.    end;
  207.  until FALSE;
  208.  if DosQueryPathInfo(@fN, Fil_QueryEAsize, fStat, sizeOf(fStat)) <> 0
  209.   then begin resFree; Fail; end;
  210.  I := 0;
  211.  GetMem(eaBuf.fpFEA2List, fStat.cbList);
  212.  eaBuf.fpGEA2List := @Buff^;
  213.  While I < eaN^.Count do
  214.   begin
  215.    sV := 4; oV := 4;
  216.    repeat
  217.     pS := eaN^.At(I);
  218.     if sV + 4 + succ(length(pS^)) > pred(eaNameBfSz) then break;
  219.     pLong(@Buff^[oV])^ := sV - oV;
  220.     pLong(@Buff^[sV])^ := 0; oV := sV;
  221.     Move(pS^, Buff^[sV + 4], succ(length(pS^)));
  222.     Inc(sV, 4 + succ(length(pS^)));
  223.     Buff^[sV] := 0; sV := (sV + 4) and $FFFFFFFC;
  224.     Inc(I);
  225.    until I >= eaN^.Count;
  226.    pLong(@Buff^[0])^ := sV;
  227.    eaBuf.fpFEA2List^.cbList := fStat.cbList;
  228.    if DosQueryPathInfo(@fN, Fil_QueryEAsFromList, eaBuf, sizeOf(eaBuf)) = 0
  229.     then begin
  230.           pEA := @eaBuf.fpFEA2List^.list;
  231.           While longint(pEA) - longint(@eaBuf.fpFEA2List^.list) <= eaBuf.fpFEA2List^.cbList do
  232.            begin
  233.             GetMem(nEA, sizeOf(Fea2) + pEA^.cbName + pEA^.cbValue);
  234.             Move(pEA^, nEA^, sizeOf(Fea2) + pEA^.cbName + pEA^.cbValue);
  235.             Insert(nEA);
  236.             if pEA^.oNextEntryOffset = 0 then break;
  237.             Inc(longint(pEA), pEA^.oNextEntryOffset);
  238.            end;
  239.          end;
  240.   end;
  241.  resFree;
  242. end;
  243.  
  244. Function tEAcollection.Attach;
  245. label
  246.  locEx;
  247. const
  248.  eaNameBfSz = 300;
  249. var
  250.  fN         : array[0..255] of Char;
  251.  oldAttr,
  252.  I,fT,maxEA : Longint;
  253.  eaBuf      : EAop2;
  254.  Buff,OneEA : pByteArray;
  255.  fInfo      : FileStatus3;
  256. begin
  257.  if (Count = 0) then begin Attach := TRUE; exit; end;
  258.  Attach := FALSE;
  259.  GetMem(Buff, eaNameBfSz);
  260.  maxEA := 0;
  261.  if (Buff = nil) then goto locEx;
  262.  if DosQueryPathInfo(StrPCopy(@fN, fName), fil_Standard, fInfo, SizeOf(fInfo)) <> 0
  263.   then goto locEx;
  264.  
  265. {temporary remove hidden/readonly attributes}
  266.  oldAttr := fInfo.attrFile;
  267.  fInfo.attrFile := fInfo.attrFile and not (file_ReadOnly + file_System + file_Hidden);
  268.  DosSetPathInfo(@fN, fil_Standard, fInfo, SizeOf(fInfo), 0);
  269.  fInfo.attrFile := oldAttr;
  270.  
  271.  For I := 0 to pred(Count) do
  272.   with pFea2(At(I))^ do
  273.    if sizeOf(Fea2) + cbName + cbValue > maxEA
  274.     then maxEA := sizeOf(Fea2) + cbName + cbValue;
  275.  Inc(maxEA, 4);
  276.  GetMem(oneEA, maxEA);
  277.  pLong(oneEA)^ := maxEA;
  278.  eaBuf.fpGEA2List := @Buff^;
  279.  eaBuf.fpFEA2list := @oneEA^;
  280.  For I := 0 to pred(Count) do
  281.   with pFea2(At(I))^ do
  282.    begin
  283.     oNextEntryOffset := 0;
  284.     pLong(@Buff^[0])^ := 4 + 4 + 1 + 1 + cbName;
  285.     pLong(@Buff^[4])^ := 0;
  286.     Buff^[8] := cbName;
  287.     Move(szName, Buff^[9], cbName);
  288.     Buff^[9 + cbName] := 0;
  289.     Move(oNextEntryOffset, oneEA^[4], sizeOf(Fea2) + cbName + cbValue);
  290.     DosSetPathInfo(@fN, fil_QueryEAsize, eaBuf, sizeOf(eaBuf), 0);
  291.    end;
  292.  Attach := DosSetPathInfo(@fN, fil_Standard, fInfo, SizeOf(fInfo), 0) = 0;
  293. locEx:
  294.  FreeMem(oneEA, maxEA);
  295.  if Buff <> nil then FreeMem(Buff, eaNameBfSz);
  296. end;
  297.  
  298. procedure tEAcollection.FreeItem;
  299. begin
  300.  if Item <> nil
  301.   then with pFea2(Item)^ do
  302.         FreeMem(Item, sizeOf(Fea2) + cbName + cbValue);
  303. end;
  304. {$endIf}
  305.  
  306. Function fileExist;
  307. var
  308.  sr : SearchRec;
  309. begin
  310.  Dos.FindFirst(fName, AnyFile, sr);
  311.  fileExist := Dos.DosError = 0;
  312. {$ifDef OS2}
  313.  Dos.FindClose(sr);
  314. {$endIf}
  315. end;
  316.  
  317. Function fileRename;
  318. var F : File;
  319. begin
  320.  Assign(F, sName); Rename(F, dName);
  321.  fileRename := ioResult = 0;
  322. end;
  323.  
  324. Function fileErase;
  325. var F : File;
  326. begin
  327.  Assign(F, FName); SetFAttr(F, Archive);
  328.  Erase(F); fileErase := ioResult = 0;
  329. end;
  330.  
  331. Function fileLength;
  332. var F : File;
  333.     I : Longint;
  334. begin
  335.  I := fileMode; fileMode := $40; { open_access_ReadOnly + open_share_DenyNone };
  336.  Assign(F, fName); Reset(F, 1);
  337.  fileMode := I;
  338.  if ioResult <> 0
  339.   then fileLength := -1
  340.   else begin
  341.         fileLength := fileSize(F);
  342.         Close(F);
  343.        end;
  344. end;
  345.  
  346. Function fileCopy;
  347. {$ifDef OS2}
  348. var
  349.  sn,dn : pChar;
  350. begin
  351.  GetMem(sn, succ(length(sName)));
  352.  GetMem(dn, succ(length(dName)));
  353.  StrPCopy(sn, sName);
  354.  StrPCopy(dn, dName);
  355.  fileCopy := DosCopy(sn, dn, dcpy_Existing) = 0;
  356.  FreeMem(sn, succ(length(sName)));
  357.  FreeMem(dn, succ(length(dName)));
  358. end;
  359. {$else}
  360. var
  361.  IS,OS : pFileStream;
  362.  At    : Word;
  363.  FT    : Longint;
  364. begin
  365.  fileCopy := FALSE;
  366.  New(IS, Create(sName, stmReadOnly));
  367.  if (IS = nil) or (IS^.Error <> steOK)
  368.   then begin
  369.         if IS <> nil then Dispose(IS, Destroy);
  370.         exit;
  371.        end;
  372.  New(OS, Create(dName, stmWriteOnly));
  373.  FT := IS^.GetTime; At := IS^.GetAttr;
  374.  if (OS = nil) or (OS^.Error <> steOK)
  375.   then begin
  376.         Dispose(IS, Destroy);
  377.         if OS <> nil then Dispose(OS, Destroy);
  378.         exit;
  379.        end;
  380.  if IS^.Size <> OS^.CopyFrom(IS^, -1)
  381.   then begin
  382.         Dispose(OS, Erase);
  383.         fileCopy := FALSE;
  384.        end
  385.   else begin
  386.         OS^.SetAttr(At);
  387.         OS^.SetTime(FT);
  388.         Dispose(OS, Destroy);
  389.         fileCopy := TRUE;
  390.        end;
  391.  Dispose(IS, Destroy);
  392. end;
  393. {$endIf}
  394.  
  395. Function makeDirTree(const dirName : string) : boolean;
  396. var
  397.  L,SC : Integer;
  398.  S    : string;
  399. begin
  400.  makeDirTree := FALSE;
  401.  L := 0; SC := 0;
  402.  While L <= length(dirName) do
  403.   begin
  404.    repeat
  405.     Inc(L);
  406.    until (L > length(dirName)) or (dirName[L] in ['/','\',':']);
  407.    if (L <= length(dirName)) and (dirName[L] = ':') then SC := 2;
  408.    if SC > 0 then begin Dec(SC); Continue; end;
  409.    S := copy(dirName, 1, pred(L));
  410.    while (S <> '') and (S[length(S)] in ['/','\']) do Dec(byte(S[0]));
  411.    if (S <> '') and (not fileExist(S)) then mkDir(S);
  412.    if ioResult <> 0 then exit;
  413.   end;
  414.  makeDirTree := TRUE;
  415. end;
  416.  
  417. Function tempFileName;
  418. var
  419.  D,N,R : string;
  420.  Count : Integer;
  421. {$ifDef OS2}
  422.  sz    : array[0..255] of Char;
  423.  Action: Longint;
  424.  Handle: hFile;
  425. {$endif}
  426. begin
  427.  D := extractDir(fName);
  428.  N := Copy(fName, succ(length(D)), 255);
  429.  if D = '' then D := GetEnv('TEMP');
  430.  if D = '' then D := GetEnv('TMP');
  431.  if not (D[length(D)] in ['/', '\']) then D := D + '\';
  432.  Count := 1000;
  433.  repeat
  434.   R := D + N; Dec(Count);
  435.   While First('?', R) <> 0 do R[First('?', R)] := char(Random(10) + byte('0'));
  436. {$ifDef OS2}
  437.   if DosOpen(strPCopy(@sz, R), Handle, Action, 0, 0,
  438.       open_action_Create_If_New + open_action_Fail_If_Exists,
  439.       open_flags_Fail_On_Error + open_Share_DenyReadWrite +
  440.       open_access_ReadOnly, nil) = 0
  441.    then begin
  442.          DosClose(Handle);
  443.          break;
  444.         end;
  445. {$else}
  446.   if (not fileExist(R)) then break;
  447. {$endIf}
  448.  until (Count = 0);
  449.  if Count = 0
  450.   then tempFileName := ''
  451.   else tempFileName := R;
  452. end;
  453.  
  454. Function SourcePath; assembler {&uses esi,edi};
  455. {$ifDef OS2}
  456. asm             mov     edi,Environment
  457.                 mov     al,0
  458.                 mov     ecx,-1
  459. @@cont:         repne   scasb
  460.                 scasb
  461.                 jnz     @@cont
  462.                 mov     esi,edi
  463.                 repne   scasb
  464. @@searchSlash:  cmp     byte ptr [edi-1],':'
  465.                 je      @@done
  466.                 dec     edi
  467.                 cmp     edi,esi
  468.                 jbe     @@done
  469.                 cmp     byte ptr [edi],'/'
  470.                 je      @@done
  471.                 cmp     byte ptr [edi],'\'
  472.                 jne     @@searchSlash
  473. @@done:         sub     edi,esi
  474.                 mov     eax,edi
  475.                 inc     eax
  476.                 mov     ecx,eax
  477.                 mov     edi,@result
  478.                 stosb
  479.                 rep     movsb
  480. end;
  481. {$else}
  482. asm             push    ds
  483.                 mov     es,PrefixSeg
  484.                 mov     ds,es:[02Ch]
  485.                 push    ds
  486.                 pop     es
  487.                 mov     al,0
  488.                 mov     cx,-1
  489.                 xor     di,di
  490. @@cont:         repne   scasb
  491.                 scasb
  492.                 jnz     @@cont
  493.                 scasw
  494.                 mov     si,di
  495.                 repne   scasb
  496. @@searchSlash:  cmp     byte ptr [di-1],':'
  497.                 je      @@done
  498.                 dec     di
  499.                 cmp     di,si
  500.                 jbe     @@done
  501.                 cmp     byte ptr [di],'/'
  502.                 je      @@done
  503.                 cmp     byte ptr [di],'\'
  504.                 jne     @@searchSlash
  505. @@done:         sub     di,si
  506.                 mov     ax,di
  507.                 inc     ax
  508.                 mov     cx,ax
  509.                 les     di,@result
  510.                 stosb
  511.                 rep     movsb
  512.                 pop     ds
  513. end;
  514. {$endIf}
  515.  
  516. procedure fSplit;
  517. var
  518.  I,J : Integer;
  519. begin
  520.  I := length(Path);
  521.  While (I > 1) and (Path[I] <> '.') and (not (Path[I] in ['/','\',':'])) do Dec(I);
  522.  if (I <= 1)
  523.   then begin
  524.         Dir := ''; Name := Path; Ext := '';
  525.         exit;
  526.        end;
  527.  if (Path[I] = '.')
  528.   then if (Path[I - 1] in ['/','\',':'])
  529.         then begin
  530.               Dir := Copy(Path, 1, I - 1);
  531.               Name := Copy(Path, I, 255);
  532.               Ext := '';
  533.               exit;
  534.              end
  535.         else begin
  536.               Ext := Copy(Path, I, 255); J := I;
  537.               While (J > 1) and (not (Path[J] in ['/','\',':'])) do Dec(J);
  538.               if (Path[J] in ['/','\',':'])
  539.                then begin
  540.                      Name := Copy(Path, J + 1, I - J - 1);
  541.                      Dir := Copy(Path, 1, J);
  542.                     end
  543.                else begin
  544.                      Name := Copy(Path, J, I - J);
  545.                      Dir := '';
  546.                     end;
  547.               exit;
  548.              end
  549.   else begin
  550.         Ext := '';
  551.         Name := Copy(Path, I, 255);
  552.         Dir := Copy(Path, 1, I - 1);
  553.        end;
  554. end;
  555.  
  556. {$ifDef OS2}
  557. function fmsInit; assembler {&uses none};
  558. asm             mov     ecx,Sem
  559.            lock bts     [ecx].tMutexSem.Owner,31      {Lock semaphore updates}
  560.                 jnc     @@ok
  561.                 mov     al,0
  562.                 ret     4
  563. @@ok:           xor     eax,eax
  564.                 mov     [ecx].tMutexSem.Next,eax
  565.            lock xchg    [ecx].tMutexSem.Owner,eax
  566.                 mov     al,1
  567. end;
  568.  
  569. function fmsRequest; assembler {&uses none};
  570. asm             mov     eax,fs:[12]            {Get ^Thread Information Block}
  571.                 push    dword ptr [eax]                      {Owner : Longint}
  572.                 push    eax                                   {Next : Pointer}
  573. @@testSem:      mov     ecx,Sem[4+4]                      {+4+4 since &frame-}
  574.            lock bts     [ecx].tMutexSem.Owner,31
  575.                 jnc     @@semFree
  576.                 push    1          {There is no hurry since semaphore is busy}
  577.                 call    DosSleep                  {Go to sleep for a while...}
  578.                 pop     eax
  579.                 jmp     @@testSem
  580.  
  581. @@semFree:      mov     edx,[ecx].tMutexSem.Owner        {Get semaphore owner}
  582.                 btr     edx,31                     {Reset `semaphor busy` bit}
  583.                 cmp     edx,[esp+4]                     {Owner = current TID?}
  584.                 jne     @@notOur
  585.                 inc     [ecx].tMutexSem.Count
  586.            lock btr     [ecx].tMutexSem.Owner,31           {Release semaphore}
  587.                 add     esp,4+4
  588.                 mov     al,1
  589.                 ret     4
  590.  
  591. @@notOur:       mov     eax,esp
  592.                 xchg    eax,[ecx].tMutexSem.Next
  593.                 test    edx,edx                                   {Owner = 0?}
  594.                 jz      @@notBusy
  595.                 mov     [esp],eax                              {Save ^nextTID}
  596.            lock btr     [ecx].tMutexSem.Owner,31           {Release semaphore}
  597.                 push    dword ptr [esp+4]                            {Our TID}
  598.                 call    SuspendThread                     {Sleep until wakeup}
  599.                 add     esp,4+4
  600.                 mov     al,1
  601.                 ret     4
  602.  
  603. @@notBusy:      xchg    eax,[ecx].tMutexSem.Next
  604.                 inc     edx
  605.                 mov     [ecx].tMutexSem.Count,edx          {Request count = 1}
  606.                 pop     eax                                    {Skip ^nextTID}
  607.                 pop     eax
  608.            lock xchg    [ecx].tMutexSem.Owner,eax {Set owner&unlock semaphore}
  609.                 mov     al,1
  610. end;
  611.  
  612. function fmsRelease; assembler {&uses none};
  613. asm
  614. @@testSem:      mov     ecx,Sem
  615.            lock bts     [ecx].tMutexSem.Owner,31      {Lock semaphore updates}
  616.                 jnc     @@semFree
  617.                 push    1
  618.                 call    DosSleep
  619.                 pop     eax
  620.                 jmp     @@testSem
  621. @@semFree:      mov     eax,fs:[12]
  622.                 mov     eax,[eax]
  623.                 bts     eax,31              {Set bit 31 in EAX for comparison}
  624.                 cmp     eax,[ecx].tMutexSem.Owner
  625.                 je      @@isOur
  626.            lock btr     [ecx].tMutexSem.Owner,31           {Release semaphore}
  627.                 mov     al,0
  628.                 ret     4
  629.  
  630. @@isOur:        dec     [ecx].tMutexSem.Count             {Request count = 1?}
  631.                 jz      @@scanChain
  632.            lock btr     [ecx].tMutexSem.Owner,31           {Release semaphore}
  633.                 mov     al,1
  634.                 ret     4
  635.  
  636. @@scanChain:    mov     edx,eax
  637.                 mov     eax,ecx
  638.                 mov     ecx,[ecx].tMutexSem.Next                    {^nextTID}
  639.                 test    ecx,ecx
  640.                 jnz     @@scanChain
  641.                 mov     ecx,Sem
  642.                 cmp     eax,ecx
  643.                 je      @@onlyOwner                  {Thread is only in chain}
  644.                 mov     [edx].tMutexSem.Next,0      {Remove thread from chain}
  645.                 mov     [ecx].tMutexSem.Count,1       {Set request count to 1}
  646.                 mov     eax,[eax].tMutexSem.Owner
  647.                 push    eax
  648. @@resumeIt:     push    eax                          {ResumeThread(TID = EAX)}
  649.            lock xchg    [ecx].tMutexSem.Owner,eax{Make thread semaphore owner}
  650.                 call    ResumeThread                          {Wake up thread}
  651.                 cmp     eax,error_Not_Frozen
  652.                 jne     @@resumeOK
  653.                 push    1
  654.                 call    DosSleep
  655.                 pop     eax
  656.                 pop     eax
  657.                 jmp     @@resumeIt
  658. @@resumeOK:     pop     eax
  659.                 mov     al,1
  660.                 ret     4
  661.  
  662. @@onlyOwner:    xor     eax,eax
  663.            lock xchg    eax,[ecx].tMutexSem.Owner
  664.                 mov     al,1
  665. end;
  666.  
  667. function fmsCheck; assembler {&uses none};
  668. asm             mov     eax,Sem
  669.                 mov     eax,[eax].tMutexSem.Owner
  670.                 and     eax,7FFFFFFFh
  671.                 setz    al
  672. end;
  673.  
  674. function GetResourceString(ID : Longint) : string;
  675. var
  676.  pS : pByte;
  677.  I  : Integer;
  678.  S  : string;
  679. begin
  680.  if DosGetResource(nullHandle, rt_String, ID div 16 + 1, Pointer(pS)) <> 0
  681.   then begin
  682.         GetResourceString := '';
  683.         exit;
  684.        end;
  685.  Inc(pS, sizeOf(Word16)); {skip codepage}
  686.  For I := 1 to ID and $0F do Inc(pS, succ(pS^));
  687.  Move(pS^, S, pS^);
  688.  Dec(byte(S[0]));
  689.  DosFreeResource(pS);
  690.  GetResourceString := S;
  691. end;
  692.  
  693. Function unlockModule(const fName : string) : boolean;
  694. var
  695.  tmp : array[0..256] of Char;
  696. begin
  697.  unlockModule := DosReplaceModule(strPCopy(tmp, fName), nil, nil) = 0;
  698. end;
  699.  
  700. {$endIf}
  701.  
  702. procedure tCommandLineParser.Parse;
  703. begin
  704.  PreProcess(S);
  705.  While S <> '' do
  706.   begin
  707.    While (S <> '') and ((S[1] = ' ') or (S[1] = #9)) do
  708.     Delete(S, 1, 1);
  709.    if S <> ''
  710.     then if (S[1] in ['/','-'])
  711.           then begin
  712.                 Delete(S, 1, 1);
  713.                 if (S <> '') then Delete(S, 1, ParmHandler(S));
  714.                end
  715.           else Delete(S, 1, NameHandler(S));
  716.   end;
  717. end;
  718.  
  719. procedure tCommandLineParser.ParseCommandLine;
  720. var
  721.  ParmStr : string;
  722. begin
  723. {$ifDef OS2}
  724.  if CmdLine = nil
  725.   then ParmStr := ''
  726.   else ParmStr := StrPas(GetASCIIZptr(CmdLine^, 2));
  727. {$else}
  728.  Move(mem[PrefixSeg:$80], ParmStr, succ(mem[PrefixSeg:$80]));
  729. {$endIf}
  730.  Parse(ParmStr);
  731. end;
  732.  
  733. Function tCommandLineParser.GetWord;
  734. var
  735.  I,J : Word;
  736.  fCh : Char;
  737. begin
  738.  I := StartChar;
  739.  if (I <= length(ParmStr)) and (not (ParmStr[I] in [#9,' ','/','-']))
  740.   then begin
  741.         J := I;
  742.         if ParmStr[I] = '"'
  743.          then fCh := '"'
  744.          else fCh := ' ';
  745.         repeat
  746.          Inc(I);
  747.         until (I > length(ParmStr)) or (ParmStr[I] = fCh);
  748.         if fCh = '"'
  749.          then begin DestStr := Copy(ParmStr, succ(J), pred(I - J)); Inc(I); end
  750.          else DestStr := Copy(ParmStr, J, I - J);
  751.        end
  752.   else DestStr := '';
  753.  GetWord := I - StartChar;
  754. end;
  755.  
  756. function tCommandLineParser.GetOpt;
  757. var
  758.  I,J,K : Longint;
  759.  Ch    : Char;
  760.  fCh   : boolean;
  761. begin
  762.  K := StartChar; I := 0;
  763.  fCh := TRUE;
  764.  repeat
  765.   if StartChar <= length(parmStr)
  766.    then Ch := UpCase(ParmStr[StartChar])
  767.    else Ch := ' ';
  768.   case Ch of
  769.    '-' : begin
  770.           if fCh then I := OptFlags[high(OptFlags)];
  771.           Option := Option and (not I);
  772.           I := 0;
  773.          end;
  774.    ':',
  775.    '+' : begin
  776.           if fCh then I := OptFlags[high(OptFlags)];
  777.           Option := Option or I;
  778.           I := 0;
  779.           if Ch = ':' then break;
  780.          end;
  781.    else begin
  782.          J := First(Ch, OptChars);
  783.          if J = 0
  784.           then begin
  785.                 if fCh then I := OptFlags[high(OptFlags)];
  786.                 Option := Option or I;
  787.                 break;
  788.                end
  789.           else I := I or OptFlags[pred(J) + low(OptFlags)];
  790.         end;
  791.   end;
  792.   fCh := FALSE;
  793.   Inc(StartChar);
  794.  until FALSE;
  795.  GetOpt := StartChar - K;
  796. end;
  797.  
  798. function tCommandLineParser.ParmHandler;
  799. var
  800.  I : Integer;
  801. begin
  802.  I := 0; While (I < length(ParmStr)) and (ParmStr[succ(I)] <= ' ') do Inc(I);
  803.  ParmHandler := I;
  804. end;
  805.  
  806. function tCommandLineParser.NameHandler;
  807. begin
  808.  NameHandler := ParmHandler(ParmStr);
  809. end;
  810.  
  811. procedure tCommandLineParser.PreProcess;
  812. begin
  813. end;
  814.  
  815. procedure tCommandLineParser.PostProcess;
  816. begin
  817. end;
  818.  
  819. end.
  820.  
  821.