seppdroid/Digital-Research-Source-Code
1
0
Fork 0
mirror of https://github.com/SEPPDROID/Digital-Research-Source-Code.git synced 2025-10-28 02:44:19 +00:00
Code Issues Actions Packages Projects Releases Wiki Activity

Upload

Browse Source 
Digital Research
This commit is contained in:
Sepp J Morris
2020-11-06 18:50:37 +01:00
parent 621ed8ccaf
commit 31738079c4
8481 changed files with 1888323 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

5
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 2.0 SOURCE/era/0read.me Normal file
View File

@@ -0,0 +1,5 @@
ERA status: working 1/31/83
ERA notes
1/31/83 changed some error messages
10/21/82 Compiled ok, ready for test

16
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 2.0 SOURCE/era/era.com Normal file
View File

@@ -0,0 +1,16 @@
$ !
$ ! Compile, link, locate and generate hex for
$ ! 'ERA'
$ ! Concurrent CP/M-86
$ !
$ util := ERA
$ ccpmsetup ! set up environment
$ assign 'f$directory()' f1:
$ plm86 'util'.plm xref 'p1' optimize(3) debug
$ link86 f2:scd.obj, 'util'.obj to 'util'.lnk
$ loc86 'util'.lnk od(sm(code,dats,data,stack,const)) -
ad(sm(code(0),dats(10000h))) ss(stack(+32)) to 'util'.
$ h86 'util'
$ !
$ !pclean

185
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 2.0 SOURCE/era/era.h86 Normal file
View File

@@ -0,0 +1,185 @@
:020000021000EC
:0100040000FB
:020000021000EC
:020006000000F8
:020000021005E7
:0700000000000000000000F9
:020000021007E5
:04000C0000000000F0
:020000021010DC
:080000000000000000000000F8
:020000020000FC
:10000000EB4B90EB7690434F505952494748542060
:1000100028432920313938332C2044494749544159
:100020004C2052455345415243482020434F4E43B4
:10003000555252454E542043502F4D2D38362032C4
:100040002E302C2030332F33312F3833209C58FA68
:100050008CD98ED18D268C01509DE97A04558BEC7C
:100060008B56048B4E06CDE0A30001891E02018948
:0F0070000E0401891606015DC204009090909065
:020000020010EC
:020000000010EE
:020000021010DC
:10000800CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC28
:10001800CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC18
:020000021018D4
:02000C002000D2
:020000021018D4
:10000E00496E76616C69642046696C6573706563D0
:01001E0024BD
:020000021019D3
:09000F0020286472697665292439
:02000002101AD2
:0C000800202866696C656E616D65292416
:02000002101BD1
:0C000400202866696C65747970652924F9
:02000002101CD0
:0C000000202870617373776F72642924EC
:02000002101CD0
:04000C002E0D0A2487
:020000021014D8
:0100000000FF
:02000002101DCF
:100000000D0A4469736B20492F4F204572726F723D
:020010002E249C
:02000002101ECE
:090002000D0A44726976652024A0
:02000002101ECE
:0A000B0052656164204F6E6C792489
:02000002101FCD
:100005000D0A496E76616C69642046696C6573708A
:0C001500656320286472697665292E243A
:020000021021CB
:1000010043757272656E746C79204F70656E6564AC
:0100110024CA
:020000021022CA
:0F00020050617373776F7264204572726F72244E
:020000021023C9
:0C00010050617373776F7264203F2024FD
:020000021023C9
:0D000D004E6F74206572617365643A2024A3
:020000021014D8
:01000D0000F2
:020000021024C8
:10000A000D0A526571756972657320436F6E637567
:0E001A007272656E742043502F4D2D383624BF
:020000021026C6
:10000800496E76616C696420436F6D6D616E642022
:080018004F7074696F6E2E2415
:020000021028C4
:10000000436F6E6669726D2064656C65746520610E
:100010006C6C20757365722066696C657320285955
:050020002F4E293F24D2
:02000002102AC2
:100005000D0A46696C65204E6F7420466F756E64E7
:020015002E2497
:020000020010EC
:0F000200558BECB00150B8000050E84EFF5DC3C5
:020000020011EB
:10000100558BECB002508A4604B40050E83DFF5DC8
:03001100C2020028
:020000020012EA
:0F000400558BECB00650B8FD0050E82CFF5DC3E3
:020000020013E9
:0F000300558BECB00B50B8000050E81DFF5DC3EB
:020000020014E8
:10000200558BECB00950FF7604E80FFF5DC2020089
:020000020015E7
:0F000200558BECB00C50B8000050E8FEFE5DC30B
:020000020016E6
:10000100558BECB01A50FF7604E8F0FE5DC2020099
:020000020017E5
:10000100558BECB01150FF7604E8E0FE5DC20200B2
:020000020018E4
:0F000100558BECB01250B8000050E8CFFE5DC335
:020000020019E3
:10000000558BECB01350FF7604E8C1FE5DC20200D0
:02000002001AE2
:0F000000558BECB02050B8FF0050E8B0FE5DC348
:02000002001AE2
:0F000F00558BECB02D50B8FF0050E8A1FE5DC33B
:02000002001BE1
:0F000E00558BECB08F50B8000050E892FE5DC3E8
:02000002001CE0
:10000D00558BECB09850B8280150E883FEA1000143
:10001D00A32C01A10401A32E01833E2C01FF7543E6
:10002D00B88E0150E84EFF833E2E01177505B89F1F
:10003D0001EB22833E2E01187505B8A801EB16833E
:10004D003E2E01197505B8B401EB0A833E2E01262B
:10005D007507B8C00150E81CFFB8CC0150E815FF7A
:05006D00E88EFF5DC3F9
:020000020023D9
:10000200558BECB09C50B8000050E81EFE891E30A3
:10001200018C063201C41E3001268B4710A3360123
:08002200C706340100005DC3B4
:020000020025D7
:10000A00558BECB00D50E8AEFEB00A50E8A8FE5D84
:01001A00C322
:020000020026D6
:10000B00558BEC8A4604FEC88846043CFF740D8A67
:10001B0046068B5E088807FF4608EBE75DC20600C5
:020000020028D4
:10000B00558BECB02050E87DFE807E04017507B85F
:10001B00D00150E8A1FE807E04027507B8E20150C2
:10002B00E894FE807E04037406807E04027507B894
:10003B00EB0150E881FE807E04047507B8F5015092
:10004B00E874FE807E04057507B8110250E867FE60
:10005B00807E04077507B8220250E85AFE807E04A2
:10006B00037206807E04047503E8C7FE5DC20200BE
:02000002002FCD
:10000B00558BECC606410101803E41010B772580E3
:10001B003E4101097506B02E50E8FAFDA04101B42E
:10002B000089C68B5E048A00247F50E8E8FDFE063B
:08003B00410175D45DC2020011
:020000020033C9
:10000300558BECA04001D0D873078B5E04804F055D
:1000130080B86C0050E816FEA05C008B5E04880775
:1000230053E839FEA338018B5E048067057FA1384E
:10003300013CFF7520A1380188E0A242013C017414
:10004300083C0274043C047507FF364201E808FFCC
:0B005300A04201EB02B0FF5DC2020002
:020000020038C4
:10000E00558BECE890FDA243013C61720E803E439D
:10001E00017B7307A043012C205DC3A043015DC388
:02000002003AC2
:10000E00558BECE8A6FEB8310250E887FDB86C00BF
:10001E0050B02050B00850E8A3FEC6064401008040
:10002E003E440107775BE8B7FFA245013C20720D05
:10003E00A045018A1E4401B70088876C00803E45AA
:10004E00010D7505E865FEEB38803E45011874BD5F
:10005E00803E450108751A803E44010172AFA044EE
:10006E0001FEC8A24401B40089C3C6876C0020EB10
:10007E00B5803E4501037503E895FDFE0644017506
:09008E009EE801FDA245015DC3DD
:020000020043B9
:03000700558BEC2A
:02000002004BB1
:10000A00558BECE89AFDB83D0250E87BFCFF363A86
:0D001A0001E82DFEFF364601E8B6FD5DC38E
:020000020043B9
:10000A00B8800050E820FDB85C0050E829FDA247FE
:10001A0001803E4701FF7466A04701B105D2E0B4F2
:10002A0000058000A33A01C41E3401268B4F0C89B7
:10003A000E3C01268A4F07880E480150E8BAFEA2F4
:10004A0046013C077510E83700E828FFFF363A01F9
:10005A00E8A6FEA24601803E4601FF7403E820009E
:10006A00B8800050E8C0FCA13C01C41E34012689B6
:10007A00470CA0480126884707E8CBFCEB905DC3F4
:02000002004DAF
:10000700558BECE875FCA33E01A13E013C3072091B
:10001700A13E0188E0A8FD7510B84A0250E84BFCE4
:10002700B000B4005050E85DFBC70628018100C747
:10003700062A015C00E891FCA24B01E81DFDE89748
:10004700FC803E6D00207418803E6D00587507C611
:1000570006400101EB0AB8680250E80EFCE887FC8D
:10006700C606490100A04901FEC0A24901B40089A2
:10007700C380BF5C003F74ED803E49010B7637A01B
:100087004001F6D0D0D8732EB8800250E8DCFBE8E8
:1000970099FBA24A01803E4A0179B0FF74014050A2
:1000A700803E4A0159B0FF740140590AC1F6D0D0C9
:1000B700D87303E831FCE83DFCB85C0050E89CFDD0
:1000C700A24C013CFF742A823E4C01007509B8A579
:1000D7000250E896FBEB1A803E4C01037207803E04
:1000E7004C01047509FF364C01E8C8FCEB03E86FC7
:0600F700FEE8F3FB5DC30F
:00000001FF

