Power-Programmierung/CD1.mdf/pascal/library/dos/files/fileman/mdel/mdel.pas

Pascal/Delphi Source File | 1988-09-03 | 24.4 KB | 796 lines

{
                       F i l e    I n f o r m a t i o n

* DESCRIPTION
MDEL (version T1.0) by Michael Miller is a replacement for the
DOS DELete command. Written in Turbo Pascal 4.0. MDEL emulates
the VAX/VMS delete utility, which includes several options not
available in the DOS version.

* ASSOCIATED FILES
MDEL.PAS
MDEL.DOC
MDEL.EXE

==========================================================================
}
program mdel;
{
  Copyright by
   Michael M. Miller
   Box 293
   Hecker,Il,62248
   2 Mar 1988
   All Rights Reserved
   Released for non-commercial use only
}
uses dos;

type
  string8 = string[8];
  userspec = string[64];
  filename = string[13];
  entry_type = record
                dirname : string[13];
                level : integer;
               end;
  stack_ptr = ^stack;
  stack = record
            entry : entry_type;
            next : stack_ptr;
          end;

var
  transferrec : searchrec;

  excl_spec,matchptrn,path,pathtmp : userspec;

  excl_nam,exc_nam,exc_ext,
  match_nam,match_ext,retname,file_nam : filename;

  exc_flag,place,pcnt,
  a_date,b_date,
  current_lvl,match_flag,lvl : integer;

  confirm ,log, after, before,exclude,
  nofind,lastfile,empty,excl_mult,
   multiple,subdirec : boolean;

  stk : stack_ptr;

  dir_rec : entry_type;

  dirpath : array[1..20] of filename;

procedure error(status : byte);

begin
  write(^G,'Error --');
  case status of
     1 : writeln(' Invalid function');
     2 : writeln(' File not found');
     3 : writeln(' Path not found');
     4 : writeln(' Too many open files');
     5 : writeln(' Access denied');
     6 : writeln(' Invalid file handle');
     7 : writeln(' Arena trashed');
     8 : writeln(' Not enough memory');
     9 : writeln(' Invalid block');
     10 : writeln(' No environment');
     11 : writeln(' No format');
     12 : writeln(' Invalid access code');
     13 : writeln(' Invalid data');
     15 : writeln(' Invalid drive');
     16 : writeln(' Can not remove current directory');
     17 : writeln(' Not same device');
     18 : writeln(' No more files');
     20 : writeln(' Invalid number of parameters.');
  end;
  halt;   {no return from here}
end;


function get_current_drive:byte;
{ get default drive spec }
 var regs : registers;

