Programmer 7500/MAX_PROGRAMMERS.iso/INFO/TURBOPAS/GDEL.ZIP/GDEL.PAS

Pascal/Delphi Source File | 1985-12-28 | 15.2 KB | 535 lines

program gdel;

{ global delete - delete all occurrances of a file in all directories }

type LStr = string[255];
var command_line : boolean;
    Param_Num    : integer;
    in_str       : LStr;
    verify       : boolean;

{ PCDOS.INC }
{
  PcDos functions
  Turbo Pascal 3.0
  IBM PC DOS 3.1

  By Michael A. Quinlan  5/11/85
}

type PcDos_reg_type  = record
                         case integer of
                           0 : (ax, bx, cx, dx, bp, si, di, ds, es, flags : integer);
                           1 : (al, ah, bl, bh, cl, ch, dl, dh            : byte)
                       end;
     PcDos_dta_type  = array[1..128] of byte;
     PcDos_Find_Area = record
                         resvd1    : array [1..21] of byte;
                         attr      : byte;
                         time      : integer;
                         date      : integer;
                         size_low  : integer;
                         size_high : integer;
                         name      : array [1..13] of char;
                         resvd2    : array [1..85] of byte;
                       end;
     PcDos_dta_ptr   = ^PcDos_dta_type;
     PcDos_Asciiz    = array [1..66] of char;

const PcDos_Attr_ReadOnly    = $01;
      PcDos_Attr_Hidden      = $02;
      PcDos_Attr_System      = $04;
      PcDos_Attr_Label       = $08;
      PcDos_Attr_Directory   = $10;
      PcDos_Attr_Archive     = $20;

var PcDos_old_dta   : PcDos_dta_ptr;
    PcDos_ErrCode   : Integer;
    PcDos_ErrClass  : Integer;
    PcDos_ErrAction : Integer;
    PcDos_ErrLocus  : Integer;

procedure PcDos_Clr_Dta(var a);
  var i : integer;
      b : PcDos_dta_type absolute a;
  begin
    for i := 1 to 128 do b[i] := 0
  end;

function Asciiz_To_String(var a) : LStr;
  var s : LStr;
      i : integer;
      aa : PcDos_Asciiz absolute a;
  begin
    i := 1;
    while aa[i] <> Chr(0) do begin
      s[i] := aa[i];
      i := i + 1
    end;
    s[0] := Chr(i-1);
    Asciiz_To_String := s
  end;

procedure String_To_Asciiz(s1 : LStr; var s2 : PcDos_Asciiz);
  var i : integer;
  begin
    for i := 1 to length(s1) do
      s2[i] := s1[i];
    s2[i+1] := Chr(0)
  end;

function PcDos_get_dta : PcDos_dta_ptr;
  var r : PcDos_reg_type;
  begin
    with r do begin
      ah := $2F;
      MsDos(r);
      PcDos_get_dta := Ptr(es, bx)
    end
  end;

procedure PcDos_set_dta(var a);
  var r   : PcDos_reg_type;
      dta : PcDos_dta_type absolute a;
  begin
    with r do begin
      ah := $1A;
      ds := Seg(dta);
      dx := Ofs(dta);
      MsDos(r)
    end
  end;