836
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 2.0 SOURCE/era/era.lst Normal file
View File

@@ -0,0 +1,836 @@
PL/M-86 COMPILER ERA: UTILITY TO ERASE FILE FOR MP/M & CCP/M PAGE 1
ISIS-II PL/M-86 V2.0 COMPILATION OF MODULE ERASE
OBJECT MODULE PLACED IN ERA.OBJ
COMPILER INVOKED BY: :F0: ERA.PLM XREF OPTIMIZE(3) DEBUG
$compact
$title ('ERA: Utility to Erase File for MP/M & CCP/M')
1 erase:
do;
/*
Revised:
19 Jan 80 by Thomas Rolander (MP/M 1.1)
19 July 81 by Doug Huskey (MP/M II )
8 Aug 81 by Danny Horovitz (MP/M-86 )
31 Jan 83 by Bill Fitler (CCP/M-86 )
*/
/* ERA checks if files are open by other users */
$include (:f2:copyrt.lit)
=
= /*
= Copyright (C) 1983
= Digital Research
= P.O. Box 579
= Pacific Grove, CA 93950
= */
=
$include (:f2:vaxcmd.lit)
=
= /**** VAX commands for generation - read the name of this program
= for PROGNAME below.
=
= $ util := PROGNAME
= $ ccpmsetup ! set up environment
= $ assign 'f$directory()' f1: ! use local dir for temp files
= $ plm86 'util'.plm xref 'p1' optimize(3) debug
= $ link86 f2:scd.obj, 'util'.obj to 'util'.lnk
= $ loc86 'util'.lnk od(sm(code,dats,data,stack,const)) -
= ad(sm(code(0),dats(10000h))) ss(stack(+32)) to 'util'.
= $ h86 'util'
=
= ***** Then, on a micro:
= A>vax progname.h86 $fans
= A>gencmd progname data[b1000]
=
= ***** Notes: Stack is increased for interrupts. Const(ants) are last
= to force hex generation.
= ****/
$include (:f2:vermpm.lit)
=
= /* This utility requires MP/M or Concurrent function calls */
=
= /****** commented out for CCP/M-86 :
PL/M-86 COMPILER ERA: UTILITY TO ERASE FILE FOR MP/M & CCP/M PAGE 2
= declare Ver$OS literally '11h',
= Ver$Needs$OS literally '''Requires MP/M-86''';
= ******/
=
2 1 = declare Ver$OS literally '14h',
= Ver$Needs$OS literally '''Requires Concurrent CP/M-86''';
=
=
3 1 = declare Ver$Mask literally '0fdh'; /* mask out Is_network bit */
=
4 1 = declare Ver$BDOS literally '30h'; /* minimal BDOS version rqd */
=
5 1 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',
bksp literally '8';
$include (:f2:proces.lit)
=
= /*
= Proces Literals MP/M-8086 II
= */
=
6 1 = declare pnamsiz literally '8';
=
7 1 = declare pd$hdr literally 'structure
= (link word,thread word,stat byte,prior byte,flag word,
= name (8) byte,uda word,dsk byte,user byte,ldsk byte,luser byte,
= mem word';
=
8 1 = declare pd$structure literally 'pd$hdr,
= dvract word,wait word,org byte,net byte,parent word,
= cns byte,abort byte,conmode word,lst byte,sf3 byte,sf4 byte,sf5 byte,
= reservd (4) byte,pret word,scratch word)';
=
9 1 = declare psrun lit '00',
= pspoll lit '01',
= psdelay lit '02',
= psswap lit '03',
= psterm lit '04',
= pssleep lit '05',
= psdq lit '06',
= psnq lit '07',
= psflagwait lit '08',
= psciowait lit '09';
=
10 1 = declare pf$sys lit '00001h',
PL/M-86 COMPILER ERA: UTILITY TO ERASE FILE FOR MP/M & CCP/M PAGE 3
= pf$keep lit '00002h',
= pf$kernal lit '00004h',
= pf$pure lit '00008h',
= pf$table lit '00010h',
= pf$resource lit '00020h',
= pf$raw lit '00040h',
= pf$ctlc lit '00080h',
= pf$active lit '00100h',
= pf$tempkeep lit '00200h',
= pf$ctld lit '00400h',
= pf$childabort lit '00800h',
= pf$noctls lit '01000h';
=
11 1 = declare pcm$11 lit '00001h',
= pcm$ctls lit '00002h',
= pcm$rout lit '00004h',
= pcm$ctlc lit '00008h',
= pcm$ctlo lit '00080h',
= pcm$rsx lit '00300h';
$include (:f2:uda.lit)
=
= /* MP/M-86 II User Data Area format - August 8, 1981 */
=
12 1 = declare uda$structure lit 'structure (
= dparam word,
= dma$ofst word,
= dma$seg word,
= func byte,
= searchl byte,
= searcha word,
= searchabase word,
= dcnt word,
= dblk word,
= error$mode byte,
= mult$cnt byte,
= df$password (8) byte,
= pd$cnt byte)';
=
13 1 dcl stack$siz lit '16';
14 1 dcl int3 lit '0CCCCh';
15 1 dcl plmstack (stack$siz) word public initial(
int3,int3,int3,int3, int3,int3,int3,int3,
int3,int3,int3,int3, int3,int3,int3,int3);
16 1 dcl stack$size word public data(stack$siz + stack$siz);
/**************************************
* *
* B D O S INTERFACE *
* *
**************************************/
17 1 mon1:
procedure (func,info) external;
PL/M-86 COMPILER ERA: UTILITY TO ERASE FILE FOR MP/M & CCP/M PAGE 4
18 2 declare func byte;
19 2 declare info address;
20 2 end mon1;
21 1 mon2:
procedure (func,info) byte external;
22 2 declare func byte;
23 2 declare info address;
24 2 end mon2;
25 1 mon3:
procedure (func,info) address external;
26 2 declare func byte;
27 2 declare info address;
28 2 end mon3;
29 1 mon4:
procedure (func,info) pointer external;
30 2 declare func byte;
31 2 declare info address;
32 2 end mon4;
33 1 declare cmdrv byte external; /* command drive */
34 1 declare fcb (1) byte external; /* 1st default fcb */
35 1 declare fcb16 (1) byte external; /* 2nd default fcb */
36 1 declare pass0 address external; /* 1st password ptr */
37 1 declare len0 byte external; /* 1st passwd length */
38 1 declare pass1 address external; /* 2nd password ptr */
39 1 declare len1 byte external; /* 2nd passwd length */
40 1 declare tbuff (1) byte external; /* default dma buffer */
/**************************************
* *
* B D O S Externals *
* *
**************************************/
41 1 read$console:
procedure byte;
42 2 return mon2 (1,0);
43 2 end read$console;
44 1 printchar:
procedure(char);
45 2 declare char byte;
46 2 call mon1(2,char);
47 2 end printchar;
48 1 conin:
procedure byte;
49 2 return mon2(6,0fdh);
50 2 end conin;
PL/M-86 COMPILER ERA: UTILITY TO ERASE FILE FOR MP/M & CCP/M PAGE 5
51 1 check$con$stat:
procedure byte;
52 2 return mon2(11,0);
53 2 end check$con$stat;
54 1 print$buf:
procedure (buffer$address);
55 2 declare buffer$address address;
56 2 call mon1 (9,buffer$address);
57 2 end print$buf;
58 1 version: procedure address;
/* returns current cp/m version # */
59 2 return mon3(12,0);
60 2 end version;
61 1 setdma: procedure(dma);
62 2 declare dma address;
63 2 call mon1(26,dma);
64 2 end setdma;
65 1 search:
procedure (fcb$address) byte;
66 2 declare fcb$address address;
67 2 return mon2 (17,fcb$address);
68 2 end search;
69 1 searchn:
procedure byte;
70 2 return mon2 (18,0);
71 2 end searchn;
72 1 delete$file:
procedure (fcb$address) address;
73 2 declare fcb$address address;
74 2 return mon3 (19,fcb$address);
75 2 end delete$file;
76 1 get$user$code:
procedure byte;
77 2 return mon2 (32,0ffh);
78 2 end get$user$code;
/* 0ff => return BDOS errors */
79 1 return$errors:
procedure;
80 2 call mon1 (45,0ffh);
81 2 end return$errors;
82 1 terminate:
procedure;
83 2 call mon1 (143,0);
84 2 end terminate;
85 1 declare
parse$fn structure (
buff$adr address,
PL/M-86 COMPILER ERA: UTILITY TO ERASE FILE FOR MP/M & CCP/M PAGE 6
fcb$adr address);
86 1 declare (saveax,savecx) word external; /* reg return vals, set in mon1 */
87 1 parse: procedure;
88 2 declare (retcode,errcode) word;
89 2 call mon1(152,.parse$fn);
90 2 retcode = saveax;
91 2 errcode = savecx;
92 2 if retcode = 0ffffh then /* parse returned an error*/
93 2 do;
94 3 call print$buf(.('Invalid Filespec$'));
95 3 if errcode = 23 then call print$buf(.(' (drive)$'));
97 3 else if errcode = 24 then call print$buf(.(' (filename)$'));
99 3 else if errcode = 25 then call print$buf(.(' (filetype)$'));
101 3 else if errcode = 38 then call print$buf(.(' (password)$'));
call print$buf(.('.',13,10,'$')); call terminate;
105 3 end;
106 2 end parse;
107 1 declare
pd$pointer pointer,
pd based pd$pointer pd$structure;
108 1 declare
uda$pointer pointer,
uda$ptr structure (
offset word,
segment word) at (@uda$pointer),
uda based uda$pointer uda$structure;
109 1 get$uda: procedure;
110 2 pd$pointer = mon4(156,0);
111 2 uda$ptr.segment = pd.uda;
112 2 uda$ptr.offset = 0;
113 2 end get$uda;
/**************************************
* *
* GLOBAL VARIABLES *
* *
**************************************/
114 1 declare xfcb byte initial(0);
115 1 declare successful lit '0FFh';
/**************************************
* *
* S U B R O U T I N E S *
* *
**************************************/
/* upper case character from console */
116 1 crlf: proc;
117 2 call printchar(cr);
118 2 call printchar(lf);
PL/M-86 COMPILER ERA: UTILITY TO ERASE FILE FOR MP/M & CCP/M PAGE 7
119 2 end crlf;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* fill string @ s for c bytes with f */
120 1 fill: proc(s,f,c);
121 2 dcl s addr,
(f,c) byte,
a based s byte;
122 2 do while (c:=c-1)<>255;
123 3 a = f;
124 3 s = s+1;
125 3 end;
126 2 end fill;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* error message routine */
127 1 error: proc(code);
128 2 declare
code byte;
129 2 call printchar(' ');
130 2 if code=1 then
131 2 call print$buf(.(cr,lf,'Disk I/O Error.$'));
132 2 if code=2 then
133 2 call print$buf(.(cr,lf,'Drive $'));
134 2 if code = 3 or code = 2 then
135 2 call print$buf(.('Read Only$'));
136 2 if code = 4 then
137 2 call print$buf(.(cr,lf,'Invalid Filespec (drive).$'));
138 2 if code = 5 then
139 2 call print$buf(.('Currently Opened$'));
140 2 if code = 7 then
141 2 call print$buf(.('Password Error$'));
142 2 if code < 3 or code = 4 then
143 2 call terminate;
144 2 end error;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* print file name */
145 1 print$file: procedure(fcbp);
146 2 declare k byte;
147 2 declare typ lit '9'; /* file type */
148 2 declare fnam lit '11'; /* file type */
149 2 declare
fcbp addr,
fcbv based fcbp (32) byte;
150 2 do k = 1 to fnam;
151 3 if k = typ then
152 3 call printchar('.');
153 3 call printchar(fcbv(k) and 7fh);
154 3 end;
155 2 end print$file;
PL/M-86 COMPILER ERA: UTILITY TO ERASE FILE FOR MP/M & CCP/M PAGE 8
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* try to delete fcb at fcb$address
return error code if unsuccessful */
156 1 delete:
procedure(fcb$address) byte;
157 2 declare
fcb$address address,
fcbv based fcb$address (32) byte,
error$code address,
code byte;
158 2 if xfcb then
159 2 fcbv(5) = fcbv(5) or 80h;
160 2 call setdma(.fcb16); /* password */
161 2 fcbv(0) = fcb(0); /* drive */
162 2 error$code = delete$file(fcb$address);
163 2 fcbv(5) = fcbv(5) and 7fh; /* reset xfcb bit */
164 2 if low(error$code) = 0FFh then do;
166 3 code = high(error$code);
167 3 if (code=1) or (code=2) or (code=4) then
168 3 call error(code);
169 3 return code;
170 3 end;
171 2 return successful;
172 2 end delete;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* upper case character from console */
173 1 ucase: proc byte;
174 2 dcl c byte;
175 2 if (c:=conin) >= 'a' then
176 2 if c < '{' then
177 2 return(c-20h);
178 2 return c;
179 2 end ucase;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* get password and place at fcb + 16 */
180 1 getpasswd: proc;
181 2 dcl (i,c) byte;
182 2 call crlf;
183 2 call print$buf(.('Password ? ','$'));
184 2 retry:
call fill(.fcb16,' ',8);
185 2 do i = 0 to 7;
186 3 nxtchr:
if (c:=ucase) >= ' ' then
187 3 fcb16(i)=c;
188 3 if c = cr then do;
190 4 call crlf;
191 4 goto exit;
PL/M-86 COMPILER ERA: UTILITY TO ERASE FILE FOR MP/M & CCP/M PAGE 9
192 4 end;
193 3 if c = ctrlx then
194 3 goto retry;
195 3 if c = bksp then do;
197 4 if i<1 then
198 4 goto retry;
199 4 else do;
200 5 fcb16(i:=i-1)=' ';
201 5 goto nxtchr;
202 5 end;
203 4 end;
204 3 if c = 3 then
205 3 call terminate;
206 3 end;
207 2 exit:
c = check$con$stat;
208 2 end getpasswd;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* try deleting files one at a time */
209 1 single$file:
procedure;
210 2 declare (code,dcnt,sav$searchl) byte;
211 2 declare (fcba,sav$dcnt) addr;
212 2 file$err: procedure;
213 3 call crlf;
214 3 call print$buf(.('Not erased: $'));
215 3 call print$file(fcba);
216 3 call error(code);
217 3 end file$err;
218 2 call setdma(.tbuff);
219 2 dcnt = search(.fcb);
220 2 do while dcnt <> 0ffh;
221 3 fcba = shl(dcnt,5) + .tbuff;
222 3 sav$dcnt = uda.dcnt;
223 3 sav$searchl = uda.searchl;
224 3 if (code:=delete(fcba)) = 7 then do;
226 4 call file$err;
227 4 call getpasswd;
228 4 code = delete(fcba);
229 4 end;
230 3 if code <> successful then
231 3 call file$err;
232 3 call setdma(.tbuff);
/* restore dcnt and search length of 11 */
233 3 uda.dcnt = sav$dcnt;
234 3 uda.searchl = sav$searchl;
235 3 dcnt = searchn;
236 3 end;
237 2 end single$file;
/**************************************
* *
* M A I N P R O G R A M *
PL/M-86 COMPILER ERA: UTILITY TO ERASE FILE FOR MP/M & CCP/M PAGE 10
* *
**************************************/
238 1 declare (i,response,user,code) byte;
239 1 declare ver address;
240 1 declare last$dseg$byte byte
initial (0);
241 1 plm$start: procedure public;
242 2 ver = version;
243 2 if low(ver) < Ver$BDOS or (high(ver) and Ver$Mask) = 0 then do;
245 3 call print$buf (.(cr,lf,Ver$Needs$OS,'$'));
246 3 call mon1(0,0);
247 3 end;
248 2 parse$fn.buff$adr = .tbuff(1);
249 2 parse$fn.fcb$adr = .fcb;
250 2 user = get$user$code;
251 2 call getuda; /* get uda address */
252 2 call return$errors;
253 2 if fcb(17) <> ' ' then
254 2 if fcb(17) = 'X' then
255 2 xfcb = true;
256 2 else do;
257 3 call print$buf (.(
'Invalid Command Option.$'));
258 3 call terminate;
259 3 end;
260 2 i = 0;
261 2 do while fcb(i:=i+1) = '?';
262 3 ;
263 3 end;
264 2 if i > 11 then
265 2 if not xfcb then
266 2 do;
267 3 call print$buf (.(
'Confirm delete all user files (Y/N)?','$'));
268 3 response = read$console;
269 3 if not ((response = 'y') or
(response = 'Y'))
then call terminate;
271 3 end;
272 2 call parse;
273 2 if (code:=delete(.fcb)) <> successful then do;
275 3 if code = 0 then
276 3 call print$buf (.(cr,lf,
'File Not Found.','$'));
277 3 else if code < 3 or code = 4 then
278 3 call error(code); /* fatal errors */
else
279 3 call single$file; /* single file error */
280 3 end;
281 2 call terminate;
282 2 end plm$start;
PL/M-86 COMPILER ERA: UTILITY TO ERASE FILE FOR MP/M & CCP/M PAGE 11
283 1 end erase;
PL/M-86 COMPILER ERA: UTILITY TO ERASE FILE FOR MP/M & CCP/M PAGE 12
CROSS-REFERENCE LISTING
-----------------------
DEFN ADDR SIZE NAME, ATTRIBUTES, AND REFERENCES
----- ------ ----- --------------------------------
121 0000H 1 A. . . . . . . . . BYTE BASED(S) 123
107 0021H 1 ABORT. . . . . . . BYTE MEMBER(PD)
5 ADDR . . . . . . . LITERALLY 121 149 211
5 BKSP . . . . . . . LITERALLY 195
85 0000H 2 BUFFADR. . . . . . WORD MEMBER(PARSEFN) 248
54 0004H 2 BUFFERADDRESS. . . WORD PARAMETER AUTOMATIC 55 56
181 003DH 1 C. . . . . . . . . BYTE 186 187 188 193 195 204 207
120 0004H 1 C. . . . . . . . . BYTE PARAMETER AUTOMATIC 121 122
174 003BH 1 C. . . . . . . . . BYTE 175 176 177 178
44 0004H 1 CHAR . . . . . . . BYTE PARAMETER AUTOMATIC 45 46
51 0033H 15 CHECKCONSTAT . . . PROCEDURE BYTE STACK=0008H 207
33 0000H 1 CMDRV. . . . . . . BYTE EXTERNAL(4)
107 0020H 1 CNS. . . . . . . . BYTE MEMBER(PD)
157 003AH 1 CODE . . . . . . . BYTE 166 167 168 169
238 0044H 1 CODE . . . . . . . BYTE 273 275 277 278
127 0004H 1 CODE . . . . . . . BYTE PARAMETER AUTOMATIC 128 130 132 134 136 138 140 142
210 003EH 1 CODE . . . . . . . BYTE 216 224 228 230
48 0024H 15 CONIN. . . . . . . PROCEDURE BYTE STACK=0008H 175
107 0022H 2 CONMODE. . . . . . WORD MEMBER(PD)
5 CR . . . . . . . . LITERALLY 117 131 133 137 188 245 276
116 015AH 17 CRLF . . . . . . . PROCEDURE STACK=000EH 182 190 213
5 CTRLC. . . . . . . LITERALLY
5 CTRLX. . . . . . . LITERALLY 193
108 000EH 2 DBLK . . . . . . . WORD MEMBER(UDA)
5 DCL. . . . . . . . LITERALLY
210 003FH 1 DCNT . . . . . . . BYTE 219 220 221 235
108 000CH 2 DCNT . . . . . . . WORD MEMBER(UDA) 222 233
156 0233H 91 DELETE . . . . . . PROCEDURE BYTE STACK=0016H 224 228 273
72 0090H 16 DELETEFILE . . . . PROCEDURE WORD STACK=000AH 162
108 0012H 8 DFPASSWORD . . . . BYTE ARRAY(8) MEMBER(UDA)
61 0004H 2 DMA. . . . . . . . WORD PARAMETER AUTOMATIC 62 63
108 0002H 2 DMAOFST. . . . . . WORD MEMBER(UDA)
108 0004H 2 DMASEG . . . . . . WORD MEMBER(UDA)
108 0000H 2 DPARAM . . . . . . WORD MEMBER(UDA)
107 0012H 1 DSK. . . . . . . . BYTE MEMBER(PD)
107 0018H 2 DVRACT . . . . . . WORD MEMBER(PD)
1 0002H ERASE. . . . . . . PROCEDURE STACK=0000H
88 0026H 2 ERRCODE. . . . . . WORD 91 95 97 99 101
127 018BH 112 ERROR. . . . . . . PROCEDURE STACK=0010H 168 216 278
157 0030H 2 ERRORCODE. . . . . WORD 162 164 166
108 0010H 1 ERRORMODE. . . . . BYTE MEMBER(UDA)
207 032FH EXIT . . . . . . . LABEL 191
120 0006H 1 F. . . . . . . . . BYTE PARAMETER AUTOMATIC 121 123
5 FALSE. . . . . . . LITERALLY
34 0000H 1 FCB. . . . . . . . BYTE ARRAY(1) EXTERNAL(5) 161 219 249 253 254 261 273
35 0000H 1 FCB16. . . . . . . BYTE ARRAY(1) EXTERNAL(6) 160 184 187 200
211 0032H 2 FCBA . . . . . . . WORD 215 221 224 228
156 0004H 2 FCBADDRESS . . . . WORD PARAMETER AUTOMATIC 157 159 161 162 163
PL/M-86 COMPILER ERA: UTILITY TO ERASE FILE FOR MP/M & CCP/M PAGE 13
65 0004H 2 FCBADDRESS . . . . WORD PARAMETER AUTOMATIC 66 67
72 0004H 2 FCBADDRESS . . . . WORD PARAMETER AUTOMATIC 73 74
85 0002H 2 FCBADR . . . . . . WORD MEMBER(PARSEFN) 249
145 0004H 2 FCBP . . . . . . . WORD PARAMETER AUTOMATIC 149 153
149 0000H 32 FCBV . . . . . . . BYTE BASED(FCBP) ARRAY(32) 153
157 0000H 32 FCBV . . . . . . . BYTE BASED(FCBADDRESS) ARRAY(32) 159 161 163
212 03BAH 29 FILEERR. . . . . . PROCEDURE STACK=0014H 226 231
120 016BH 32 FILL . . . . . . . PROCEDURE STACK=0008H 184
107 0006H 2 FLAG . . . . . . . WORD MEMBER(PD)
148 FNAM . . . . . . . LITERALLY 150
5 FOREVER. . . . . . LITERALLY
29 0000H 1 FUNC . . . . . . . BYTE PARAMETER 30
17 0000H 1 FUNC . . . . . . . BYTE PARAMETER 18
108 0006H 1 FUNC . . . . . . . BYTE MEMBER(UDA)
21 0000H 1 FUNC . . . . . . . BYTE PARAMETER 22
25 0000H 1 FUNC . . . . . . . BYTE PARAMETER 26
180 02AEH 137 GETPASSWD. . . . . PROCEDURE STACK=0012H 227
109 0132H 40 GETUDA . . . . . . PROCEDURE STACK=0008H 251
76 00A0H 15 GETUSERCODE. . . . PROCEDURE BYTE STACK=0008H 250
HIGH . . . . . . . BUILTIN 166 243
238 0041H 1 I. . . . . . . . . BYTE 260 261 264
181 003CH 1 I. . . . . . . . . BYTE 185 187 197 200
21 0000H 2 INFO . . . . . . . WORD PARAMETER 23
17 0000H 2 INFO . . . . . . . WORD PARAMETER 19
25 0000H 2 INFO . . . . . . . WORD PARAMETER 27
29 0000H 2 INFO . . . . . . . WORD PARAMETER 31
14 INT3 . . . . . . . LITERALLY 15
146 0039H 1 K. . . . . . . . . BYTE 150 151 153
240 0045H 1 LASTDSEGBYTE . . . BYTE INITIAL
107 0014H 1 LDSK . . . . . . . BYTE MEMBER(PD)
37 0000H 1 LEN0 . . . . . . . BYTE EXTERNAL(8)
39 0000H 1 LEN1 . . . . . . . BYTE EXTERNAL(10)
5 LF . . . . . . . . LITERALLY 118 131 133 137 245 276
107 0000H 2 LINK . . . . . . . WORD MEMBER(PD)
5 LIT. . . . . . . . LITERALLY 9 10 11 12 13 14 115 147 148
LOW. . . . . . . . BUILTIN 164 243
107 0024H 1 LST. . . . . . . . BYTE MEMBER(PD)
107 0015H 1 LUSER. . . . . . . BYTE MEMBER(PD)
107 0016H 2 MEM. . . . . . . . WORD MEMBER(PD)
17 0000H MON1 . . . . . . . PROCEDURE EXTERNAL(0) STACK=0000H 46 56 63 80 83 89
246
21 0000H MON2 . . . . . . . PROCEDURE BYTE EXTERNAL(1) STACK=0000H 42 49 52 67 70
77
25 0000H MON3 . . . . . . . PROCEDURE WORD EXTERNAL(2) STACK=0000H 59 74
29 0000H MON4 . . . . . . . PROCEDURE POINTER EXTERNAL(3) STACK=0000H 110
108 0011H 1 MULTCNT. . . . . . BYTE MEMBER(UDA)
107 0008H 8 NAME . . . . . . . BYTE ARRAY(8) MEMBER(PD)
107 001DH 1 NET. . . . . . . . BYTE MEMBER(PD)
186 02D4H NXTCHR . . . . . . LABEL 201
108 0000H 2 OFFSET . . . . . . WORD MEMBER(UDAPTR) 112
107 001CH 1 ORG. . . . . . . . BYTE MEMBER(PD)
107 001EH 2 PARENT . . . . . . WORD MEMBER(PD)
87 00CDH 101 PARSE. . . . . . . PROCEDURE STACK=000EH 272
85 0020H 4 PARSEFN. . . . . . STRUCTURE 89 248 249
36 0000H 2 PASS0. . . . . . . WORD EXTERNAL(7)
38 0000H 2 PASS1. . . . . . . WORD EXTERNAL(9)
11 PCM11. . . . . . . LITERALLY
PL/M-86 COMPILER ERA: UTILITY TO ERASE FILE FOR MP/M & CCP/M PAGE 14
11 PCMCTLC. . . . . . LITERALLY
11 PCMCTLO. . . . . . LITERALLY
11 PCMCTLS. . . . . . LITERALLY
11 PCMROUT. . . . . . LITERALLY
11 PCMRSX . . . . . . LITERALLY
107 0000H 48 PD . . . . . . . . STRUCTURE BASED(PDPOINTER) 111
108 001AH 1 PDCNT. . . . . . . BYTE MEMBER(UDA)
7 PDHDR. . . . . . . LITERALLY 107
107 0028H 4 PDPOINTER. . . . . POINTER 107 110 111
8 PDSTRUCTURE. . . . LITERALLY 107
10 PFACTIVE . . . . . LITERALLY
10 PFCHILDABORT . . . LITERALLY
10 PFCTLC . . . . . . LITERALLY
10 PFCTLD . . . . . . LITERALLY
10 PFKEEP . . . . . . LITERALLY
10 PFKERNAL . . . . . LITERALLY
10 PFNOCTLS . . . . . LITERALLY
10 PFPURE . . . . . . LITERALLY
10 PFRAW. . . . . . . LITERALLY
10 PFRESOURCE . . . . LITERALLY
10 PFSYS. . . . . . . LITERALLY
10 PFTABLE. . . . . . LITERALLY
10 PFTEMPKEEP . . . . LITERALLY
15 0000H 32 PLMSTACK . . . . . WORD ARRAY(16) PUBLIC INITIAL
241 03D7H 246 PLMSTART . . . . . PROCEDURE PUBLIC STACK=001EH
6 PNAMSIZ. . . . . . LITERALLY
107 002CH 2 PRET . . . . . . . WORD MEMBER(PD)
54 0042H 16 PRINTBUF . . . . . PROCEDURE STACK=000AH 94 96 98 100 102 103 131 133
135 137 139 141 183 214 245 257 267 276
44 0011H 19 PRINTCHAR. . . . . PROCEDURE STACK=000AH 117 118 129 152 153
145 01FBH 56 PRINTFILE. . . . . PROCEDURE STACK=0010H 215
107 0005H 1 PRIOR. . . . . . . BYTE MEMBER(PD)
5 PROC . . . . . . . LITERALLY 116 120 127 173 180
9 PSCIOWAIT. . . . . LITERALLY
9 PSDELAY. . . . . . LITERALLY
9 PSDQ . . . . . . . LITERALLY
9 PSFLAGWAIT . . . . LITERALLY
9 PSNQ . . . . . . . LITERALLY
9 PSPOLL . . . . . . LITERALLY
9 PSRUN. . . . . . . LITERALLY
9 PSSLEEP. . . . . . LITERALLY
9 PSSWAP . . . . . . LITERALLY
9 PSTERM . . . . . . LITERALLY
41 0002H 15 READCONSOLE. . . . PROCEDURE BYTE STACK=0008H 268
107 0028H 4 RESERVD. . . . . . BYTE ARRAY(4) MEMBER(PD)
238 0042H 1 RESPONSE . . . . . BYTE 268 269
88 0024H 2 RETCODE. . . . . . WORD 90 92
184 02BBH RETRY. . . . . . . LABEL 194 198
79 00AFH 15 RETURNERRORS . . . PROCEDURE STACK=0008H 252
120 0008H 2 S. . . . . . . . . WORD PARAMETER AUTOMATIC 121 123 124
211 0034H 2 SAVDCNT. . . . . . WORD 222 233
86 0000H 2 SAVEAX . . . . . . WORD EXTERNAL(12) 90
86 0000H 2 SAVECX . . . . . . WORD EXTERNAL(13) 91
210 0040H 1 SAVSEARCHL . . . . BYTE 223 234
107 002EH 2 SCRATCH. . . . . . WORD MEMBER(PD)
65 0071H 16 SEARCH . . . . . . PROCEDURE BYTE STACK=000AH 219
108 0008H 2 SEARCHA. . . . . . WORD MEMBER(UDA)
PL/M-86 COMPILER ERA: UTILITY TO ERASE FILE FOR MP/M & CCP/M PAGE 15
108 000AH 2 SEARCHABASE. . . . WORD MEMBER(UDA)
108 0007H 1 SEARCHL. . . . . . BYTE MEMBER(UDA) 223 234
69 0081H 15 SEARCHN. . . . . . PROCEDURE BYTE STACK=0008H 235
108 0002H 2 SEGMENT. . . . . . WORD MEMBER(UDAPTR) 111
61 0061H 16 SETDMA . . . . . . PROCEDURE STACK=000AH 160 218 232
107 0025H 1 SF3. . . . . . . . BYTE MEMBER(PD)
107 0026H 1 SF4. . . . . . . . BYTE MEMBER(PD)
107 0027H 1 SF5. . . . . . . . BYTE MEMBER(PD)
SHL. . . . . . . . BUILTIN 221
209 0337H 131 SINGLEFILE . . . . PROCEDURE STACK=001AH 279
13 STACKSIZ . . . . . LITERALLY 15 16
16 0000H 2 STACKSIZE. . . . . WORD PUBLIC DATA
107 0004H 1 STAT . . . . . . . BYTE MEMBER(PD)
115 SUCCESSFUL . . . . LITERALLY 171 230 273
40 0000H 1 TBUFF. . . . . . . BYTE ARRAY(1) EXTERNAL(11) 218 221 232 248
82 00BEH 15 TERMINATE. . . . . PROCEDURE STACK=0008H 104 143 205 258 270 281
107 0002H 2 THREAD . . . . . . WORD MEMBER(PD)
5 TRUE . . . . . . . LITERALLY 255
147 TYP. . . . . . . . LITERALLY 151
173 028EH 32 UCASE. . . . . . . PROCEDURE BYTE STACK=000CH 186
108 0000H 27 UDA. . . . . . . . STRUCTURE BASED(UDAPOINTER) 222 223 233 234
107 0010H 2 UDA. . . . . . . . WORD MEMBER(PD) 111
108 002CH 4 UDAPOINTER . . . . POINTER 108 222 223 233 234
108 002CH 4 UDAPTR . . . . . . STRUCTURE AT 111 112
12 UDASTRUCTURE . . . LITERALLY 108
238 0043H 1 USER . . . . . . . BYTE 250
107 0013H 1 USER . . . . . . . BYTE MEMBER(PD)
239 0036H 2 VER. . . . . . . . WORD 242 243
4 VERBDOS. . . . . . LITERALLY 243
3 VERMASK. . . . . . LITERALLY 243
2 VERNEEDSOS . . . . LITERALLY 245
2 VEROS. . . . . . . LITERALLY
58 0052H 15 VERSION. . . . . . PROCEDURE WORD STACK=0008H 242
107 001AH 2 WAIT . . . . . . . WORD MEMBER(PD)
114 0038H 1 XFCB . . . . . . . BYTE INITIAL 158 255 265
MODULE INFORMATION:
CODE AREA SIZE = 04CDH 1229D
CONSTANT AREA SIZE = 012BH 299D
VARIABLE AREA SIZE = 0046H 70D
MAXIMUM STACK SIZE = 001EH 30D
566 LINES READ
0 PROGRAM ERROR(S)
END OF PL/M-86 COMPILATION

