$ TITLE('CP/M 3.0 --- TYPE ') type: 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 07 July 82 by John Knight 06 Oct 82 by Doug Huskey 02 Dec 82 by Bruce Skidmore */ declare mpmproduct literally '01h', /* requires mp/m */ cpmversion literally '30h'; /* requires 3.0 cp/m */ /************************************** * * * EQUATES (LITERALS) * * * **************************************/ declare true literally '0FFh', 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', ctrli literally '9', ctrlc literally '3', ctrlo literally '0fh', ctrlx literally '18h', bksp literally '8', dcnt$offset literally '45h', searcha$offset literally '47h', searchl$offset literally '49h', hash1$offset literally '00h', hash2$offset literally '02h', hash3$offset literally '04h', con$page$mode literally '2ch', con$page$size literally '1ch'; /************************************** * * * GLOBAL VARIABLES * * * **************************************/ declare plm label public; declare (eod,i,char) byte; declare control$z literally '1AH'; declare (cnt,tcnt,code) byte; declare (ver, error$code) address; declare paging byte initial (true); declare negate byte initial (false); declare status address; declare m based status byte; declare no$chars byte; declare last$dseg$byte byte initial (0); declare wflag byte initial (false); declare cur$fcb (33) byte; /* current fcb (to type) */ declare more (*) byte data (cr,lf,cr,lf,'Press RETURN to Continue $'), failed (*) byte data(cr,lf,'ERROR: Not typed: $'); /************************************** * * * 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 */ /************************************** * * * 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 (buff$adr); declare buff$adr address; call mon1 (9,buff$adr); 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; version: procedure address; /* returns current cp/m version # */ return mon3(12,0); end version; check$con$stat: procedure byte; return mon2 (11,0); end check$con$stat; open$file: procedure (fcb$address) address; declare fcb$address address; return mon3(15,fcb$address); end open$file; close$file: procedure (fcb$address) byte; declare fcb$address address; return mon2 (16,fcb$address); end close$file; read$record: procedure (fcb$address) byte; declare fcb$address address; return mon2 (20,fcb$address); end read$record; setdma: procedure(dma); declare dma address; call mon1(26,dma); end setdma; /* 0ff & 0fe = return BDOS errors */ return$errors: procedure(mode); declare mode byte; call mon1 (45,mode); end return$errors; terminate: procedure; call mon1 (0,0); end terminate; 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; declare scbpd structure (offset byte, set byte, value address); getscbbyte: procedure (offset) byte; declare offset byte; scbpd.offset = offset; scbpd.set = 0; return mon2(49,.scbpd); end getscbbyte; 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 control-c only */ call mon1(109,1); end set$console$mode; declare parse$fn structure ( buff$adr address, fcb$adr address); parse: procedure(pfcb) address external; declare pfcb address; end parse; /************************************** * * * 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; /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ /* 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 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 go to exit; 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; /* clear raw I/O mode */ end getpasswd; /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ /* error message routine */ error: proc(code); declare code byte; if code=0 then do; call print$buf (.('No File','$')); call terminate; end; if code=1 then do; call print$buf(.(cr,lf,'BDOS Bad Sector$')); call terminate; end; if code=4 then do; call print$buf(.(cr,lf,'Invalid Drive$')); call terminate; end; if code = 5 then call print$buf(.('Currently Opened$')); if code = 7 then call print$buf(.('Password Error$')); end error; /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ /* print file name */ print$file: procedure(fcbp); declare (k,c) byte; declare typ lit '9'; /* file type */ declare fnam lit '11'; /* file type */ declare fcbp addr, fcbv based fcbp (32) byte; if fcbv(0) <> 0 then do; call printchar(fcbv(0)+'@'); call printchar(':'); end; do k = 1 to fnam; if k = typ then call printchar('.'); if (c := (fcbv(k) and 7fh)) <> ' ' then call printchar(c); end; end print$file; /* - - - - - - - - - - - - - - - - - - - - - - - - - - - */ error$opt: procedure (code); declare code byte; call print$buf(.('ERROR: $')); if code = 0 then call print$buf(.('Invalid or missing delimiter(s) $')); if code = 1 then call print$buf(.('Try ''PAGE'' or ''NO PAGE'' $')); call terminate; end error$opt; /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ input$found: procedure (buffer$adr) byte; declare buffer$adr address; declare char based buffer$adr byte; do while (char = ' ') or (char = 9); /* tabs & spaces */ buffer$adr = buffer$adr + 1; end; if char = 0 then /* eoln */ return false; /* input not found */ else return true; /* input found */ end input$found; /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ scanques: procedure(str$addr) byte; declare str$addr address; declare char based str$addr byte; declare i byte; declare wildcard byte; i = 0; wildcard = false; do while (i < 11); if char = '?' then wildcard = true; i = i + 1; str$addr = str$addr + 1; end; /* do while */ return wildcard; end scanques; /*- - - - - - - - - - - - - - - - - - - - - - - - - - - -*/ /* skip over blanks or tabs in command */ page$test: procedure; if cnt <> 0 then if (tcnt:=tcnt+1) >= cnt then do; call print$buf(.more); tcnt = conin; call print$char(cr); if tcnt = ctrlc then call terminate; if tcnt = ctrlo then eod = true; tcnt = -1; end; end page$test; /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ /* type a file specified by FCB */ type$file: procedure; call return$errors(0FFh); /* return after error message */ call setdma(.fcb16); /* set dma to password */ curfcb(6) = curfcb(6) or 80h; /* open in RO mode */ curfcb(12) = 0; /* open zero extent */ error$code = open$file (.curfcb); if low(error$code) = 0FFh then if (code := high(error$code)) = 7 then do; call getpasswd; call crlf; call setdma(.fcb16); /* set dma to password */ curfcb(6) = curfcb(6) or 80h; /* open in RO mode */ call return$errors(0); error$code = open$file(.curfcb); end; else do; call print$buf(.failed); call print$file(.curfcb); call printchar(' '); call error(code); end; if low(error$code) <> 0FFH then do; call return$errors(0); /* reset error mode */ call setdma(.tbuff); curfcb(32) = 0; eod = 0; do while (not eod) and (read$record (.curfcb) = 0); do i = 0 to 127; if (char := tbuff(i)) = control$z then eod = true; if not eod then do; if check$con$stat then do; tcnt = conin; call terminate; /* terminate only on ctrl-c */ end; if cnt <> 0 then do; if char = 0ah then call page$test; end; call printchar (char); end; end; end; /* necessary to close under MP/M & Concurrent call close (.curfcb); */ end; else call error(0); end type$file; /*- - - - - - - - - - - - - - - - - - - - - - - - - - - -*/ /* try typing files one at a time */ multi$file: procedure; declare (code,dcnt) byte; declare (nextfcb$adr,savdcnt,savsearcha,savsearchl) addr; declare nextfcb based nextfcb$adr (32) byte; declare (hash1,hash2,hash3) address; call setdma(.tbuff); if (dcnt:=search$first(.fcb)) = 0ffh then call error(0); do while dcnt <> 0ffh; nextfcb$adr = shl(dcnt,5) + .tbuff; 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); /* saved one extra byte */ call move(16,nextfcb$adr,.curfcb); /* copy matched filename */ curfcb(0) = fcb(0); /* set drive */ call page$test; call crlf; call print$file(.curfcb); call printchar(':'); call page$test; call crlf; call type$file; 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 .fcb <> savsearcha then /*restore orig fcb if destroyed*/ call move(16,.fcb,savsearcha); dcnt = search$next; end; end multi$file; /*- - - - - - - - - - - - - - - - - - - - - - - - - - - -*/ /* skip over blanks or tabs in command */ eat$blanks: procedure; do while (m = ' ') or (m = ctrli); status = status + 1; end; end eat$blanks; /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ /************************************** * * * M A I N P R O G R A M * * * **************************************/ plm: do; ver = version; if (low(ver) < cpmversion) or (high(ver) = mpmproduct) then do; call print$buf (.('Requires CP/M 3.0','$')); call terminate; end; call set$console$mode; /* set program interrupt to control-c only */ /* get command */ if not input$found(.tbuff(1)) then do; /* prompt for file */ call print$buf(.('Enter file: $')); no$chars = read$console$buf(.tbuff(0),40); call print$buf(.(cr,lf,'$')); tbuff(1) = ' '; /* blank out nc field */ tbuff(no$chars+2)=0; /* mark eoln */ /* convert input to upper case */ do i = 2 to no$chars+1; if tbuff(i) >= 'a' then if tbuff(i) < '}' then tbuff(i) = tbuff(i) - 20h; end; end; /* parse command for file and options */ tcnt,cnt = 0; 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 terminate; end; /* get default paging mode */ if getscbbyte(con$page$mode) <> 0 then paging = false; /* check for options */ if (status <> 0) then do; /* options follow? */ call eat$blanks; if m = 0 then goto continue; /* no options found */ /* check for page option */ if m <> '[' then call error$opt(0); status = status + 1; call eat$blanks; if m = 'N' then do; status = status + 1; if (m = 'O') or (m = ' ') then do; status = status + 1; negate = true; end; else call error$opt(1); call eat$blanks; end; if m = 'P' then paging = true; else call error$opt(1); status = status + 1; if ( m = ']' ) or ( m = 0 ) then goto continue; else if m <> 'A' then goto end$opt; status = status + 1; if ( m = ']' ) or ( m = 0 ) then goto continue; else if m <> 'G' then goto end$opt; status = status + 1; if ( m = ']' ) or ( m = 0 ) then goto continue; else if m <> 'E' then goto end$opt; status = status + 1; end$opt: call eat$blanks; if ( m <> ']' ) and ( m <> 0 ) then call error$opt(1); end; continue: /* check for negation of paging */ if negate then paging = not paging; /* get page size */ if paging then do; cnt = getscbbyte(con$page$size)-2; if cnt = 0 then cnt = 22; /* by default, 22 lines on screen */ end; else cnt = 0; /* no paging */ /* check for wild card or single file */ wflag = scanques(.fcb); if wflag = true then call multi$file; else do; call move(16,.fcb,.curfcb); call type$file; end; call terminate; end; end type;