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