[INHERIT ('SYS$LIBRARY:STARLET')]PROGRAM qr(OUTPUT);

{

This software is provided at no charge, and there is
no warranty. Permission to copy is granted without
conditions.

        David A. Johnson
        VAX System Manager
        Lockheed Palo Alto Research Lab
        Dept. 5233, Bldg 255
        3251 Hanover St.
        Palo Alto, CA 94304
        (415) 858-4038

                                               }


LABEL 99;

CONST

  maxque = 1;
  max_q_mgr = 15;

  parmdef = 'PARM.PLV                                        ';
  vecdef  = 'VECTR1.PLV                                      ';


TYPE

  byte = [BYTE]-128..127;
  word = [WORD]-32768..32767;
  longword = INTEGER;
  quadword = PACKED ARRAY [1..2] OF INTEGER;
  
  alfa4  = PACKED ARRAY [1.. 4] OF CHAR;
  alfa6  = PACKED ARRAY [1.. 6] OF CHAR;
  alfa8  = PACKED ARRAY [1.. 8] OF CHAR;
  alfa9  = PACKED ARRAY [1.. 9] OF CHAR;
  alfa12 = PACKED ARRAY [1..12] OF CHAR;
  alfa13 = PACKED ARRAY [1..13] OF CHAR;
  alfa15 = PACKED ARRAY [1..15] OF CHAR;
  alfa16 = PACKED ARRAY [1..16] OF CHAR;
  alfa17 = PACKED ARRAY [1..17] OF CHAR;
  alfa18 = PACKED ARRAY [1..18] OF CHAR;
  alfa19 = PACKED ARRAY [1..19] OF CHAR;
  alfa24 = PACKED ARRAY [1..24] OF CHAR;
  alfa26 = PACKED ARRAY [1..26] OF CHAR;
  alfa30 = PACKED ARRAY [1..30] OF CHAR;
  alfa33 = PACKED ARRAY [1..33] OF CHAR;
  alfa48 = PACKED ARRAY [1..48] OF CHAR;
  alfa63 = PACKED ARRAY [1..63] OF CHAR;
  alfa132= PACKED ARRAY [1..132] OF CHAR;

%INCLUDE 'PLTSEC.PAS/LIST'

  two_wrds = PACKED ARRAY [1..2] OF word;

  prottyp  = ( rd, wrt, exe, del );

  proset   = PACKED SET OF prottyp;

  prowrd   = PACKED ARRAY [1..4] OF proset;

  ioblock = PACKED RECORD
	    iostat,byte_count:word;
	    process_id:INTEGER
	    END;

  equiv = PACKED RECORD
  	CASE INTEGER OF
  		 1:(alpha:alfa4);
  		 2:( numb:INTEGER);
  		 3:( twin:two_wrds)
  	END;

  string = VARYING[48] OF CHAR;
  actions = (plot, tex_plot, delete_plot, initialize, start, stop,
             delete_q, show, scrub, set_device, new_log, no_log);

  cstr   = PACKED RECORD
  	   length:byte;
  	   string:alfa48;
  	   END;
  str    = ARRAY [1..10] OF cstr;



  dbl = ARRAY [1..2] OF secptr;

VAR
  tag,mbx:alfa4;
  pfdlen,vfdlen:INTEGER;
  pfdef,vfdef:alfa48;
  ptr:secptr;
  m,nq,np:INTEGER;
  plot_entry,qn,ix,jx,qf:INTEGER;
  system,owner,found:BOOLEAN;
  tst:alfa4;
  q_name,plot_number,parms,pfile,vfile:string;
  noprint,notify,nodelspec,done:BOOLEAN;
  efn,wcnt,estat:INTEGER;
  msg,reply:alfa132;
  reptag,repno:alfa4;
  dname:alfa63;
  gsdnam:alfa9;
  inadr,retadr:dbl;
  fstat,st1,st2,st3,st4,st5,st6,st7,st8:INTEGER;
  dig1,dig2,pid,k:INTEGER;
  nd,lnam:INTEGER;
  pro1,pro2:prowrd;
  tstpro:proset;
  chan1,chan2:word;
  iosb1,iosb2:ioblock;
  mbname:alfa6;
  convert:equiv;
  username:alfa12;
  usruic:INTEGER;
  action:actions;
{
*****************EXTERNALS*************************
}

