$ TITLE('CP/M 3.0 --- SUBMIT')
sub:
do;
$include (copyrt.lit)
/*
  Revised:
    26 July 79  for CP/M 2.0
    01 July 82  for CP/M 3.0 by John Knight
    23 Aug  82  for CP/M 3.0 by Doug Huskey
    11 Sept 82  for CP/M 3.0 by Doug Huskey
     1 Nov  82  for CP/M 3.0 by Doug Huskey

*/

/*
	generation procedure 

seteof submit.plm
seteof copyrt.lit
is14
asm80 mcd80a.asm debug
asm80 getf.asm debug
asm80 parse.asm debug
plm80 submit.plm pagewidth(100) debug optimize
link mcd80a.obj,submit.obj,parse.obj,getf.obj,plm80.lib to submit.mod
locate submit.mod code(0100H) stacksize(100)
era submit.mod
cpm
objcpm submit
rmac getrsx
xref getrsx
link getrsx[op]
era get.rsx
ren get.rsx=getrsx.prl
gencom submit.com get.rsx 

*/

declare plm label public;


/*********************************
*                                *                               
*  B D O S    I N T E R F A C E  *
*                                *
*********************************/

declare
    sfcb(33)  byte external,	/* default fcb */
    buff(128) byte external;    /* default buffer */

  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 */

mon1: procedure(f,a) external;
    declare f byte, a address;
    /* bdos interface, no returned value */
    end mon1;

mon2a: procedure(f,a) external;
    declare f byte, a byte;
    /* bdos interface, no returned value */
    end mon2a;

mon2: procedure(f,a) byte external;
    declare f byte, a address;
    /* bdos interface, return byte value */
    end mon2;

mon3: procedure(func,info) address external;
    declare func byte;
    declare info address;
    end mon3;

parse:
   procedure (pfcb) address external;
     declare pfcb address;
end parse;

getf:
   procedure (input$type) external;	/* does submit file processing */
     declare input$type address;
end getf;

/************************************
*                                   *
*          L I T E R A L S          *
*                                   *
************************************/

 declare lit literally 'literally',
    dcl lit 'declare',
    proc lit 'procedure',
    addr lit 'address',
    ctll lit '0ch',
    lca  lit '110$0001b',  /* lower case a */
    lcz  lit '111$1010b',  /* lower case z */
    endfile lit '1ah',    /* cp/m end of file */
    sysin$endfile lit '0ffh',
    true literally '1',
    false literally '0',
    forever literally 'while true',
    cr literally '13',
    lf literally '10',
    what literally '63',
    temp$file$drive$offset literally '50h',
    con$type literally '0',
    cpmversion literally '30h',
    ctrli literally '09h';

/****************************************
*                                       *
*    G L O B A L   V A R I A B L E S    *
*                                       *
****************************************/

declare
    ln(9) byte initial('00001 : $'),
    ln1 byte at(.ln(0)),
    ln2 byte at(.ln(1)),
    ln3 byte at(.ln(2)),
    ln4 byte at(.ln(3)),
    ln5 byte at(.ln(4)),
    dfcb(36) byte initial(0,'SYSIN   $$$',0,0,0),
    drec byte at(.dfcb(32)),  /* current record */
    drrec address at(.dfcb(33)),  /* random record */
    drr2 byte at(.dfcb(35)),   /* random record byte 3 */
    dcnt byte,
    get$init$pb byte initial(128),	/* getrsx sub-functions */
    get$kill$pb byte initial(129),
    get$fcb$pb  byte initial(130),
    sstring(128) byte,	/* substitute string */
    sbp byte,	/* source buffer pointer */
    ssbp byte,  /* sub string buffer pointer */
    ver address,
    a address,	/* calling program's stack pointer */
    prog$flag based a address;

declare scbpd structure
   (offset byte,
    set    byte,
    value  address);

declare parse$fn structure
   (buff$adr address,
    fcb$adr  address);

declare subpb structure
  (io$type       byte,
   echo$flag     byte,
   filtered$flag byte,
   program$flag  byte)
   initial (con$type,true,true,false);


declare
    ctrlc   		literally '3',
    ctrlx   		literally '18h',
    bksp    		literally '8',
    submit$file$drv	literally '15';
    

/****************************************
*                                       *
* B D O S   F U N C T I O N   C A L L S *
*                                       *
****************************************/



