Upload

Digital Research

CPM OPERATING SYSTEMS/CPM 3.X/CPM 3.0/SOURCE/submit.plm

@@ -0,0 +1,663 @@
+$ 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;