home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / t_power / tpclone.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-10-03  |  7.8 KB  |  278 lines
  1. {$S-,R-,V-,I-,B-,F+}
  2.  
  3. {$IFNDEF Ver40}
  4.   {$I OPLUS.INC}
  5. {$ENDIF}
  6.  
  7. {*********************************************************}
  8. {*                  TPCLONE.PAS 1.00                     *}
  9. {*                by TurboPower Software                 *}
  10. {*********************************************************}
  11.  
  12. unit TpClone;
  13.   {-Clone typed constants into a program}
  14.  
  15. interface
  16.  
  17. uses
  18.   Dos,
  19.   TpString,
  20.   TpMemChk;
  21.  
  22. type
  23.   ClonePack =
  24.     record
  25.       CloneF : File;
  26.       CloneT : LongInt;
  27.     end;
  28.   DateUpdateType = (UpdateNone, UpdateDate, UpdateAll);
  29. const
  30.   DateUpdate : DateUpdateType = UpdateDate;
  31. var
  32.   CloneError : Word;
  33.  
  34. procedure OpenForCloning(FName : string; var CP : ClonePack);
  35.   {-Open file for cloning}
  36.  
  37. function FindDefaultsEnd(var CP : ClonePack; var ID; IdSize : Word; Skip : LongInt) : LongInt;
  38.   {-Find the ID in the clone file, searching from the end backward}
  39.   {Offset returned is the start of the IDString}
  40.  
  41. function FindDefaultsStart(var CP : ClonePack; var ID; IdSize : Word; Skip : LongInt) : LongInt;
  42.   {-Find the ID in the clone file, searching from the start forward}
  43.   {Offset returned is the start of the IDString}
  44.  
  45. function InitForCloning(FName : string; var CP : ClonePack; var ID; IdSize : Word) : LongInt;
  46.   {-Open file and find ID. Uses FindDefaultsEnd}
  47.  
  48. procedure LoadDefaults(var CP : ClonePack; FileOfs : LongInt; var Defaults; Bytes : Word);
  49.   {-Seek to position FileOfs and read defaults there}
  50.  
  51. procedure StoreDefaults(var CP : ClonePack; FileOfs : LongInt; var Defaults; Bytes : Word);
  52.   {-Seek to position FileOfs and store defaults there}
  53.  
  54. procedure CloseForCloning(var CP : ClonePack);
  55.   {-Close the current clone file}
  56.  
  57.   {=================================================================}
  58.  
  59. implementation
  60.  
  61.   procedure OpenForCloning(FName : string; var CP : ClonePack);
  62.     {-Open file for cloning}
  63.   begin
  64.     {Open file}
  65.     Assign(CP.CloneF, FName);
  66.     Reset(CP.CloneF, 1);
  67.     CloneError := IoResult;
  68.     if CloneError <> 0 then
  69.       Exit;
  70.  
  71.     {Save the original date/time}
  72.     GetFTime(CP.CloneF, CP.CloneT);
  73.   end;
  74.  
  75.   function FindDefaultsEnd(var CP : ClonePack; var ID; IdSize : Word; Skip : LongInt) : LongInt;
  76.     {-Find the ID string in the clone file}
  77.   label
  78.     ExitPoint;
  79.   type
  80.     SearchBuffer = array[0..4095] of Char;
  81.   var
  82.     BufPtr : ^SearchBuffer;
  83.     BufSize : Word;
  84.     BufLessId : Word;
  85.     BufPos : Word;
  86.     BytesRead : Word;
  87.     FilePtr : LongInt;
  88.   begin
  89.     FindDefaultsEnd := 0;
  90.  
  91.     {Allocate buffer space}
  92.     if not GetMemCheck(BufPtr, SizeOf(SearchBuffer)) then begin
  93.       CloneError := 203;
  94.       Exit;
  95.     end;
  96.  
  97.     {Initialize for search}
  98.     BufSize := SizeOf(SearchBuffer);
  99.     BufLessId := BufSize-IdSize;
  100.  
  101.     {Initialize file position}
  102.     FilePtr := FileSize(CP.CloneF)-Skip-BufSize;
  103.     if FilePtr < 0 then
  104.       FilePtr := 0;
  105.     Seek(CP.CloneF, FilePtr);
  106.  
  107.     {Fill the buffer}
  108.     BlockRead(CP.CloneF, BufPtr^, BufSize, BytesRead);
  109.     CloneError := IoResult;
  110.     if CloneError <> 0 then
  111.       goto ExitPoint;
  112.  
  113.     {Search the buffer}
  114.     BufPos := Search(BufPtr^, BytesRead, ID, IdSize);
  115.  
  116.     {Loop until Id found or beginning of file reached}
  117.     while (BufPos = $FFFF) and (FilePtr > 0) do begin
  118.       {Move the front end of the buffer to the tail of the buffer}
  119.       Move(BufPtr^, BufPtr^[BufLessId], IdSize);
  120.  
  121.       {Back up the file pointer}
  122.       Dec(FilePtr, BufLessId);
  123.       if FilePtr < 0 then
  124.         FilePtr := 0;
  125.       Seek(CP.CloneF, FilePtr);
  126.  
  127.       {Fill the front part of the buffer}
  128.       BlockRead(CP.CloneF, BufPtr^, BufLessId, BytesRead);
  129.       CloneError := IoResult;
  130.       if CloneError <> 0 then
  131.         goto ExitPoint;
  132.  
  133.       if BytesRead < BufLessId then
  134.         {Move things forward if necessary}
  135.         Move(BufPtr^[BufLessId], BufPtr^[BytesRead], IdSize);
  136.  
  137.       if BytesRead > 0 then begin
  138.         {Adjust BytesRead to indicate the actual number of bytes in the buffer}
  139.         Inc(BytesRead, IdSize);
  140.         {Search the buffer for Id}
  141.         BufPos := Search(BufPtr^, BytesRead, ID, IdSize);
  142.       end;
  143.     end;
  144.  
  145.     if BufPos <> $FFFF then
  146.       {Calculate the actual position in the file}
  147.       FindDefaultsEnd := FilePtr+BufPos;
  148.  
  149. ExitPoint:
  150.     {Deallocate buffer space}
  151.     FreeMemCheck(BufPtr, SizeOf(SearchBuffer));
  152.   end;
  153.  
  154.   function FindDefaultsStart(var CP : ClonePack; var ID; IdSize : Word; Skip : LongInt) : LongInt;
  155.     {-Find the ID string in the clone file}
  156.   label
  157.     ExitPoint;
  158.   type
  159.     SearchBuffer = array[0..4095] of Char;
  160.   var
  161.     BufPtr : ^SearchBuffer;
  162.     BufSize : Word;
  163.     BufPos : Word;
  164.     BytesRead : Word;
  165.     FilePtr : LongInt;
  166.   begin
  167.     FindDefaultsStart := 0;
  168.  
  169.     {Allocate buffer space}
  170.     if not GetMemCheck(BufPtr, SizeOf(SearchBuffer)) then begin
  171.       CloneError := 203;
  172.       Exit;
  173.     end;
  174.  
  175.     {Initialize for search}
  176.     BufSize := SizeOf(SearchBuffer);
  177.     Seek(CP.CloneF, Skip);
  178.  
  179.     {Read the first bufferful}
  180.     BlockRead(CP.CloneF, BufPtr^, BufSize, BytesRead);
  181.     CloneError := IoResult;
  182.     if CloneError <> 0 then
  183.       goto ExitPoint;
  184.     FilePtr := BytesRead;
  185.  
  186.     {Search the buffer}
  187.     BufPos := Search(BufPtr^, BytesRead, ID, IdSize);
  188.  
  189.     {Loop until ID found or end of file reached}
  190.     while (BufPos = $FFFF) and (BytesRead >= IdSize) do begin
  191.       {Move the tail end of the buffer to the front of the buffer}
  192.       Move(BufPtr^[BytesRead-IdSize], BufPtr^, IdSize);
  193.       {Read the next bufferful}
  194.       BlockRead(CP.CloneF, BufPtr^[IdSize], BufSize-IdSize, BytesRead);
  195.       if BytesRead > 0 then begin
  196.         Inc(FilePtr, BytesRead);
  197.         Inc(BytesRead, IdSize);
  198.         BufPos := Search(BufPtr^, BytesRead, ID, IdSize);
  199.       end;
  200.     end;
  201.  
  202.     if BufPos <> $FFFF then
  203.       FindDefaultsStart := FilePtr-BytesRead+BufPos;
  204.  
  205. ExitPoint:
  206.     {Deallocate buffer space}
  207.     FreeMemCheck(BufPtr, SizeOf(SearchBuffer));
  208.   end;
  209.  
  210.   function InitForCloning(FName : string; var CP : ClonePack; var ID; IdSize : Word) : LongInt;
  211.     {-Open file and find ID}
  212.   begin
  213.     OpenForCloning(FName, CP);
  214.     if CloneError <> 0 then
  215.       InitForCloning := 0
  216.     else
  217.       InitForCloning := FindDefaultsEnd(CP, ID, IdSize, 0);
  218.   end;
  219.  
  220.   procedure LoadDefaults(var CP : ClonePack; FileOfs : LongInt; var Defaults; Bytes : Word);
  221.     {-Seek to position FileOfs and read defaults there}
  222.   var
  223.     BytesRead : Word;
  224.   begin
  225.     Seek(CP.CloneF, FileOfs);
  226.     CloneError := IoResult;
  227.     if CloneError = 0 then begin
  228.       {Read defaults}
  229.       BlockRead(CP.CloneF, Defaults, Bytes, BytesRead);
  230.       CloneError := IoResult;
  231.       if (CloneError = 0) and (BytesRead <> Bytes) then
  232.         CloneError := 100;
  233.     end;
  234.   end;
  235.  
  236.   procedure StoreDefaults(var CP : ClonePack; FileOfs : LongInt; var Defaults; Bytes : Word);
  237.     {-Seek to position FileOfs and store defaults there}
  238.   var
  239.     BytesWritten : Word;
  240.   begin
  241.     Seek(CP.CloneF, FileOfs);
  242.     CloneError := IoResult;
  243.     if CloneError = 0 then begin
  244.       {Write defaults}
  245.       BlockWrite(CP.CloneF, Defaults, Bytes, BytesWritten);
  246.       CloneError := IoResult;
  247.       if (CloneError = 0) and (BytesWritten <> Bytes) then
  248.         CloneError := 101;
  249.     end;
  250.   end;
  251.  
  252.   procedure CloseForCloning(var CP : ClonePack);
  253.     {-Close the current clone file}
  254.   var
  255.     Status : Word;
  256.     DT : DateTime;
  257.   begin
  258.     case DateUpdate of
  259.       UpdateNone : {Set original date/time}
  260.         SetFTime(CP.CloneF, CP.CloneT);
  261.       UpdateDate : {Change the date but not the time}
  262.         begin
  263.           UnpackTime(CP.CloneT, DT);
  264.           with DT do
  265.             GetDate(Year, Month, Day, Status);
  266.           PackTime(DT, CP.CloneT);
  267.           SetFTime(CP.CloneF, CP.CloneT);
  268.         end;
  269.       UpdateAll :  {Let new date and time take effect}
  270.         ;
  271.     end;
  272.  
  273.     Close(CP.CloneF);
  274.     CloneError := IoResult;
  275.   end;
  276.  
  277. end.
  278.