FUNCTION get_pid:INTEGER;EXTERN;

PROCEDURE wait(x:REAL);EXTERN;

PROCEDURE LIB$GET_EF(VAR efn:INTEGER);EXTERN;

PROCEDURE LIB$FREE_EF(efn:INTEGER);EXTERN;

PROCEDURE getid(%STDESCR uname:alfa12;VAR uic:INTEGER);EXTERN;

PROCEDURE xlate1(nam1:alfa48; ln1:INTEGER; VAR nam2:alfa63;
		VAR ln2,stat:INTEGER;
  		VAR prot:prowrd);EXTERN;

PROCEDURE xlate2(nam1:alfa48; ln1:INTEGER; VAR nam2:alfa63;
		VAR ln2,stat:INTEGER;
  		VAR prot:prowrd);EXTERN;

PROCEDURE xlate3(nam1:alfa48; ln1:INTEGER; VAR nam2:alfa63;
		VAR ln2,stat:INTEGER;
  		VAR prot:prowrd);EXTERN;

PROCEDURE addr1(VAR inadr:dbl);EXTERN;

{
***************** CVTI4 *************************
}
  PROCEDURE cvti4 (k:INTEGER; VAR a:alfa4);
  VAR
    m,n:INTEGER;
  BEGIN
  n := k;
  FOR m := 4 DOWNTO 1 DO
    BEGIN
    a[m] := chr((n MOD 10) + ord('0'));
    n := n DIV 10;
    END;
  END;
{
***************** PARSE_CMD *************************
}

PROCEDURE parse_cmd;

TYPE

  alfa6  = PACKED ARRAY [1..6] OF CHAR;
  ptalf  = ^alfa6;
  desct  = PACKED RECORD
		ln:INTEGER;
	        pt:ptalf;
		END;
  cliret = (present, defaulted, absent, negated, nogood);

VAR
  st,stat:INTEGER;
  verb:VARYING[48] OF CHAR;
  ptr:ptalf;
  clistat:cliret;

  {
  ***************** CLI_PRESENT *************************
  }
  FUNCTION cli_present(prm:string):cliret;

  CONST
    cli$_present   = %X3FD19;
    cli$_defaulted = %X3FD21;
    cli$_absent    = %X381F0;
    cli$_negated   = %X381F8;

  VAR
    k,stat:INTEGER;
    x:desct;

    FUNCTION cli$present(x:desct):INTEGER;EXTERN;

  BEGIN
  ptr^ := '      ';
  x.pt := ptr;
  x.ln := LENGTH(prm);
  FOR k := 1 TO x.ln DO ptr^[k] := prm[k];
  stat := cli$present(x);
  IF      stat = cli$_present    THEN cli_present := present
  ELSE IF stat = cli$_defaulted  THEN cli_present := defaulted
  ELSE IF stat = cli$_absent     THEN cli_present := absent
  ELSE IF stat = cli$_negated    THEN cli_present := negated
  ELSE cli_present := nogood;
  END;

  {
  ***************** GET_VALUE *************************
  }
  PROCEDURE get_value(prm:string; VAR ret:string);

  VAR
    k,stat:INTEGER;
    x:desct;

  FUNCTION cli$get_value(x:desct;%DESCR retbuf:string):INTEGER;EXTERN;

  BEGIN
  ptr^ := '      ';
  x.pt := ptr;
  x.ln := LENGTH(prm);
  FOR k := 1 TO x.ln DO ptr^[k] := prm[k];
  stat := cli$get_value( x, ret );
  END;

