RPM Program 1

$standard_level 'HP3000', uslinit$
program creator (input,output);
const
   maxdata = 2000;
   maxname = 20;
type
   smallint       = -32768..32767;
   datatype       = packed array [1..maxdata] of char;
   nametype       = packed array [1..maxname] of char;
   byte           = 0..255;
var
   calldesc        : integer;
   result          : integer;
   progname        : packed array [1..15] of char;
   location        : packed array [1..16] of char;
   login           : packed array [1..25] of char;
   flags           : packed array [0..31] of boolean;   {32 contiguous bits}
   pd              : packed array [0..15] of byte;
   destdescriptor  : integer;
   vcdesc          : integer;
   dlen            : integer;
   i               : integer;
   data            : datatype;
   len             : smallint;
   datastr         : string[maxdata];
   socketname      : nametype;
   nodename        : nametype;
   opt             : packed array [1..50] of byte; {INITOPT and ADDOPT
                                       will structure the array for us}procedure terminate; intrinsic;{RPM and IPC intrinsic declarations}procedure ipccreate; intrinsic;procedure ipcname; intrinsic;procedure initopt; intrinsic;procedure addopt; intrinsic;procedure rpmcreate; intrinsic;procedure ipcrecvcn; intrinsic;procedure ipcerrmsg; intrinsic;procedure ipcrecv; intrinsic;procedure ipcshutdown; intrinsic;procedure ipcsend; intrinsic;procedure leave(result: integer);
     var msg: string[80];
          i, len, newresult: integer;begin
ipcerrmsg (result, msg, len, newresult);
if newresult = 0 then
     begin
     setstrlen(msg, len);
     writeln(msg);           {print error message}
     endelse
     writeln('IpcErrMsg result is ', newresult:1);
terminate;
end;
procedure check ( result : integer);
{error procedure}
begin
if result << >> 0 then
     leave (result);       {failed}
end;{error handling procedure}
{The following procedure receives one message that was sent via an ipcsend call. It assumes that the length (number of bytes) of the   message was sent as the first 2 bytes of data and that the length value does not include those 2 bytes.}procedure receive (     connection : integer;
                     var       rbfr : datatype;
                     var       rlen : smallint;
                     var  errorcode : integer    ) ;const
     head_len = 2;type    length_buffer_type = packed array[1..2] of char; header_len_type = record case integer of
                           0: ( word: smallint );
                            1: ( byte: length_buffer_type);
                    end;
var i, j          : integer;
    dlen          : integer;
    header_len    : header_len_type;
    tempbfr       : datatype;@COMPUTERTXT = begin   { procedure receive }i:=0;
errorcode := 0;
while (i < head_len) and (errorcode = 0) do     { get length of message }     begin
     dlen := head_len - i;
     ipcrecv ( connection, tempbfr, dlen, ,, errorcode );
     if errorcode = 0
        then strmove(dlen, tempbfr, 1, header_len.byte, i+1);
     i := i + dlen;
     end;if errorcode = 0 then
     begin
     rlen := header_len.word;
     i := 0;
     while (i < rlen) and (errorcode = 0) do     { get the message }
        begin
        dlen := header_len.word - i;
        ipcrecv
( connection, tempbfr, dlen, , , errorcode );
        if errorcode = 0
          then strmove(dlen, tempbfr, 1, rbfr, i+1);
        i := i + dlen;
        end;     endelse
     rlen := 0;
end;    { procedure receive }
begin  {creator}
{create call socket, then name it}
ipccreate ( 3, 4, , , calldesc,  result);    {call socket, TCP protocol}
check (result);      {error procedure}socketname := 'MYSOCKET';
ipcname (calldesc,  socketname, 8, result);
check (result);
{place rpmstring with socket information in opt parameter}
prompt('What is the name of your local node? ');
readln(datastr);
len := strlen(datastr);
strmove(len,datastr,1,nodename,1);
fginitopt(opt, 2);      {2 option entries}
addopt(opt,0,20000,8,socketname); {option entry 0, rpmstring option code}
addopt(opt,1,20000,len,nodename); {option entry 1, rpmstring option code}
{create remote process and remote session;
the program file CREATURE must exist in the logon group for VPRES.ACCNTG on the remote node}
progname := 'CREATURE';
location := 'REMNODE';
login := 'VPRES.ACCNTG,PUB';
for i := 0 to 30 do flags [i] := false;   {false=0, true=1
                                            for each bit in array}
flags [31] := true;     {set dependent flag}
rpmcreate (progname,8,location,7,login,14, , ,flags,opt,pd,result);
if result < > 0 then
     begin
     writeln('RPM ERROR # is ',result);
     terminate;
    end;{wait for connection request from remote process}
ipcrecvcn (calldesc,  vcdesc, , , result);check (result);
ipcshutdown (calldesc);
{receive messages on connection and print them;
repeat until 'END' message received}
repeat
     begin
     receive (vcdesc, data, len, result);
     check (result);
     setstrlen(datastr, len);
     strmove(len, data, 1, datastr, 1);
    if datastr < > 'END' then writeln (datastr); {print data received}
     enduntil datastr= 'END';
writeln('END received');data := 'Y';                             {shutdown procedure}
ipcsend ( vcdesc, data, 1, , , result );
check (result);
receive ( vcdesc, data, len, result );
if result = 64 then ipcshutdown( vcdesc )
               else check ( result );
end.  {creator}