home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / FILEAT.ZIP / FA.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-01-04  |  12.3 KB  |  364 lines
  1. (****************************************************************************)
  2. (*                                                                          *)
  3. (*   File Attribute Utility version 4.0                                     *)
  4. (*     by Steve Trace  OPUS & Fido Net 157/1                                *)
  5. (*                                                                          *)
  6. (*   version 4                                                              *)
  7. (*      Modified to run under Turbo Pascal 4.0                              *)
  8. (*      Utilizes 4.0 directory routines.                                    *)
  9. (*      Improved message on current path.                                   *)
  10. (*      CHMOD now only used to change attribute.                            *)
  11. (*      Improved syntax message when error occurs.                          *)
  12. (*                                                                          *)
  13. (*   version 3                                                              *)
  14. (*      never existed jumped to 4.0 to remain consistant with Borland       *)
  15. (*                                                                          *)
  16. (*   version 2a                                                             *)
  17. (*      Same as version 2 but included documentation file FILEATTR.DOC      *)
  18. (*                                                                          *)
  19. (*   version 2                                                              *)
  20. (*      Allowed directories to be hidden                                    *)
  21. (*      Allowed for use of full path on file spec                           *)
  22. (*                                                                          *)
  23. (*   version 1                                                              *)
  24. (*      Original version changed only files in current directory            *)
  25. (*                                                                          *)
  26. (****************************************************************************)
  27.  
  28.  
  29. {$R-,S-,I+,D+,T+,F-,V-,B-,N-,L+ }
  30. {$M 2048,0,4096}
  31.  
  32. program File_Attribute_Version_4;
  33.  
  34. { Manipulates DOS file & directory attributes
  35.      (Hidden, System, Archive, Read Only)     }
  36.  
  37. uses DOS;
  38.  
  39. type
  40.    changeType = (no,on,off);
  41.    attrType   = (arc,sys,hid,r_o);
  42.    attrArray  = array[attrType] of changeType;
  43.  
  44. const
  45.    mask       : attrArray = (no,no,no,no);  { typed constant default to no change }
  46.    changeAttr : boolean = false;            {  "     "  default to not changed }
  47.    changed    : word = 0;
  48.    count      : word = 0;
  49.  
  50. var
  51.    fData           : searchRec;
  52.    f               : file;
  53.    origAttr        : byte;
  54.    dir             : boolean;
  55.    fileSpec,
  56.    path            : string;
  57.    i               : word;
  58.  
  59. procedure syntaxError;
  60.  
  61.    begin
  62.       writeln('Syntax Error!');
  63.       writeln;
  64.       writeln('A>[d:][path\]FA [options] [d:][path\]fileSpec [options]');
  65.       writeln;
  66.       writeln('options *A -Archive');
  67.       writeln('        *H -Hidden');
  68.       writeln('        *R -Read Only');
  69.       writeln('        *S -System');
  70.       writeln;
  71.       writeln('replace * with (+) to set attribute');
  72.       writeln('               (-) to turn off attribute');
  73.       writeln;
  74.       writeln;
  75.       writeln;
  76.       writeln;
  77.       writeln;
  78.       writeln;
  79.       writeln;
  80.       writeln;
  81.       halt;
  82.    end;
  83.  
  84. function upcaseStr(s : string) : string;
  85.  
  86.    var
  87.       i : word;        { function converts string to upper case chacters }
  88.  
  89.    begin
  90.       for i := 1 to length(s) do
  91.          s[i] := upCase(s[i]);
  92.       upcaseStr := s;
  93.    end;
  94.  
  95. function DOSVersionOk : boolean;
  96.  
  97.    var
  98.       regs : registers;
  99.  
  100.    begin
  101.       with regs do
  102.          begin
  103.             ah := $30;            { DOS function hex 30 returns dos version }
  104.             MsDos(regs);          {             in al register              }
  105.             if al >= 2 then       { this program requires DOS 2.0 or higher }
  106.                DOSVersionOk := true
  107.             else
  108.                begin
  109.                   DOSVersionOk := false;
  110.                   writeln('FA Requires DOS 2.0 or Higher');  { if DOS 1.x print error msg }
  111.                end;
  112.          end;
  113.    end;
  114.  
  115. procedure error;
  116.  
  117.    begin
  118.       write('DOS Error: ',dosError:1,'- ');
  119.       case dosError of
  120.           2 : writeln('File not found');
  121.           3 : writeln('Path not found');
  122.           4 : writeln('Too many files open');
  123.           5 : writeln('Access denied');
  124.           6 : writeln('Invalid handle');
  125.           8 : writeln('Not enough memory');
  126.          10 : writeln('Invalid environment');
  127.          11 : writeln('Invalid format');
  128.          15 : writeln('Invalid drive');
  129.          18 : writeln('File not found or invalid drive');
  130.         100 : writeln('Disk read error');
  131.         101 : writeln('Disk write error');
  132.         150 : writeln('Disk write-protected');
  133.         152 : writeln('Disk drive not ready');
  134.         else writeln('Unknown error');
  135.       end;
  136.       halt;
  137.    end;
  138.  
  139. procedure SetChange(mark : char; bit : attrType; var mask : attrArray);
  140.               { mark mask with desired changes }
  141.    begin
  142.       if mark = '+' then   { if desire on then }
  143.          mask[bit] := on   { change portion of mask on }
  144.       else
  145.          mask[bit] := off; { else set it off }
  146.    end;
  147.  
  148. procedure MarkChange(mark, code : char; var mask : attrArray);
  149.                         { change mask modified if change requested }
  150.    begin
  151.       changeAttr := true;
  152.       case code of
  153.          'S' : SetChange(mark,sys,mask);
  154.          'H' : SetChange(mark,hid,mask);
  155.          'R' : SetChange(mark,r_o,mask);
  156.          'A' : SetChange(mark,arc,mask);
  157.          else syntaxError;      { if bad parameter passed then Print Syntax }
  158.       end;
  159.    end;
  160.  
  161. function extractPath(fileSpec : string) : string;
  162.  
  163.    var
  164.       path : string;     { Make path acceptable to DOS function Calls }
  165.                          { and break path from File name or spec }
  166.  
  167.    function parsePath(path : string) : string;
  168.  
  169.       var
  170.          current : string;
  171.          drive   : word;
  172.  
  173.       begin
  174.          if pos(':',path) = 0 then
  175.             drive := 0
  176.          else
  177.             begin
  178.                drive := byte(path[1]) - 64;
  179.                delete(path,1,pos(':',path));
  180.             end;
  181.          getDir(drive,current);
  182.          if path = '' then
  183.             begin
  184.                if current[length(current)] = '\' then
  185.                   parsePath := current
  186.                else
  187.                   parsePath := current + '\'
  188.             end
  189.          else
  190.             begin
  191.                case path[1] of
  192.                   '\' : parsePath := copy(current,1,2) + path;
  193.                   '.' : begin
  194.                            while pos('..\',path) > 0 do
  195.                               begin
  196.                                  delete(path,1,3);
  197.                                  delete(current,length(current),1);
  198.                                  while current[length(current)] <> '\' do
  199.                                     delete(current,length(current),1);
  200.                               end;
  201.                            parsePath := current + path;
  202.                         end;
  203.                   else begin
  204.                           if current[length(current)] = '\' then
  205.                              parsePath := current + path
  206.                           else
  207.                              parsePath := current + '\' + path;
  208.                        end;
  209.                end;
  210.             end;
  211.       end;
  212.  
  213.    begin
  214.       path := fileSpec;
  215.       if (pos('\',fileSpec) = 0) and (pos(':',fileSpec) = 0) then
  216.          path := ''
  217.       else
  218.          begin
  219.             while (path[length(path)] <> ':') and (path[length(path)] <> '\') do
  220.                delete(path,length(path),1);
  221.          end;
  222.       extractPath := parsePath(path);
  223.    end;
  224.  
  225. function params(var path,fileSpec : string; var mask : attrArray) : boolean;
  226.  
  227.    var
  228.       i : word;  { read parameters passed with fa2 and set changes }
  229.       s : string;
  230.  
  231.    begin
  232.       if ParamCount = 0 then
  233.          params := false
  234.       else
  235.          begin
  236.             for i := 1 to ParamCount do
  237.                begin
  238.                   s := ParamStr(i);
  239.                   s := upcaseStr(s);
  240.                   case s[1] of            { if flag to change then change }
  241.                      '+',
  242.                      '-' : MarkChange(s[1],s[2],mask);
  243.                      else fileSpec := s;
  244.                   end;
  245.                end;
  246.             if fileSpec = '' then
  247.                params := false
  248.             else
  249.                begin
  250.                   params := true;
  251.                   path := extractPath(fileSpec);
  252.                end;
  253.          end;
  254.    end;
  255.  
  256. function switch(attr : byte; mask : attrArray) : byte;
  257.  
  258.    { if change requested make it if not already exists }
  259.  
  260.    begin
  261.       case mask[arc] of
  262.          on  : Attr := Attr or archive;
  263.          off : Attr := Attr and (not archive);
  264.       end;
  265.       case mask[sys] of
  266.          on  : Attr := Attr or sysFile;
  267.          off : Attr := Attr and (not sysFile);
  268.       end;
  269.       case mask[hid] of
  270.          on  : Attr := Attr or hidden;
  271.          off : Attr := Attr and (not hidden);
  272.       end;
  273.       case mask[r_o] of
  274.          on  : Attr := Attr or readOnly;
  275.          off : Attr := Attr and (not readOnly);
  276.       end;
  277.       switch := Attr;
  278.    end;
  279.  
  280. procedure bracket(msg : string);
  281.  
  282.    begin
  283.       write('[',msg,']   ');
  284.    end;
  285.  
  286. procedure report(fileData : searchRec);
  287.  
  288.    var
  289.       dateData : dateTime;
  290.  
  291.    begin                       { report file name and attributes }
  292.       with fileData do
  293.          begin
  294.             write(' ',name);
  295.             for i := length(name) to 13 do
  296.                write(' ');
  297.             if attr and directory = directory then
  298.                write('<DIR>   ')
  299.             else
  300.                write('        ');
  301.             if attr and archive = archive then
  302.                bracket('Arc');
  303.             if attr and sysFile = sysFile then
  304.                bracket('Sys');
  305.             if attr and hidden = hidden then
  306.                bracket('Hid');
  307.             if attr and readOnly = readOnly then
  308.                bracket('R-O');
  309.             writeln;
  310.          end;
  311.    end;
  312.  
  313. begin
  314.    writeln;
  315.    writeln('File Attribute Utility   version 4.0   by Steve Trace');
  316.    writeln;
  317.    if not params(path,fileSpec,mask) then
  318.       syntaxError;                             { if no parameters print syntax }
  319.    if not DosVersionOk then
  320.       halt;
  321.    findFirst(fileSpec,anyFile,fData);          { find 1st occurance of fileSpec }
  322.    if dosError = 0 then                        { if all well }
  323.       begin
  324.          writeln(' Directory of: ',path);     { print path }
  325.          writeln;
  326.          repeat
  327.             with fData do
  328.                begin
  329.                   if name[1] <> '.' then       { if not a . or .. directory }
  330.                      begin
  331.                         inc(count);
  332.                         if changeAttr then     { if attribute change requested }
  333.                            begin
  334.                               origAttr := attr;
  335.                               dir := (attr and directory) = directory;
  336.                               if dir then
  337.                                  attr := switch(attr,mask) and (not (directory + archive + sysFile + readOnly))
  338.                               else
  339.                                  attr := switch(attr,mask);
  340.                               assign(f,path + name);
  341.                               setFattr(f,attr);
  342.                               if dir then
  343.                                  attr := attr or directory;
  344.                               if attr <> origAttr then
  345.                                  inc(changed);
  346.                            end;                    { requires assign(f,path + name)}
  347.                         report(fData);
  348.                      end;
  349.                end;
  350.             findNext(fData);
  351.             if not (dosError in [0,18]) then
  352.                error;
  353.             if (count mod 21) = 20 then
  354.                begin
  355.                   write('Press <Enter> to continue');
  356.                   readln;
  357.                end;
  358.          until dosError = 18;                    { until no more files found }
  359.          writeln;
  360.          writeln('Total files: ',count,'   Total changed: ',changed)
  361.       end
  362.    else
  363.       error;
  364. end.