BEGIN
new(ptr);
get_value( '$VERB', verb );
IF verb = 'PLOT' THEN
  BEGIN
  tag := 'PLOT';
  IF cli_present('NOTIFY') = present THEN notify := TRUE
  				     ELSE NOTIFY := FALSE;
  IF cli_present('DELETE') = present THEN nodelspec := FALSE
  				     ELSE nodelspec := TRUE;
  get_value('PARM', pfile);
  get_value('VECT', vfile);
  action := plot;
  END

ELSE IF verb = 'PDEL' THEN
  BEGIN
  tag := 'PDEL';  
  action := delete_plot;
  get_value('DELNO', plot_number);
  END

ELSE IF verb = 'PSHO' THEN action := show

ELSE IF verb = 'PTEX' THEN
  BEGIN
  tag := 'PTEX';
  action := tex_plot;
  parms := ' ';
  IF cli_present('H') = present THEN parms := parms + '/H';
  IF cli_present('S') = present THEN parms := parms + '/S';
  IF cli_present('XTAG') = present THEN
    BEGIN
    get_value('XTAG', vfile);
    parms := parms + '/X=' + vfile;
    END;
  IF cli_present('TMTG') = present THEN
    BEGIN
    get_value('TMTG', vfile);
    parms := parms + '/TM=' + vfile;
    END;
  IF cli_present('RMTG') = present THEN
    BEGIN
    get_value('RMTG', vfile);
    parms := parms + '/RM=' + vfile;
    END;
  get_value('DVIF', pfile);
  vfile := parms;
{
  WRITELN(' Processing PTEX ', parms);
  WRITELN(' Input file is ', pfile);
  halt;
						}
  END

ELSE IF verb = 'PQUE' THEN
  BEGIN
  st := 0;
  IF cli_present('INIT') = present THEN
    BEGIN
    tag := 'INIQ';
    action := initialize;
    st := st + 1;
    clistat := cli_present('PRINT');
    IF clistat IN [absent, negated] THEN noprint := TRUE
    				    ELSE noprint := FALSE;
    IF cli_present('DEVICE') = present THEN
      get_value('DEVICE', q_name);
    END;
  IF (cli_present('DEVICE') = present) AND (st = 0) THEN
    BEGIN
    action := set_device;
    tag := 'SETD';
    st := st + 1;
    get_value('DEVICE', q_name);
    END;
  IF cli_present('START') = present THEN
    BEGIN
    tag := 'STRT';
    action := start;
    st := st + 1;
    END;
  IF cli_present('STOP') = present THEN
    BEGIN
    tag := 'STOP';
    action := stop;
    st := st + 1;
    END;
  IF cli_present('DELETE') = present THEN
    BEGIN
    tag := 'DELQ';
    action := delete_q;
    st := st + 1;
    END;
  IF cli_present('SCRUB') = present THEN
    BEGIN
    tag := 'SCRB';
    action := scrub;
    st := st + 1;
    END;

  clistat := cli_present('LOG');

  CASE clistat OF
     present:BEGIN
	      st := st + 1;
	      action := new_log;
	      tag := 'ILOG';
	     END;
    negated:BEGIN
	      st := st +1;
	      action := no_log;
	      tag := 'NLOG';
	     END;
    END;  { CASE clistat  }

  IF st <> 1 THEN 
    BEGIN
    WRITELN(' PQUE spec ambiguous');
    halt;
    END;
  END;
END;

{
***************** ALPHAHEX *************************
}

FUNCTION alphahex(k:INTEGER):CHAR;
BEGIN
IF k < 10 THEN alphahex := chr(k+ord('0'))
 ELSE
  alphahex := chr(k - 10 + ord('A') );
END;

{
***************** MAP *************************
}

PROCEDURE map;
VAR
  status:INTEGER;
BEGIN
gsdnam := 'PLOTQSECT';
addr1( inadr );
status := $mgblsc( inadr, retadr, 0,
  			sec$m_sysgbl,
  			gsdnam, 0, 0);
ptr := retadr[1];
END;

{
***************** SHOW_QUEUE *************************
}

