home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 9 Archive / 09-Archive.zip / lxlt121s.zip / lxLite_src / lxLite.pas < prev    next >
Pascal/Delphi Source File  |  1997-08-17  |  27KB  |  852 lines
  1. {&AlignCode-,AlignData-,AlignRec-,G3+,Speed-,Frame-}
  2. {&M 262144}
  3. {&R lxlite.res}
  4. {&R os2api.res}
  5. uses
  6.  use32, Dos, Crt, os2def, os2base, exe386, os2exe, strOp, miscUtil,
  7.  SysLib, Collect, Country, Strings, lxLite_Global, lxLite_Objects;
  8.  
  9. label
  10.  done;
  11.  
  12. Procedure LoadStub;
  13. type
  14.  pDosEXEheader = ^tDosEXEheader;
  15.  tDosEXEheader = record
  16.   ID        : SmallWord;
  17.   PartPage  : SmallWord;
  18.   PageCount : SmallWord;
  19.   ReloCount : SmallWord;
  20.   HeaderSize: SmallWord;
  21.   MinAlloc  : SmallWord;
  22.   MaxAlloc  : SmallWord;
  23.   InitSS    : SmallWord;
  24.   InitSP    : SmallWord;
  25.   CheckSum  : SmallWord;
  26.   InitIP    : SmallWord;
  27.   InitCS    : SmallWord;
  28.   RelTblOfs : SmallWord;
  29.   Overlay   : SmallWord;
  30.   dummy     : array[1..16] of SmallWord;
  31.   ExtHdrOfs : Longint;
  32.  end;
  33. var
  34.  F    : File;
  35.  EH   : pDosEXEheader;
  36.  P    : pByteArray;
  37.  S,hS : Longint;
  38. begin
  39.  if (opt.tresholdStub <= 0) or (opt.stubName = '')
  40.   then begin NewStubSz := 0; exit; end;
  41.  Assign(F, opt.stubName); Reset(F, 1);
  42.  if ioResult <> 0
  43.   then begin Assign(F, SourcePath + opt.stubName); Reset(F, 1); end;
  44.  if ioResult <> 0 then Stop(msgCantLoadStub, opt.stubName);
  45.  newStubSz := FileSize(F);
  46.  GetMem(newStub, newStubSz);
  47.  BlockRead(F, newStub^, newStubSz);
  48.  Close(F);
  49.  if ioResult <> 0 then Stop(msgCantLoadStub, opt.stubName);
  50.  EH := newStub;
  51.  with EH^ do
  52.   begin
  53.    if (ID <> $4D5A) and (ID <> $5A4D) then Stop(msgInvalidStub, opt.stubName);
  54.    if RelTblOfs < $40
  55.     then begin
  56.           hS := ($40 + ReloCount * 4 + 15) and $FFFFFFF0;
  57.           S := hS + (PageCount * 512 - (512 - PartPage) - HeaderSize * 16);
  58.           GetMem(P, S); FillChar(P^, S, 0);
  59.           Move(newStub^, P^, RelTblOfs);
  60.           pDosEXEheader(P)^.RelTblOfs := $40;
  61.           pDosEXEheader(P)^.HeaderSize := hS shr 4;
  62.           pDosEXEheader(P)^.PageCount := (S + 511) shr 9;
  63.           pDosEXEheader(P)^.PartPage := S and 511;
  64.           Move(pByteArray(newStub)^[RelTblOfs], P^[$40], ReloCount * 4);
  65.           Move(pByteArray(newStub)^[HeaderSize * 16], P^[hS], S - hS);
  66.           FreeMem(newStub, newStubSz);
  67.           newStub := P; newStubSz := S;
  68.          end;
  69.   end;
  70. end;
  71.  
  72. procedure FreeStub;
  73. begin
  74.  FreeMem(newStub, newStubSz);
  75.  newStubSz := 0;
  76. end;
  77.  
  78. Procedure ShowConfigList;
  79. var
  80.  I,J,
  81.  xPos : Longint;
  82.  pSC  : pStringCollection;
  83.  pZS  : pZTstrCollection;
  84.  S    : string;
  85. begin
  86.  SetColor($0E); Write(GetResourceString(msgListCfg)); NL;
  87.  For I := 1 to cfgIDs^.Count do
  88.   begin
  89.    SetColor($07); Write('├[');
  90.    SetColor($0A); Write(pString(cfgIDs^.At(pred(I)))^);
  91.    SetColor($07); Write(']'); NL;
  92.    pSC := pStringCollection(cfgOpts^.At(pred(I)));
  93.    For J := 1 to pSC^.Count do
  94.     begin
  95.      SetColor($07); Write('├ ');
  96.      SetColor($02); Write(pString(pSC^.At(pred(J)))^); NL;
  97.     end;
  98.   end;
  99.  SetColor($0E); Write(GetResourceString(msgListSel)); NL;
  100.  For I := 1 to extra^.Count do
  101.   begin
  102.    pZS := pFileMatch(extra^.At(pred(I)))^.matchStrings;
  103.    xPos := 1000;
  104.    For J := 1 to pZS^.Count do
  105.     begin
  106.      S := strPas(pZS^.At(pred(J)));
  107.  
  108.      if xPos + length(S) > lo(WindMax)
  109.       then begin
  110.             if xPos <> 1000 then NL;
  111.             SetColor($07);
  112.             if xPos <> 1000 then Write('├ ') else Write('├[');
  113.             Write('/');
  114.             SetColor($0A);
  115.             xPos := 3;
  116.            end
  117.       else S := ':' + S;
  118.      Write(S); Inc(xPos, length(S));
  119.     end;
  120.    SetColor($07); Write(']'); NL;
  121.    pSC := extraOpts^.At(pred(I));
  122.    For J := 1 to pSC^.Count do
  123.     begin
  124.      SetColor($07); Write('├ ');
  125.      SetColor($02); Write(pString(pSC^.At(pred(J)))^); NL;
  126.     end;
  127.   end;
  128. end;
  129.  
  130. Function CheckError(ec : byte) : boolean;
  131. begin
  132.  if ec <> lxeOK
  133.   then begin
  134.         SetColor($0C);
  135.         Write(GetResourceString(msgLXerror + ec));
  136.         SetColor($0B); Writeln(#13'├');
  137.         CheckError := TRUE;
  138.        end
  139.   else CheckError := FALSE;
  140. end;
  141.  
  142. var
  143.  prevProgressValue : Longint;
  144.  
  145. function showProgress(Current,Max : Longint) : boolean;
  146. var
  147.  S   : string;
  148.  val : Longint;
  149. begin
  150.  if RedirOutput then exit;
  151.  S := Strg('▒', 20);
  152.  val := Current * 20 div Max;
  153.  if val <> prevProgressValue
  154.   then begin
  155.         FillChar(S[1], val, '█');
  156.         SetColor($03);
  157.         Write(S,']' + Strg(#8, length(S) + 2) + '[');
  158.         prevProgressValue := val;
  159.        end;
  160. end;
  161.  
  162. function altChar(Ch : Char) : Char;
  163. const
  164.  altCh : array[16..143] of Char =
  165.   ('Q','W','E','R','T','Y','U','I','O','P','[',']',' ',' ','A','S',
  166.    'D','F','G','H','J','K','L',';','''','`',' ','\','Z','X','C','V',
  167.    'B','N','M',',','.','/',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',
  168.    ' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',
  169.    ' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',
  170.    ' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',
  171.    ' ',' ',' ',' ',' ',' ',' ',' ','1','2','3','4','5','6','7','8',
  172.    '9','0','-','=',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ');
  173. begin
  174.  AltChar := altCh[byte(Ch)];
  175. end;
  176.  
  177. Function Ask(idQ : Word; argQ : array of const; idA : Word; qNo : byte) : byte;
  178. const
  179.   auxAsk : array[askFirst..askLast] of Char = (#0, #0, #0, #0, #0, #0);
  180. var
  181.  Q,A : string;
  182.  ch  : char;
  183.  Alt : boolean;
  184.  N   : Integer;
  185. begin
  186.  Q := FormatStr(idQ, argQ);
  187.  A := GetResourceString(idA);
  188.  if auxAsk[qNo] <> #0
  189.   then ch := auxAsk[qNo]
  190.   else ch := opt.AskStatus[qNo].Reply;
  191.  N := First(upCase(ch), A);
  192.  if N <> 0 then begin Ask := N; exit; end;
  193.  SetColor($02);
  194.  Write('└ ', Q, ' ');
  195.  repeat
  196.   Alt := FALSE;
  197.   ch := upCase(ReadKey);
  198.   if ch = #0
  199.    then begin Alt := TRUE; ch := altChar(ReadKey); end;
  200.   if First(ch, A) <> 0
  201.    then begin
  202.          Ask := First(ch, A);
  203.          if Alt then auxAsk[qNo] := ch;
  204.          break;
  205.         end;
  206.  until FALSE;
  207.  Writeln(Ch, #13'├');
  208. end;
  209.  
  210. var
  211.  askU : byte;
  212.  
  213. Function CheckUseCount(const fName : string) : boolean;
  214. var
  215.  F : File;
  216.  I : Longint;
  217. begin
  218.  CheckUseCount := FALSE; askU := 0;
  219.  I := FileMode; FileMode := open_access_ReadOnly or open_share_DenyReadWrite;
  220.  Assign(F, fName);
  221.  Reset(F, 1); Close(F); FileMode := I;
  222.  if ioResult = 0 then exit;
  223.  SetColor($0E);
  224.  Writeln(FormatStr(msgModInUse, [fName]));
  225.  CheckUseCount := TRUE;
  226.  askU := Ask(msgModInUseAsk, [nil], msgModInUseRpl, askInUse);
  227.  case askU of
  228.   1 : ;
  229.   2 : exit;
  230.   3 : begin allDone := TRUE; exit; end;
  231.  end;
  232.  if not unlockModule(fName)
  233.   then begin
  234.         SetColor($0C);
  235.         Writeln(FormatStr(msgModInUseCant, [fName]));
  236.         exit;
  237.        end;
  238.  CheckUseCount := FALSE;
  239. end;
  240.  
  241. Procedure StoreData(const fName,fMask : string; var destF : string;
  242.                     var Buff; BuffSize : Longint);
  243. var
  244.  Source,
  245.  Mask,
  246.  Target : array[0..255] of Char;
  247.  F      : File;
  248.  _d     : DirStr;
  249.  _n     : NameStr;
  250.  _e     : ExtStr;
  251.  
  252. begin
  253.  if (fMask = '') or (@buff = nil) then Exit;
  254.  fSplit(fName, _d, _n, _e);
  255.  StrPcopy(Source, _n + _e);
  256.  StrPcopy(Mask, fMask);
  257.  if DosEditName(1, Source, Mask, Target, sizeOf(Target)) <> 0
  258.   then Stop(msgBadFileMask, '');
  259.  if StrComp(Source, Target) = 0 then Stop(msgEqualFilename, '');
  260.  destF := _d + StrPas(Target);
  261.  Assign(F, destF); Rewrite(F, 1);
  262.  if ioResult <> 0 then Stop(msgCantWriteOut, '');
  263.  BlockWrite(F, Buff, BuffSize);
  264.  inOutRes := 0; Close(F); inOutRes := 0;
  265. end;
  266.  
  267. Function CheckIfProcessed(const fName : string) : boolean;
  268. var
  269.  i : Integer;
  270.  s : String;
  271. begin
  272.  s := lowStrg(fExpand(fName));
  273.  i := pfNames^.IndexOf(@s);
  274.  CheckIfProcessed := (i <> -1);
  275.  if i = -1 then pfNames^.Insert(NewStr(s));
  276. end;
  277.  
  278. Procedure ProcessFile(fName : string);
  279. label
  280.  SaveLX,locEx;
  281. var
  282.  _d       : DirStr;
  283.  _n       : NameStr;
  284.  _e       : ExtStr;
  285.  bk,newbk,dbgOut,xtrOut,
  286.  stbOut   : string;
  287.  Short    : string[28];
  288.  I,oldDbgInfoOfs,
  289.  bkf,exT,_ss,_fs,
  290.  rc,ss,fs : Longint;
  291.  askD,askX,askN,
  292.  askB     : Byte;
  293.  isPacked : boolean;
  294.  
  295. Procedure TrackProcess;
  296. begin
  297.  SetColor($0B);
  298.  if not RedirOutput
  299.   then begin Write(#13); ClearToEOL; end;
  300.  Short := Copy(_n + _e, 1, 28);
  301.  Write(FormatStr(msgProcessing, [Short]));
  302. end;
  303.  
  304. Procedure LogError(rc : Word);
  305. begin
  306.  if opt.Log and lcfUnsucc <> 0
  307.   then begin
  308.         bk := Cntry^.TimeStr(toStdTimeL);
  309.         _d := GetResourceString(rc);
  310.         Writeln(logFile, FormatStr(msgLogError, [bk, Short, _d]));
  311.        end;
  312. end;
  313.  
  314. const
  315.  OptBackup  : boolean = FALSE;
  316. var
  317.  oldOpt     : Pointer;
  318.  oldfNames  : pStringCollection;
  319.  oldExclude : pZTstrCollection;
  320.  oldLoadCFG : pStringCollection;
  321.  oldStub    : pByteArray;
  322.  oldStubSz  : Longint;
  323.  
  324. procedure PushOptions;
  325. begin
  326.  if OptBackup
  327.   then Stop(msgRecursiveCfg, '');
  328.  OptBackup := TRUE;
  329.  GetMem(oldOpt, sizeOf(opt));
  330.  Move(opt, oldOpt^, sizeOf(opt));
  331.  New(oldfNames, Clone(fNames));
  332.  New(oldExclude, Clone(exclude^.matchStrings));
  333.  New(oldLoadCFG, Clone(loadCFG));
  334.  
  335.  GetMem(oldStub, newStubSz);
  336.  Move(newStub^, oldStub^, newStubSz);
  337.  oldStubSz := newStubSz;
  338. end;
  339.  
  340. procedure PopOptions;
  341. begin
  342.  if not OptBackup then exit;
  343.  OptBackup := FALSE;
  344.  Move(oldOpt^, opt, sizeOf(opt));
  345.  FreeMem(oldOpt, sizeOf(opt));
  346.  Dispose(exclude^.matchStrings, Destroy);
  347.  Dispose(fNames, Destroy);
  348.  Dispose(loadCFG, Destroy);
  349.  fNames := oldfNames;
  350.  exclude^.matchStrings := oldExclude;
  351.  loadCFG := oldLoadCFG;
  352.  
  353.  FreeStub;
  354.  newStubSz := oldStubSz;
  355.  newStub := oldStub;
  356. end;
  357.  
  358. procedure CheckExtraOptions;
  359. var
  360.  I,J : Integer;
  361.  S   : string;
  362.  pSC : pStringCollection;
  363. begin
  364.  S := _n + _e;
  365.  For I := 0 to pred(extra^.Count) do
  366.   if pFileMatch(extra^.At(I))^.Matches(S)
  367.    then begin
  368.          PushOptions;
  369.          pSC := extraOpts^.At(I);
  370.          For J := 0 to pred(pSC^.Count) do
  371.           begin
  372.            S := pString(pSC^.At(J))^;
  373.            Parser^.Parse(S);
  374.           end;
  375.          LoadStub;
  376.          break;
  377.         end;
  378. end;
  379.  
  380. begin
  381.  fSplit(fName, _d, _n, _e);
  382.  if exclude^.Matches(_n + _e) then exit;
  383.  if (opt.backupDir <> '')
  384.   then begin
  385.         bk := opt.backupDir;
  386.         While (bk <> '') and (bk[1] in ['\','/']) do Delete(bk, 1, 1);
  387.         While (bk <> '') and (bk[length(bk)] in ['\','/']) do Delete(bk, length(bk), 1);
  388.         if (bk <> '') and (Pos(lowStrg(bk), lowStrg(_d)) <> 0)
  389.          then exit;
  390.        end;
  391.  
  392.  if not opt.DiscardXOpts then CheckExtraOptions;
  393.  TrackProcess;
  394.  askD := 0; askX := 0; askB := 0; askU := 0;
  395.  dbgOut := ''; xtrOut := ''; stbOut := '';
  396.  bkf := $8000;
  397.  if opt.doUnpack
  398.   then begin
  399.         opt.Unpack := TRUE;
  400.         opt.PackMode := opt.PackMode and not (pkfRunLength or pkfLempelZiv);
  401.        end;
  402.  
  403.  exT := ntfLXmodule;
  404.  rc := LX^.LoadLX(fName);
  405.  if (rc = lxeIsNEformat) and (opt.NEloadMode and lneAlways <> 0)
  406.   then begin
  407.         rc := LX^.LoadNE(fName, opt.NEloadMode);
  408.         exT := ntfNEmodule; bkf := bkf or bkfIfNE;
  409.        end;
  410.  if CheckError(rc)
  411.   then begin LogError(msgLXerror + rc); Goto locEx; end;
  412.  oldDbgInfoOfs := LX^.Header.lxDebugInfoOfs;
  413.  with LX^ do
  414.   if (Header.lxDebugLen > 0) and (Header.lxDebugLen < opt.tresholdDbug) and
  415.      (opt.FinalWrite and fwfWrite <> 0)
  416.    then begin
  417.          Write(#13); ClearToEOL;
  418.          SetColor($0E);
  419.          Writeln(FormatStr(msgModDebugInfo, [Short, Header.lxDebugLen]));
  420.          askD := Ask(msgModDebugAsk, [nil], msgModDebugRpl, askDbgInfo);
  421.          if (opt.ForceOut and fofDebug <> 0) or (askD = 1)
  422.           then StoreData(fName, opt.ddFileMask, dbgOut, DebugInfo^, Header.lxDebugLen);
  423.          case askD of
  424.           1 : if Header.lxDebugInfoOfs <> 0
  425.                then begin
  426.                      FreeMem(DebugInfo, Header.lxDebugLen);
  427.                      Header.lxDebugInfoOfs := 0;
  428.                      Header.lxDebugLen := 0;
  429.                     end;
  430.           3 : begin LogError(msgDbgSkip); Goto locEx; end;
  431.           4 : begin LogError(msgDbgAbort); allDone := TRUE; Goto locEx; end;
  432.          end;
  433.          TrackProcess;
  434.          bkf := bkf or bkfIfDebug;
  435.         end;
  436.  if opt.tresholdStub > 0 then I := newStubSz else I := -1;
  437.  if (not opt.ForceRepack) and (LX^.isPacked(opt.Realign, I, opt.PackMode, opt.SaveMode, oldDbgInfoOfs, fs))
  438.   then begin
  439.         SetColor($0C); Write(GetResourceString(msgAlreadyProc));
  440.         SetColor($0B); Writeln(#13'├');
  441.         if opt.Log and lcfAlways = lcfAlways then LogError(msgAlreadyProc);
  442.         Goto locEx;
  443.        end;
  444.  with LX^ do
  445.   if (OverlaySize > 0) and (OverlaySize < opt.tresholdXtra) and
  446.      (opt.FinalWrite and fwfWrite <> 0)
  447.    then begin
  448.          Write(#13); ClearToEOL;
  449.          SetColor($0E);
  450.          Writeln(FormatStr(msgModOverlay, [Short, OverlaySize]));
  451.          askX := Ask(msgModOvrAsk, [nil], msgModOvrRpl, askExtraData);
  452.          if (opt.ForceOut and fofXtra <> 0) or (askX = 1)
  453.           then StoreData(fName, opt.xdFileMask, xtrOut, Overlay^, OverlaySize);
  454.          case askX of
  455.           1 : begin
  456.                FreeMem(Overlay, OverlaySize);
  457.                OverlaySize := 0;
  458.               end;
  459.           3 : begin LogError(msgOverlaySkip); Goto locEx; end;
  460.           4 : begin LogError(msgOverlayAbort); allDone := TRUE; Goto locEx; end;
  461.          end;
  462.          TrackProcess;
  463.          bkf := bkf or bkfIfXtra;
  464.         end;
  465.  with LX^ do
  466.   if (NResNameTbl^.Count > 0) and (opt.FinalWrite and fwfWrite <> 0)
  467.    then begin
  468.          rc := 0;
  469.          For I := 0 to pred(NResNameTbl^.Count) do
  470.           if pNameTblRec(NResNameTbl^.At(I))^.Ord <> 0
  471.            then Inc(rc);
  472.          if rc > 0
  473.           then begin
  474.                 rc := 0;
  475.                 For I := 0 to pred(NResNameTbl^.Count) do
  476.                  if pNameTblRec(NResNameTbl^.At(I))^.Ord <> 0
  477.                   then Inc(rc, length(pNameTblRec(NResNameTbl^.At(I))^.Name^) + 1 + sizeOf(Word16));
  478.                 Write(#13); ClearToEOL;
  479.                 SetColor($0E);
  480.                 Writeln(FormatStr(msgNResTable, [Short, rc]));
  481.                 askN := Ask(msgNResAsk, [nil], msgNResRpl, askNResTable);
  482.                {if (opt.ForceOut and fofXtra <> 0) or (askX = 1)
  483.                  then StoreData(fName, opt.xdFileMask, xtrOut, Overlay^, OverlaySize);}
  484.                 case askN of
  485.                  1 : For I := pred(NResNameTbl^.Count) downto 0 do
  486.                       if pNameTblRec(NResNameTbl^.At(I))^.Ord <> 0
  487.                        then NResNameTbl^.AtFree(I);
  488.                  3 : begin LogError(msgNResSkip); Goto locEx; end;
  489.                  4 : begin LogError(msgNResAbort); allDone := TRUE; Goto locEx; end;
  490.                 end;
  491.                 TrackProcess;
  492.                {bkf := bkf or bkfIfXtra;}
  493.                end;
  494.         end;
  495.  if (LX^.StubSize < opt.tresholdStub)
  496.   then with LX^ do
  497.         begin
  498.          StoreData(fName, opt.sdFileMask, stbOut, Stub^, StubSize);
  499.          FreeMem(Stub, StubSize);
  500.          GetMem(Stub, NewStubSz);
  501.          Move(NewStub^, Stub^, NewStubSz);
  502.          StubSize := NewStubSz;
  503.         end
  504.   else if opt.ForceOut and fofStub <> 0
  505.         then StoreData(fName, opt.sdFileMask, stbOut, LX^.Stub^, LX^.StubSize);
  506.  ss := FileLength(fName);
  507.  if opt.Realign <> 255
  508.   then LX^.Header.lxPageShift := opt.Realign;
  509.  with LX^.Header do
  510.   if (opt.NewTypeCond and (ntfLXmodule or ntfNEmodule) = 0) or
  511.      (opt.NewTypeCond and exT <> 0)
  512.    then begin
  513.          case lxMFlags and lxModType of
  514.           lxEXE   : exT := ntfExecutable;
  515.           lxDLL   : exT := ntfLibrary;
  516.           lxPMDLL : exT := ntfLibrary;
  517.           lxPDD   : exT := ntfPhysDriver;
  518.           lxVDD   : exT := ntfVirtDriver;
  519.           else exT := 0;
  520.          end;
  521.          if opt.NewTypeCond and exT <> 0
  522.           then lxMFlags := (lxMFlags and (not lxModType)) or opt.NewType;
  523.         end;
  524.  if opt.Unpack then LX^.Unpack;
  525.  if opt.ApplyFixups then LX^.ApplyFixups;
  526.  if (not opt.doUnpack) and (opt.PackMode and (pkfRunLength or pkfLempelZiv or pkfFixups) <> 0)
  527.   then begin
  528.         prevProgressValue := -1;
  529.         LX^.Pack(opt.PackMode, showProgress);
  530.        end;
  531.  Write(#13); ClearToEOL;
  532.  if opt.Verbose <> 0
  533.   then begin
  534.         LX^.packFixups(opt.PackMode);
  535.         LX^.DisplayExeInfo;
  536.        end;
  537.  if (opt.FinalWrite = 0) then Goto locEx;
  538.  if (opt.FinalWrite and fwfWrite <> 0)
  539.   then begin
  540.         if CheckUseCount(fName)
  541.          then begin LogError(msgFileInUse); Goto locEx; end;
  542.         bk := _d + _n + '.bak';
  543.         if FileExist(bk)
  544.          then begin
  545.                SetColor($0E);
  546.                Writeln(FormatStr(msgBackupExists, [bk]));
  547.                askB := Ask(msgBackupAsk, [nil], msgBackupRpl, askOverBak);
  548.                case askB of
  549.                 1 : FileErase(bk);
  550.                 2 : goto SaveLX;
  551.                 3 : begin LogError(msgBackupSkip); Goto locEx; end;
  552.                 4 : begin allDone := TRUE; Goto locEx; end;
  553.                end;
  554.               end;
  555.         SetColor($0B); Write(FormatStr(msgBackingUp, [Short]));
  556.         if not FileCopy(fName, bk)
  557.          then begin
  558.                SetColor($0C); Write(GetResourceString(msgBackupError));
  559.                SetColor($0B); Writeln(#13'├');
  560.                LogError(msgBackupError); Goto locEx;
  561.               end;
  562.         Write(#13); ClearToEOL;
  563.        end;
  564. SaveLX:
  565.  if (opt.FinalWrite and fwfWrite <> 0)
  566.   then begin
  567.         SetColor($0B); Write(FormatStr(msgSaving, [Short]));
  568.         rc := LX^.Save(fName, opt.SaveMode);
  569.         if CheckError(rc)
  570.          then begin
  571.                LogError(msgLXerror + rc);
  572.                if not FileCopy(bk, fName) then Stop(msgFatalIOerror, '');
  573.                FileErase(bk);
  574.                Goto locEx;
  575.               end;
  576.         if opt.Backup and bkf = 0
  577.          then FileErase(bk)
  578.          else if opt.backupDir <> ''
  579.                then begin
  580.                      newbk := opt.backupDir;
  581.                      if (First(':', newbk) <> 0) or
  582.                         (newbk[1] in ['/', '\'])
  583.                       then begin
  584.                             _d := fExpand(_d); fs := 1;
  585.                             While (fs <= length(_d)) and (_d[fs] <> ':') do Inc(fs);
  586.                             if (fs <= length(_d)) then Delete(_d, 1, fs);
  587.                             if (_d <> '') and (_d[1] in ['/','\'])
  588.                              then Delete(_d, 1, 1);
  589.                             newbk := newbk + _d;
  590.                            end
  591.                       else newbk := _d + newbk;
  592.                      if not MakeDirTree(newbk)
  593.                       then Stop(msgCantCreateDir, newbk);
  594.                      newbk := newbk + _n + _e;
  595.                      if not fileExist(newbk)
  596.                       then if (not fileRename(bk, newbk)) and
  597.                               ((not fileCopy(bk, newbk)) or (not fileErase(bk)))
  598.                             then Stop(msgCantCopyBackup, bk)
  599.                             else
  600.                       else if (not fileErase(bk))
  601.                             then Stop(msgCantCopyBackup, bk);
  602.                      CheckIfProcessed(newbk);
  603.                     end
  604.                else CheckIfProcessed(bk);
  605.         fs := FileLength(fName)
  606.        end
  607.   else begin
  608.         if opt.tresholdStub > 0 then I := newStubSz else I := -1;
  609.         LX^.isPacked(opt.Realign, I, opt.PackMode, opt.SaveMode, oldDbgInfoOfs, fs);
  610.        end;
  611.  Write(#13); ClearToEOL;
  612.  SetColor($0B);
  613.  
  614.  _ss := ss; _fs := fs;
  615.  if (_fs >= 2048*1024)
  616.   then begin
  617.         rc := succ(_fs div (2048*1024));
  618.         _fs := _fs div rc;
  619.         _ss := _ss div rc;
  620.        end;
  621.  _d := long2str(1000 - (_fs * 1000) div _ss);
  622.  If (length(_d) < 2 + byte(_d[1] = '-'))
  623.   then Insert('0.', _d, length(_d))
  624.   else Insert('.', _d, length(_d));
  625.  Writeln(FormatStr(msgCompRate, [Short, ss, fs, _d]));
  626.  Inc(totalGain, ss - fs);
  627.  
  628.  if opt.Log and lcfSucc <> 0
  629.   then begin
  630.         bk := Cntry^.TimeStr(toStdTimeL);
  631.         Writeln(logFile, FormatStr(msgLogOp, [bk, Short, ss, fs, _d]));
  632.         case askD of
  633.          1 : if dbgOut <> ''
  634.               then Writeln(logFile, FormatStr(msgLogDebug, [dbgOut]))
  635.               else Writeln(logFile, GetResourceString(msgLogDebugRmv));
  636.          2 : Writeln(logFile, GetResourceString(msgLogDebugKept));
  637.         end;
  638.         case askX of
  639.          1 : if xtrOut <> ''
  640.               then Writeln(logFile, FormatStr(msgLogXtra, [xtrOut]))
  641.               else Writeln(logFile, GetResourceString(msgLogXtraRmv));
  642.          2 : Writeln(logFile, msgLogXtraKept);
  643.         end;
  644.         case askN of
  645.          1 : {if xtrOut <> ''
  646.               then Writeln(logFile, FormatStr(msgLogXtra, [xtrOut]))
  647.               else }Writeln(logFile, GetResourceString(msgLogNResRmv));
  648.          2 : Writeln(logFile, msgLogNResKept);
  649.         end;
  650.         case askB of
  651.          1 : Writeln(logFile, GetResourceString(msgLogBackOverw));
  652.          2 : Writeln(logFile, GetResourceString(msgLogBackSkip));
  653.         end;
  654.         case AskU of
  655.          1 : Writeln(logFile, GetResourceString(msgLogModLocked));
  656.         end;
  657.         if stbOut <> ''
  658.          then Writeln(logFile, FormatStr(msgLogStubOut, [stbOut]));
  659.        end;
  660. locEx:
  661.  PopOptions;
  662. end;
  663.  
  664. procedure LoadModuleDefs;
  665. var
  666.  I  : Integer;
  667.  S  : string;
  668.  MD : pModuleDef;
  669. begin
  670.  New(ModDef, Create(16, 16));
  671.  For I := 1 to 99 do
  672.   begin
  673.    S := GetResourceString(I);
  674.    if charCount('.', S) = 2
  675.     then begin
  676.           New(MD);
  677.           MD^.ModuleName := UpStrg(Copy(S, 1, pred(First('.', S))));
  678.           S := Copy(S, succ(First('.', S)), 255);
  679.           MD^.defStart := decVal(S);
  680.           Delete(S, 1, 1);
  681.           MD^.defLength := decVal(S);
  682.           ModDef^.Insert(MD);
  683.          end;
  684.   end;
  685. end;
  686.  
  687. Procedure ProcessFiles(const fN : string; Level : Longint);
  688. var
  689.  sr : SearchRec;
  690.  nf : Longint;
  691.  dl : boolean;
  692.  _d : DirStr;
  693.  _n : NameStr;
  694. begin
  695.  _d := extractDir(fN);
  696.  _n := extractName(fN);
  697.  FindFirst(fN, Archive or Hidden or SysFile, sr);
  698.  nf := 0; dl := FALSE;
  699.  if (Dos.DosError <> 0) and (Level = 0) and (not opt.RecurSearch)
  700.   then begin
  701.         SetColor($0C);
  702.         Writeln(FormatStr(msgCantFindFile, [fN]));
  703.        end
  704.   else
  705.  While (Dos.DosError = 0) and (not allDone) do
  706.   begin
  707.    Inc(nf);
  708.    if (length(_d) + length(sr.Name) <= 255) and
  709.       (not CheckIfProcessed(_d + sr.Name))
  710.     then begin
  711.           if opt.Pause
  712.            then case Ask(msgConfirmAsk, [sr.Name], msgConfirmRpl, askConfirm) of
  713.                  2 : sr.Name := '';
  714.                  3 : begin allDone := TRUE; break; end;
  715.                 end;
  716.           if (sr.Name <> '')
  717.            then begin
  718.                  if (not dl) and (_d <> '')
  719.                   then begin
  720.                         dl := TRUE; SetColor($0A);
  721.                         Writeln(FormatStr(msgCurDir, [_d]));
  722.                         if (opt.Log <> 0)
  723.                          then Writeln(logFile, FormatStr(msgLogCurDir, [Cntry^.TimeStr(toStdTimeL), _d]));
  724.                        end;
  725.                  ProcessFile(_d + sr.Name);
  726.                 end;
  727.          end;
  728.    FindNext(sr);
  729.   end;
  730.  FindClose(sr);
  731.  if allDone or not opt.RecurSearch then Exit;
  732.  if nf = 0
  733.   then begin
  734.         SetColor($0B); Write('└ ', Short(_d, 77));
  735.         ClearToEOL; Write(#13);
  736.        end;
  737.  FindFirst(_d + '*', Archive or Hidden or SysFile or Directory, sr);
  738.  While (Dos.DosError = 0) and (not allDone) do
  739.   begin
  740.    if (sr.Attr and Directory <> 0) and (sr.Name[1] <> '.') and
  741.       (length(_d) + length(sr.Name) + length(_n) + 1 <= 255)
  742.     then ProcessFiles(_d + sr.Name + '\' + _n, succ(Level));
  743.    FindNext(sr);
  744.   end;
  745.  FindClose(sr);
  746. end;
  747.  
  748. procedure InitLogFile;
  749. var
  750.  sD,sT : string[20];
  751. begin
  752.  if opt.logFileName = '' then opt.Log := 0;
  753.  if opt.Log = 0 then exit;
  754.  Assign(logFile, opt.logFileName);
  755.  Append(logFile); if ioResult <> 0 then Rewrite(logFile);
  756.  if ioResult <> 0 then Stop(msgCannotOpenLog, opt.logFileName);
  757.  
  758.  sD := Cntry^.DateStr(doStdDateL);
  759.  sT := Cntry^.TimeStr(toStdTimeL);
  760.  Writeln(logFile, FormatStr(msgLogStart, [sD, sT, Version]));
  761. end;
  762.  
  763. Procedure MyExitProc;
  764. begin
  765.  if TextRec(logFile).Handle <> 0 then Close(logFile);
  766.  FreeStub;
  767.  if ModDef    <> nil then Dispose(ModDef, Destroy);
  768.  if pfNames   <> nil then Dispose(pfNames, Destroy);
  769.  if exclude   <> nil then Dispose(exclude, Destroy);
  770.  if Parser    <> nil then Dispose(Parser, Destroy);
  771.  if loadCFG   <> nil then Dispose(loadCFG, Destroy);
  772.  if fNames    <> nil then Dispose(fNames, Destroy);
  773.  if LX        <> nil then Dispose(LX, Destroy);
  774.  if Cntry     <> nil then Dispose(Cntry, Destroy);
  775.  if extraOpts <> nil then Dispose(extraOpts, Destroy);
  776.  if extra     <> nil then Dispose(extra, Destroy);
  777.  if cfgOpts   <> nil then Dispose(cfgOpts, Destroy);
  778.  if cfgIDs    <> nil then Dispose(cfgIDs, Destroy);
  779.  if exitCode >= 100
  780.   then begin
  781.         if WhereX > 1 then Writeln;
  782.         SetColor($4F); ClearToEOL;
  783.         Writeln(FormatStr(msgRuntime1, [exitCode, errorAddr, Version]));
  784.         ClearToEOL;
  785.         Writeln(GetResourceString(msgRuntime2));
  786.        end;
  787.  if not RedirOutput
  788.   then begin
  789.         Write(#13);
  790.         SetColor($07); ClearToEOL;
  791.        end;
  792.  OldExit;
  793.  Halt(exitCode);
  794. end;
  795.  
  796. var
  797.  I : longint;
  798.  
  799. begin
  800.  SetColor($0F);
  801.  @OldExit := ExitProc; ExitProc := @MyExitProc;
  802.  HeapBlock := 64 * 1024;
  803.  
  804.  New(cfgIDs, Create(16, 16));
  805.  New(cfgOpts, Create(16, 16));
  806.  New(extra, Create(16, 16));
  807.  New(extraOpts, Create(16, 16));
  808.  LoadConfig;
  809.  
  810.  New(Cntry, Create(cyDefault, cpDefault));
  811.  if Cntry = nil then Stop(msgNoCountryInfo, '');
  812.  New(LX, Create);
  813.  New(fNames, Create(16, 16));
  814.  New(loadCFG, Create(16, 16));
  815.  New(Parser, Create);
  816.  New(exclude, Create(''));
  817.  New(pfNames, Create(16, 16));
  818.  
  819.  setConfig('default');
  820.  Parser^.ParseCommandLine;
  821.  PrintHeader;
  822.  
  823.  if opt.ForceIdle then DosSetPriority(Prtys_ProcessTree, Prtyc_IdleTime, 16, 0);
  824.  if opt.QueryCfgList then begin ShowConfigList; Goto Done; end;
  825.  if (fNames^.Count = 0) and (not opt.ShowConfig) then Stop(1, '');
  826.  LoadModuleDefs;
  827.  LoadStub;
  828.  InitLogFile;
  829.  if opt.ShowConfig then ShowConfig;
  830.  
  831.  I := 0;
  832.  While I < fNames^.Count do
  833.   begin
  834.    ProcessFiles(pString(fNames^.At(I))^, 0);
  835.    if allDone then break else Inc(I);
  836.   end;
  837.  
  838.  ClearToEOL;
  839.  if totalGain <> 0
  840.   then begin
  841.         SetColor($03);
  842.         Writeln(FormatStr(msgOverall, [totalGain]));
  843.        end;
  844.  if opt.Log <> 0
  845.   then Writeln(logFile, FormatStr(msgLogOverall, [totalGain]));
  846.  
  847. done:
  848.  SetColor($01);
  849.  if not RedirOutput then Write(#13);
  850.  Writeln(GetResourceString(msgDone));
  851. end.
  852.