Upload

Digital Research

CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/erase.plm

@@ -0,0 +1,824 @@
+$ TITLE('CP/M 3.0 --- ERA ')
+/* contains the confirm option */
+
+era:
+do;
+
+/*
+  Copyright (C) 1982
+  Digital Research
+  P.O. Box 579
+  Pacific Grove, CA 93950
+*/
+
+/*
+  Revised:
+    19 Jan  80  by Thomas Rolander
+    14 Sept 81  by Doug Huskey
+    23 June 82  by John Knight
+    03 Dec  82  by Bruce Skidmore
+*/
+
+declare
+    true    literally '1',
+    false   literally '0',
+    forever literally 'while true',
+    lit     literally 'literally',
+    proc    literally 'procedure',
+    dcl     literally 'declare',
+    addr    literally 'address',
+    cr      literally '13',
+    lf      literally '10',
+    ctrlc   literally '3',
+    ctrlx   literally '18h',
+    tab     literally '9',
+    bksp    literally '8',
+    cpmversion     literally '30h',
+    dcnt$offset    literally '45h',
+    searcha$offset literally '47h',
+    searchl$offset literally '49h',
+    hash1$offset   literally '00h',
+    hash2$offset   literally '02h',
+    hash3$offset   literally '04h';
+
+  declare plm label public;
+ 
+  /**************************************
+   *                                    *
+   *       B D O S   INTERFACE          *
+   *                                    *
+   **************************************/
+
+
+  mon1:
+    procedure (func,info) external;
+      declare func byte;
+      declare info address;
+    end mon1;
+
+  mon2:
+    procedure (func,info) byte external;
+      declare func byte;
+      declare info address;
+    end mon2;
+
+  mon3:
+    procedure (func,info) address external;
+      declare func byte;
+      declare info address;
+    end mon3;
+
+  parse:
+    procedure (pfcb) address external;
+      declare pfcb address;
+    end parse;
+
+  declare cmdrv     byte    external;	/* command drive      */
+  declare fcb (1)   byte    external;	/* 1st default fcb    */
+  declare fcb16 (1) byte    external;	/* 2nd default fcb    */
+  declare pass0     address external;	/* 1st password ptr   */
+  declare len0      byte    external;	/* 1st passwd length  */
+  declare pass1     address external;	/* 2nd password ptr   */
+  declare len1      byte    external;	/* 2nd passwd length  */
+  declare tbuff (1) byte    external;	/* default dma buffer */
+
+
+  /**************************************
+   *                                    *
+   *       B D O S   Externals          *
+   *                                    *
+   **************************************/
+
+  read$console:
+    procedure byte;
+      return mon2 (1,0);
+    end read$console;
+
+
+  printchar: 
+    procedure(char);
+    declare char byte;
+    call mon1(2,char);
+    end printchar;
+
+  conin: 
+    procedure byte;
+    return mon2(6,0fdh);
+    end conin;
+
+  print$buf:
+    procedure (buffer$address);
+      declare buffer$address address;
+      call mon1 (9,buffer$address);
+    end print$buf;
+
+
+  read$console$buf:
+    procedure (buffer$address,max) byte;
+      declare buffer$address address;
+      declare new$max based buffer$address address;
+      declare max byte;
+      new$max = max;
+      call mon1(10,buffer$address);
+      buffer$address = buffer$address + 1;
+      return new$max; 	/* actually number of chars input */
+  end read$console$buf;
+
+  check$con$stat:
+    procedure byte;
+      return mon2 (11,0);
+    end check$con$stat;
+
+  version: procedure address;
+    /* returns current cp/m version # */
+    return mon3(12,0);
+    end version;
+
+  setdma: procedure(dma);
+    declare dma address;
+    call mon1(26,dma);
+    end setdma;
+
+  search$first:
+    procedure (fcb$address) byte;
+      declare fcb$address address;
+      return mon2 (17,fcb$address);
+    end search$first;
+
+  search$next:
+    procedure byte;
+      return mon2 (18,0);
+    end search$next;
+
+  delete$file:
+    procedure (fcb$address) address;
+      declare fcb$address address;
+      return mon3 (19,fcb$address);
+    end delete$file;
+
+  get$user$code:
+    procedure byte;
+      return mon2 (32,0ffh);
+    end get$user$code;
+
+  /* 0ff => return BDOS errors */
+  return$errors:
+    procedure;
+      call mon1 (45,0ffh);	
+    end return$errors;
+
+  declare scbpd structure
+    (offset byte,
+     set    byte,
+     value  address);
+
+  getscbword:
+    procedure (offset) address;
+    declare offset byte;
+    scbpd.offset = offset;
+    scbpd.set = 0;
+    return mon3(49,.scbpd);
+  end getscbword;
+
+  setscbword:
+    procedure (offset,value);
+    declare offset byte;
+    declare value address;
+    scbpd.offset = offset;
+    scbpd.set = 0FEh;
+    scbpd.value = value;
+    call mon1(49,.scbpd);
+  end setscbword;
+
+  set$console$mode: procedure;
+  /* set console mode to ctrl-c only */
+    call mon1(109,1);
+  end set$console$mode;
+
+  declare
+    parse$fn structure (
+      buff$adr  address,
+      fcb$adr   address);
+
+
+  /**************************************
+   *                                    *
+   *         GLOBAL VARIABLES           *
+   *                                    *
+   **************************************/
+
+  declare successful lit '0FFh';
+
+  declare dir$entry$adr address;
+  declare dir$entry based dir$entry$adr (1) byte;
+  declare confirm$opt byte initial (false);
+  declare passwd$opt byte initial (false);
+  declare save$passwd (8) byte;
+  declare (savdcnt,savsearcha,savsearchl) address;
+  declare (hash1,hash2,hash3) address;
+  
+  /* options scanner variables and data */
+  declare
+    options(*) byte
+	data('PASSWORD0CONFIRM',0ffh),
+
+	off$opt(*) byte data(0,9,16),
+
+	end$list	byte data (0ffh),
+
+	delimiters(*) byte data (0,'[]=, ',0,0ffh),
+
+	SPACE		byte data(5),
+		
+	j		byte initial(0),
+	buf$ptr		address,
+	index		byte,
+	endbuf		byte,
+	delimiter	byte;
+
+  declare end$of$string byte initial('0');
+
+
+  /**************************************
+   *                                    *
+   *       S U B R O U T I N E S        *
+   *                                    *
+   **************************************/
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+/*                * * *  Option scanner  * * *               */
+
+
+separator: procedure(character) byte;
+
+					/* determines if character is a 
+					   delimiter and which one */
+	declare	k	byte,
+		character	byte;
+
+	k = 1;
+loop:	if delimiters(k) = end$list then return(0);
+	if delimiters(k) = character then return(k);	/* null = 25 */
+		k = k + 1;
+		go to loop;
+
+end separator;
+
+opt$scanner:	procedure(list$ptr,off$ptr,idx$ptr);
+					/* scans the list pointed at by idxptr
+					   for any strings that are in the 
+					   list pointed at by list$ptr.
+					   Offptr points at an array that 
+					   contains the indices for the known
+					   list. Idxptr points at the index 
+					   into the list. If the input string
+					   is unrecognizable then the index is
+				   	   0, otherwise > 0.
+
+					First, find the string in the known
+					list that starts with the same first 
+					character.  Compare up until the next
+					delimiter on the input. if every input
+					character matches then check for 
+					uniqueness.  Otherwise try to find 
+					another known string that has its first
+					character match, and repeat.  If none
+					can be found then return invalid.
+
+					To test for uniqueness, start at the 
+					next string in the knwon list and try
+					to get another match with the input.
+					If there is a match then return invalid.
+
+					else move pointer past delimiter and 
+					return.
+
+				P.Balma		*/
+
+	declare
+		buff		based buf$ptr (1) byte,
+		idx$ptr		address,
+		off$ptr		address,
+		list$ptr	address;
+
+	declare
+		i		byte,
+		j		byte,
+		list		based list$ptr (1) byte,
+		offsets		based off$ptr (1) byte,
+		wrd$pos  	byte,
+		character	byte,
+		letter$in$word	byte,
+		found$first	byte,
+		start		byte,
+		index		based idx$ptr byte,
+		save$index	byte,
+		(len$new,len$found)	byte,
+		valid		byte;
+
+/*****************************************************************************/
+/*			internal subroutines				     */
+/*****************************************************************************/
+
+check$in$list: procedure;
+				/* find known string that has a match with 
+				   input on the first character.  Set index
+				   = invalid if none found.   */
+			
+	declare	i	byte;
+
+	i = start;
+	wrd$pos = offsets(i);
+	do while list(wrd$pos) <> end$list;
+		i = i + 1;
+		index = i;
+		if list(wrd$pos) = character then return;
+		wrd$pos = offsets(i);
+	end;
+			/* could not find character */
+	index = 0;
+	return;
+end check$in$list;
+
+setup:	procedure;
+	character = buff(0);
+	call check$in$list;
+	letter$in$word = wrd$pos;
+			/* even though no match may have occurred, position
+			   to next input character.  */
+	i = 1;
+	character = buff(1);
+end setup;
+
+test$letter:	procedure;
+			/* test each letter in input and known string */
+
+	letter$in$word = letter$in$word + 1;
+
+					/* too many chars input? 0 means
+					   past end of known string */
+	if list(letter$in$word) = end$of$string then valid = false;
+	else
+	if list(letter$in$word) <> character then valid = false;
+
+	i = i + 1;
+	character = buff(i);
+
+end test$letter;
+
+skip:	procedure;
+					/* scan past the offending string;
+					   position buf$ptr to next string...
+					   skip entire offending string;
+					   ie., falseopt=mod, [note: comma or
+					   space is considered to be group 
+					   delimiter] */
+	character = buff(i);
+	delimiter = separator(character);
+	/* No skip for ERA */
+        do while ((delimiter < 1) or (delimiter > 6));
+		i = i + 1;
+		character = buff(i);
+		delimiter = separator(character);
+	end;
+	endbuf = i;
+	buf$ptr = buf$ptr + endbuf + 1;
+	return;
+end skip;
+
+eat$blanks: procedure;
+
+	declare	charac	based buf$ptr byte;
+
+
+	do while ((delimiter := separator(charac)) = SPACE);
+		buf$ptr = buf$ptr + 1;
+	end;
+
+end eat$blanks;
+
+/*****************************************************************************/
+/*			end of internals				     */
+/*****************************************************************************/
+
+
+					/* start of procedure */
+	call eat$blanks;
+	start = 0;
+	call setup;
+
+					/* match each character with the option
+					   for as many chars as input 
+					   Please note that due to the array
+					   indices being relative to 0 and the
+					   use of index both as a validity flag
+					   and as a index into the option/mods
+					   list, index is forced to be +1 as an
+					   index into array and 0 as a flag*/
+
+	do while index <> 0;
+		start = index;
+		delimiter = separator(character);
+
+					/* check up to input delimiter */
+
+		valid = true;		/* test$letter resets this */
+		do while delimiter = 0;
+			call test$letter;
+			if not valid then go to exit1;
+			delimiter = separator(character);
+		end;
+
+		go to good;
+
+					/* input ~= this known string;
+					   get next known string that 
+					   matches */
+exit1:		call setup;
+	end;
+					/* fell through from above, did
+					   not find a good match*/
+	endbuf = i;			/* skip over string & return*/
+	call skip;
+	return;
+
+					/* is it a unique match in options
+					   list? */
+good:	endbuf = i;
+	len$found = endbuf;
+	save$index = index;
+	valid = false;
+next$opt:
+		start = index;
+		call setup;
+		if index = 0 then go to finished;
+
+					/* look at other options and check
+					   uniqueness */
+
+		len$new = offsets(index + 1) - offsets(index) - 1;
+		if len$new = len$found then do;
+			valid = true;
+			do j = 1 to len$found;
+				call test$letter;
+				if not valid then go to next$opt;
+			end;
+		end;
+		else go to nextopt;
+					/* fell through...found another valid
+					   match --> ambiguous reference */
+	index = 0;
+	call skip;		/* skip input field to next delimiter*/
+	return;
+
+finished:			/* unambiguous reference */
+	index = save$index;
+	buf$ptr = buf$ptr + endbuf;
+	call eat$blanks;
+	if delimiter <> 0 then
+          buf$ptr = buf$ptr + 1;
+        else
+          delimiter = 5;
+	return;
+
+end opt$scanner;
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+break: procedure;
+  if check$con$stat then do;
+    call print$buf(.(cr,lf,'*** Aborted by ^C ***$'));
+    call mon1(0,0);
+  end;
+end break;
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+                  /* upper case character from console */
+crlf:   proc;
+    call printchar(cr);
+    call printchar(lf);
+    end crlf;
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+/* fill string @ s for c bytes with f */
+fill:   proc(s,f,c);
+    dcl s addr,
+        (f,c) byte,
+        a based s byte;
+
+        do while (c:=c-1)<>255;
+        a = f;
+        s = s+1;
+        end;
+    end fill;
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+                  /* error message routine */
+error:   proc(code);
+   declare
+      code byte;
+
+    call printchar(' ');
+    if code=1 then 
+        call print$buf(.(cr,lf,'Disk I/O $'));
+    if code=2 then 
+        call print$buf(.(cr,lf,'Drive $'));
+    if code = 3 or code = 2 then
+        call print$buf(.('Read Only$'));
+    if code = 5 then      
+        call print$buf(.('Currently Opened$'));
+    if code = 7 then
+        call print$buf(.('Password Error$'));
+    if code < 3 then 
+        call mon1(0,0);
+    end error;
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+  /* try to delete fcb at fcb$address
+            return error code if unsuccessful */
+  delete:
+    procedure(fcb$address) byte;
+    declare
+       fcb$address address,
+       fcbv based  fcb$address (32) byte,
+       error$code  address,
+       code        byte;
+       
+    if passwd$opt then 
+        fcbv(5) = fcbv(5) or 80h;
+    call setdma(.save$passwd(0));          /* password */
+    fcbv(0) = fcb(0);                      /* drive */
+    error$code = delete$file(fcb$address);
+    fcbv(5) = fcbv(5) and 7fh;             /* reset xfcb bit */
+    if low(error$code) = 0FFh then do;
+        code = high(error$code);
+        if (code=1) or (code=2) then 
+            call error(code);
+        return code;
+        end;
+    return successful;      
+    end delete;
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+                  /* upper case character from console */
+ucase:   proc byte;
+    dcl c byte;
+
+    if (c:=conin) >= 'a' then
+       if c < '{' then
+          return(c-20h);
+    return c;
+    end ucase;
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+                  /* get password and place at fcb + 16 */
+getpasswd:   proc;
+    dcl (i,c) byte;
+
+    call print$buf(.('Password: ','$'));
+retry:
+    call fill(.save$passwd(0),' ',8);
+        do i = 0 to 7;
+nxtchr:
+        if (c:=ucase) >= ' ' then 
+            save$passwd(i)=c;
+        if c = cr then
+            go to exit;
+        if c = ctrlx then
+            goto retry;
+        if c = bksp then do;
+            if i<1 then
+                goto retry;
+            else do;
+                save$passwd(i:=i-1)=' ';
+                goto nxtchr;
+                end;
+            end;
+        if c = 3 then
+            call mon1(0,0);
+        end;
+exit:
+    c = check$con$stat;             /* clear raw I/O mode */
+    end getpasswd;
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+                  /* error on deleting a file */
+    file$err: procedure(code);
+        declare code byte;
+
+        if not confirm$opt then do;	/* print file */
+          call printchar('A'+fcb(0)-1);
+          call printchar(':');
+          call printchar(' ');
+          do k=1 to 11;
+            if k=9 then
+              call printchar('.');
+            call printchar(dir$entry(k));
+          end;
+          call print$buf(.('  $'));
+        end;
+        call print$buf(.('Not erased, $'));
+        call error(code);
+        call crlf;
+      end file$err;
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+erase: procedure;
+  if (code:=delete(.fcb)) <> successful then do;
+    if code < 3 then
+      call error(code);
+    else if code = 7 then do;
+      call file$err(code);
+      call getpasswd;
+      call crlf;
+      code = delete(.fcb);
+      end;
+    if code <> successful then
+      call file$err(code);
+    end;
+end erase;
+
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+  parse$options: procedure;
+    declare
+      t address,
+      char based t byte,
+      i byte;
+   
+    delimiter = 1;
+    index = 0;
+    do while ((delimiter <> 0) and (delimiter <> 2) and (delimiter <> 6));
+      call opt$scanner(.options(0),.off$opt(0),.index);
+      if index = 0 then do;
+        /* unrecognized option */
+        call print$buf(.(cr,lf,'ERROR: Missing Delimiter or$'));
+        call print$buf(.(cr,lf,'       Unrecognized Option $'));
+        call print$buf(.('Near: $'));
+        t = buf$ptr - endbuf - 1;
+        do i = 1 to endbuf;
+          call printchar(char);
+          t = t + 1;
+        end;
+        call mon1(0,0);
+      end;
+      if index = 1 then
+        passwd$opt = true;
+      if index = 2 then
+        confirm$opt = true;
+    end;
+  end parse$options;
+ 
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+input$found: procedure (buffer$adr) byte;
+  declare buffer$adr address;
+  declare char based buffer$adr byte;
+  do while (char = ' ') or (char = tab);
+    buffer$adr = buffer$adr + 1;
+  end;
+  if char = 0 then	/* eoln */
+    return false;	/* input not found */
+  else
+    return true;	/* input found */
+end input$found;
+
+  /**************************************
+   *                                    *
+   *       M A I N  P R O G R A M       *
+   *                                    *
+   **************************************/
+
+declare (i,k,code,response,user,dcnt) byte;
+declare status address;
+declare char$count byte;
+declare last$dseg$byte byte
+  initial (0);
+declare no$chars byte;
+declare m based status byte;
+
+plm:
+  do;
+      if (low(version) < cpmversion) or (high(version) = 1) then do;
+        call print$buf(.('Requires CP/M 3.0 $'));
+        call mon1(0,0);
+      end;
+      call set$console$mode;
+      if not input$found(.tbuff(1)) then do;
+        /* prompt for file */
+        confirm$opt = true;	/* confirm, unless otherwise specified */
+        call print$buf(.('Enter filename: $'));
+        no$chars = read$console$buf(.tbuff(0),40);
+        char$count = no$chars + 2;
+        call print$buf(.(cr,lf,'$'));
+        tbuff(1) = ' ';	/* blank out nc field */
+        tbuff(char$count) = 00h;	/* eoln marker set */
+        /* convert input string to upper case */
+        do i = 1 to char$count;
+          if tbuff(i+1) >= 'a' then
+            if tbuff(i+1) < '}' then
+              tbuff(i+1) = tbuff(i+1) - 20h;
+        end;
+      end;
+      parse$fn.buff$adr = .tbuff(1);
+      parse$fn.fcb$adr = .fcb;
+      status = parse(.parse$fn);
+      if status = 0FFFFh then do;
+        call print$buf(.('ERROR: Invalid file name $'));
+        call mon1(0,0);
+      end;
+      if status <> 0 then do;	/* options must follow */
+        do while m = ' '; 
+          status = status + 1;	/* skip over blank delimiters */
+        end;
+        buf$ptr = status + 1;	/* skip first delimiter */
+        call parse$options;
+      end;
+      if fcb(0) = 0 then
+        fcb(0) = low (mon2 (25,0)) + 1;
+      user = get$user$code;
+      call return$errors;
+      call move(8,.fcb16,.save$passwd(0));
+      if not confirm$opt then do;
+        i = 0;
+        do while fcb(i:=i+1) = '?';
+        end;
+        if i > 11 then
+          if not passwd$opt then do;
+            call print$buf(.('Confirm delete all user files (Y/N)?$'));
+            response = read$console;
+            if not ((response = 'y') or (response = 'Y')) then
+              call mon1(0,0);
+            call crlf;
+        end;
+      end;
+      call move(16,.fcb,.fcb16);
+      call setdma(.tbuff);
+      dcnt = search$first (.fcb16);
+      if dcnt = 0FFh then do;
+        call print$buf(.('No File $'));
+        call mon1(0,0);
+      end;
+      do while dcnt <> 0ffh;
+        dir$entry$adr = .tbuff(ror(dcnt,3) and 110$0000b);
+        savdcnt = getscbword(dcnt$offset);
+        savsearcha = getscbword(searcha$offset);
+        savsearchl = getscbword(searchl$offset);
+        /* save searched fcb's hash code (5 bytes) */
+        hash1 = getscbword(hash1$offset);
+        hash2 = getscbword(hash2$offset);
+        hash3 = getscbword(hash3$offset);
+        if confirm$opt then do;
+          if dir$entry(0) = user then do;
+            call printchar ('A'+fcb(0)-1);
+            call printchar (':');
+            call printchar (' ');
+            do k = 1 to 11;
+              if k = 9
+                then call printchar ('.');
+              call printchar (dir$entry(k));
+            end;
+            call print$buf(.(' (Y/N)? $'));
+            response = read$console;
+            call printchar (cr);
+            call printchar (lf);
+            if response = ctrlc then do;
+              call print$buf(.(cr,lf,'*** Aborted by ^C ***$'));
+              call mon1(0,0);
+            end;
+            if (response = 'y') or
+               (response = 'Y') then do;
+                 call move (12,.dir$entry(1),.fcb(1));
+                 call erase;
+            end;
+          end;
+        end;
+        else do;	/* not confirm option */
+          call move(12,.dir$entry(1),.fcb(1));
+          call break;
+          call erase;
+        end;
+        call setdma(.tbuff);
+        call setscbword(dcnt$offset,savdcnt);
+        call setscbword(searcha$offset,savsearcha);
+        call setscbword(searchl$offset,savsearchl);
+        /* restore hash code */
+        call setscbword(hash1$offset,hash1);
+        call setscbword(hash2$offset,hash2);
+        call setscbword(hash3$offset,hash3);
+        if .fcb16 <> savsearcha then	/* restore search fcb if destroyed */
+          call move(16,.fcb16,savsearcha);
+        dcnt = search$next;
+     end;
+     call mon1(0,0);
+   end;
+end era;