PROCEDURE show_queue;

VAR
  z, ne, nj :INTEGER;

  PROCEDURE write_file_name(a:fdtype);
  VAR
    k:INTEGER;
  BEGIN
   WITH a DO
    BEGIN
    FOR k := 1 TO dlen DO WRITE(dir_name[k]);
    FOR k := 1 TO flen DO WRITE(f_name[k]);
    END;
  END;

BEGIN
WITH ptr^.qhead DO
  BEGIN
  WHILE structure_busy DO
    BEGIN
    WRITELN(' Status in UPDATE...stand by...');
    wait(1.0);
    END;
  z := link1;
  ne := entries;
  WRITELN;
  WRITE( '   PLOT QUEUE "');
  WRITE(device_name);
  WRITE('" entries= ', entries:1, ' ');
  IF idle IN status THEN WRITE('idle ');
  IF waiting IN status THEN WRITE('waiting ');
  IF plotting IN status THEN WRITE('plotting ');
  IF stopped IN status THEN WRITE('stopped ');
  IF print_mode IN status THEN WRITE('print_mode ');
  WRITELN;
  WRITELN;
  END;
nj := 0;
IF ne = 0 THEN WRITELN('  Queue is empty')
ELSE
  WHILE nj < ne DO
    BEGIN
    nj := nj + 1;
    WITH ptr^.qinfo[z].job_head DO
      BEGIN
      WRITE('     ');
      IF (nj = 1) AND (plotting IN ptr^.qhead.status)
	        THEN WRITE('Current job ')
                ELSE WRITE('Pending job ');
      WRITE(entry_no:4, '  ');
      IF processor=2 THEN write_file_name(ptr^.qinfo[parm_link].file_descr)
                     ELSE write_file_name(ptr^.qinfo[vec_link].file_descr);
      IF (ptr^.control.working = 1) AND (nj = 1) THEN WRITE(' **working**');
      WRITELN;
      z := link;
      END;
    END;
END;

{
***************** MAIN PROGRAM *************************
}

BEGIN

map;
system := FALSE;

FOR k := 1 TO 132 DO msg[k] := ' ';
q_name := '    ';
nodelspec := TRUE;
notify := FALSE;
noprint := FALSE;

parse_cmd;

IF q_name = '    ' THEN q_name := 'LVA0';
IF action = show THEN
  BEGIN
  m := ptr^.control.flen;
  IF m = 0 THEN WRITELN(' No queue.')
  ELSE show_queue;
  GOTO 99;
  END;
pid := get_pid;
dig1 := pid MOD 16;
dig2 := ( pid DIV 16 ) MOD 16;
mbname := 'PRMBxx';
mbname[5] := alphahex(dig2);
mbname[6] := alphahex(dig1);
st1 := $crembx(1, chan2, 0, 0, 0, 0, mbname);
st2 := $delmbx(chan2);
st3 := $assign('PLSMBX', chan1);
FOR k := 1 TO 4 DO msg[k] := tag[k];
FOR k := 1 TO 4 DO msg[k+4] := q_name[k];
msg[9] := mbname[5];
msg[10] := mbname[6];
getid(username, usruic);

system := FALSE;
FOR k := 1 TO ptr^.no_of_mgrs DO
        IF usruic = ptr^.q_mgrs[k] THEN system := TRUE;

IF (NOT(action IN [plot, tex_plot, delete_plot, show])) 
	AND (NOT system) THEN
  BEGIN
  WRITELN(' No privilege for attempted operation.');
  GOTO 99;
  END;

IF action IN [plot, tex_plot, delete_plot] THEN
  BEGIN
  convert.numb := usruic;
  FOR k := 1 TO 4 DO msg[k+24] := convert.alpha[k];
  convert.numb := pid;
  FOR k := 1 TO 4 DO msg[k+28] := convert.alpha[k];
  FOR k := 1 TO 12 DO msg[k+12] := username[k];
  END;

CASE action OF

