$ TITLE('MP/M II --- STAT 2.0') stat: do; /* c p / m s t a t u s c o m m a n d (s t a t) */ declare mpmproduct literally '01h', /* requires mp/m */ cpmversion literally '30h'; /* requires 3.0 cp/m */ /* status status status status status status */ /* status status status status status status */ /* status status status status status status */ /* status status status status status status */ /* status status status status status status */ /* status status status status status status */ /* status status status status status status */ /* status status status status status status */ /* status status status status status status */ /* status status status status status status */ /* status status status status status status */ /* status status status status status status */ /* status status status status status status */ /* status status status status status status */ /* status status status status status status */ /* status status status status status status */ /* status status status status status status */ /* status status status status status status */ /* status status status status status status */ /* status status status status status status */ /* status status status status status status */ /* status status status status status status */ /* status status status status status status */ /* copyright(c) 1975, 1976, 1977, 1978, 1979, 1980, 1981 digital research box 579 pacific grove, ca 93950 Revised: 20 Jan 80 by Thomas Rolander 14 Sept 81 by Doug Huskey (for MP/M 2.0) */ /* modified 10/30/78 to fix the space computation */ /* modified 01/28/79 to remove despool dependencies */ /* modified 07/26/79 to operate under cp/m 2.0 */ declare start label; declare jump byte data(0c3h), jadr address data (.start-3); /* jump to status */ declare copyright(*) byte data ( 'Copyright (c) 1981, Digital Research '); /* function call 32 returns the address of the disk parameter block for the currently selected disk, which consists of: scptrk (2 by) number of sectors per track blkshf (1 by) log2 of blocksize (2**blkshf=blksize) blkmsk (1 by) 2**blkshf-1 extmsk (1 by) logical/physical extents maxall (2 by) max alloc number dirmax (2 by) size of directory-1 dirblk (2 by) reservation bits for directory chksiz (2 by) size of checksum vector offset (2 by) offset for operating system */ /************************************** * * * 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; 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 */ declare maxb address external, /* addr field of jmp BDOS */ buff(128)byte external, /* default buffer */ buffa literally '.buff', /* default buffer */ fcba literally '.fcb', /* default file control block */ dolla literally '.fcb(6dh-5ch)', /* dollar sign position */ parma literally '.fcb(6dh-5ch)', /* parameter, if sent */ rreca literally '.fcb(7dh-5ch)', /* random record 7d,7e,7f */ rreco literally '.fcb(7fh-5ch)', /* high byte of random overflow */ sectorlen literally '128', /* sector length */ memsize literally 'maxb', /* end of memory */ rrec address at(rreca), /* random record address */ rovf byte at(rreco), /* overflow on getfile */ doll byte at(dolla), /* dollar parameter */ parm byte at(parma), /* parameter */ sizeset byte initial(0), /* true if displaying size field */ user$code byte, /* current user code */ cdisk byte, /* current disk */ dpba address, /* disk parameter block address */ dpb based dpba structure (spt address, bls byte, bms byte, exm byte, mxa address, dmx address, dbl address, cks address, ofs address), scptrk literally 'dpb.spt', blkshf literally 'dpb.bls', blkmsk literally 'dpb.bms', extmsk literally 'dpb.exm', maxall literally 'dpb.mxa', dirmax literally 'dpb.dmx', dirblk literally 'dpb.dbl', chksiz literally 'dpb.cks', offset literally 'dpb.ofs'; boot: procedure external; /* reboot */ end boot; declare alloca address, /* alloca is the address of the disk allocation vector */ alloc based alloca (1024) byte; /* allocation vector */ 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'; printchar: procedure(char); declare char byte; call mon1(2,char); end printchar; printb: procedure; /* print blank character */ call printchar(' '); end printb; blanks: procedure(b); declare b byte; do while (b:=b-1) <> -1; call printb; end; end blanks; printx: procedure(a); declare a address; declare s based a byte; do while s <> 0; call printchar(s); a = a + 1; end; end printx; break: procedure byte; return mon2(11,0); /* console ready */ end break; crlf: procedure; call printchar(cr); call printchar(lf); if break then do; call mon1 (1,0); /* read character */ call printx(.(cr,lf,'** Aborted **',0)); call mon1 (0,0); /* system reset */ end; end crlf; print: procedure(a); declare a address; /* print the string starting at address a until the next 0 is encountered */ call crlf; call printx(a); end print; declare dcnt byte; version: procedure address; /* returns current cp/m version # */ return mon3(12,0); end version; select: procedure(d); declare d byte; cdisk = d; call mon1(14,d); end select; open: procedure(fcb); declare fcb address; dcnt = mon2(15,fcb); end open; declare anything byte initial(false); declare ufcb byte initial('?'), /* search all dir entries */ bfcba address, /* index into dir buffer */ bfcbuser based bfcba byte, bfcb based bfcba (32) byte; /* template over dirbuff */ check$user: procedure; dcl i byte; do forever; if anything then return; if dcnt = 0ffh then return; bfcba = shl(dcnt,5)+buffa; if bfcbuser >= 20h then goto next; do i=1 to 11; if fcb(i) <> '?' then if fcb(i) <> (bfcb(i) and 7fh) then go to next; end; if (bfcbuser and 0fh) = user$code then return; /* pick up xfcbs and fcbs */ next: dcnt = mon2(18,0); end; end check$user; search: procedure(fcb); declare fcb address; declare fcb0 based fcb byte; dcnt = mon2(17,fcb); call check$user; end search; searchn: procedure; dcnt = mon2(18,0); call check$user; end searchn; cselect: procedure byte; /* return current disk number */ return mon2(25,0); end cselect; setdma: procedure(dma); declare dma address; call mon1(26,dma); end setdma; getalloca: procedure address; /* get base address of alloc vector */ return mon3(27,0); end getalloca; getlogin: procedure address; /* get the login vector */ return mon3(24,0); end getlogin; writeprot: procedure; /* write protect the current disk */ call mon1(28,0); end writeprot; getrodisk: procedure address; /* get the read-only disk vector */ return mon3(29,0); end getrodisk; setind: procedure; /* set file indicators for current fcb */ call mon1(30,fcba); end setind; set$dpb: procedure; /* set disk parameter block values */ dpba = mon3(31,0); /* base of dpb */ end set$dpb; getuser: procedure byte; /* return current user number */ return mon2(32,0ffh); end getuser; setuser: procedure(user); declare user byte; call mon1(32,user); end setuser; getfilesize: procedure(fcb); declare fcb address; call mon1(35,fcb); end getfilesize; getfreesp: procedure(d); declare d byte; call mon1(46,d); end getfreesp; declare fcbmax literally '512', /* max fcb count */ spkshf literally '3', /* 2**n sectors per kbyte */ fcbs literally 'memory',/* remainder of memory */ ioval byte; /* io byte */ declare kpb address; /* kbytes per block */ /* we want kpb (kbytes per block) so that each time we find a block address we can add kpb k to the kilobyte accumulator for file size. We derive kpb as follows: BLKSHF RECS/BLK K/BLK BLKSHF-3 3 8 1 0 4 16 2 1 5 32 4 2 6 64 8 3 7 128 16 4 */ set$kpb: procedure; declare kshf byte; call set$dpb; /* disk parameters set */ if (kshf:=blkshf-spkshf) < 1 then kpb = 1; else kpb = shl(double(1),blkshf-spkshf); end set$kpb; select$disk: procedure(d); declare d byte; /* select disk and set kpb */ call select(d); call set$kpb; /* bytes per block */ end select$disk; getalloc: procedure(i) byte; /* return the ith bit of the alloc vector */ declare i address; return rol(alloc(shr(i,3)), (i and 111b) + 1); end getalloc; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SCANNER * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ declare accum(4) byte, /* accumulator */ ibp byte; /* input buffer pointer */ declare readonly (*) byte data ('Read Only (RO)',0), readwrite (*) byte data ('Read Write (RW)',0), system (*) byte data ('System (Sys)',0), directory (*) byte data ('Directory (Dir)',0), entries (*) byte data (' Directory Entries',0), filename (*) byte data (' d:filename.typ',0), attributes (*) byte data ('[ro] [rw] [sys] or [dir]',0); /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ /* compare accumulator with 4 bytes at a */ compare: procedure(a) byte; declare a address; declare (s based a) (4) byte; declare i byte; do i = 0 to 3; if s(i) <> accum(i) then return false; end; return true; end compare; /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ /* get next input value into accum */ scan: procedure; /* fill accum with next input value */ declare (i,b) byte; setacc: procedure(b); declare b byte; accum(i) = b; i = i + 1; end setacc; /* deblank input */ do while buff(ibp) = ' '; ibp=ibp+1; end; /* initialize accum length */ i = 0; do while i < 4; if (b := buff(ibp)) > 1 then /* valid */ call setacc(b); else /* blank fill */ call setacc(' '); if b <= 1 or b = ',' or b = ':' or b = '*' or b = '.' or b = '>' or b = '<' or b = '=' then buff(ibp) = 1; else ibp = ibp + 1; end; ibp = ibp + 1; end scan; /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ /* print a decimal number from 2 byte binary */ pvalue: procedure(v); declare (d,zero) byte, (k,v) address; k = 10000; zero = false; do while k <> 0; d = low(v/k); v = v mod k; k = k / 10; if zero or k = 0 or d <> 0 then do; zero = true; call printchar('0'+d); end; end; end pvalue; /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ /* print a decimal number from 2 byte binary in a fixed field (precision) */ pdecimal: procedure(v,prec); /* print value v with precision prec (10,100,1000) with leading zero suppression */ declare v address, /* value to print */ prec address, /* precision */ zerosup byte, /* zero suppression flag */ d byte; /* current decimal digit */ zerosup = true; do while prec <> 0; d = v / prec ; /* get next digit */ v = v mod prec;/* get remainder back to v */ prec = prec / 10; /* ready for next digit */ if prec <> 0 and zerosup and d = 0 then call printb; else do; zerosup = false; call printchar('0'+d); end; end; end pdecimal; /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ /* 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; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * PRINT A NUMBER * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ declare val (7) byte initial(0,0,0,0,0,0,0), /* BCD digits */ fac (7) byte initial(0,0,0,0,0,0,0), /* hibyte factor */ f0 (7) byte initial(6,3,5,5,6,0,0), /* 65,536 */ f1 (7) byte initial(2,7,0,1,3,1,0), /* 131,072 */ f2 (7) byte initial(4,4,1,2,6,2,0), /* 262,144 */ f3 (7) byte initial(8,8,2,4,2,5,0), /* 524,288 */ f4 (7) byte initial(6,7,5,8,4,0,1), /* 1,048,576 */ f5 (7) byte initial(2,5,1,7,9,0,2), /* 2,097,152 */ f6 (7) byte initial(4,0,3,4,9,1,4), /* 4,194,304 */ ptr (7) address initial(.f0,.f1,.f2,.f3,.f4,.f5,.f6); /* BCD - convert 16 bit binary to 7 one byte BCD digits */ bcd: procedure(value); declare (value,prec) address, i byte; prec = 10000; i = 5; /* digits: 4,3,2,1,0 */ do while prec <> 0; val(i:=i-1) = value / prec; /* get next digit */ value = value mod prec; /* remainder in value */ prec = prec / 10; end; end bcd; /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ /* print BCD number in val array */ printbcd: procedure(fixed); declare (fixed, zerosup, i) byte; pchar: procedure(c); declare c byte; if val(i) = 0 then if zerosup then if i <> 0 then do; if fixed then call printb; return; end; /* else */ call printchar(c); zerosup = false; end pchar; zerosup = true; i = 7; do while (i:=i-1) <> -1; call pchar('0'+val(i)); if i = 6 or i = 3 then call pchar(','); end; end printbcd; /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ /* add two BCD numbers result in second */ add: procedure(ap,bp); declare (ap,bp) address, a based ap (7) byte, b based bp (7) byte, (c,i) byte; c = 0; /* carry */ do i = 0 to 6; /* 0 = LSB */ b(i) = a(i) + b(i) + c; c = b(i) / 10; b(i) = b(i) mod 10; end; end add; /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ /* print 3 byte value based at byte3adr */ p3byte: procedure(byte3adr,fixed); declare fixed byte, i byte, high$byte byte, byte3adr address, b3 based byte3adr structure ( lword address, hbyte byte); call fill(.val,0,7); call fill(.fac,0,7); call bcd(b3.lword); /* put 16 bit value in val */ high$byte = b3.hbyte; do i = 0 to 6; /* factor for bit i */ if high$byte then /* LSB is 1 */ call add(ptr(i),.fac); /* add in factor */ high$byte = shr(high$byte,1); /* get next bit */ end; call add(.fac,.val); /* add factor to value */ call printbcd(fixed); /* print value */ end p3byte; /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ /* divide 3 byte value by 8 */ shr3byte: procedure(byte3adr); dcl byte3adr address, b3 based byte3adr structure ( lword address, hbyte byte), temp1 based byte3adr (2) byte, temp2 byte; temp2 = ror(b3.hbyte,3) and 11100000b; /* get 3 bits */ b3.hbyte = shr(b3.hbyte,3); b3.lword = shr(b3.lword,3); temp1(1) = temp1(1) or temp2; /* or in 3 bits from hbyte */ end shr3byte; /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ /* multiply 3 byte value by #records per block */ shl3byte: procedure(byte3adr); dcl byte3adr address, b3 based byte3adr structure ( lword address, hbyte byte), temp1 based byte3adr (2) byte; b3.hbyte = (rol(temp1(1),blkshf) and blkmsk) or shl(b3.hbyte,blkshf); b3.lword = shl(b3.lword,blkshf); end shl3byte; /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ /* display current drive */ show$drive: procedure; call printchar(cdisk+'A'); call printx(.(': ',0)); end show$drive; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * STATUS ROUTINES * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* display drive characteristics */ drivestatus: procedure; dcl b3a address, b3 based b3a structure ( lword address, hbyte byte); /* print 3 byte value */ pv3: procedure; call crlf; call p3byte(buffa,true); call printchar(':'); call printb; end pv3; /* print address value v */ pv: procedure(v); dcl v address; b3.hbyte = 0; b3.lword = v; call pv3; end pv; /* print the characteristics of the currently selected drive */ b3a = .buff; call print(.(' ',0)); call show$drive; call printx(.('Drive Characteristics',0)); b3.hbyte = 0; b3.lword = maxall + 1; /* = # blocks */ call shl3byte(buffa); /* # blocks * records/block */ call pv3; call printx(.('128 Byte Record Capacity',0)); call shr3byte(buffa); /* divide by 8 */ call pv3; call printx(.('Kilobyte Drive Capacity',0)); call pv(dirmax+1); call printx(.('32 Byte',0)); call printx(.entries); call pv(shl(chksiz,2)); call printx(.('Checked',0)); call printx(.entries); call pv((extmsk+1) * 128); call printx(.('Records / Directory Entry',0)); call pv(shl(double(1),blkshf)); call printx(.('Records / Block',0)); call pv(scptrk); call printx(.('Sectors / Track',0)); call pv(offset); call printx(.('Reserved Tracks',0)); call crlf; end drivestatus; userstatus: procedure; /* display active user numbers */ declare i byte; declare user(16) byte; call crlf; call show$drive; call printx(.('Active User :',0)); call pdecimal(getuser,100); call crlf; call show$drive; call printx(.('Active Files:',0)); do i = 0 to last(user); user(i) = false; end; call setdma(.fcbs); anything = true; call search(.ufcb); do while dcnt <> 255; if (i := fcbs(shl(dcnt and 11b,5))) <> 0e5h then user(i and 0fh) = true; call searchn; end; do i = 0 to last(user); if user(i) then call pdecimal(i,100); end; end userstatus; diskstatus: procedure; /* display disk status */ declare login address, d byte; login = getlogin; /* login vector set */ d = 0; do while login <> 0; if low(login) then do; call select$disk(d); call drivestatus; end; login = shr(login,1); d = d + 1; end; end diskstatus; match: procedure(va,vl) byte; /* return index+1 to vector at va if match */ declare va address, v based va (16) byte, vl byte; declare (i,j,match,sync) byte; j,sync = 0; do sync = 1 to vl; match = true; do i = 0 to 3; if v(j) <> accum(i) then match=false; j = j + 1; end; if match then return sync; end; return 0; /* no match */ end match; declare devl(*) byte data ('VAL:USR:DSK:'); devreq: procedure byte; /* process device request, return true if found */ /* device tables */ declare (i,j,iobyte,items) byte; prname: procedure(a); declare a address, x based a byte; /* print device name at a */ do while x <> ':'; call printchar(x); a=a+1; end; call printchar(':'); end prname; items = 0; do forever; call scan; if (i:=match(.devl,3)) = 0 then return items<>0; items = items+1; /* found first/next item */ if i = 1 then /* list possible assignment */ do; call printx(.('STAT 2.0',0)); call crlf; call print(.('Read Only Disk: d:=RO',0)); call print(.('Set Attribute:',0)); call printx(.filename); call printx(.attributes); call print(.('Disk Status : DSK: d:DSK:',0)); call print(.('User Status : USR: d:USR:',0)); end; else if i = 2 then /* list user status values */ do; call userstatus; return true; end; else if i = 3 then /* show the disk device status */ call diskstatus; /* end of current item, look for more */ call scan; if accum(0) = ' ' then return true; if accum(0) <> ',' then do; call print(.('Bad Delimiter',0)); return true; end; end; /* of do forever */ end devreq; /* print the actual byte count */ prcount: procedure(fixed); declare fixed byte; call setdma(.buff); call getfreesp(cdisk); call shr3byte(.buff); call p3byte(.buff,fixed); call printchar('k'); end prcount; pralloc: procedure; /* print allocation for current disk */ call crlf; call crlf; if sizeset then call blanks(17); else call blanks(7); call printx(.('Bytes Remaining On ',0)); call show$drive; call prcount(false); call crlf; end pralloc; prstatus: procedure; /* print the status of the disk system */ declare (login, rodisk) address; declare d byte; login = getlogin; /* login vector set */ rodisk = getrodisk; /* read only disk vector set */ d = 0; do while login <> 0; if low(login) then do; call select$disk(d); call crlf; call show$drive; call printchar('R'); if low(rodisk) then call printchar('O'); else call printchar('W'); call printx(.(', Space: ',0)); call prcount(true); end; login = shr(login,1); rodisk = shr(rodisk,1); d = d + 1; end; call crlf; end prstatus; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * DISPLAY FILES * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ DECLARE kblks address initial(0), /* total number of 1k blks */ nfcbs address initial(0), /* total number of fcbs */ nxfcbs address initial(0), /* total number of xfcbs */ tall address initial(0); /* total allocation */ setdisk: procedure; if fcb(0) <> 0 then call select$disk(fcb(0)-1); end setdisk; getfile: procedure; /* process file request */ declare fnam literally '11', fext literally '12', fs1 literally '13', fmod literally '14', frc literally '15', fln literally '15', fdm literally '16', fdl literally '31', ftyp literally '9', rofile literally '9', /* read/only file */ infile literally '10', /* invisible file */ archiv literally '11', /* archived file */ attrb1 literally '1', /* attribute F1' */ attrb2 literally '2', /* attribute F2' */ attrb3 literally '3', /* attribute F3' */ attrb4 literally '4'; /* attribute F4' */ declare fcbn address, /* number of fcb's collected so far */ finx(fcbmax) address, /* index vector used during sort */ fcbr(fcbmax) address, /* record count */ fcbsa address, /* index into fcbs */ fcbea address, /* ext byte of fcbv */ fcbs1 address, /* s1 byte of fcbv */ fcbma address, /* mod byte of fcbv */ fcbe based fcbea address, /* extent count in fcbs entry */ fcbk based fcbma address, /* kbyte count in fcbs entry */ xfcb based fcbs1 byte, /* bit 7 = xfcb for fcbs entry */ fcbv based fcbsa (16) byte; /* template over fcbs entry */ declare i address, /* fcb counter during collection and display */ l address, /* used during sort and display */ k address, /* " */ m address, /* " */ kb byte, /* byte counter */ lb byte, /* byte counter */ mb byte, /* byte counter */ (b,f) byte, /* counters */ xfcbfound byte,/* true means xfcb found */ matched byte; /* used during fcbs search */ /* display a line of b dashes */ dots: procedure(i); declare i byte; call crlf; do while (i:=i-1) <> -1; call printchar('-'); end; end dots; /* test if attribute fcbv(i) is on */ attribute: procedure(i) byte; declare i byte; if rol(fcbv(i),1) then return true; return false; end attribute; /* print character c if attribute(b) is true */ prnt$attrib: procedure(b,c); declare (b,c) byte; if attribute(b) then call printchar(c); else call printb; end prnt$attrib; /* set fcbsa to the ith 16 byte fcb in memory set fcbea to the extent byte of that fcb */ multi16: procedure; /* utility to compute fcbs address from i */ fcbea = (fcbsa:=shl(i,4)+.fcbs) + fext; fcbma = fcbsa + fmod; fcbs1 = fcbsa + fs1; end multi16; declare scase byte; /* status case # */ /* check for R/O or R/W in command buffer for compatibility with earilier STATs */ check$slash: procedure; dcl i byte; i=0; do while tbuff(i:=i+1) <> 0; if tbuff(i)='R' then if tbuff(i+1)='/' then accum(1) = tbuff(i+2); end; end check$slash; setfilestatus: procedure byte; /* eventually, scase set r/o=0,r/w=1,dat=2,sys=3 */ declare fstat(*) byte data('RO RW SYS DIR '); if doll = ' ' then return false; if doll = '$' then call move(4,.parm+1,.accum); /* $???? */ else call move(4,.parm,.accum); /* [???? */ if accum(0) = 'S' and accum(1) = 'I' then return not (sizeset := true); if accum(0) = 'R' then call check$slash; /* must be a parameter */ if (scase := match(.fstat,4)) = 0 then do; call print(.('Use [size] ',0)); call printx(.attributes); end; return true; end setfilestatus; printfn: procedure; declare (k, lb) byte; /* print file name */ do k = 1 to fnam; if k = ftyp then call printchar('.'); call printchar(fcbv(k) and 7fh); end; end printfn; call set$kpb; /* in case default disk */ call setdisk; sizeset = false; scase = 255; if setfilestatus then do; if scase = 0 then return; scase = scase - 1; end; else if fcb(1) = ' ' then /* no file named */ do; call pralloc; return; end; /* read the directory, collect all common file names */ fcbn,fcb(0) = 0; fcb(fext),fcb(fmod) = '?'; /* question mark matches all */ call search(.ufcb); /* fill directory buffer */ /* collect fcbs for display */ collect: /* label for debug */ do while dcnt <> 255; /* another item found, compare it for common entry */ bfcba = shl(dcnt and 11b,5)+buffa; /* dcnt mod 4 * 32 */ matched = false; i = 0; do while not matched and i < fcbn; /* compare current entry */ call multi16; do kb = 1 to fnam; if (bfcb(kb) and 7fh) <> (fcbv(kb) and 7fh) then kb = fnam; else /* complete match if at end */ matched = kb = fnam; end; i = i + 1; end; checkmatched: /* label for debug */ if matched then i = i - 1; else do; /* copy to new position in fcbs */ fcbn = (i := fcbn) + 1; call multi16; /* fcbsa set to next to fill */ if (fcbn > fcbmax) or (fcbsa + 16) >= memsize then do; call print(.('** Too Many Files **',0)); call mon1(0,0); /* abort */ end; /* save index to element for later sort */ finx(i) = i; do kb = 0 to fnam; fcbv(kb) = bfcb(kb); end; fcbe,fcbk,fcbr(i) = 0; end; /* entry is at, or was placed at location i in fcbs fcbsa = finx(i) */ if bfcb(0) < 10h then do; /* NOT AN XFCB */ /* set any attribute that is on */ do kb=1 to fnam; if (bfcb(kb) and 80h) = 80h then fcbv(kb) = fcbv(kb) or 80h; /* set */ end; /* reset archived attribute if it is off */ if (bfcb(archiv) and 80h) <> 80h then fcbv(archiv) = fcbv(archiv) and 7fh; /* reset */ fcbe = fcbe + 1; /* extent incremented */ nfcbs = nfcbs + 1; /* record count */ fcbr(i) = fcbr(i) + bfcb(frc) + (bfcb(fext) and extmsk) * 128; /* count kilobytes */ countbytes: /* label for debug */ lb = 1; if maxall > 255 then lb = 2; /* double precision inx */ do kb = fdm to fdl by lb; mb = bfcb(kb); if lb = 2 then /* double precision inx */ mb = mb or bfcb(kb+1); if mb <> 0 then /* allocated */ fcbk = fcbk + kpb; /* kpb = kbytes per block */ end; end; else if bfcb(0) < 20h then do; /* XFCB */ xfcb = xfcb or 80h; /* bit 7 = xfcb exists flag */ nxfcbs = nxfcbs + 1; end; call searchn; /* to next entry in directory */ end; /* of do while dcnt <> 255 */ display: /* label for debug */ /* now display the collected data */ if fcbn = 0 then call print(.('File Not Found',0)); else if scase = 255 then /* display collected data */ do; /* sort the file names in ascending order */ if fcbn > 1 then /* requires at least two to sort */ do; l = 1; do while l > 0; /* bubble sort */ l = 0; do m = 0 to fcbn - 2; i = finx(m+1); call multi16; bfcba = fcbsa; i = finx(m); call multi16; /* sets fcbsa, basing fcbv */ do kb = 1 to fnam; /* compare for less or equal */ if (b:=(bfcb(kb) and 7fh)) < (f:=(fcbv(kb) and 7fh)) then /* switch */ do; k = finx(m); finx(m) = finx(m + 1); finx(m + 1) = k; l = l + 1; kb = fnam; end; else if b > f then kb = fnam; /* stop compare */ end; end; end; end; /* display */ if sizeset then call print(.(' Size ',0)); else call crlf; call printx(.(' Recs Bytes FCBs Attributes Name',0)); l = 0; do while l < fcbn; i = finx(l); /* i is the index to next in order */ call multi16; call crlf; /* set fcbv,fcbk,fcbe */ /* print the file length */ call move(16,.fcbv(0),fcba); fcb(0) = 0; /* display size */ if sizeset then do; call getfilesize(fcba); call p3byte(rreca,true); call printb; end; /* display records */ call pdecimal(fcbr(i),10000); /* rrrrr */ call printb; /* display kbytes increment 1-kblocks (kblks) */ kblks = (fcbr(i) / 8) + kblks; if fcbr(i) mod 8 <> 0 then kblks = kblks + 1; call pdecimal(fcbk,10000); /* bbbbbk */ tall = tall + fcbk; call printchar('k'); call printb; /* is there an xfcb ? (check hi-bit of s1 byte) */ xfcbfound = attribute(fs1); /* save for xfcb column */ xfcb = xfcb and 7fh; /* clear bit7 */ /* display # fcbs */ call pdecimal(fcbe,1000); /* eeee */ call blanks(2); /* display attributes: sys,ro,x,a,f1-f4 */ if attribute(infile) then call printx(.('Sys',0)); else call printx(.('Dir',0)); call printb; call printchar('R'); if attribute(rofile) then call printchar('O'); else call printchar('W'); call printb; /* display # xfcbs (0 or 1) */ if xfcbfound then call printchar('X'); else call printb; call prnt$attrib(archiv,'A'); call prnt$attrib(attrb1,'1'); call prnt$attrib(attrb2,'2'); call prnt$attrib(attrb3,'3'); call prnt$attrib(attrb4,'4'); call printb; /* display filename */ call printchar('A'+cdisk); call printchar(':'); /* print filename.typ */ call printfn; /* increment fcbs counter */ l = l + 1; end; /* print the totals */ /* skip past size and recs fields */ if sizeset then do; call dots(57); call crlf; call blanks(16); end; else do; call dots(47); call crlf; call blanks(6); end; call pdecimal(tall,10000); /* total kbytes */ call printchar('k'); call pdecimal(nfcbs,10000); /* total # fcbs */ call blanks(2); call printchar('('); call pvalue(fcbn); call printx(.(' file',0)); if fcbn < 2 then call printx(.(', ',0)); else call printx(.('s, ',0)); call pvalue(kblks); call printx(.('-1k blocks',0)); call printchar(')'); call pralloc; end; else setfileatt: /* label for debug */ /* set file attributes */ do; l = 0; do while l < fcbn; i = l; call multi16; call crlf; call printfn; do case scase; /* set to r/o */ fcbv(rofile) = fcbv(rofile) or 80h; /* set to r/w */ fcbv(rofile) = fcbv(rofile) and 7fh; /* set to sys */ fcbv(infile) = fcbv(infile) or 80h; /* set to dir */ fcbv(infile) = fcbv(infile) and 7fh; end; /* place name into default fcb location */ call move(16,fcbsa,fcba); fcb(0) = 0; /* in case matched user# > 0 */ call setind; /* indicators set */ call printx(.(' set to ',0)); do case scase; call printx(.readonly); call printx(.readwrite); call printx(.system); call printx(.directory); end; l = l + 1; end; end; end getfile; setdrivestatus: procedure; declare i byte; /* handle possible drive status assignment */ call scan; /* remove drive name */ call scan; /* check for = */ if accum(0) = '=' then do; call scan; /* get assignment */ if compare(.('RO ')) then do; call setdisk; /* a: ... */ call writeprot; call crlf; call show$drive; call printx(.('set to ',0)); call printx(.readonly); end; else if compare(.('RW ')) then call print(.('Use SET or DSKRESET',0)); else call print(.('Use: STAT d:=RO',0)); end; else /* not a disk assignment */ do; call setdisk; if (i:=match(.devl,3)) = 3 then call drivestatus; else if i = 2 then call userstatus; else call getfile; end; end setdrivestatus; declare ver address; declare last$dseg$byte byte initial (0); start: /* process request */ ver = version; cdisk = cselect; if low(ver) <> cpmversion or high(ver) <> mpmproduct then call print (.('Requires MP/M 2.0',0)); else do; user$code = getuser; /* size display if $S set in command */ ibp = 1; /* initialize buffer pointer */ if fcb(0) = 0 and fcb(1) = ' ' then /* stat only */ call prstatus; else do; if fcb(0) <> 0 then call setdrivestatus; else do; if not devreq then /* must be file name */ call getfile; end; end; end; call mon1 (0,0); end;