$title ('TYPE utility: Types file to Console')
type:
do;

$include (:f2:copyrt.lit)

$include(:f2:vaxcmd.lit)

/*
  Revised:
    19 Jan  80  by Thomas Rolander (mp/m 1.1)
    21 July 81  by Doug Huskey (mp/m 2.0)
     6 Aug  81  by Danny Horovitz (mp/m-86 2.0)
    23 Jun  82  by Bill Fitler (ccp/m-86)
    25 Jan  83  by Fran Borda & Bill Fitler (ccp/m-86 2.0)
*/

/* MODIFICATION LOG:
 *  July 82 whf: abort if wildcard char in filename.
    Jan 83 fmb : check for openfile error codes in AH reg.
 */

$include (:f2:vermpm.lit)

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',
    ctrlc   literally '3',
    ctrlx   literally '18h',
    bksp    literally '8';
   

  /**************************************
   *                                    *
   *       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(f,a) pointer external;
      declare f byte, a 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;

  print$buf:
    procedure (buff$adr);
      declare buff$adr address;
      call mon1 (9,buff$adr);
    end print$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;

  con$status:
    procedure byte;
      return mon2 (11,0);
    end con$status;

  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 => return BDOS errors */
  return$errors:
    procedure(mode);
    declare mode byte;
      call mon1 (45,mode);	
    end return$errors;

  terminate:
    procedure;
      call mon1 (143,0);
    end terminate;

  declare 
    parse$fn  structure (                      /* The input to parsefilename */
              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;


  
  /**************************************
   *                                    *
   *       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
            goto 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;
    end getpasswd;

  /**************************************
   *                                    *
   *       M A I N  P R O G R A M       *
   *                                    *
   **************************************/


  declare (eod,i,char) byte;
  declare control$z literally '1AH';

  /*
    Main Program
  */

declare (cnt,tcnt) byte;
declare (ver, error$code)  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 (.(Ver$Needs$OS,'$'));
      call mon1(0,0);
      end;

    tcnt,
    cnt = 0;
    if fcb16(1) = 'P' then
      do;
      if fcb16(2) = ' ' or fcb16(2) = 'A' then   
        cnt = 24;
      else
        cnt = (fcb16(2)-'0')*10
           +(fcb16(3)-'0');
      end;

    parse$fn.buff$adr = .tbuff(1);
    parse$fn.fcb$adr = .fcb;
    call parse;

    do i = 1 to 11;                     /* check for wildcards */
      if fcb(i) = '?' then do;
        call print$buf(.('No wildcards allowed.','$'));
        call crlf;
        call terminate;
        end;
      end;
    
    call return$errors(0FEh);           /* return after error message */
    call setdma(.fcb16);                /* set dma to password */
    fcb(6) = fcb(6) or 80h;             /* open in RO mode     */
    error$code = open$file (.fcb);
    if low(error$code) = 0FFh then
       do;
       if high(error$code) = 0 then 
         do;
         call print$buf (.('File not found.','$'));
         call terminate;
         end;
       else if high(error$code) = 7 then      /* User left out password*/
         do;
         call getpasswd;
         call crlf;
         call setdma(.fcb16);                /* set dma to password */
         fcb(6) = fcb(6) or 80h;             /* open in RO mode     */
         error$code = open$file(.fcb);
         end;
       else if high(error$code) = 4 then
         do;
         call crlf;
         call print$buf(.('Invalid Filespec.','$'));
         end;
      end;                                   /* Error Checks */
    if low(error$code) <> 0FFH then
    do;
      call return$errors(0);        /* reset error mode */
      call setdma(.tbuff);
      fcb(32) = 0;
      eod = 0;
      do while (not eod) and (read$record (.fcb) = 0);
        do i = 0 to 127;
          if (char := tbuff(i)) = control$z
            then eod = true;
          if not eod then
          do;
/**** 					allow type-ahead    whf 
            if con$status then
            do;
              i = read$console;
              call terminate;
            end;
****/
            if cnt <> 0 then
            do;
              if char = 0ah then
              do;
                if (tcnt:=tcnt+1) = cnt then
                do;
                  tcnt = read$console;
                  tcnt = 0;
                end;
              end;
            end;
            call printchar (char);
          end;
        end;
      end;
    /*
      call close (.fcb);
      *** Warning ***
      If this call is left in, the file can be destroyed.
    */
    end;
    call terminate;
end plm$start;

end type;