delete_plot:

  BEGIN
  plot_entry := 0;
  FOR k := 1 TO 4 DO 
  	plot_entry := 10*plot_entry + ord(plot_number[k])
  			- ord('0');
  found := FALSE;
   IF (NOT found) AND (ptr^.control.flen > 0) THEN
    BEGIN
    ix := ptr^.qhead.link1;
    WHILE ( ix <> 0 ) AND (NOT found) DO
      BEGIN
      WITH ptr^.qinfo[ix].job_head DO
	BEGIN
	IF plot_entry = entry_no THEN
	  BEGIN
	  found := TRUE;
	  jx := ix;
	  IF usruic = uic THEN owner := TRUE
	  		  ELSE owner := FALSE;
	  END;
	ix := link;
	END;
      END;
    END;
  IF found THEN
    IF owner OR system THEN
      BEGIN
      WRITE(' Deleting entry ', plot_entry:4);
      WRITE(' from queue ');
      WRITE( ptr^.qhead.device_name );
      WRITELN; 
      FOR k := 1 TO 4 DO msg[k+32] := plot_number[k];
      END
    ELSE
      BEGIN
      WRITELN(' That''s not your plot, rat-fink.');
      GOTO 99;
      END
  ELSE
    BEGIN
    WRITELN( ' Can''t find entry no. ', plot_entry:4);
    GOTO 99;
    END;
  END;        { CASE plot_delete  }

plot:
  BEGIN
  tstpro := [rd, wrt];
  IF NOT nodelspec THEN tstpro := tstpro + [del];
  pfdlen := LENGTH(pfile);
  FOR k := 1 TO pfdlen DO pfdef[k] := pfile[k];
  xlate1(pfdef, pfdlen, dname, lnam, fstat, pro1);

  IF fstat <> 0 THEN
    BEGIN
    WRITELN(' First File parameter:');
    WRITE(' Couldn''t open ');
    FOR k := 1 TO pfdlen DO WRITE(pfile[k]);
    WRITELN;
    GOTO 99;
    END;
  IF NOT ( tstpro <= pro1[1] ) THEN
    BEGIN
    WRITE(' ');
    FOR k := 1 TO lnam DO WRITE( dname[k] );
    WRITELN(' has too much protection.');
    GOTO 99;
    END;
  k := 0;
  REPEAT
    k := k + 1;
    msg[k+35] := dname[k];
  UNTIL (k>=48) OR (dname[k]=']');
  nd := k;
  IF nd > 33 THEN
    BEGIN
    WRITELN(' Resolved Directory name limited to 33 characters.');
    WRITE(' ', nd:3, ':  ');
    FOR k := 1 TO nd DO WRITE( dname[k] );
    GOTO 99;
    END;
  msg[33] := chr(nd);
  msg[34] := chr(lnam - nd);
  FOR k := nd+1 TO lnam DO
    msg[k+71-nd] := dname[k];
  vfdlen := LENGTH(vfile);
  FOR k := 1 TO vfdlen DO vfdef[k] := vfile[k];
  xlate2(vfdef, vfdlen, dname, lnam, fstat, pro2);
  IF fstat <> 0 THEN
    BEGIN
    WRITELN(' Second file parameter:');
    WRITE(' Couldn''t open ');
    FOR k := 1 TO vfdlen DO WRITE(vfile[k]);
    WRITELN;
    GOTO 99;
    END;    
  IF NOT ( tstpro <= pro2[1] ) THEN
    BEGIN
    WRITE(' ');
    FOR k := 1 TO lnam DO WRITE(dname[k]);
    WRITELN(' has too much protection.');
    GOTO 99;
    END;
  k := 0;
  REPEAT k := k + 1 UNTIL dname[k]=']';
  nd := k;
  FOR k := nd+1 TO lnam DO
    msg[k+89-nd] := dname[k];
  msg[35] := chr(lnam-nd);

  IF nodelspec THEN msg[11] := 'N';
  IF notify    THEN msg[12] := 'N';

  END;         { CASE plot }

