home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / MAGAZINE / MISC / ITPJAN90.ZIP / LOCATION.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-12-15  |  3.4 KB  |  124 lines
  1. { Turbo Pascal Location Example }
  2. PROGRAM Location;
  3.  
  4. USES Dos, Crt;
  5.  
  6. CONST
  7.    DataPath =
  8.       'NOT ASSIGNED !!!!!!!!!!!!!!!!!!!!';
  9.  
  10. TYPE
  11.    DataBlock = ARRAY[1..256] OF Byte;
  12.  
  13. VAR
  14.    CurrPath, NewPath : PathStr;
  15.    Dir : DirStr;
  16.    Name : NameStr;
  17.    Ext : ExtStr;
  18.  
  19. PROCEDURE ReplaceSpec(CurrPath, SearchSpec,
  20.                       NewSpec : PathStr);
  21. VAR
  22.   InF, OutF : FILE;
  23.   OutPath, EmptyStr : PathStr;
  24.   Result1, Result2 : Word;
  25.   i, j, SearchLen : Integer;
  26.   SearchArray : ARRAY[1..128] OF Byte;
  27.   EndFlag, BlkDone,
  28.   SearchResult, Changes : boolean;
  29.   FileBlock1, FileBlock2 : DataBlock;
  30.  BEGIN
  31.   FillChar(EmptyStr, SizeOf(EmptyStr), ' ');
  32.   FOR i := 1 TO Ord(NewSpec[0]) DO
  33.      NewSpec[i] := UpCase(NewSpec[i]);
  34.   NewSpec := copy(NewSpec+EmptyStr, 1,
  35.                   SizeOf(SearchSpec));
  36.   SearchLen := Ord(SearchSpec[0]);
  37.   FOR i := 1 TO SearchLen DO
  38.      SearchArray[i] := Ord(SearchSpec[i]);
  39.   Assign(InF, CurrPath);
  40.   {$I-} Reset(InF, 1); {$I+}
  41.    IF IOResult = 0 THEN
  42.    BEGIN
  43.      FSplit(CurrPath, Dir, Name, Ext);
  44.      OutPath := Dir + Name + '.NEW';
  45.      Assign(OutF, OutPath);
  46.      Rewrite(OutF, 1);
  47.      EndFlag := FALSE;
  48.      BlkDone := FALSE;
  49.      SearchResult := FALSE;
  50.      Changes := FALSE;
  51.      BlockRead(InF, FileBlock2,
  52.                SizeOf(FileBlock2), Result2);
  53.      EndFlag := Result2 <> SizeOf(FileBlock2);
  54.      REPEAT
  55.       FileBlock1 := FileBlock2;
  56.       Result1 := Result2;
  57.       FOR i := 1 TO SizeOf(FileBlock2) DO
  58.         FileBlock2[i] := $00;
  59.       IF NOT EndFlag THEN
  60.         BEGIN
  61.          BlockRead(InF, FileBlock2,
  62.                    SizeOf(FileBlock2), Result2);
  63.          EndFlag := Result2 <> SizeOf(FileBlock2);
  64.         END
  65.       ELSE
  66.         BlkDone := TRUE;
  67.       IF NOT SearchResult THEN
  68.        FOR i := 1 TO Result1 DO
  69.         IF SearchArray[1] = FileBlock1[i] THEN
  70.          BEGIN
  71.           FOR j := 1 TO SearchLen DO
  72.            BEGIN
  73.             IF i+j-1 <= Result1
  74.               THEN SearchResult :=
  75.                SearchArray[j] = FileBlock1[i+j-1]
  76.               ELSE SearchResult :=
  77.                SearchArray[j] =
  78.                  FileBlock2[i+j-257];
  79.             IF NOT SearchResult THEN
  80.                j := SearchLen;
  81.            END;
  82.           IF SearchResult THEN
  83.            FOR j := 1 TO SearchLen DO
  84.             IF i+j-1 <= Result1
  85.              THEN FileBlock1[i+j-1] :=
  86.                    Ord(NewSpec[j])
  87.             ELSE FileBlock2[i+j-257] :=
  88.                    Ord(NewSpec[j]);
  89.        END;
  90.       BlockWrite(OutF, FileBlock1,
  91.                  Result1, Result1);
  92.      UNTIL BlkDone;
  93.      Close(OutF);
  94.      Close(InF);
  95.      erase(InF);
  96.      rename(OutF, Name+'.EXE');
  97.    END
  98.   ELSE
  99.    WriteLn(CurrPath, ' invalid file name!');
  100. END;
  101.  
  102. BEGIN
  103.    CurrPath := FExpand('LOCATION.EXE');
  104.    ClrScr;
  105.    WriteLn('CurrPath = ', CurrPath);
  106.    WriteLn('DataPath = ', DataPath);
  107.    WriteLn;
  108.    Write('Specification format:    ');
  109.    WriteLn('[d:\][path1\][path2\] ... ');
  110.    Write('Enter filepath specification: ');
  111.    ReadLn(NewPath);
  112.    IF NewPath <> '' THEN
  113.    BEGIN
  114.       FSplit(NewPath, Dir, Name, Ext);
  115.       NewPath := Dir;
  116.       WriteLn('New filepath = ', NewPath);
  117.       IF NewPath <> '' THEN
  118.        ReplaceSpec(CurrPath, DataPath, NewPath);
  119.    END;
  120.    GotoXY(1, 25);   clreol;
  121.    Write('Press any key to continue: ');
  122.    WHILE NOT KeyPressed DO;
  123. END.
  124.