home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / TURBOPAS / VDEL.ZIP / VDEL.PAS
Encoding:
Pascal/Delphi Source File  |  1985-12-28  |  13.4 KB  |  480 lines
  1. program vdel;
  2.  
  3. { delete with verify }
  4.  
  5. type LStr = string[255];
  6.  
  7. { PCDOS.INC }
  8. {
  9.   PcDos functions
  10.   Turbo Pascal 3.0
  11.   IBM PC DOS 3.1
  12.  
  13.   By Michael A. Quinlan  5/11/85
  14. }
  15.  
  16. type PcDos_reg_type  = record
  17.                          case integer of
  18.                            0 : (ax, bx, cx, dx, bp, si, di, ds, es, flags : integer);
  19.                            1 : (al, ah, bl, bh, cl, ch, dl, dh            : byte)
  20.                        end;
  21.      PcDos_dta_type  = array[1..128] of byte;
  22.      PcDos_Find_Area = record
  23.                          resvd1    : array [1..21] of byte;
  24.                          attr      : byte;
  25.                          time      : integer;
  26.                          date      : integer;
  27.                          size_low  : integer;
  28.                          size_high : integer;
  29.                          name      : array [1..13] of char;
  30.                          resvd2    : array [1..85] of byte;
  31.                        end;
  32.      PcDos_dta_ptr   = ^PcDos_dta_type;
  33.      PcDos_Asciiz    = array [1..66] of char;
  34.  
  35. const PcDos_Attr_ReadOnly    = $01;
  36.       PcDos_Attr_Hidden      = $02;
  37.       PcDos_Attr_System      = $04;
  38.       PcDos_Attr_Label       = $08;
  39.       PcDos_Attr_Directory   = $10;
  40.       PcDos_Attr_Archive     = $20;
  41.  
  42. var PcDos_old_dta   : PcDos_dta_ptr;
  43.     PcDos_ErrCode   : Integer;
  44.     PcDos_ErrClass  : Integer;
  45.     PcDos_ErrAction : Integer;
  46.     PcDos_ErrLocus  : Integer;
  47.  
  48. procedure PcDos_Clr_Dta(var a);
  49.   var i : integer;
  50.       b : PcDos_dta_type absolute a;
  51.   begin
  52.     for i := 1 to 128 do b[i] := 0
  53.   end;
  54.  
  55. function Asciiz_To_String(var a) : LStr;
  56.   var s : LStr;
  57.       i : integer;
  58.       aa : PcDos_Asciiz absolute a;
  59.   begin
  60.     i := 1;
  61.     while aa[i] <> Chr(0) do begin
  62.       s[i] := aa[i];
  63.       i := i + 1
  64.     end;
  65.     s[0] := Chr(i-1);
  66.     Asciiz_To_String := s
  67.   end;
  68.  
  69. procedure String_To_Asciiz(s1 : LStr; var s2 : PcDos_Asciiz);
  70.   var i : integer;
  71.   begin
  72.     for i := 1 to length(s1) do
  73.       s2[i] := s1[i];
  74.     s2[i+1] := Chr(0)
  75.   end;
  76.  
  77. function PcDos_get_dta : PcDos_dta_ptr;
  78.   var r : PcDos_reg_type;
  79.   begin
  80.     with r do begin
  81.       ah := $2F;
  82.       MsDos(r);
  83.       PcDos_get_dta := Ptr(es, bx)
  84.     end
  85.   end;
  86.  
  87. procedure PcDos_set_dta(var a);
  88.   var r   : PcDos_reg_type;
  89.       dta : PcDos_dta_type absolute a;
  90.   begin
  91.     with r do begin
  92.       ah := $1A;
  93.       ds := Seg(dta);
  94.       dx := Ofs(dta);
  95.       MsDos(r)
  96.     end
  97.   end;
  98.  
  99. function PcDos_Error_Meaning(i : integer) : LStr;
  100.   const Num_Errors = 88;
  101.         Error_Meaning : array[0..Num_Errors] of String[50] = (
  102.           '00 - No Error',
  103.           '01 - Invalid Function Number',
  104.           '02 - File Not Found',
  105.           '03 - Path Not Found',
  106.           '04 - Too Many Open Files',
  107.           '05 - Access Denied',
  108.           '06 - Invalid Handle',
  109.           '07 - Memory Control Blocks Destroyed',
  110.           '08 - Insufficient Memory',
  111.           '09 - Invalid Memory Block Address',
  112.           '10 - Invalid Environment',
  113.           '11 - Invalid Format',
  114.           '12 - Invalid Access Code',
  115.           '13 - Invalid Data',
  116.           '14 - Reserved',
  117.           '15 - Invalid Drive',
  118.           '16 - Attempt to Remove Current Directory',
  119.           '17 - Not Same Device',
  120.           '18 - No More Files',
  121.           '19 - Attempt to Write on Write-Protected Diskette',
  122.           '20 - Unknown Unit',
  123.           '21 - Drive Not Ready',
  124.           '22 - Unknown Command',
  125.           '23 - Data Error (CRC)',
  126.           '24 - Bad Request Structure Length',
  127.           '25 - Seek Error',
  128.           '26 - Unknown Media Type',
  129.           '27 - Sector Not Found',
  130.           '28 - Printer Out Of Paper',
  131.           '29 - Write Fault',
  132.           '30 - Read Fault',
  133.           '31 - General Fault',
  134.           '32 - Sharing Violation',
  135.           '33 - Lock Violation',
  136.           '34 - Invalid Disk Change',
  137.           '35 - FCB Unavailable',
  138.           '36 - Sharing Buffer Overflow',
  139.           '37 - Reserved',
  140.           '38 - Reserved',
  141.           '39 - Reserved',
  142.           '40 - Reserved',
  143.           '41 - Reserved',
  144.           '42 - Reserved',
  145.           '43 - Reserved',
  146.           '44 - Reserved',
  147.           '45 - Reserved',
  148.           '46 - Reserved',
  149.           '47 - Reserved',
  150.           '48 - Reserved',
  151.           '49 - Reserved',
  152.           '50 - Network Request Not Supported',
  153.           '51 - Remote Computer Not Listening',
  154.           '52 - Duplicate Name On Network',
  155.           '53 - Network Name Not Found',
  156.           '54 - Network Busy',
  157.           '55 - Network Device No Longer Exists',
  158.           '56 - Net BIOS Command Limit Exceeded',
  159.           '57 - Network Adapter Hardware Error',
  160.           '58 - Incorrect Response From Network',
  161.           '59 - Unexpected Network Error',
  162.           '60 - Incompatible Remote Adapter',
  163.           '61 - Print Queue Full',
  164.           '62 - Not Enough Space For Print File',
  165.           '63 - Print File Was Deleted',
  166.           '64 - Network Name Was Deleted',
  167.           '65 - Access Denied',
  168.           '66 - Network Device Type Incorrect',
  169.           '67 - Network Name Not Found',
  170.           '68 - Network Name Limit Exceeded',
  171.           '69 - Net BIOS Session Limit Exceeded',
  172.           '70 - Temporarily Paused',
  173.           '71 - Network Request Not Accepted',
  174.           '72 - Print Or Disk Redirection is Paused',
  175.           '73 - Reserved',
  176.           '74 - Reserved',
  177.           '75 - Reserved',
  178.           '76 - Reserved',
  179.           '77 - Reserved',
  180.           '78 - Reserved',
  181.           '79 - Reserved',
  182.           '80 - File Exists',
  183.           '81 - Reserved',
  184.           '82 - Cannot Make Directory Entry',
  185.           '83 - Fail on INT 24',
  186.           '84 - Too Many Redirections',
  187.           '85 - Duplicate Redirection',
  188.           '86 - Invalid Password',
  189.           '87 - Invalid Parameter',
  190.           '88 - Network Device Fault');
  191.   begin
  192.     writeln('Error Meaning for code ', i);
  193.     PcDos_Error_Meaning := Error_Meaning[i]
  194.   end;
  195.  
  196. function PcDos_Error_Action(i : integer) : LStr;
  197.   const Num_Actions = 7;
  198.         Error_Action : array [1..Num_Actions] of String[50] = (
  199.           '01 - Retry',
  200.           '02 - Delay Retry',
  201.           '03 - Ask User to Reenter Input',
  202.           '04 - Abort With Cleanup',
  203.           '05 - Immediate Exit',
  204.           '06 - Ignore',
  205.           '07 - Retry After User Intervention');
  206.   begin
  207.     PcDos_Error_Action := Error_Action[i]
  208.   end;
  209.  
  210. function PcDos_Error_Class(i : integer) : LStr;
  211.   const Num_Classes = 13;
  212.         Error_Class : array [1..Num_Classes] of String[50] = (
  213.           '01 - Out Of Resource',
  214.           '02 - Temporary Situation',
  215.           '03 - Authorization',
  216.           '04 - Internal',
  217.           '05 - Hardware Failure',
  218.           '06 - System Failure',
  219.           '07 - Application Program Error',
  220.           '08 - Not Found',
  221.           '09 - Bad Format',
  222.           '10 - Locked',
  223.           '11 - Media',
  224.           '12 - Already Exists',
  225.           '13 - Unknown');
  226.   begin
  227.     PcDos_Error_Class := Error_Class[i]
  228.   end;
  229.  
  230. function PcDos_Error_Locus(i : integer) : LStr;
  231.   const Num_Loci = 5;
  232.         Error_Locus : array [1..Num_Loci] of String[50] = (
  233.           '01 - Unknown',
  234.           '02 - Block Device',
  235.           '03 - Network',
  236.           '04 - Serial Device',
  237.           '05 - Memory');
  238.   begin
  239.     PcDos_Error_Locus := Error_Locus[i]
  240.   end;
  241.  
  242. procedure PcDos_Error;
  243.   var r : PcDos_reg_type;
  244.   begin
  245.     with r do begin
  246.       ah := $59;
  247.       bx := 0;
  248.       MsDos(r);
  249.  
  250.       { AX = extended error code;
  251.         BH = error class;
  252.         BL = recommended action;
  253.         CH = locus }
  254.  
  255.       PcDos_ErrCode   := ax;
  256.       PcDos_ErrClass  := bh;
  257.       PcDos_ErrAction := bl;
  258.       PcDos_ErrLocus  := ch
  259.     end
  260.   end;
  261.  
  262. procedure PcDos_Error_Halt;
  263.   begin
  264.     WriteLn('Program Halted Due to Unrecoverable Error in PcDos Routines');
  265.     WriteLn('Extended Error Code = ', PcDos_Error_Meaning(PcDos_ErrCode));
  266.     WriteLn('Error Class = ', PcDos_Error_Class(PcDos_ErrClass));
  267.     WriteLn('Recommended Action = ', PcDos_Error_Action(PcDos_ErrAction));
  268.     WriteLn('Error Locus = ', PcDos_Error_Locus(PcDos_ErrLocus));
  269.     Halt
  270.   end;
  271.  
  272. function PcDos_Handle(var r : PcDos_reg_type) : integer;
  273.   var r2 : PcDos_reg_type;
  274.       ok : boolean;
  275.       retry_count : integer;
  276.       ret_value   : integer;
  277.   begin
  278.     retry_count := 0;
  279.     ret_value   := 0;
  280.     repeat
  281.       ok := TRUE;
  282.       r2 := r;
  283.       MsDos(r2);
  284.       if (r2.flags and $0001) = $0001 then begin  { carry flag on; ERROR }
  285.         PcDos_Error;
  286.         case PcDos_ErrAction of
  287.           1 : begin             { retry }
  288.                 if retry_count > 10 then PcDos_Error_Halt;
  289.                 retry_count := retry_count + 1;
  290.                 ok := FALSE
  291.               end;
  292.           2 : begin             { delay retry }
  293.                 if retry_count > 10 then PcDos_Error_Halt;
  294.                 delay(500);
  295.                 retry_count := retry_count + 1;
  296.                 ok := FALSE
  297.               end;
  298.           3 : ret_value := PcDos_ErrCode;  { invalid input from user }
  299.           4 : PcDos_Error_Halt;  { abort }
  300.           5 : PcDos_Error_Halt;  { immediate exit }
  301.           6 : ret_value := PcDos_ErrCode;  { ignore }
  302.           7 : ret_value := PcDos_ErrCode;  { retry after user intervention }
  303.         else
  304.           ret_value := PcDos_ErrCode
  305.         end; { case }
  306.       end  { if }
  307.     until ok;
  308.     r := r2;
  309.     PcDos_Handle := ret_value
  310.   end;
  311.  
  312. procedure PcDos_find_first(fn : LStr; attr : integer; var dta : PcDos_Find_Area);
  313.   var r   : PcDos_reg_type;
  314.       e   : integer;
  315.       s   : PcDos_Asciiz;
  316.   begin
  317.     PcDos_Clr_Dta(dta);
  318.     PcDos_old_dta := PcDos_get_dta;
  319.     PcDos_set_dta(dta);
  320.  
  321.     String_To_Asciiz(fn, s);
  322.     with r do begin
  323.       ah := $4E;
  324.       ds := Seg(s);
  325.       dx := Ofs(s);
  326.       cx := attr
  327.     end;
  328.     e := PcDos_Handle(r);
  329.     if not (e in [0, 2, 3, 18]) then PcDos_Error_Halt;
  330.     if e <> 0 then dta.name[1] := Chr(0);
  331.  
  332.     PcDos_set_dta(PcDos_old_dta^)
  333.   end;
  334.  
  335. procedure PcDos_Find_Next(var dta : PcDos_Find_Area);
  336.   var r   : PcDos_reg_type;
  337.       e   : integer;
  338.   begin
  339.     PcDos_old_dta := PcDos_get_dta;
  340.     PcDos_set_dta(dta);
  341.  
  342.     r.ah := $4F;
  343.     e := PcDos_Handle(r);
  344.     if not (e in [0, 2, 3, 18]) then PcDos_Error_Halt;
  345.     if e <> 0 then dta.name[1] := Chr(0);
  346.  
  347.     PcDos_set_dta(PcDos_old_dta^)
  348.   end;
  349.  
  350. procedure PcDos_ChMod(fn : LStr; attr : integer);
  351.   var r : PcDos_reg_type;
  352.       e : integer;
  353.       f : PcDos_Asciiz;
  354.   begin
  355.     String_To_Asciiz(fn, f);
  356.     with r do begin
  357.       ah := $43;
  358.       ds := seg(f);
  359.       dx := ofs(f);
  360.       cx := attr;
  361.       al := $01
  362.     end;
  363.     e := PcDos_Handle(r);
  364.     if e <> 0 then PcDos_Error_Halt
  365.   end;
  366.  
  367. procedure PcDos_Delete_File(fn : LStr);
  368.   var r : PcDos_reg_type;
  369.       e : integer;
  370.       f : PcDos_Asciiz;
  371.   begin
  372.     String_To_Asciiz(fn, f);
  373.     with r do begin
  374.       ah := $41;
  375.       ds := seg(f);
  376.       dx := ofs(f)
  377.     end;
  378.     e := PcDos_Handle(r);
  379.     if e <> 0 then PcDos_Error_Halt
  380.   end;
  381.  
  382. function PcDos_Mem_Avail : integer;
  383. { returns size (in paragraphs) of the largest memory block }
  384.   var r : PcDos_reg_type;
  385.   begin
  386.     r.ah := $48;
  387.     r.bx := $FFFF;  { ask for 64K paragraphs -- will be too big }
  388.     MsDos(r);
  389.     if r.ax <> 8 then begin
  390.       PcDos_Error;
  391.       PcDos_Error_Halt
  392.     end;
  393.     PcDos_Mem_Avail := r.bx
  394.   end;
  395.  
  396. procedure PcDos_Get_Date(var day_of_week, year, month, day : integer);
  397.   var r : PcDos_reg_type;
  398.   begin
  399.     r.ah := $2A;
  400.     MsDos(r);
  401.     day_of_week := r.al;
  402.     year        := r.cx;
  403.     month       := r.dh;
  404.     day         := r.dl
  405.   end;
  406.  
  407. procedure PcDos_Get_Time(var hour, minute, second, hundredths : integer);
  408.   var r : PcDos_reg_type;
  409.   begin
  410.     r.ah := $2C;
  411.     MsDos(r);
  412.     hour       := r.ch;
  413.     minute     := r.cl;
  414.     second     := r.dh;
  415.     hundredths := r.dl
  416.   end;
  417.  
  418. {======================}
  419. {   END OF PCDOS.INC   }
  420. {======================}
  421.  
  422. var i : integer;
  423.     numdel : integer;
  424.  
  425. procedure vdel(f : LStr);
  426.   var dta : PcDos_Find_Area;
  427.       ff  : LStr;
  428.       dir : LStr;
  429.       i   : integer;
  430.       b   : boolean;
  431.       c   : char;
  432.   begin
  433.     { delete the filename and extension; leaving the drive and path }
  434.     dir := f;
  435.     i := length(dir);
  436.     b := TRUE;
  437.     while b do begin
  438.       if i > 0 then begin
  439.         if dir[i] in [':', '\'] then b := FALSE
  440.         else i := i - 1
  441.       end else b := FALSE
  442.     end;
  443.     dir[0] := Chr(i);
  444.  
  445.     PcDos_Find_First(f, PcDos_Attr_System+PcDos_Attr_Hidden, dta);
  446.     ff := Asciiz_To_String(dta.name);
  447.     while ff <> '' do begin
  448.       write('Delete ', dir, ff, '? ');
  449.       readln(c);
  450.       if c in ['Y', 'y'] then begin
  451.         if (dta.attr and PcDos_Attr_ReadOnly) <> 0 then begin
  452.           write('  File is Read Only; are you SURE? ');
  453.           readln(c);
  454.           if c in ['Y', 'y'] then begin
  455.             PcDos_ChMod(dir + ff, $00);
  456.             PcDos_Delete_File(dir + ff);
  457.             writeln(dir + ff, ' was deleted');
  458.             numdel := numdel + 1
  459.           end
  460.         end else begin
  461.           PcDos_Delete_File(dir + ff);
  462.           writeln(dir + ff, ' was deleted');
  463.           numdel := numdel + 1
  464.         end
  465.       end;
  466.       PcDos_Find_Next(dta);
  467.       ff := Asciiz_To_String(dta.name)
  468.     end
  469.   end;
  470.  
  471. begin
  472.   TextColor(LightGray);
  473.   numdel := 0;
  474.   if ParamCount = 0 then vdel('*.*')
  475.   else
  476.     for i := 1 to ParamCount do
  477.       vdel(ParamStr(i));
  478.   writeln(numdel, ' files deleted.');
  479. end.
  480.