(* SEND:  Sends up to a 250 character message to another process or terminal.
          Message is terminated and sent with a <CNTR>-Z.

          When user name is specified, routine obtains terminal device name if
          one is allocated to the user.  If the user does not have an allocated
          terminal device, or if the user has allocated more than one terminal,
          then the terminal name must be specified.

          A conflict occurs if more than one user outside of the sender's UIC
          group has the same name.  In this case, the terminal name must also
          be specified.
          
          Routine check to make sure that a specified device is defined as a
          terminal via the DC$_TERM constant.

Link command:  $ LINK [USRLIB.SYS]SEND+[USRLIB.SYS]SENDFTNS+-
               $_     [USRLIB.PROCESSES]PROCLIB/LIB+[SYSEXE]SYS.STB/SELECTIVE

Author:  Mark Snitily
Date:    June 16,1980                                                         *)
          
(*$ S- *)
program send;
const
   %include 'dba0:[syslib]dcdef.pas'  (* device class definitions *)
   %include 'dba0:[syslib]iodef.pas'  (* I/O definitions *)
   %include 'dba0:[syslib]jpidef.pas' (* job process information definitions *)
   %include 'dba0:[syslib]ssdef.pas'  (* system status definitions *)

type 
   byte = 0..255;
   word = 0..65535;
   msgvector  = packed array [1..2] of integer;
   strdscr = record (* string descriptor *)
                length:  integer;
                addr:    integer;
             end;
   itembuffer = array[1..2] of
                packed record
                          buflen:  word;
                          itmcode: word;
                          bufaddr: integer;
                          retlad:  integer;
                       end;
   statblk = packed record (* I/O status block *)
                status, length:  word;
                info:  integer
             end;
   device_info_buf = packed record (* device information buffer *)
                               devchar: integer;
                               devclass,devtype: byte;
                               devbufsiz: word;
                               devdepend: integer;
                               unit,devnamoff: word;
                               pid,ownuic: integer;
                               vprot,errcnt: word;
                               opcnt: integer;
                               volnamoff,recsiz: word;
                               names: packed array[0..27] of byte;
                            end;

var
   i, chan, status, pid, hour, time_addr,
   sender_name_len, user_name_len, unique_term_sts: integer;
   bel, bs, lf, cr, blank, del, ch: char;
   terminal_found, proc_name,
   no_error_yet, same_dev_name, already_caps: boolean;
   dscr, sender_dev_dscr, user_dev_dscr, input_dscr, header_dscr,
   user_dscr, terminal_dscr, message_dscr: strdscr;
   sender_dev_buf, user_dev_buf: device_info_buf;
   input_name: packed array[1..10] of char;
   header: packed array[1..46] of char;
   user_name: packed array[1..80] of char;
   terminal: packed array[1..6] of char;
   message: packed array[1..250] of char;
   item_list: itembuffer;
   iosb: statblk;
   sender_name:  packed array[1..15] of char;
   who: packed array[1..8] of char;
   not_terminal: packed array [1..47] of char;
   no_user_term: packed array [1..57] of char;
   too_many_term: packed array [1..65] of char;
   name_conflict: packed array [1..73] of char;
   bad_name: packed array [1..61] of char;
   self_talker: packed array [1..43] of char;
   prompt_write: packed array[1..64] of char;
   confirm_send: packed array[1..18] of char;
   mask: array[1..2] of integer;

value
   blank := ' ';  mask := (0,0);
   header := '   From                                       ';
   who := '$_Who?: ';
   not_terminal := '%SEND-W-DEVNOTTERM, Device is not a terminal.  ';
   no_user_term := '%SEND-W-NOTERMALLOC, No terminal is allocated for user.  ';
   too_many_term:= '%SEND-W-TOOMANYTERM, User has allocated more than one terminal.  ';
   name_conflict:= '%SEND-W-NAMCONFLICT, More than one user outside of group has same name.  ';
   bad_name     := '%SEND-W-BADNAME, Nonexistent/invalid user or terminal name.  ';
   self_talker  := 'Ahhhh... So you like to talk to yourself.  ';
   prompt_write := 'Enter message.   <CTRL>Z sends message.   (250 character max.)  ';
   confirm_send := 'Sending message...';