tex_plot:

  BEGIN
  tstpro := [rd, wrt];
  IF NOT nodelspec THEN tstpro := tstpro + [del];
  pfdlen := LENGTH(pfile);
  FOR k := 1 TO pfdlen DO pfdef[k] := pfile[k];
  xlate3(pfdef, pfdlen, dname, lnam, fstat, pro1);

  IF fstat <> 0 THEN
    BEGIN
    WRITELN(' First File parameter:');
    WRITE(' Couldn''t open ');
    FOR k := 1 TO pfdlen DO WRITE(pfile[k]);
    WRITELN;
    GOTO 99;
    END;
  IF NOT ( tstpro <= pro1[1] ) THEN
    BEGIN
    WRITE(' ');
    FOR k := 1 TO lnam DO WRITE( dname[k] );
    WRITELN(' has too much protection.');
    GOTO 99;
    END;
  k := 0;
  REPEAT
    k := k + 1;
    msg[k+35] := dname[k];
  UNTIL (k>=48) OR (dname[k]=']');
  nd := k;
  IF nd > 33 THEN
    BEGIN
    WRITELN(' Resolved Directory name limited to 33 characters.');
    WRITE(' ', nd:3, ':  ');
    FOR k := 1 TO nd DO WRITE( dname[k] );
    GOTO 99;
    END;
  msg[33] := chr(nd);
  msg[34] := chr(lnam - nd);
  FOR k := nd+1 TO lnam DO
    msg[k+71-nd] := dname[k];
  vfdlen := LENGTH(vfile);
  FOR k := 1 TO vfdlen DO msg[k+89] := vfile[k];
  msg[35] := chr(vfdlen);

  IF nodelspec THEN msg[11] := 'N';
  IF notify    THEN msg[12] := 'N';

  END;         { CASE plot_tex }

initialize:

  BEGIN
{  IF parm[2].length > 0 THEN
  	FOR k := 1 TO 4 DO msg[k+12] := parm[2].string[k];
  IF parm[3].length > 0 THEN
  	FOR k := 1 TO parm[4].length DO msg[k+16] := parm[4].string[k]; }
  IF noprint THEN msg[30] := ' '
  	     ELSE msg[30] := 'Y';
  END;

END;	{    CASE action   }

LIB$GET_EF(efn);

st4 := $qio(efn, chan1, IO$_WRITEVBLK, iosb1,
  		, 0, msg,   109);

wcnt := 0;
REPEAT
  wait(0.1);
  wcnt := wcnt + 1;
  st8 := $readef(efn, estat);
UNTIL (st8=ss$_wasset) OR (wcnt > 10);
LIB$FREE_EF(efn);
IF st8 <> ss$_wasset THEN
  BEGIN
  WRITELN(' No response from VQ.');
  WRITELN(' ...plot spooling is disabled.');
  GOTO 99;
  END;

st5 := $qiow(0, chan2, IO$_READVBLK,  iosb2,
		, 0, reply, 132);         

IF reply[1] = '*' THEN
  BEGIN
  FOR k := 1 TO 8 DO WRITE(reply[k]);
  WRITELN;
  END
ELSE
  BEGIN
  FOR k := 1 TO 4 DO
    BEGIN
    reptag[k] := reply[k];
    repno [k] := reply[k+4];
    END;
  IF reptag = 'NEW ' THEN WRITELN(' Entered ', repno);
  IF reptag = ' Xd ' THEN WRITELN(' Deleted entry # ', repno);
  IF reptag = ' NG ' THEN WRITELN(' Couldn''t delete entry ', repno);
  IF reptag = 'NOT*' THEN WRITELN(' Queue not stopped.');
  IF reptag = 'NO S' THEN WRITELN(' No such Queue.');
  IF reptag = 'Q EX' THEN WRITELN(' Queue already exists.');
  IF reptag = 'NO R' THEN WRITELN(' No more queues allowed.');
  END;

st6 := $dassgn(chan1);
st7 := $dassgn(chan2);
99:END.