begin
  with regs do
   begin
     ax := $1900;       {set DOS function}
     msdos(regs);
     get_current_drive := lo(ax);       {return drive #}
   end;
end;

procedure give_help;
var ans : char;
begin
   writeln('MDEL  File delete utility');
   writeln('Command format:');
   writeln('mdel[/l][/c][/a=mm-dd-yy][/b=mm-dd-yy][/e=[path]filename] [path]filename');
   writeln(' (brackets indicate optional items)');
   writeln('Parameters and switches');
   writeln('  /l              list files as they are deleted. Default for *.* filename');
   writeln('  /c              confirm that this file is to be deleted');
   writeln('  /e              exclude specified files from being deleted');
   writeln('  /a  /b          allows before and after dates to select which');
   writeln('                   files are to be deleted. date format is mm-dd-yy');
   write('Press return for more...');
   readln(ans);
   writeln('  Path format');
   writeln('  path\filename             delete specified file');
   writeln('  drv:\dirnam...\filename   delete file(s) from directory and all subtrees');
   writeln('  drv:\*...\filename        delete file(s) on entire given drive');
   writeln('  *...\filename             delete file(s) on entire default drive');
   writeln('  ...\filename              delete file(s) from current directory & subtrees');
   writeln('  Filename format');
   writeln('   name.ext          any valid file name');
   writeln('   [*].ext           delete all files that end with ext');
   writeln('   name[.*]          delete all files that start with name');
   writeln('   [*cc*][.*cc*]     delete files based on a combination of wildcards');
   writeln('                     wildcards can be at the beginning or end of each part of');
   writeln('                     the filename but not at the same time. For example:');
   writeln('                       *trek.p*  is valid   *tre*.pas  is invalid');
   writeln(' Copyright 1988  Michael M. Miller');
   halt;  { do nothing else if help given}
end;


procedure push (var top: stack_ptr;
                    new_entry: entry_type);
{ This routine pushes an entry onto a stack. }

  var
    temp: stack_ptr;       {temporary record}

  begin
    new(temp);   {create a new record}
    temp^.entry := new_entry; {fill the record with the entry information}
    temp^.next := top;    {link the new record to the top of the stack}
    top := temp;   {set the top of the stack to the new record}
  end;   { push }

procedure pop (var top: stack_ptr;
           var top_entry: entry_type;
             var empty_stack: boolean);
{ This routine pops the top record off of the stack and
returns the value of its contents.  If the stack is empty,
an error flag is set. }


  var
    temp: stack_ptr;        {temporary record}

  begin
    if top = nil then   {if the stack is empty, set error flag}
      empty_stack := true
    else
      begin
        empty_stack := false;
        top_entry := top^.entry;  {fill record from top of stack }
        temp := top; {remember the current stack top for later disposal}
        top := top^.next;  {move the top down}
        dispose (temp);    {dispose of the old top record}
      end;
  end;  { pop }

procedure string_to_date (in_date: string8;
              var day,month,year : integer;
              var date_error: boolean);
{
    This procedure converts a date in string form to
    its component parts.

parameters:
    in_date (in) - the date input (mm-dd-yy)
    day (out) - the day of the month [1-31]
    month (out) - the month of the year [1-12]
    year (out) - [1980-2099]
    date_error (out) - flag showing if the numbers were bad

}

    var
      VALCODE: integer;                   {the string convert error code}

    begin
      date_error := false;
      val(copy (in_date, 1, 2), month, valcode);  {convert the month}
      if valcode <> 0 then
    date_error := true
      else
    begin
      val(copy (in_date, 4, 2), day, valcode);  {convert the day}
      if valcode <> 0 then
        date_error := true
      else
        begin
          val(copy (in_date, 7, 2), year, valcode);  {convert the year}
          if valcode <> 0 then
        date_error := true;
        end;
    end;
    end;

function set_match_date (day,month,year :integer): integer;
{
    This routine converts the input date to the format used
    in the files FCB.

parameters:
    day (in) - day of the month [1-31]
    month (in) - month of the year [1-12]
    year (in) - [1980-2099]
    set_match_date(out) converted date
}
var match_date :integer;

begin   {convert date to internal format}
  match_date := (year - 80) shl 9;
  match_date := match_date + (month shl 5);
  set_match_date := match_date + day;
end;

procedure parse_sw(var count,index : integer);
{this procedure decodes any command line option switches
  and sets global variables for them. it also passes
  back a modified parameter count and an index to the
  file specification.

parameters
 count (out)                   count of parameters left to process
 index (out)                   postion of the file specification on
                the command line
 confirm  (global)              boolean switches for the
 log (global)                     various command line
 after (global)                     switches that are
 before (global)                       possible
 a_date (global)                after date
 b_date (global)                before date

}
var
  swf,err : boolean;      {flags that switches were found}
  day,month,year,
  s_count,i,x,j : integer;  {counters}
  t_date : string8;    {temporary for any input date strings}
  temp : userspec;     {temporary for the options}

begin
  count := paramcount;   {make working copy}
  if count <> 0
   then begin
    if count > 2 then error(20);
    swf := false;
    for x := 1 to count do
    begin
      if pos('/',paramstr(x)) = 1   { check for switches }
      then begin
    temp := paramstr(x);    {copy the switch string}
    s_count:=0;
    for i := 1 to length(temp) do
    begin                    {get switch count}
      if temp[i] = '/' then s_count := s_count + 1;
      temp[i] := upcase(temp[i]);
    end;
    i := 2;  {set switch index}
    for j := 1 to s_count do
      case temp[i] of
         'C' : begin
             confirm := true;
             i := i + 2;
           end;
         'L' : begin
             log := true;
             i := i + 2;
           end;
     'A','B' : begin
             t_date := copy(temp,i+2,8);
             string_to_date(t_date,day,month,year,err);
             if not err
             then begin
               if temp[i] = 'A' then
             begin
              a_date := set_match_date(day,month,year);
              after := true;
             end
               else begin
             b_date := set_match_date(day,month,year);
             before := true;
            end;
               i := i +11;
               end
             else begin
              writeln('Error in date parameter');
              halt;
             end;
           end;
         'E' : begin
             excl_spec := copy(temp,i+2,length(temp));
             if pos('/',excl_spec) <> 0  {if not the last switch}
               then begin                {keep only the exclude stuff}
             excl_spec:=copy(excl_spec,1,pos('/',excl_spec)-1);
             i:=i+length(excl_spec)+3;
               end;
             exclude:=true;
           end;
      end; {case}
    swf := true;   { flag that a switch was found }
      end;
    end;        {for}
    if swf and (count = 2)  {now set index to file spec if needed }
     then index := 2
     else if swf and (count = 1)
         then count := 0
         else index := 1;
   end;
end;   {parse_sw}


procedure parse_path(var filnam : filename;
             var rootnam : userspec;
             var multple : boolean);
{ this routine will parse the input parameters and seperate the path name
   from the file name.


parameters
 filnam (out)                   file to search for
 rootnam (in/out)               (in) data to parse
                (out) search path start point
 multple (out)                  single or multiple directory flag
 paramstr(x) (global)           command line parameter(s)
}

var
 temp : userspec;
 posinstr,i : integer;
 ans : char;
begin
    temp := rootnam;        {make copy of input file spec}
    if temp = '?' then give_help;
    if (pos('\',temp) = 0) and (pos(':',temp) = 0) then   {only filename given}
     begin
       getdir(0,rootnam);
       multple := false;
       if (length(rootnam)=3) and (pos(':',rootnam) = 2) and (pos('\',rootnam) = 3)
      then rootnam := chr(65+get_current_drive) + ':';
       if (pos('.',temp) = 0) then temp := temp + '.*';
       if pos('.',temp) = 1 then temp := '*' + temp;
       filnam := '\' + temp;
     end
    else
     begin      {extract path from input data}
       if pos('\',temp)=0
     then begin
       posinstr:=pos(':',temp);
       filnam := '\' + copy(temp,posinstr+1,length(temp));
       rootnam := copy(temp,1,2);
       end
     else begin
       posinstr:=length(temp);
       while temp[posinstr] <> '\' do posinstr :=posinstr-1;
       if (pos('\',temp)<>posinstr)
       then begin
         filnam := copy(temp,posinstr,length(temp));
         rootnam := copy(temp,1,posinstr-1);
        end
       else begin
         if (pos('\',temp) = 1) or (pos(':\',temp) = 2)
           then begin
             rootnam := copy(temp,1,length(temp));
             filnam :='\*.*';
             end
           else begin
             rootnam := copy(temp,1,posinstr-1);
             filnam := copy(temp,posinstr,length(temp));
           end;
        end;
      end;
       if ((length(filnam)=1) and (filnam = '\')) then filnam :='\*.*';
       if (pos('.',filnam) = 0) then filnam := filnam + '.*';
       if pos('\.',filnam) = 1 then filnam := '\*' + copy(filnam,2,length(filnam));
       if pos(':',rootnam) = 0
     then if (pos('\',rootnam) = 1) or (length(rootnam) = 0)
         then rootnam := chr(65+get_current_drive) + ':' + rootnam
         else begin
          getdir(0,temp);
          if length(temp) = 0
           then rootnam := chr(65+get_current_drive) + ':\' + rootnam
           else rootnam := temp + '\' + rootnam;
         end;
       multple := false;        {say no wild card search for now}
       posinstr := pos('*...',rootnam); {check for wild cards}
       if posinstr > 0 then
    begin
      rootnam := copy(rootnam,1,2);
      multple := true;
    end
       else
    begin
      posinstr := pos('...',rootnam); {check for other wild cards}
      if posinstr > 0 then
       begin
        if rootnam[posinstr-1]='\'
         then rootnam := copy(rootnam,1,posinstr-2)
         else rootnam := copy(rootnam,1,posinstr-1);
         multple := true;
       end;
    end;
     end;
    if pos('\*.*',filnam) > 0
     then begin
       write('Are you sure[Y/N]? ');
       readln(ans);
       if upcase(ans) = 'Y'
     then log := true
     else halt;
       if not confirm
       then begin
     write('Do you wish to confirm each deletion[Y/N]?');
     readln(ans);
     if upcase(ans) = 'Y'
       then confirm := true;
       end;
     end;
    for i:= 1 to length(filnam) do
     filnam[i] := upcase(filnam[i]); {convert to upper case}
    for i:= 1 to length(rootnam) do
     rootnam[i] := upcase(rootnam[i]); {convert to upper case}
end;    {parsecmd}

procedure parsefil(var filnam:filename;
                   var result_nam : filename;
                   var result_ext : filename;
                   var result_flag : integer);
{ this procedure parses the input file looking for wild cards and
 sets a code specifing which action to take based on wild cards found.

parameters
  filnam(in)             input filename
  result_nam(out)        name porition of the filename
  result_ext(out)        extension porition
  result_flag(out)       action code used to match files
}

var
 nam_pos,ext_pos,dot_cnt :integer;


begin
  result_flag := 0;
  dot_cnt := pos('.',filnam);   {get split point}
  result_nam := copy(filnam,2,dot_cnt-2);
  result_ext := copy(filnam,dot_cnt+1,3);
  nam_pos := pos('*',result_nam);
  ext_pos := pos('*',result_ext);
  if ((nam_pos + ext_pos)=0)
   then result_flag:=0  {no wild cards}
   else
    if ((nam_pos - ext_pos)=0) and (length(filnam)=4)
     then result_flag:=1    {both wild}
     else
      begin
        if nam_pos > 0 then
         begin        {wild card in name}
           if result_nam='*' then result_flag:=2
           else
            if result_nam[1]='*' then
             begin
               result_nam:=copy(result_nam,2,length(result_nam)-1);
               result_flag:=3;         {wild 1st char}
             end
            else
             begin
               result_nam:=copy(result_nam,1,nam_pos-1);
               result_flag:=4;         {wild last char}
             end;
         end;
    if ext_pos > 0 then
         begin        {wild card in ext}
           if result_ext='*' then
                 if result_flag = 0 then result_flag:=5
                                    else result_flag:=result_flag+6
           else
            if result_ext[1]='*' then
             begin
               result_ext:=copy(result_ext,2,length(result_ext)-1);
               if result_flag=0
                then result_flag:=6         {wild 1st char}
                else result_flag:=result_flag+10;
             end
            else
             begin
               result_ext:=copy(result_ext,1,ext_pos-1);
               if result_flag=0
                then result_flag:=7         {wild last char}
                else result_flag:=result_flag+20;
             end;
         end;
      end;
  filnam := '\*.*'; {change input to catch everything}
end; {parsefil}

procedure fndfirst(pattern : userspec; var found : filename;
  var nomatch : boolean; var lastone : boolean;
  var subdir :boolean);

var
  count : integer;

begin
 findfirst(pattern,anyfile,transferrec);
 if doserror > 0 then
  begin
    case doserror of
      2 : begin {no match}
        nomatch:=true;
        lastone:=true;
      end;
     18 : begin {no more files}
        nomatch:=false;
        lastone:=true;
      end;
    else error(doserror);
    end; {case}
  end
  else
   begin
     nomatch:=false;
     lastone:=false;
   end;
 if (not nomatch) then
  with transferrec do
  begin
    found:=name;
    if (attr and directory) > 10 {test to see if it is a subdirectory}
     then
      begin
    subdir:=true;
    if (found <> '.') and (found <> '..') then
     begin   { found a subdir so put it on the stack }
       dir_rec.dirname := found;
       dir_rec.level := current_lvl;
       push(stk,dir_rec);
     end;
      end
     else begin
       subdir:=false;
     end;
    for count:=length(found) +1 to 13
      do found:=found + ' ';
  end;
end; {fndfirst}

procedure fndnext(var found : filename;
  var lastone : boolean; var subdir : boolean);

var
  count : integer;

begin
  findnext(transferrec);
  if doserror > 0 then
   if doserror = 18 then lastone:=true
            else error(doserror)
  else lastone :=false;
  if not lastone then
   begin
     with transferrec do
     begin
       found:=name;
       if (attr and directory) > 10
    then
     begin
       subdir:=true;
       if (found <> '.') and (found <> '..') then
        begin  { found a subdir so put it on the stack }
          dir_rec.dirname := found;
          dir_rec.level := current_lvl;
          push(stk,dir_rec);
        end;
     end
    else begin
      subdir:=false;
       end;
       for count:=length(found) +1 to 13
     do found:=found + ' ';
     end; {with transferec}
   end;
end; {fndnext}

function check_file_name (file_name,chk_nam,chk_ext : filename;
              chk_flag : integer) : boolean;
{ check the input filename against what was specified by the user
  using the match code from parsefil
}
 var
  tst_nam,tst_ext : filename;

 begin
   check_file_name:=false;   {assume false until true}
   tst_nam:=copy(file_name,1,pos('.',file_name)-1);  {extract the good}
   tst_ext:=copy(file_name,pos('.',file_name)+1,3);  {  parts}
   case chk_flag of  {now check for a valid file name}
     0: if (chk_nam = tst_nam) and (chk_ext = tst_ext)
          then check_file_name:=true;
     1: check_file_name:=true;
     2: if chk_ext = tst_ext then check_file_name:=true;
     3: if (pos(chk_nam + '.',tst_nam + '.') > 0) and
       (chk_ext = tst_ext) then check_file_name:=true;
     4: if (pos(chk_nam,tst_nam) =1) and
       (chk_ext = tst_ext) then check_file_name:=true;
     5: if chk_nam = tst_nam then check_file_name:=true;
     6: if (chk_nam = tst_nam) and (pos(chk_ext,tst_ext) >=1)
           then check_file_name:=true;
     7: if (chk_nam = tst_nam) and (pos('.'+chk_ext,'.'+tst_ext)>0)
           then check_file_name:=true;
     9: if (pos(chk_nam + '.',tst_nam + '.') > 0) then check_file_name:=true;
    10: if (pos(chk_nam,tst_nam) =1) then check_file_name:=true;
    12: if (pos(chk_ext,tst_ext) >=1) then check_file_name:=true;
    13: if (pos(chk_nam + '.',tst_nam + '.') > 0) and
       (pos(chk_ext,tst_ext) >=1) then check_file_name:=true;
    14: if (pos(chk_nam,tst_nam) =1) and
       (pos(chk_ext,tst_ext) >=1) then check_file_name:=true;
    22: if  (pos('.'+chk_ext,'.'+tst_ext)>0) then check_file_name:=true;
    23: if (pos(chk_nam + '.',tst_nam + '.') > 0) and
       (pos('.'+chk_ext,'.'+tst_ext)>0) then check_file_name:=true;
    24: if (pos(chk_nam,tst_nam) =1) and
       (pos('.'+chk_ext,'.'+tst_ext)>0) then check_file_name:=true;
   end;                {case of chk_flag}
 end;    {check_file_name}

procedure delete_file (filename: userspec);
{
    This routine deletes the file specified.

parameters:
    filename (in) - the file to delete
    confirm  (global)   boolean switches for the
    log (global)          various command line
    after (global)          switches that are
    before (global)           possible


}
  var
    regs: registers;
    ok_to_delete : boolean;
    ans : char;
    status : byte;
    fdate : datetime;
    filedate : integer;

begin
    ok_to_delete := true;
    if before or after   {check file date if needed}
      then with transferrec do
       begin
     unpacktime(time,fdate);  {convert date to FCB format}
     filedate := set_match_date(fdate.day,fdate.month,fdate.year-1900);
     if after       {after date flag set}
      then if  filedate < a_date then ok_to_delete := false
                     else ok_to_delete := true;
     if before       {before date flag set}
      then if  filedate > b_date then ok_to_delete := false
                     else ok_to_delete := true;
     if before and after    {both date flags set}
       then if (filedate <= b_date) and (filedate >= a_date)
           then ok_to_delete := true
           else ok_to_delete := false;
       end; {with transferrec}
    if confirm and ok_to_delete
      then begin
    write('Delete ',filename,' [Y/N/Q]? ');
    readln(ans); ans:=upcase(ans);
    if ans = 'Y' then ok_to_delete := true
             else ok_to_delete := false;
    if ans = 'Q' then halt;
       end;
    if ok_to_delete
      then with regs do
      begin  {convert the file name to delete to asciiz and set the registers
        to delete the file}
       filename := filename + chr(0);     {convert to asciiz}
       ax := $4100;                       {DOS function code}
       ds := seg(filename[1]);
       dx := ofs(filename[1]);
       msdos(regs);  {delete the file}
       if ((1 and flags) = 1) then    {test status}
       error(lo(ax));             {error if carry flag set}
      end;
    if log and ok_to_delete
       then writeln('File ',filename,' deleted');
  end; {delete_file}

procedure pad(var extension : filename; ext_code : integer);
{
  This procedure pads the input filename extension if it is
  less than 3 characters. This allows easier matching to what
  DOS returns in the check_file_name function.
}
begin
  case ext_code of
   0,2,3,4 : while length(extension) < 3
              do extension := extension + ' ';
  end; {case}
end; {pad}

begin {main}
  stk := nil; {init the globals}
  confirm := false;
  log := false;
  after := false;
  before := false;
  exclude := false;
  current_lvl := 1;
  parse_sw(pcnt,place);  {process command line options}
  if pcnt = 0 then
    begin  { no input data so halt }
      writeln(^G'*** Input Filename Missing. ***');
      writeln;
      give_help;
    end;
  if exclude
   then begin
     parse_path(excl_nam,excl_spec,excl_mult);   {process exclude file spec}
     parsefil(excl_nam,exc_nam,exc_ext,exc_flag); {and filename}
     if length(exc_ext) < 3
        then pad(exc_ext,exc_flag);
   end;
  path:=paramstr(place);                {get input file spec}
  parse_path(file_nam,path,multiple);   {parse path spec}
  parsefil(file_nam,match_nam,match_ext,match_flag);  {now check the filename}
                                                      {for wildcards}
  if length(match_ext) < 3
     then pad(match_ext,match_flag);
  matchptrn := path + file_nam;
  pathtmp := path;
  repeat
    fndfirst(matchptrn,retname,nofind,lastfile,subdirec);
    if nofind or lastfile then writeln('No Files Found')
     else
      begin
        while (not lastfile) do
        begin
     if exclude
      then begin
         if (excl_mult and (pos(excl_spec,pathtmp)>0)) or (excl_spec = pathtmp)
             then begin
          if not check_file_name(retname,exc_nam,exc_ext,exc_flag)
             then if (check_file_name(retname,match_nam,match_ext,match_flag)
                  and (not subdirec) and (not((transferrec.attr and volumeid)=8)))
                 then Delete_file(pathtmp + '\' + retname);
           end
         else if (check_file_name(retname,match_nam,match_ext,match_flag)
             and (not subdirec) and (not((transferrec.attr and volumeid)=8)))
             then Delete_file(pathtmp + '\' + retname);
      end
      else begin
       if (check_file_name(retname,match_nam,match_ext,match_flag)
           and (not subdirec) and (not((transferrec.attr and volumeid)=8)))
          then Delete_file(pathtmp + '\' + retname);
      end;
     fndnext(retname,lastfile,subdirec);
        end;
      end;
    if multiple then    {multiple subdirectories where specified}
     begin
       pop(stk,dir_rec,empty); {see if any where found}
       if not empty then       {if so build a new pathname}
        begin
          dirpath[dir_rec.level] := dir_rec.dirname;
          matchptrn := path;
          for lvl := 1 to dir_rec.level do
           matchptrn := matchptrn + '\' + dirpath[lvl];
          pathtmp := matchptrn;
          matchptrn := matchptrn + file_nam;
          current_lvl := dir_rec.level + 1; {set new current level}
        end;
     end;
  until (not multiple or empty);
end.