(******************************************************************************)
(* External system procedures. *)

(* Function that returns the address of a device information buffer. *)
function bufaddr(var b: device_info_buf): integer; extern;

(* This procedure capitalises a string of arbitrary length. *)
procedure caps( var str: packed array[integer] of char); extern;

(* Procedure that obtains the command line. *)
procedure get_commandline(var cmd_dscr: strdscr); extern;

(* Function that returns the address of a character. *)
function charaddr(var ch: char): integer; extern;

(* Function that tries to find a unique process from a specified user name.
   Only invoked if user name is not within group. If more than one name is
   found, then SS$_TOOMUCHDATA is returned. *)
function find_user_name(var user_pid: integer;
                        var user_dscr: strdscr): integer; extern;

(* Function that obtains the device name of a user's terminal.  If user does
   not own a terminal, then SS$_DEVOFFLINE is returned.  If user owns more
   than one terminal, then SS$_DEVICEFULL is returned. *)
function find_user_term(%immed user_pid: integer;
                        var terminal_dscr: strdscr): integer; extern;

(* Function that returns the address of an integer. *)          
function intaddr(var i: integer): integer; extern;

(* Function that returns the address of a packed character string. *)
function stringaddr(var str: packed array[integer] of char): integer; extern;

(*  SYS$ASCTIM:  Converts an absolute system time to an ASCII string. *)
function SYS$ASCTIM(%immed asci_string_len: integer;
                    var asci_string: strdscr;
                    %immed binary_time, convert_flag: integer):
            integer; extern;

(*  SYS$BRDCST:  Broadcast a message to another terminal. *)
function SYS$BRDCST(var msg_dscr: strdscr;
                    var dev_dscr: strdscr):
          integer; extern;

(*  SYS$ASSIGN:  Assign a data channel to a device. *)
function SYS$ASSIGN(var dev_dscr:  strdscr;
                    var chan:  word;
                    %immed acmode, mbxnam:  integer):
         integer; extern;

(*  SYS$EXIT:  Exit program with specified error code. *)
procedure SYS$EXIT(%immed status_code: integer); extern;

(*  SYS$GETDEV:  Get device information. (returns same info as SYS$GETCHN) *)
function SYS$GETDEV(var dev_name_dscr: strdscr;
                    %immed primary_length:  integer;  {not used}
                    var primary_buffer:  strdscr;
                    %immed secondary_len:  integer;   {not used}
                    %immed secondary_buf:  integer):  {not used}
          integer; extern;

(*  SYS$GETJPI:  Get job process information. *)
function SYS$GETJPI(%immed dummy1:  integer;
                    var pid:  integer;
                    %immed prcnam_dscr:  integer;
                    var itmlst:  itembuffer;
                    %immed dummy5, dummy6, dummy7:  integer):
            integer; extern;

(*  SYS$PUTMSG:  Write system status code message to user process. *)
procedure SYS$PUTMSG(var msgvec: msgvector;
                     %immed action_routine:  integer;
                     %stdescr facil: packed array[integer] of char); extern;

(*  SYS$QIOW:  Perform I/O and wait for event flag. *)
function SYS$QIOW(%immed efn, chan, func:  integer;
                  var iosb:  statblk;
                  %immed astadr:  integer;
                  %immed astprm:  integer;
                  %immed buf_addr: integer;
                  %immed p2, p3, p4, p5, p6:  integer):
        integer; extern;

(*  SYS$TRNLOG:  Translate logical name to equivalence name.  *)
function SYS$TRNLOG(%stdescr log_name:  packed array[integer] of char;
                    %immed result_len:  integer;
                    var result_dscr:  strdscr;
                    %immed table, acmode, dsbmsk:  integer):
          integer; extern;

