(* SEND: Sends up to a 250 character message to another process or terminal. Message is terminated and sent with a -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. 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 -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 *)