function PcDos_Error_Meaning(i : integer) : LStr;
  const Num_Errors = 88;
        Error_Meaning : array[0..Num_Errors] of String[50] = (
          '00 - No Error',
          '01 - Invalid Function Number',
          '02 - File Not Found',
          '03 - Path Not Found',
          '04 - Too Many Open Files',
          '05 - Access Denied',
          '06 - Invalid Handle',
          '07 - Memory Control Blocks Destroyed',
          '08 - Insufficient Memory',
          '09 - Invalid Memory Block Address',
          '10 - Invalid Environment',
          '11 - Invalid Format',
          '12 - Invalid Access Code',
          '13 - Invalid Data',
          '14 - Reserved',
          '15 - Invalid Drive',
          '16 - Attempt to Remove Current Directory',
          '17 - Not Same Device',
          '18 - No More Files',
          '19 - Attempt to Write on Write-Protected Diskette',
          '20 - Unknown Unit',
          '21 - Drive Not Ready',
          '22 - Unknown Command',
          '23 - Data Error (CRC)',
          '24 - Bad Request Structure Length',
          '25 - Seek Error',
          '26 - Unknown Media Type',
          '27 - Sector Not Found',
          '28 - Printer Out Of Paper',
          '29 - Write Fault',
          '30 - Read Fault',
          '31 - General Fault',
          '32 - Sharing Violation',
          '33 - Lock Violation',
          '34 - Invalid Disk Change',
          '35 - FCB Unavailable',
          '36 - Sharing Buffer Overflow',
          '37 - Reserved',
          '38 - Reserved',
          '39 - Reserved',
          '40 - Reserved',
          '41 - Reserved',
          '42 - Reserved',
          '43 - Reserved',
          '44 - Reserved',
          '45 - Reserved',
          '46 - Reserved',
          '47 - Reserved',
          '48 - Reserved',
          '49 - Reserved',
          '50 - Network Request Not Supported',
          '51 - Remote Computer Not Listening',
          '52 - Duplicate Name On Network',
          '53 - Network Name Not Found',
          '54 - Network Busy',
          '55 - Network Device No Longer Exists',
          '56 - Net BIOS Command Limit Exceeded',
          '57 - Network Adapter Hardware Error',
          '58 - Incorrect Response From Network',
          '59 - Unexpected Network Error',
          '60 - Incompatible Remote Adapter',
          '61 - Print Queue Full',
          '62 - Not Enough Space For Print File',
          '63 - Print File Was Deleted',
          '64 - Network Name Was Deleted',
          '65 - Access Denied',
          '66 - Network Device Type Incorrect',
          '67 - Network Name Not Found',
          '68 - Network Name Limit Exceeded',
          '69 - Net BIOS Session Limit Exceeded',
          '70 - Temporarily Paused',
          '71 - Network Request Not Accepted',
          '72 - Print Or Disk Redirection is Paused',
          '73 - Reserved',
          '74 - Reserved',
          '75 - Reserved',
          '76 - Reserved',
          '77 - Reserved',
          '78 - Reserved',
          '79 - Reserved',
          '80 - File Exists',
          '81 - Reserved',
          '82 - Cannot Make Directory Entry',
          '83 - Fail on INT 24',
          '84 - Too Many Redirections',
          '85 - Duplicate Redirection',
          '86 - Invalid Password',
          '87 - Invalid Parameter',
          '88 - Network Device Fault');
  begin
    writeln('Error Meaning for code ', i);
    PcDos_Error_Meaning := Error_Meaning[i]
  end;

function PcDos_Error_Action(i : integer) : LStr;
  const Num_Actions = 7;
        Error_Action : array [1..Num_Actions] of String[50] = (
          '01 - Retry',
          '02 - Delay Retry',
          '03 - Ask User to Reenter Input',
          '04 - Abort With Cleanup',
          '05 - Immediate Exit',
          '06 - Ignore',
          '07 - Retry After User Intervention');
  begin
    PcDos_Error_Action := Error_Action[i]
  end;

function PcDos_Error_Class(i : integer) : LStr;
  const Num_Classes = 13;
        Error_Class : array [1..Num_Classes] of String[50] = (
          '01 - Out Of Resource',
          '02 - Temporary Situation',
          '03 - Authorization',
          '04 - Internal',
          '05 - Hardware Failure',
          '06 - System Failure',
          '07 - Application Program Error',
          '08 - Not Found',
          '09 - Bad Format',
          '10 - Locked',
          '11 - Media',
          '12 - Already Exists',
          '13 - Unknown');
  begin
    PcDos_Error_Class := Error_Class[i]
  end;

function PcDos_Error_Locus(i : integer) : LStr;
  const Num_Loci = 5;
        Error_Locus : array [1..Num_Loci] of String[50] = (
          '01 - Unknown',
          '02 - Block Device',
          '03 - Network',
          '04 - Serial Device',
          '05 - Memory');
  begin
    PcDos_Error_Locus := Error_Locus[i]
  end;

procedure PcDos_Error;
  var r : PcDos_reg_type;
  begin
    with r do begin
      ah := $59;
      bx := 0;
      MsDos(r);

      { AX = extended error code;
        BH = error class;
        BL = recommended action;
        CH = locus }

      PcDos_ErrCode   := ax;
      PcDos_ErrClass  := bh;
      PcDos_ErrAction := bl;
      PcDos_ErrLocus  := ch
    end
  end;