456
CPM OPERATING SYSTEMS/CPM 86/CONCURRENT/CCPM-86 2.0 SOURCE/era/era.plm Normal file
View File

@@ -0,0 +1,456 @@
$compact
$title ('ERA: Utility to Erase File for MP/M & CCP/M')
erase:
do;
/*
Revised:
19 Jan 80 by Thomas Rolander (MP/M 1.1)
19 July 81 by Doug Huskey (MP/M II )
8 Aug 81 by Danny Horovitz (MP/M-86 )
31 Jan 83 by Bill Fitler (CCP/M-86 )
*/
/* ERA checks if files are open by other users */
$include (:f2:copyrt.lit)
$include (:f2:vaxcmd.lit)
$include (:f2:vermpm.lit)
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',
bksp literally '8';
$include (:f2:proces.lit)
$include (:f2:uda.lit)
dcl stack$siz lit '16';
dcl int3 lit '0CCCCh';
dcl plmstack (stack$siz) word public initial(
int3,int3,int3,int3, int3,int3,int3,int3,
int3,int3,int3,int3, int3,int3,int3,int3);
dcl stack$size word public data(stack$siz + stack$siz);
/**************************************
* *
* 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;
mon4:
procedure (func,info) pointer external;
declare func byte;
declare info address;
end mon4;
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;
check$con$stat:
procedure byte;
return mon2(11,0);
end check$con$stat;
print$buf:
procedure (buffer$address);
declare buffer$address address;
call mon1 (9,buffer$address);
end print$buf;
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:
procedure (fcb$address) byte;
declare fcb$address address;
return mon2 (17,fcb$address);
end search;
searchn:
procedure byte;
return mon2 (18,0);
end searchn;
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;
terminate:
procedure;
call mon1 (143,0);
end terminate;
declare
parse$fn structure (
buff$adr address,
fcb$adr address);
declare (saveax,savecx) word external; /* reg return vals, set in mon1 */
parse: procedure;
declare (retcode,errcode) word;
call mon1(152,.parse$fn);
retcode = saveax;
errcode = savecx;
if retcode = 0ffffh then /* parse returned an error*/
do;
call print$buf(.('Invalid Filespec$'));
if errcode = 23 then call print$buf(.(' (drive)$'));
else if errcode = 24 then call print$buf(.(' (filename)$'));
else if errcode = 25 then call print$buf(.(' (filetype)$'));
else if errcode = 38 then call print$buf(.(' (password)$'));
call print$buf(.('.',13,10,'$')); call terminate;
end;
end parse;
declare
pd$pointer pointer,
pd based pd$pointer pd$structure;
declare
uda$pointer pointer,
uda$ptr structure (
offset word,
segment word) at (@uda$pointer),
uda based uda$pointer uda$structure;
get$uda: procedure;
pd$pointer = mon4(156,0);
uda$ptr.segment = pd.uda;
uda$ptr.offset = 0;
end get$uda;
/**************************************
* *
* GLOBAL VARIABLES *
* *
**************************************/
declare xfcb byte initial(0);
declare successful lit '0FFh';
/**************************************
* *
* S U B R O U T I N E S *
* *
**************************************/
/* 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 Error.$'));
if code=2 then
call print$buf(.(cr,lf,'Drive $'));
if code = 3 or code = 2 then
call print$buf(.('Read Only$'));
if code = 4 then
call print$buf(.(cr,lf,'Invalid Filespec (drive).$'));
if code = 5 then
call print$buf(.('Currently Opened$'));
if code = 7 then
call print$buf(.('Password Error$'));
if code < 3 or code = 4 then
call terminate;
end error;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* print file name */
print$file: procedure(fcbp);
declare k byte;
declare typ lit '9'; /* file type */
declare fnam lit '11'; /* file type */
declare
fcbp addr,
fcbv based fcbp (32) byte;
do k = 1 to fnam;
if k = typ then
call printchar('.');
call printchar(fcbv(k) and 7fh);
end;
end print$file;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* 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 xfcb then
fcbv(5) = fcbv(5) or 80h;
call setdma(.fcb16); /* 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) or (code=4) 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 crlf;
call print$buf(.('Password ? ','$'));
retry:
call fill(.fcb16,' ',8);
do i = 0 to 7;
nxtchr:
if (c:=ucase) >= ' ' then
fcb16(i)=c;
if c = cr then do;
call crlf;
goto exit;
end;
if c = ctrlx then
goto retry;
if c = bksp then do;
if i<1 then
goto retry;
else do;
fcb16(i:=i-1)=' ';
goto nxtchr;
end;
end;
if c = 3 then
call terminate;
end;
exit:
c = check$con$stat;
end getpasswd;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* try deleting files one at a time */
single$file:
procedure;
declare (code,dcnt,sav$searchl) byte;
declare (fcba,sav$dcnt) addr;
file$err: procedure;
call crlf;
call print$buf(.('Not erased: $'));
call print$file(fcba);
call error(code);
end file$err;
call setdma(.tbuff);
dcnt = search(.fcb);
do while dcnt <> 0ffh;
fcba = shl(dcnt,5) + .tbuff;
sav$dcnt = uda.dcnt;
sav$searchl = uda.searchl;
if (code:=delete(fcba)) = 7 then do;
call file$err;
call getpasswd;
code = delete(fcba);
end;
if code <> successful then
call file$err;
call setdma(.tbuff);
/* restore dcnt and search length of 11 */
uda.dcnt = sav$dcnt;
uda.searchl = sav$searchl;
dcnt = searchn;
end;
end single$file;
/**************************************
* *
* M A I N P R O G R A M *
* *
**************************************/
declare (i,response,user,code) byte;
declare ver address;
declare last$dseg$byte byte
initial (0);
plm$start: procedure public;
ver = version;
if low(ver) < Ver$BDOS or (high(ver) and Ver$Mask) = 0 then do;
call print$buf (.(cr,lf,Ver$Needs$OS,'$'));
call mon1(0,0);
end;
parse$fn.buff$adr = .tbuff(1);
parse$fn.fcb$adr = .fcb;
user = get$user$code;
call getuda; /* get uda address */
call return$errors;
if fcb(17) <> ' ' then
if fcb(17) = 'X' then
xfcb = true;
else do;
call print$buf (.(
'Invalid Command Option.$'));
call terminate;
end;
i = 0;
do while fcb(i:=i+1) = '?';
;
end;
if i > 11 then
if not xfcb then
do;
call print$buf (.(
'Confirm delete all user files (Y/N)?','$'));
response = read$console;
if not ((response = 'y') or
(response = 'Y'))
then call terminate;
end;
call parse;
if (code:=delete(.fcb)) <> successful then do;
if code = 0 then
call print$buf (.(cr,lf,
'File Not Found.','$'));
else if code < 3 or code = 4 then
call error(code); /* fatal errors */
else
call single$file; /* single file error */
end;
call terminate;
end plm$start;
end erase;