printchar: 
    procedure(char);
    declare char byte;
    call mon1(2,char);
    end printchar;

conin:
    procedure byte;
    return mon2(6,0fdh);
    end conin;

print: procedure(a);
    declare a address;
    /* print the string starting at address a until the
    next dollar sign is encountered */
    call mon1(9,a);
    end print;

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 characters input */
end read$console$buf;

version: procedure address;
    /* returns current cp/m version */
    return mon3(12,0);
    end version;

open: procedure(fcb) address;
    declare fcb address;
    return (mon3(15,fcb));
    end open;

close: procedure(fcb);
    declare fcb address;
    dcnt = mon2(16,fcb);
    end close;

delete: procedure(fcb);
    declare fcb address;
    call mon1(19,fcb);
    end delete;

diskread: procedure(fcb) byte;
    declare fcb address;
    return mon2(20,fcb);
    end diskread;

diskwrite: procedure(fcb) byte;
    declare fcb address;
    return mon2(21,fcb);
    end diskwrite;


ranread: procedure(fcb) byte;
    declare fcb address;
    return mon2(33,fcb);
    end ranread;

make: procedure(fcb);
    declare fcb address;
    dcnt = mon2(22,fcb);
    end make;

setdma: procedure(dma);
  declare dma address;
  call mon1(26,dma);
  end setdma;

errormode: procedure(mode);
  declare mode byte;
  call mon2a(45,mode);
  end errormode;

getscbbyte: procedure (offset) byte;
    declare offset byte;
    scbpd.offset = offset;
    scbpd.set = 0;
    return mon2(49,.scbpd);
end getscbbyte;

setscbbyte:
    procedure (offset,value);
    declare offset byte;
    declare value byte;
    scbpd.offset = offset;
    scbpd.set = 0ffh;
    scbpd.value = double(value);
    call mon1(49,.scbpd);
 end setscbbyte;

rsx$call: procedure (rsxpb) address;
/* call Resident System Extension */
  declare rsxpb address;
  return mon3(60,rsxpb);
end rsx$call;

/*************************************************
*                                                *
*         M A I N    S U B R O U T I N E S       *
*                                                *
*************************************************/

move: procedure(s,d,n);
    declare (s,d) address, n byte;
    declare a based s byte, b based d byte;
        do while (n := n - 1) <> 255;
        b = a; s = s + 1; d = d + 1;
        end;
    end move;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

crlf:   proc;
    call printchar(cr);
    call printchar(lf);
    end crlf;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

bad$file:  proc;
   call print(.('Invalid file name $'));
   call mon1(0,0);
end bad$file;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */


/* fill string @ s for c bytes with f */
fill: procedure(s,f,c);
  declare s address;
  declare (f,c) byte;
  declare a based s byte;
  do while (c:=c-1) <> 255;
    a=f;
    s=s+1;
  end;
end fill;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

error: procedure(a);
    declare a address;
    call crlf;
    call print(.('Error On Line $'));
    call print(.ln1);
    call print(a);
    call move(.dfcb(0),.sfcb(0),33);
    call delete(.sfcb(0));	/* cleanup before exit */
    call mon1(0,0);
    /* return to ccp */
    end error;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

ucase: procedure (char) byte;
  declare char byte;
  if char >= 'a' then
    if char < '{' then
      return (char-20h);
  return char;
end ucase;

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

getucase: procedure byte;
  declare c byte;
  c = ucase(conin);
  return c;
end getucase;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

getpasswd: procedure;
  declare (i,c) byte;
  call crlf;
  call crlf;
  call print(.('Enter Password:	$'));
retry:
  call fill(.fcb16,' ',8);
  do i=0 to 7;
nxtchr:
  if (c:=getucase) >= ' ' then
    fcb16(i)=c;
  if c = cr then 
    return;
  if c = ctrlx then
    go to 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 mon1(0,0);
  end;
end getpasswd;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

deblankparm: procedure;
    /* clear to next non-blank substitute string */
    do while (sstring(ssbp) = ' ' or sstring(ssbp) = ctrli);
       ssbp = ssbp + 1;
    end;
end deblankparm;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