procedure PcDos_Error_Halt;
  begin
    WriteLn('Program Halted Due to Unrecoverable Error in PcDos Routines');
    WriteLn('Extended Error Code = ', PcDos_Error_Meaning(PcDos_ErrCode));
    WriteLn('Error Class = ', PcDos_Error_Class(PcDos_ErrClass));
    WriteLn('Recommended Action = ', PcDos_Error_Action(PcDos_ErrAction));
    WriteLn('Error Locus = ', PcDos_Error_Locus(PcDos_ErrLocus));
    Halt
  end;

function PcDos_Handle(var r : PcDos_reg_type) : integer;
  var r2 : PcDos_reg_type;
      ok : boolean;
      retry_count : integer;
      ret_value   : integer;
  begin
    retry_count := 0;
    ret_value   := 0;
    repeat
      ok := TRUE;
      r2 := r;
      MsDos(r2);
      if (r2.flags and $0001) = $0001 then begin  { carry flag on; ERROR }
        PcDos_Error;
        case PcDos_ErrAction of
          1 : begin             { retry }
                if retry_count > 10 then PcDos_Error_Halt;
                retry_count := retry_count + 1;
                ok := FALSE
              end;
          2 : begin             { delay retry }
                if retry_count > 10 then PcDos_Error_Halt;
                delay(500);
                retry_count := retry_count + 1;
                ok := FALSE
              end;
          3 : ret_value := PcDos_ErrCode;  { invalid input from user }
          4 : PcDos_Error_Halt;  { abort }
          5 : PcDos_Error_Halt;  { immediate exit }
          6 : ret_value := PcDos_ErrCode;  { ignore }
          7 : ret_value := PcDos_ErrCode;  { retry after user intervention }
        else
          ret_value := PcDos_ErrCode
        end; { case }
      end  { if }
    until ok;
    r := r2;
    PcDos_Handle := ret_value
  end;

procedure PcDos_find_first(fn : LStr; attr : integer; var dta : PcDos_Find_Area);
  var r   : PcDos_reg_type;
      e   : integer;
      s   : PcDos_Asciiz;
  begin
    PcDos_Clr_Dta(dta);
    PcDos_old_dta := PcDos_get_dta;
    PcDos_set_dta(dta);

    String_To_Asciiz(fn, s);
    with r do begin
      ah := $4E;
      ds := Seg(s);
      dx := Ofs(s);
      cx := attr
    end;
    e := PcDos_Handle(r);
    if not (e in [0, 2, 3, 18]) then PcDos_Error_Halt;
    if e <> 0 then dta.name[1] := Chr(0);

    PcDos_set_dta(PcDos_old_dta^)
  end;

procedure PcDos_Find_Next(var dta : PcDos_Find_Area);
  var r   : PcDos_reg_type;
      e   : integer;
  begin
    PcDos_old_dta := PcDos_get_dta;
    PcDos_set_dta(dta);

    r.ah := $4F;
    e := PcDos_Handle(r);
    if not (e in [0, 2, 3, 18]) then PcDos_Error_Halt;
    if e <> 0 then dta.name[1] := Chr(0);

    PcDos_set_dta(PcDos_old_dta^)
  end;

procedure PcDos_ChMod(fn : LStr; attr : integer);
  var r : PcDos_reg_type;
      e : integer;
      f : PcDos_Asciiz;
  begin
    String_To_Asciiz(fn, f);
    with r do begin
      ah := $43;
      ds := seg(f);
      dx := ofs(f);
      cx := attr;
      al := $01
    end;
    e := PcDos_Handle(r);
    if e <> 0 then PcDos_Error_Halt
  end;

procedure PcDos_Delete_File(fn : LStr);
  var r : PcDos_reg_type;
      e : integer;
      f : PcDos_Asciiz;
  begin
    String_To_Asciiz(fn, f);
    with r do begin
      ah := $41;
      ds := seg(f);
      dx := ofs(f)
    end;
    e := PcDos_Handle(r);
    if e <> 0 then PcDos_Error_Halt
  end;