(******************************************************************************)
(* Procedure that writes an error message to current SYS$OUTPUT and aborts. *)
procedure error_abort;
var msgvec: msgvector;
begin (* error_abort *)
   msgvec[1] := 1;              (* One message in message vector. *)
   msgvec[2] := status;         (* Message identification. *)
   SYS$PUTMSG(msgvec,0,'SEND'); (* Write the error message. *)
   SYS$EXIT(SS$_NORMAL);        (* Abort without system error message. *)
end;  (* error_abort *)
(*----------------------------------------------------------------------------*)
(* This procedure reads/writes a character to/from the sender's terminal. *)
procedure char_io(var ch: char; func,p4: integer);
begin (* char_io *)
   status := SYS$QIOW(0,chan,func,iosb,0,0,
                      charaddr(ch),1,0,p4,0,0);
   if not odd(status) then error_abort;
   if not odd(iosb.status)
   then begin
          status := iosb.status;
          error_abort;
        end;
end;  (* char_io *)

(*----------------------------------------------------------------------------*)
(* This procedure reads a line of text from the sender's terminal. Maximum
   buffer size is contained received in LEN.  This routine will not read control
   characters, (only TAB and DEL are allowed). Will beep on all others.
   Message is terminated with a carriage return or end of buffer.  Length of the
   message is returned in the parameter LEN. *)
procedure read_line(var msg: packed array[integer] of char;
                    var len: integer);
var
   max_length: integer;
begin (* read_line *)

   max_length := len;
   len := 0;
   char_io(ch,IO$_READVBLK+IO$M_NOECHO+IO$M_NOFILTR,intaddr(mask[1]));
   while (ch <> cr) and (len < max_length) do
   begin (* read the line *)
      if ((ch >= ' ') and (ch <= '~')) or (ch = chr(9))
      then begin (* valid character *)
              len := len + 1;
              msg[len] := ch;
              char_io(ch,IO$_WRITEVBLK,0);
           end   (* valid character *)
      else if ch <> del
           then char_io(bel,IO$_WRITEVBLK,0)
           else if len > 0
                then begin (* delete last char *)
                        char_io(bs,IO$_WRITEVBLK,0);
                        char_io(blank,IO$_WRITEVBLK,0);
                        char_io(bs,IO$_WRITEVBLK,0);
                        msg[len] := blank;
                        len := len - 1;
                     end   (* delete last char *)
                else char_io(bel,IO$_WRITEVBLK,0);
      char_io(ch,IO$_READVBLK+IO$M_NOECHO+IO$M_NOFILTR,intaddr(mask[1]));
   end;  (* read the line *)
   char_io(cr,IO$_WRITEVBLK,0);
   char_io(lf,IO$_WRITEVBLK,0);

end;  (* read_line *)

(*----------------------------------------------------------------------------*)
(* This procedure reads a message from the sender's terminal. Maximum buffer
   size is contained received in LEN.  This routine will not read control
   characters, (only TAB, CR and DEL are allowed). Will beep on all others.
   Message is terminated with a <control>-Z or end of buffer.  Length of the
   message is returned in the parameter LEN. *)
procedure read_msg(var msg: packed array[integer] of char;
                   var len: integer);
var
   max_length: integer;
begin (* read_msg *)

   max_length := len;
   len := 0;
   char_io(ch,IO$_READVBLK+IO$M_NOECHO+IO$M_NOFILTR,intaddr(mask[1]));
   while (ch <> chr(%x1A)) and (len < max_length) do
   begin (* read the message *)
      if ((ch >= ' ') and (ch <= '~')) or (ch = chr(9))
      then begin (* valid character *)
              len := len + 1;
              msg[len] := ch;
              char_io(ch,IO$_WRITEVBLK,0);
           end   (* valid character *)
      else if (ch <> del) and (ch <> cr)
           then char_io(bel,IO$_WRITEVBLK,0)
           else if (len > 0) and (ch = del)
                then begin (* delete last char if possible *)
                        if msg[len] = lf
                        then char_io(bel,IO$_WRITEVBLK,0)
                        else begin (* delete last char in current line *)
                                char_io(bs,IO$_WRITEVBLK,0);
                                char_io(blank,IO$_WRITEVBLK,0);
                                char_io(bs,IO$_WRITEVBLK,0);
                                msg[len] := blank;
                                len := len - 1;
                             end;  (* delete last char in current line *)
                     end   (* delete last char if possible *)
                else if ch = cr
                     then begin (* insert carriage return/line feed *)
                             char_io(cr,IO$_WRITEVBLK,0);
                             char_io(lf,IO$_WRITEVBLK,0);
                             len := len + 1;
                             msg[len] := cr;
                             if len < max_length
                             then begin (* insert line feed *)
                                     len := len + 1;
                                     msg[len] := lf;
                                  end;  (* insert line feed *)
                          end   (* insert carriage return/line feed *)
                     else char_io(bel,IO$_WRITEVBLK,0);

      (* Read next character. *)
      char_io(ch,IO$_READVBLK+IO$M_NOECHO+IO$M_NOFILTR,intaddr(mask[1]));

   end;  (* read the message *)

   char_io(cr,IO$_WRITEVBLK,0);
   char_io(lf,IO$_WRITEVBLK,0);

end;  (* read_msg *)

(*----------------------------------------------------------------------------*)
(* This procedure writes a message to the sender's terminal. *)
procedure write_msg(var msg: packed array[integer] of char);
begin (* write_msg *)
   status := SYS$QIOW(0,chan,IO$_WRITEVBLK,iosb,0,0,
                      stringaddr(msg),upper(msg)-lower(msg)+1,0,0,0,0);
   if not odd(status) then error_abort;
   if not odd(iosb.status)
   then begin
          status := iosb.status;
          error_abort;
        end;
end;  (* write_msg *)

(*----------------------------------------------------------------------------*)
(* This procedure attempts to find a unique user from its process name.  The
   problem with process names is that they are qualified by the user's group
   number.  So this routine first attempts to obtain the user within the group
   via SYS$GETJPI. Then if that fails, a MACRO routine FIND_USER_NAME searches
   all PCB's in order to find a matching name. If only one name is found, then
   it is a success, but if more than one name is found, it's ambiguous. *)
procedure find_user_pid;
begin (* find_user_pid *)
   status := SYS$GETJPI(0,pid,intaddr(user_dscr.length),
                        item_list,0,0,0);
   if odd(status) 
   then proc_name := true
   else if status <> SS$_NONEXPR 
        then error_abort
        else begin (* try to find name outside of group *)
                status := find_user_name(pid,user_dscr);
                if odd(status)
                then proc_name := true
                else if (status <> SS$_NONEXPR) and (status <> SS$_TOOMUCHDATA)
                     then error_abort
                     else if status = SS$_TOOMUCHDATA
                          then begin (* name conflict outside of group *)
                                  write_msg(name_conflict);
                                  no_error_yet := false;
                               end;  (* name conflict outside of group *)
             end;  (* try to find name outside of group *)
end;  (* find_user_pid *)
(*----------------------------------------------------------------------------*)
begin (* send *)
   bel := chr(7);  bs := chr(8);   del := chr(%x7F);
   cr  := chr(13); lf := chr(10);

   (* Get current process's process name. *)
   with item_list[1] do
      begin (* set up buffer to receive process's status. *)
         buflen :=  15;
         itmcode := JPI$_PRCNAM;
         bufaddr := stringaddr(sender_name);
         retlad := intaddr(sender_name_len);
      end;  (* set up buffer to receive process's status. *)
   item_list[2].itmcode := 0;
   pid := 0;
   status := SYS$GETJPI(0,pid,0,item_list,0,0,0);
   if not odd(status) then error_abort;

   (* Obtain the name of the terminal used for current I/O. *)
   input_dscr.length := 10;
   input_dscr.addr := stringaddr(input_name);
   status := SYS$TRNLOG('SYS$INPUT',0,input_dscr,0,0,0);
   if not odd(status) then error_abort;

   (* Get info about terminal for test to see if sender owns it. *)
   if input_name[1] = chr(%x1B)
   then begin (* Remove system header. *)
           input_dscr.length := 6;
           for i:=1 to 6 do input_name[i] := input_name[i+4];
        end;  (* Remove system header. *)
   user_dev_dscr.length := 64;
   user_dev_dscr.addr := bufaddr(user_dev_buf);
   sender_dev_dscr.length := 64;
   sender_dev_dscr.addr := bufaddr(sender_dev_buf);
   status := SYS$GETDEV(input_dscr,0,sender_dev_dscr,0,0);
   if not odd(status) then error_abort;

   (* If sender owns only the one terminal, then just use the sender's name,
      but if sender doesn't own the terminal, or if the sender owns more than
      one terminal, then leave the terminal name and add the sender's name
      in parens. *)
   terminal_dscr.length := 6;
   terminal_dscr.addr := stringaddr(terminal);
   unique_term_sts := find_user_term(pid,terminal_dscr);
   header[1] := cr;  (* carriage return *)
   header[2] := lf;  (* line feed *)
   header[3] := bel; (* beep *)
   if (sender_dev_buf.pid = pid) and (unique_term_sts <> SS$_DEVICEFULL)
   then begin (* sender owns only one terminal *)
           for i := 1 to sender_name_len do
              header[i+8] := sender_name[i];
           time_addr := 12 + sender_name_len;
        end   (* sender owns only one terminal *)
   else begin (* sender does not own the terminal, or owns more than one *)
           for i := 2 to 6 do
              header[i+7] := input_name[i];
           header[15] := '(';
           for i := 1 to sender_name_len do
              header[i+15] := sender_name[i];
           header[sender_name_len+16] := ')';
           time_addr := 20 + sender_name_len;
        end;  (* sender does not own the terminal, or owns more than one *)

   (* Get the current ASCII time. *)
   dscr.length := 11;
   dscr.addr := stringaddr(header) + time_addr;
   status := SYS$ASCTIM(0,dscr,0,1);
   if not odd(status) then error_abort;

   (* Convert ASCII time string to AM/PM annotation string. *)
   header[time_addr+9] := ' ';
   header[time_addr+11] := 'M';
   hour := (ord(header[time_addr+1])-%x30)*10 +
            ord(header[time_addr+2])-%x30;
   if hour > 11 then begin (* PM *)
                        hour := hour - 12;
                        header[time_addr+10] := 'P';
                     end   (* PM *)
                else header[time_addr+10] := 'A';
   if hour = 0 then hour := 12;
   header[time_addr+2] := chr(hour - hour div 10 * 10 + %x30);
   if hour > 9 then header[time_addr+1] := '1'
               else header[time_addr+1] := ' ';

   (* Initialize carriage return & line feeds *)
   no_user_term[56]  := cr;     no_user_term[57]  := lf;
   too_many_term[64] := cr;     too_many_term[65] := lf;
   name_conflict[72] := cr;     name_conflict[73] := lf;
   not_terminal[46]  := cr;     not_terminal[47]  := lf;
   bad_name[60]      := cr;     bad_name[61]      := lf;
   self_talker[42]   := cr;     self_talker[43]   := lf;
   prompt_write[63]  := cr;     prompt_write[64]  := lf;

   (* Assign I/O channel to the sender's terminal. *)
   status := SYS$ASSIGN(input_dscr,chan,0,0);
   if not odd(status) then error_abort;

   (*#### NOTE:  The word "user" refers to the receiver of the message. ####*)
   (* Obtain the command line. Assume command line is the user name. *)
   user_dscr.addr := stringaddr(user_name);
   get_commandline(user_dscr);
   if user_dscr.length <> 0
      then already_caps := true
      else already_caps := false;

   (* Verify user name or terminal and convert to a terminal descriptor. *)
   terminal_found := false;
   while not terminal_found do
   begin (* find the terminal *)

      (* Prompt for a user name or terminal. *)
      if user_dscr.length = 0
      then begin (* prompt for user or terminal *)
              write_msg(who);
              user_dscr.length := 80;
              read_line(user_name,user_dscr.length);
           end;  (* prompt for user or terminal *)

      (* Test if name is a current user. *)
      proc_name := false;
      no_error_yet := true;
      if user_dscr.length <> 0
      then begin (* test the name *)
              pid := 0;
              item_list[1].itmcode := 0;
              find_user_pid;

              (* If no success, then try again with caps. *)
              if (not proc_name) and (not already_caps)
              then begin (* convert to caps & try again *)
                      caps(user_name);
                      find_user_pid;
                   end;  (* convert to caps & try again *)

              (* If user name is valid, then see if user has a terminal,
                 otherwise see if the user name is a terminal. *)
              if proc_name
              then begin (* find user's terminal *)
                      terminal_dscr.length := 6;
                      status := find_user_term(pid,terminal_dscr);
                      if (not odd(status)) and (status <> SS$_DEVICEFULL) and
                         (status <> SS$_DEVOFFLINE)
                      then error_abort
                      else if status = SS$_DEVICEFULL
                           then begin (* user has more than one terminal *)
                                   write_msg(too_many_term);
                                   no_error_yet := false;
                                end   (* user has more than one terminal *)
                           else if status = SS$_DEVOFFLINE
                                then begin (* user does not own a terminal *)
                                        write_msg(no_user_term);
                                        no_error_yet := false;
                                     end   (* user does not own a terminal *)
                                else begin (* found user's terminal *)
                                        terminal_found := true;
                                        status := SYS$GETDEV(terminal_dscr,0,user_dev_dscr,0,0);
                                        if not odd(status) then error_abort
                                     end;  (* found user's terminal *)
                   end   (* find user's terminal *)

              else begin (* test if name is a valid terminal *)
                      status := SYS$GETDEV(user_dscr,0,user_dev_dscr,0,0);
                      if (not odd(status)) and (status <> SS$_NOSUCHDEV) and
                         (status <> SS$_IVDEVNAM)
                      then error_abort
                      else if status <> SS$_IVDEVNAM
                           then if status <> SS$_NOSUCHDEV
                                then if user_dev_buf.devclass <> DC$_TERM
                                     then begin (* device not terminal *)
                                             write_msg(not_terminal);
                                             no_error_yet := false;
                                          end   (* device not terminal *)
                                     else begin (* valid terminal *)
                                             terminal_found := true;
                                             terminal_dscr.length := user_dscr.length;
                                             terminal_dscr.addr := user_dscr.addr;
                                          end;  (* valid terminal *)
                   end;  (* test if name is a valid terminal *)

              (* Give warning message if user not found. *)
              if (not terminal_found) and no_error_yet
                 then write_msg(bad_name);

              (* Reset user decriptor's length so that $_Who? is printed. *)
              if not terminal_found
                 then user_dscr.length := 0;

           end;  (* test the name *)

      (* Input read from terminal is not in caps so clear the flag. *)
      already_caps := false;

   end;  (* find the terminal *)

   (* Give warning message if sender is talking to self. *)
   if user_dev_buf.unit = sender_dev_buf.unit
   then if user_dev_buf.names[user_dev_buf.devnamoff-%x24] =   (* Same device *)
           sender_dev_buf.names[sender_dev_buf.devnamoff-%x24] (* name length?*)
        then begin (* test device names *)
                same_dev_name := true;
                for i := 1 to user_dev_buf.names[user_dev_buf.devnamoff-%x24] do
                   if user_dev_buf.names[i] <> sender_dev_buf.names[i]
                   then same_dev_name := false;
                if same_dev_name then write_msg(self_talker);
             end;  (* test device names *)

   (* Now read the desired message. *)
   write_msg(prompt_write);
   message_dscr.length := 250;
   message_dscr.addr := stringaddr(message);
   read_msg(message,message_dscr.length);

   (* Send the message to the other user. *)
   header_dscr.length := time_addr+11;
   header_dscr.addr := stringaddr(header);
   write_msg(confirm_send);
   status := SYS$BRDCST(header_dscr,terminal_dscr);
   if not odd(status) then error_abort;
   status := SYS$BRDCST(message_dscr,terminal_dscr);
   if not odd(status) then error_abort;

end.  (* send *)