try$open: procedure;
  declare error$code address;
  call fill(.fcb16,' ',8);	/* blank storage for password */
  if len0 <> 0 then
      call move(pass0,.fcb16,len0);
  call error$mode(0feh);
  call setdma(.fcb16);	/* set dma to password */
  error$code = open(.sfcb);
  if low(error$code) = 0ffh then
    if high(error$code) = 7 then do;
      call getpasswd;
      call crlf;
      call setdma(.fcb16);
      call error$mode(0);
      error$code=open(.sfcb);
    end;
    else do;
      if high(error$code) = 0 then
        call print(.('ERROR: No ''SUB'' File Found$'));
      call mon1(0,0);
    end;
  call setdma(.buff(0));
  call error$mode(0);
end try$open;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

setup: procedure;
    declare no$chars byte;
    declare pstatus address;
    declare b byte;
    /* move buffer to substitute string */
    call move(.buff(1),.sstring(0),127);
    sstring(buff(0))=0; /* mark end of string */
    /* check to see if there are parameters */
    ssbp = 0;
    call deblankparm;   /* skip over leading spaces */
    if sstring(ssbp) = 0 then do;	/* no sub file, prompt for it */
       call print(.('CP/M 3 SUBMIT Version 3.0',cr,lf,'$'));
       call print(.('Enter File to SUBMIT: $'));
       no$chars = read$console$buf(.buff(0),40);
       buff(no$chars+2)=0;	/* mark end of input */
       call crlf;
       parse$fn.buff$adr = .buff(2);
       parse$fn.fcb$adr = .sfcb(0);
       pstatus = parse(.parse$fn);
       if pstatus = 0FFFFh then 
          call bad$file;
       call move(.buff(2),.sstring(0),127);
    end;
    call move(.('SUB'),.sfcb(9),3);	/* set file type to SUB */
    if sfcb(0) = 0 then 
       if (b:=getscbbyte(submit$file$drv)) > 0 then do;
          sfcb(0)=b;      /* set file drive to that saved by CCP */
          call setscbbyte(submit$file$drv,0);
          end; 
    call try$open;
    do while (sstring(ssbp) <> ' ' and sstring(ssbp) <> 0 
    and sstring(ssbp) <> ctrli); 
       ssbp = ssbp + 1;	/* skip over file name */
    end;
    call deblankparm;	/* skip over any spaces */
    b = sstring(ssbp);
    /* File is open if this point reached */
    sbp = 128; /* causes read below */

    end setup;

getsource: procedure byte;
    /* read the next source character */
    declare b byte;
    if sbp > 127 then
        do; if diskread(.sfcb(0)) <> 0 then
            return endfile;
        sbp = 0;
        end;
    if (b := buff((sbp:=sbp+1)-1)) = cr then do;
      /* increment line */
      if (ln5:=ln5+1) > '9' then do;
        ln5 = '0';
        if (ln4:=ln4+1) > '9' then do;
          ln4 = '0';
          if (ln3:=ln3+1) > '9' then do;             
            ln3 = '0';
            if (ln2:=ln2+1) > '9' then do;
              ln2 = '0';
              ln1 = ln1 + 1;
            end;
          end;
        end;
      end;
    end;
    return b;
    end getsource;

writebuff: procedure;
    /* write the contents of the buffer to disk */
    if diskwrite(.dfcb) <> 0 then /* error */
        call error(.('Disk Write Error$'));
    end writebuff;

declare rbuff(2048) byte, /* jcl buffer */
    rbp address,      /* jcl buffer pointer */
    rlen byte;     /* length of current command */