function PcDos_Mem_Avail : integer;
{ returns size (in paragraphs) of the largest memory block }
  var r : PcDos_reg_type;
  begin
    r.ah := $48;
    r.bx := $FFFF;  { ask for 64K paragraphs -- will be too big }
    MsDos(r);
    if r.ax <> 8 then begin
      PcDos_Error;
      PcDos_Error_Halt
    end;
    PcDos_Mem_Avail := r.bx
  end;

procedure PcDos_Get_Date(var day_of_week, year, month, day : integer);
  var r : PcDos_reg_type;
  begin
    r.ah := $2A;
    MsDos(r);
    day_of_week := r.al;
    year        := r.cx;
    month       := r.dh;
    day         := r.dl
  end;

procedure PcDos_Get_Time(var hour, minute, second, hundredths : integer);
  var r : PcDos_reg_type;
  begin
    r.ah := $2C;
    MsDos(r);
    hour       := r.ch;
    minute     := r.cl;
    second     := r.dh;
    hundredths := r.dl
  end;

{====================}
{  END OF PCDOS.INC  }
{====================}

function dir_del(d, f : LStr) : integer;
{ delete file in given directory (and all its subdirectories);
  return number of files deleted }

  var dta : PcDos_Find_Area;
      n   : integer;
      s   : LStr;

  function do_delete(s : LStr) : integer;
    var n : integer;
        f : LStr;
        c : char;
        fullname : LStr;
    begin { do_delete }
      n := 0;
      PcDos_Find_First(s, PcDos_Attr_Hidden+PcDos_Attr_System, dta);
      f := Asciiz_To_String(dta.name);
      while f <> '' do begin
        fullname := d + '\' + f;
        if verify then begin
          write('Delete ', fullname, '? ');
          readln(c);
          if c in ['Y', 'y'] then begin
            if (dta.attr and PcDos_Attr_ReadOnly) <> 0 then begin
              write('File is Read Only; Are You SURE? ');
              readln(c);
              if c in ['Y', 'y'] then begin
                PcDos_ChMod(fullname, $00);
                PcDos_Delete_File(fullname);
                n := n + 1;
                writeln(fullname, ' deleted')
              end
            end else begin
              PcDos_Delete_File(fullname);
              n := n + 1;
              writeln(fullname, ' deleted')
            end
          end
        end else begin
          if (dta.attr and PcDos_Attr_ReadOnly) <> 0 then
            PcDos_ChMod(fullname, $00);
          PcDos_Delete_File(fullname);
          n := n + 1;
          writeln(fullname, ' deleted')
        end;
        PcDos_Find_Next(dta);
        f := Asciiz_To_String(dta.name)
      end;
      do_delete := n
    end; { do_delete }

  begin { dir_del }
    s := d + '\' + f;
    writeln('Searching ', d, '...');
    n := do_delete(s);  { delete file(s) from current directory }
    PcDos_Find_First(d+'\*.*', PcDos_Attr_Directory, dta);
    s := Asciiz_To_String(dta.name);
    while s <> '' do begin
      if (s <> '.') and (s <> '..') and ((dta.attr and PcDos_Attr_Directory) <> 0) then
        n := n + dir_del(d + '\' + s, f);
      PcDos_Find_Next(dta);
      s := Asciiz_To_String(dta.name)
    end;
    dir_del := n
  end;

procedure global_del(s : LStr);
{ search all directories and delete file from them }
  var drive : String[2];
      fn    : String[12];
      n     : integer;
  begin
    if s[2] = ':' then begin
      drive := copy(s, 1, 2);
      fn    := copy(s, 3, 12)
    end else begin
      drive := '';
      fn    := s
    end;
    n := dir_del(drive, fn);

    if n = 0 then writeln('No files deleted')
    else if n = 1 then writeln('1 file deleted')
    else writeln(n, ' files deleted');

    writeln
  end;

begin
  writeln('Global Delete Files');
  verify := TRUE;

  if ParamCount <> 0 then begin
    command_line := TRUE;
    for Param_Num := 1 to ParamCount do
      if (ParamStr(Param_Num) = '/n') or (ParamStr(Param_Num) = '/N') then
        verify := FALSE
      else
        global_del(ParamStr(Param_Num))
  end else begin
    command_line := FALSE;
    while TRUE do begin
      write('Name of file to delete: ');
      readln(in_str);
      if in_str = '' then halt;
      global_del(in_str)
    end
  end
end.