home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / BEEHIVE / UTILITYS / PUDD.ARC / FILETOOL.PAS < prev    next >
Pascal/Delphi Source File  |  1991-08-11  |  7KB  |  256 lines
  1. {...................do these declarations in the main file............
  2. type  filename =   string[8]   ;
  3.       filetype =   string[3]   ;
  4.       fullname =   string[14]  ;
  5. var   name :       filename    ;
  6.       ftype :      filetype    ;
  7.       UseFile :    fullname    ;
  8.       drive :      char        ;
  9.       X,Y  :       integer     ;}
  10.  
  11. function Exist(name:fullname):boolean;   {....if file exists returns true }
  12. var
  13.   fil:file;
  14. begin
  15.  Assign(fil,name);
  16.  {$I-}
  17.  Reset(fil);
  18.  {$I+}
  19.  Exist := (IOresult = 0)
  20. end;
  21.  
  22. function CurrDrive:char; { ...returns the current drive as a single charactor}
  23. var DriveNum:integer;
  24. begin
  25.   DriveNum :=  Bdos(25);
  26.   case DriveNum of
  27.    0:CurrDrive := 'A';
  28.    1:CurrDrive := 'B';
  29.    2:CurrDrive := 'C';
  30.    3:CurrDrive := 'D';
  31.    4:CurrDrive := 'E';
  32.    5:CurrDrive := 'F';
  33.    6:CurrDrive := 'G';  {..I could go on but who has more than 6 drives ?}
  34.   end;  {............case }
  35. end;
  36.  
  37. procedure NewDrive(Drive:char);  {..changes current logged drive}
  38. var DriveNum:integer;
  39. begin
  40.  DriveNum := 0;
  41.  case UpCase(Drive) of
  42.  'A':DriveNum := 0;
  43.  'B':DriveNum := 1;
  44.  else
  45.   begin
  46.    write('Error....illegal drive designation  Drive will default to A:');
  47.    write(^G);
  48.    delay(1500);
  49.   end;
  50.  end; {........case}
  51.  Bdos(14,DriveNum);
  52. end;
  53.  
  54. procedure GetDrive(var UseFile:fullname;var drive:char);
  55.           { .......................set drive from file specified, if
  56.                                  none stated drive is set to default }
  57. begin
  58.  if copy(UseFile,2,1) = ':' then    {..check for drive designation}
  59.   begin
  60.    drive := UpCase(copy(UseFile,1,1));
  61.    UseFile := copy(UseFile,3,12);
  62.   end
  63.  else                               {......else use current drive }
  64.   begin
  65.    drive := CurrDrive;
  66.   end;
  67. end;
  68.  
  69. function CheckString(UseFile:filename):boolean;      {..check for valid name}
  70. begin
  71.   if pos('*',UseFile)           { .....checks common illegal charactors }
  72.     +pos('.BAK',UseFile)        {......and dis-allows .bak types        }
  73.     +pos('?',UseFile)
  74.     +pos(';',UseFile)           {.......dis-allows common errors        }
  75.     +pos('C:',UseFile)          {...... dis-allows non-existant drives  }
  76.     +pos('D:',UseFile)
  77.     +pos(' ',UseFile)
  78.     +pos('!',UseFile) <> 0 then
  79.       CheckString := false
  80.    else
  81.       CheckString := true;
  82. end;
  83.  
  84.  
  85. procedure UpCaseString(var name:fullname);  {....change string to upper case}
  86. var i :    integer ;
  87.     byte : char    ;
  88. begin
  89.   for i := 1 to length(name) do
  90.    begin
  91.      byte := copy(name,i,1);
  92.      delete(name,i,1);
  93.      insert(UpCase(byte),name,i);
  94.    end;
  95. end;
  96.  
  97.  
  98. procedure GetType(var UseFile:fullname;var ftype:filetype);
  99.                           {.......... sets type and strips type from name
  100.                                       if no type present a default is set }
  101. const DefaultType : string[3] = 'SCR';
  102. var i : integer;
  103. begin
  104.    if pos('.',UseFile) <> 0 then    {....strip off the file type}
  105.     begin
  106.       i := pos('.',UseFile);
  107.       ftype := copy(UseFile,(i+1),3);
  108.       UseFile := copy(UseFile,1,(i-1));
  109.     end
  110.    else
  111.       ftype := DefaultType;
  112. end;
  113.  
  114.  
  115. procedure FetchName(var drive:   char;          {...gets a legal name }
  116.                     var name:    filename;
  117.                     var ftype:   filetype;
  118.                         X,Y  :   integer );
  119.  
  120. var UseFile:fullname;
  121. begin
  122.  UseFile := '?';       {.....initalize name}
  123.  while not CheckString(UseFile) do
  124.   begin
  125.    GotoXY(X,Y);
  126.    ClrEol;
  127.    write('Enter a file name ');
  128.    read(UseFile);
  129.    UpCaseString(UseFile);
  130.    if not CheckString(UseFile) then
  131.     begin
  132.      GotoXY(X,Y);
  133.      ClrEol;
  134.      write('illegal file name!');
  135.      Delay(1500);
  136.     end;
  137.   end;
  138.  GetDrive(UseFile,drive);
  139.  GetType(UseFile,ftype);
  140.  name := copy(UseFile,1,8);
  141. end;
  142.  
  143.  
  144. procedure  BackFile(drive:  char    ;      {..........backup a file}
  145.                     name :  filename;
  146.                     ftype:  filetype );
  147.  
  148. var old     :   file     ;
  149.     UseFile :   fullname ;
  150. begin
  151.   UseFile := drive+':'+name+'.'+'bak'; {...erase any old *.bak file}
  152.   if Exist(UseFile) then
  153.     begin
  154.       assign(old,UseFile);
  155.       Erase(old);
  156.     end;
  157.   assign(old,drive+':'+name+'.'+ftype); {.....rename *.* to *.bak }
  158.   UseFile := drive+':'+name+'.'+'bak';
  159.   Rename(old,UseFile);
  160. end;
  161.  
  162. procedure NewFileName(var drive :     char    ;
  163.                       var name  :     filename;
  164.                       var ftype :     filetype;
  165.                           X,Y   :     integer);
  166. var   UseFile :    fullname    ;
  167.       byte :       char        ;
  168.       i :          integer     ;
  169.       done :       boolean     ;
  170.  
  171. begin
  172.  done := false;
  173.  while not done do
  174.  begin
  175.   FetchName(drive,name,ftype,X,Y);             {...get a legal name}
  176.   if Exist(drive+':'+name+'.'+ftype) then      {...check previous existance}
  177.     begin
  178.       GotoXY(X,Y);
  179.       ClrEol;
  180.       write('File exists................ ');
  181.       Delay(1500);
  182.       GotoXY(X,Y);
  183.       ClrEol;
  184.       write('(B)ackup, (C)hange name, (O)verwrite ..... ');
  185.        begin
  186.           repeat
  187.            read(kbd,byte);
  188.            byte := UpCase(byte)
  189.           until ((byte = 'B') or
  190.                  (byte = 'C') or
  191.                  (byte = 'O')  );
  192.           case byte of
  193.            'B':begin              {.......(B)ackup existing  }
  194.                  BackFile(drive,name,ftype);
  195.                  done := true;
  196.                end;
  197.            'O':begin              {.......(O)verwrite }
  198.                 done := true;
  199.                end;
  200.            'C':begin              {....get a different name }
  201.                end;
  202.           end;  {......case}
  203.        end;
  204.     end  {.....existance question}
  205.     else
  206.      done := true;
  207.   end;
  208. end;  {......file drive, name, and type found}
  209.  
  210.  
  211.  
  212. procedure OldFileName(var drive :     char    ;
  213.                       var name  :     filename;
  214.                       var ftype :     filetype;
  215.                           X,Y   :     integer);
  216. var   UseFile :    fullname    ;
  217.       byte :       char        ;
  218.       i :          integer     ;
  219.       done :       boolean     ;
  220.  
  221. begin
  222.  done := false;
  223.  while not done do
  224.  begin
  225.   FetchName(drive,name,ftype,X,Y);             {...get a legal name}
  226.   if not(Exist(drive+':'+name+'.'+ftype)) then      {...check previous existance}
  227.     begin
  228.       GotoXY(X,Y);
  229.       ClrEol;
  230.       write('No such file exists................ ');
  231.       Delay(1500);
  232.       GotoXY(X,Y);
  233.       ClrEol;
  234.       write('(C)hange name  or  (Q)uit ..... ');
  235.        begin
  236.           repeat
  237.            read(kbd,byte);
  238.            byte := UpCase(byte)
  239.           until ((byte = 'Q') or
  240.                  (byte = 'C')  );
  241.           case byte of
  242.            'Q':begin              {.......Quit }
  243.                 done := true;
  244.                 name := '';
  245.                 ftype := '';
  246.                end;
  247.            'C':begin              {....get a different name }
  248.                end;
  249.           end;  {......case}
  250.        end;
  251.     end  {.....existance question}
  252.     else
  253.      done := true;
  254.   end;
  255. end;  {......file drive, name, and type found}
  256.