Oakland CPM Archive/oakcpm.iso/sigm/vol148/erase.pas

Pascal/Delphi Source File | 1984-04-29 | 5.1 KB | 209 lines

.po 0
PROGRAM ERASE;
{ This program will erase only files that show in the directory. It will
not touch any file that is R/O or SYS. }


TYPE
    byte=0..255;
    string12=packed array [1..12] of char;

    registers=record
        a:0..255;        { A register }
        bc,de,hl:integer    { BC, DE, HL registers }
    end;
{**********************************************************************}

VAR
    currentdisk { disk user is logged into },
    dircode     { return code from CP/M }        :byte;

    found    :boolean;    { found a directory file to delete }
    reg    :registers;
{**********************************************************************}

{ call is provided on Pascal/Z source disk.  CALL the memory
    location pointed to by 'address' with the values in the required
    registers. }

procedure call(var regs:registers;address:integer);external;

{***********************************************************************}

{* You can find the assembler source for peek and poke written by      *
 * Ray Penley in the PascalZ Users Group Newsletter #14, Sept., 1982   *
 * on page 5                                                           *}

function peek (address:integer):byte;external;

procedure poke (address:integer;abyte:byte);external;

{***********************************************************************}

procedure directory(var dircode:byte;var title:string12);
const
    srchfst=17;        { CP/M function code = search first }
    srchnxt=18;        { CP/M function code = search next }
    delfile=19;        { CP/M function code = delete file }
    bdos=5;            { CP/M BDOS entry point }
    eodir=255;        { end of directory flag }
{=======================================================================}

var
    ch    :char;
    fcb    :integer;    { address of the file control block }
    i    :byte;        { indexer }
    dirptr    :integer;
    func    :integer;    { function code to be passed to CP/M }
{========================================================================}

procedure search(var dircode:byte;func:integer);
begin
    fcb:=92;
    reg.de:=fcb;
    reg.bc:=func;
    call(reg,bdos);
    dircode:=reg.a
end;
{========================================================================}

{ This procedure does the actual deleting of files that are DIR and R/W. }

procedure eraser;
begin

{ If the high bit is set for any of the three characters used for file type
    then the particular file in question is not DIR and R/W. }

    if (peek(dirptr+9) < 128) and (peek(dirptr+10) < 128) and
        (peek(dirptr+11) < 128) then begin

    reg.de:=dirptr;
    reg.bc:=delfile;
    call(reg,bdos);        { delete the file when DIR and R/W }
    dircode:=reg.a;

    found:=true        { found a file to delete }

    end {if}
end;
{==========================================================================}

begin  {directory}
    found:=false;

{ First find out what drive the user is logged into and save }
    reg.a    :=0;
    reg.bc    :=25;        { CP/M return current disk function }
    reg.de    :=0;
    reg.hl    :=0000;
    call(reg,5);
    currentdisk:=reg.a;

{ set up the address at which we wish to leave anything that CP/M reads
   from the disk to 80H = 128 dec }
    reg.a    :=0;
    reg.bc    :=26;         { CP/M set DMA address function}
    reg.de    :=128;         {to 80H}
    reg.hl    :=0000;
    call(reg,5);

    fcb:=92;        { set pointer to the default file control
                block at memory location 5CH = 92 dec }

    for i:=1 to 12 do begin
        poke(fcb,ord(title[i]));
        fcb:=fcb+1
    end;

    func:=srchfst;
    search(dircode,func);

    func:=srchnxt;

{ set the directory pointer at the start of information received from the
  directory and erase DIR, R/W files }
    while dircode <> eodir do begin
        dirptr:=128 + (dircode*32);
        eraser;
        search(dircode,func)
    end {while}

end {directory};

{*******************************************************************}

{ Process the directory list for selected drive }

procedure list;
var
    title:string12;
    ch:char;
    i:byte;
{=====================================================================}

{ Converts all letters to uppercase }
function toupper(ch:char):char;
begin
    if ('a' <= ch) and (ch <= 'z') then
        toupper:=chr(ord(ch)-32)
    else
        toupper:=ch
end;
{=====================================================================}

begin { list procedure }

    title:='0???????????';    { 12 chars. 1st char = drive unit }

{ I have inserted a clear screen for my terminal (an ADDS Regent 40)
  at this point }
    write(chr(12));
    writeln; writeln;
    write('Erase directory files on what drive (A thru P)? ');
    readln(ch);
    ch:=toupper(ch);

{ Construct the proper binary unit identifier:
    1 = drive A
    2 = drive B
    .
    .
    16 = drive P                           }

    title[1]:=chr(ord(ch)-ord('@'));

{ Log on to the drive that files are to be deleted on }
    reg.a    :=0;
    reg.bc    :=14;        { select disk }
    reg.de    :=ord(title[1]) - 1;
    reg.hl    :=0000;
    call(reg,5);

    writeln;

{ Repeat finding and erasing files until end of directory and no other
  files are found to delete. }
    repeat
        directory (dircode,title)
    until (found=false) and (dircode=255);

{ Return to the user logged in disk }
    reg.a    :=0;
    reg.bc    :=14;        { select disk }
    reg.de    :=currentdisk;
    reg.hl    :=0000;
    call(reg,5)

end;

{*******************************************************************}

{ This is where the program begins. }

{$C+}{enable control-c from the keyboard}

BEGIN
    list
END.