fillrbuff: procedure;
    declare s byte;  /* sub string buffer pointer */

    notend: procedure byte;
        /* look at next character in sstring, return
        true if not at the end of the string - char passed
        back in 's' */
        if not ((s := sstring(ssbp)) = ' ' or s = 0) then
            do;
            ssbp = ssbp + 1;
            return true;
            end;
        return false;
        end notend;

    write$rbuff: procedure;
      declare j byte;
      declare i address;
      rbp=0; i=0;
      do while (i < 2048);
        do j=0 to 127;
          if rbuff(i+j)=sysin$endfile
            then goto close$file;
        end;
        call setdma(.rbuff(i));
        call writebuff;
        i=i+128;
      end;
      call setdma(.buff(0));
      return;

    close$file: 
      call setdma(.rbuff(i));
      call writebuff;
      call setdma(.buff(0));
      drrec, drr2 = 0;			/* set to 1st record in file */
      dcnt = ranread(.dfcb);		/* read to position at start */
      if dcnt <> 0 then
         call error(.('Random Read $'));
      goto exit$from$process;
    end write$rbuff;

  putrbuff: procedure(b);
       declare b byte;
        if (rbp > last(rbuff)) then do;
          call print(.('.$'));
          call write$rbuff;
        end;
        rbuff(rbp) = b;
        if b = sysin$endfile then
          call write$rbuff;
        rbp = rbp + 1;
    end putrbuff;

    declare (reading,b,newline,progline) byte;
    /* fill the jcl buffer */
    rbp = 0;
    reading = true;
        do while reading;
        rlen = 0; /* reset command length */
        newline,progline = true;
            do while (b:=getsource) <> endfile and b <> cr;
            if b <> lf then
                do; if b = sysin$endfile then
                      call error(.('Invalid ASCII Character$'));
                    if newline then do; /* program input begins with < */
                      newline = false;
                      if b <> '<' then
                        progline = false;
                    end;
                    if b = '$' then /* copy substitute string */
                      do; if (b:=getsource) = '$' then
                         /* $$ replaced by $ */
                         call putrbuff(b); else
                      if (b := b - '0') > 9 then
                         call error(.('Parameter Error$')); else
                         do; /* find string 'b' in sstring */
                         ssbp = 0; call deblankparm; /* ready to scan string */
                            do while b <> 0; b = b - 1;
                            /* clear next parameter */
                                do while notend;
                                end;
                            call deblankparm;
                            end;
                       /* ready to copy substitute string from position ssbp */
                            do while notend;
                            call putrbuff(s);
                            end;
                       end;
                   end; else /* not a '$' */
                if b = '^' then do;	/* possible control character */
                  b=getsource;
                  if b = '^' then
                    call putrbuff('^');	/* '^^' ==> '^' */
                  else do;
                    if b < '@' then	/* number symbols */
                      call putrbuff(b-' ');
                    else 
                      if b < '`' then	/* upper case */
                        call putrbuff(b-'@');
                      else
                        call putrbuff(b-'`');	/* lower case */
                  end;
                end;
                /* check for multiple commands <com>!<com>!<com> */
                else if b = '!' and not progline then do;
                  call putrbuff(cr); /* mark eoln with cr, lf */
                  call putrbuff(lf);
                end;
                else /* not $ or ^ */
                  call putrbuff(b);
              end;
            end; /* of line or input file - compute length */
        reading = b = cr;
        call putrbuff(cr); /* mark eoln with cr, lf */
        call putrbuff(lf);
        end;
    /* entire file has been read and processed */
    rbp = rbp - 2;	/* back up; too many cr,lf's on last line */
    call putrbuff(sysin$endfile);	/* mark end of file */
    end fillrbuff;

makefile: procedure;
    declare i byte;
    declare rsxadr addr;
    declare rsxbase based rsxadr addr;

    rsxadr = rsx$call(.get$init$pb);	
    i = high(rsxbase);		/* rsxbase = addr of kill flag */
    i = shr(i,2);
    dfcb(6) = i/10 + '0';
    dfcb(7) = i mod 10 + '0';
    call errormode(0ffh);	/* set to return errors */
    drec = 0; /* zero the next record to write */
    call make(.dfcb);
    if dcnt = 255 then do;
       call delete(.dfcb);	/* file might exist */
       call errormode(0);
       call make(.dfcb);	/* try make again */
       if dcnt = 255 then do; 	
          call print(.('ERROR: Directory Full$'));
          call mon1(0,0);
          end;
       end;
    call errormode(0);
end makefile;

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

plm: 
     ver = version;
     if (low(ver) < cpmversion) or (high(ver) = 1) then do;
       call print(.('Requires CP/M 3.0 $'));
       call mon1(0,0);
     end;
     dfcb(0)=getscbbyte(temp$file$drive$offset);
     call setup;
     call makefile;
     call fillrbuff;
exit$from$process:
     /* check if GET is above us and about to abort */
     a = rsx$call(.get$fcb$pb);
     if a <> 0ffh then do;
       a = a - 2;
       if prog$flag then
         a = rsx$call(.get$kill$pb);
     end;
     call move(.dfcb(0),.sfcb(0),33);	/* move to fcb @ 5ch */
     call getf(.subpb);		/* GETF also does submit processing */
end sub;