Trailing-Edge
-
PDP-10 Archives
-
BB-KL11J-BM_1990
-
t20src/mxlcl.b36
There are 19 other files named mxlcl.b36 in the archive. Click here to see a list.
MODULE mxlcl =
BEGIN
! COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1985, 1989.
! ALL RIGHTS RESERVED.
!
! THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
! ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
! INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
! COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
! OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
! TRANSFERRED.
!
! THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
! AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
! CORPORATION.
!
! DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
! SOFTWARE ON EQUIPMENT THAT IS NOT SUPPLIED BY DIGITAL.
!++
! FACILITY: Decmail/MS Message eXchange (MX) Local Mail Subtasks
!
! ABSTRACT: This module contains the data structures and routines used by
! the Local Mail Sub-System.
!
! ENVIRONMENT: Tops-10/Tops-20 User Mode
!
! AUTHOR: Tim Grady, CREATION DATE: 18 February 1985
!
! MODIFIED BY: Richard B. Waddington
!
! MX: VERSION 1.0
! 01 -
!--
!
! INCLUDE FILES:
!
%IF %SWITCHES(TOPS20) %THEN
LIBRARY 'monsym';
UNDECLARE time;
LIBRARY 'mxjlnk';
%FI
LIBRARY 'mxnlib' ; ! Our version of NML's utility library
LIBRARY 'mxlib'; ! Local mail service symbols
REQUIRE 'blt';
!
! EXTERNAL REFERENCES:
!
EXTERNAL ROUTINE
mx$file_routines,
mx$error_routines,
mx$database_routines,
mx$message_queue_post,
mx$message_queue_checkpoint,
mx$release_message,
mx$release_asciz,
nmu$ipcf_manager,
nmu$page_allocator,
nmu$text_manager,
nmu$sched_manager,
nmu$queue_manager,
nmu$memory_manager,
nmu$table_routines,
%IF %SWITCHES(TOPS20) %THEN
mx$update_pobox_status: NOVALUE,
%FI
log;
%IF %SWITCHES(TOPS20) %THEN
declare_jsys(odtim);
%FI
EXTERNAL
pobsts: VOLATILE,
nodnam,
nettab: VECTOR[max_number_of_domains],
active_message_table,
uc_tab,
work_queue: SQ_HEADER,
rtrylc; !Retry time in minutes
!
! TABLE OF CONTENTS
!
FORWARD ROUTINE
scan_pkt,
new_msg,
old_msg,
get_file: NOVALUE,
get_dest: NOVALUE,
get_sender: NOVALUE,
get_subj: NOVALUE,
copy_asciz,
copy_string,
find_work_req,
parse_rcpt,
pname,
pnode,
local_deliver: NOVALUE,
append_mail,
kleanup: NOVALUE,
get_header,
get_name,
get_quota: NOVALUE,
nag: NOVALUE,
logged_in,
mx$get_username,
mx$validate_local_user,
mx$build_repair_spec;
!
! OWN STORAGE
!
OWN
flag,
error_list: VOLATILE REF list_blk;
!
! EQUATED SYMBOLS
!
LITERAL
user_name_only = 0,
name_and_quota = 1,
actjob = %O'56000014'; !For TOPS-20 getab
%global_routine ('LCLSRV') :NOVALUE = !
!++
! FUNCTIONAL DESCRIPTION:
! This task listens for connections from User Interface programs and
! sets up WORK-REQUESTS and ACTIVE-MESSAGE-TABLE entries for MX. The
! WORK-REQUESTS get queued to the WORK-QUEUE.
!
! FORMAL PARAMETERS:
!
! NONE
!
! IMPLICIT INPUTS:
!
! NONE
!
! IMPLICIT OUTPUTS:
!
! NONE
!
! ROUTINE VALUE:
!
! NONE
!
! SIDE EFFECTS:
!
! NONE
!
!--
BEGIN !BEGIN LCLSRV
LITERAL
page_size = 512;
MACRO
pidname =
%IF %SWITCHES(TOPS10) %THEN
ch$asciz('MAILER')
%ELSE !TOPS-20
%IF %VARIANT EQL 0 %THEN
ch$asciz('MXMAIL')
%ELSE
ch$asciz('MXTEST')
%FI %FI %,
![308] ADD MACRO REBIND_PID_NAME
rebind_pid_name(id,nam)[] =
BEGIN
nmu$sched_sleep(30);
%IF %SWITCHES(TOPS20) %THEN
BEGIN
declare_jsys(msend);
STACKLOCAL
nfoblk: VECTOR[$ipcfp + 1],
nforeq: VECTOR[$ipci2 + 2];
nfoblk[$ipcfl] = 0; !NO FLAGS
nfoblk[$ipcfs] = nmu$ipcf_map_id(id); !MY PID
nfoblk[$ipcfr] = 0; !SEND TO INFO
nfoblk[$ipcfp] = (($ipci2 + 2) ^ 18) + nforeq; !LEN,,ADDRESS
nforeq[$ipci0] = $ipcii; !GIVE IT A NAME
nforeq[$ipci1] = 0; !NO DUPS
CH$MOVE(7,nam,CH$PTR(nforeq[$ipci2])); !COPY THE NAME
$$msend($ipcfp+1, nfoblk);
END
%FI
![310] MOVE FOLLOWING END OUT OF TOPS-20 CONDITIONAL
END % ;
LOCAL
ipcf_packet: REF ipcf_msg, !address of the ipcf message
msg: REF message_table_entry, !message block
message_id, !MX Message Id
Sender_caps, !Sender's capabilities
Sender_pid, !IPCF PID of sender
Sender_Uid, !Sender's User ID
Server_Pid, !IPCF Process id
work_request;
BIND
slpptr = CH$PTR(UPLIT(%ASCIZ' - Sleeping 10 seconds')),
name = pidname;
!
! Create the local mailer PID
!
INCR i FROM 1 TO 30 DO ![308] CHANGE FROM 10 TO 30
BEGIN
IF (server_pid = NMU$IPCF_CREATE(name, $false)) NEQ 0
THEN
EXITLOOP;
%(318)% $error(SEVERITY = STS$K_WARNING,
%(318)% FACILITY = $err,
CODE = LS$CCP,
MESSAGE_DATA = slpptr);
nmu$sched_sleep(10)
END;
IF .server_pid EQL 0
THEN
%(318)% $error(SEVERITY = STS$K_SEVERE, !Crash MX - NO PID...
%(318)% FACILITY = $err,
CODE = LS$CCP);
WHILE 1 DO
BEGIN !BEGIN main loop
ipcf_packet = NMU$IPCF_RECEIVE(
.Server_Pid, Sender_Pid, Sender_Uid, Sender_caps);
![308] ADD TEST FOR PACKETS FROM INFO
IF .sender_pid EQL 0 ![308]
THEN ![308]
REBIND_PID_NAME(.server_pid,name) ![308]
ELSE ![308]
BEGIN ![308]
$TRACE('LCLSRV running');
msg = scan_pkt(.ipcf_packet, .sender_pid, .sender_uid, .sender_caps);
nmu$ipcf_transmit(.server_pid, .sender_pid, .ipcf_packet, 512);
END ![308]
END; !END of main loop
END; ! END LCLSRV
GLOBAL ROUTINE scan_pkt (packet, pid, uid, cap) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine scans an incoming IPCF packet, and validates the
! format and content of that packet. There are two types of packets:
! primary packets initiate the posting of a message to MX; secondary
! packets are used when there is more information needed to complete
! the posting of a message. Primary packets must contain the file
! name of the message to be posted. Primary packets indicate whether
! there will be secondary packets for this message by the cell hdr_state
! which contains $msg_incomplete if there are more packets to come.
! The last packet in a sequence contains the value $msg_complete in this
! cell.
!
! Packets are sequenced, and must arrive in sequence. If a packet is
! found to be out of sequence, the message is invalidated, and an error
! returned to the user agent (usually MS).
!
! FORMAL PARAMETERS:
!
! packet - IPCF packet
! pid - sender's IPCF PID
! uid - sender's user number (TOPS20) or PPN (TOPS10)
! cap - sender's enabled capabilities (from IPCF header)
!
! IMPLICIT INPUTS:
!
! NONE
!
! IMPLICIT OUTPUTS:
!
! NONE
!
! ROUTINE VALUE:
!
! The address of the Active Message Table Entry
!
! SIDE EFFECTS:
!
! NONE
!--
BEGIN !BEGIN scan_pkt
MAP
packet: REF ipcf_msg; !reference the IPCF packet
BIND
hdr = packet[ipcf_header]: ipcf_hdr; !and the header data
LOCAL
rootine,
pck: VOLATILE,
msg: REF message_table_entry VOLATILE,
rec: REF ipcf_rec VOLATILE, !IPCF record
sts;
ENABLE
mx$error_handler (pck,msg,rec);
$TRACE('SCAN%P called');
pck = .packet;
!
! If this is a new message, get the file spec and build a message table
! entry, otherwise lookup the old message table entry and continue.
!
CASE .hdr[hdr_type]
FROM min_hdr_type TO max_hdr_type OF
SET
[lcl_post]: msg = new_msg(.packet, .pid, .uid, .cap);
[lcl_cont]: msg = old_msg(.packet, .pid, .uid, .cap);
[OUTRANGE]: $signal_error(
%(318)% SEVERITY=STS$K_ERROR,
%(318)% FACILITY=$err,
CODE=ls$iht);
TES;
!
! We now have the message block, so scan the ipcf packet, and add the
! contents to the message block
!
rec = hdr[hdr_record]; !get first record
INCR i FROM 1 TO .hdr[hdr_record_count] DO
BEGIN !BEGIN packet scan
rootine =
(CASE .rec[rec_type]
FROM min_rec_type TO max_rec_type OF
SET
[rec_dest]: get_dest;
[rec_sender]: get_sender;
[rec_file]: get_file;
[rec_subj]: get_subj;
[OUTRANGE]: BEGIN
$signal_error(
%(318)% SEVERITY=STS$K_SEVERE,
%(318)% FACILITY=$err,
CODE=ls$irt);
EXITLOOP;
END;
TES);
(.rootine) (CH$PTR(rec[rec_data]), (.rec[rec_length] - 3) * 5, .msg);
rec = .rec + .rec[rec_length];
END; !END packet scan
IF .msg NEQ 0
THEN
BEGIN
sts = .msg[msg_state];
CASE .sts FROM 1 TO 4 OF
SET
[$msg_complete]: mx$message_queue_post(.msg);
[$msg_incomplete]: ; !Do nothing
[$msg_warning]: IF .hdr[hdr_status] EQL $msg_complete
THEN
mx$message_queue_post(.msg);
[$msg_canceled]: mx$release_message(.msg);
TES;
hdr[hdr_status] = .sts;
END
ELSE
hdr[hdr_status] = $msg_canceled;
RETURN .msg;
END; ! END scan_pkt
ROUTINE new_msg (packet, pid, uid, caps) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine is called whenever an IPCF packet arrives with hdr_type
! set to lcl_post. The packet is scanned for the message file spec,
! and a new message table entry is created for this message. The
! sender field is set to the sending UID's user name (which may be
! overridden later, if the sender is privileged) and the address of
! the message table entry is returned.
!
! FORMAL PARAMETERS:
!
! packet - IPCF packet address
! pid - sender's IPCF pid
! uid - sender's user number (TOPS20) or PPN (TOPS10)
! cap - sender's enabled capabilities, from IPCF header
!
! IMPLICIT INPUTS:
!
! NONE
!
! IMPLICIT OUTPUTS:
!
! NONE
!
! ROUTINE VALIE
!
! The address of the Message data block (an Active Table Entry)
!
! SIDE EFFECTS:
!
! NONE
!--
BEGIN !BEGIN new_msg
![307] ADD VUFLG DEFINITION. REMOVE MSG_ID (IT WASN'T BEING USED...)
LOCAL
pck: VOLATILE,
msg: REF message_table_entry VOLATILE, !address of msg block
vuflg; ![307] FLAG FOR INVALID SENDERS
MAP
packet: REF ipcf_msg; !reference the IPCF packet
BIND
hdr = packet[ipcf_header]: ipcf_hdr; !and the header data
ENABLE
mx$error_handler(pck, msg);
pck = .packet;
msg = mx$get_message_table_entry;
IF .msg EQL 0
THEN
$signal_error( !It failed...
%(318)% SEVERITY=STS$K_WARNING,
%(318)% FACILITY=$err,
CODE=mx$nom);
!Now, initialize the message block
msg[msg_fil_spec] = 0;
![307] CALL MX$GET_USERNAME SO THAT IT TELLS IF SENDER IS AN INVALID USER
msg[msg_sender_string] = mx$get_username(.uid,vuflg); ![307]
msg[msg_work_req_list] = 0;
msg[msg_work_req_count] = 0;
msg[msg_sender_domain] = .hdr[hdr_domain_id];
msg[msg_state] = .hdr[hdr_status];
msg[msg_sender_pid] = .pid;
msg[msg_sender_uid] = .uid;
msg[msg_sender_caps] = .caps;
hdr[hdr_id] = .msg[msg_msg_id];
$TRACE_ALWAYS(.msg[msg_unique_id], %(318)%
'Message submitted by %A',CH$PTR(.msg[msg_sender_string]));
![307] IF VUFLG IS SET, CANCEL THIS MESSAGE
IF NOT .vuflg
THEN
BEGIN
msg[msg_state] = $msg_canceled;
$TRACE_ALWAYS( .msg[msg_unique_id], %(318)%
'...%A is not a valid user - Message rejected',
CH$PTR(.msg[msg_sender_string]))
END;
RETURN (.msg); !return the message table entry
END; !END new_msg
ROUTINE old_msg (packet, pid, uid, caps) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine is called whenever an IPCF packet is recieved with header
! type lcl_cont. It fetches the message block from the held message table
! and performs some consistancy checks. In particular, the PID and UID must
! match in the held data and the new packet.
!
! FORMAL PARAMETERS:
!
! msg_id: The index into the HELD_DATA_TABLE
! pid: The pid of the requesting process
! uid: The user id of the requestor
!
! IMPLICIT INPUTS:
!
! NONE
!
! IMPLICIT OUTPUTS:
!
! NONE
!
! RETURN VALUE:
!
! The address of the message data block
!
! SIDE EFFECTS:
!
! NONE
!--
BEGIN
MAP
packet: REF ipcf_msg; !reference the IPCF packet
BIND
hdr = packet[ipcf_header]: ipcf_hdr; !and the header data
LOCAL
msg_id,
pck: VOLATILE,
msg: REF message_table_entry VOLATILE;
ENABLE
mx$error_handler(pck, msg);
$TRACE('A continuation block...');
pck = .packet;
NMU$TABLE_FETCH(active_message_table, .hdr[hdr_id], msg);
IF .msg EQL 0
THEN !Invalid continuation packet
$signal_error(
%(318)% SEVERITY=STS$K_ERROR,
%(318)% FACILITY=$err,
CODE=ls$icp);
IF .msg [msg_sender_pid] NEQ .pid
THEN !Invalid Sender Pid
$signal_error(
%(318)% SEVERITY=STS$K_ERROR,
%(318)% FACILITY=$err,
CODE=ls$isp);
IF .msg [msg_sender_uid] NEQ .uid
THEN !Invalid Sender User id
$signal_error(
%(318)% SEVERITY=STS$K_ERROR,
%(318)% FACILITY=$err,
CODE=ls$isu);
msg[msg_state] = .hdr[hdr_status];
RETURN (.msg); ! return message block
END;
ROUTINE get_file (ptr, len, msg): NOVALUE =
BEGIN
MAP
msg: REF message_table_entry;
LOCAL
p1;
IF .msg[msg_fil_spec] NEQ 0
THEN !Duplicate Message File
$signal_error(
%(318)% SEVERITY=STS$K_ERROR,
%(318)% FACILITY=$err,
CODE=ls$dmf,
MESSAGE_DATA=(CH$PTR(.msg[msg_fil_spec]), .ptr));
IF NOT mx$file_exists(.ptr)
THEN !No message file
BEGIN
$signal_error(
%(318)% SEVERITY=STS$K_ERROR,
%(318)% FACILITY=$err,
CODE=ls$nmf,
MESSAGE_DATA=.ptr);
msg[msg_fil_spec] = 0;
END
ELSE
BEGIN
%if %switches(TOPS20)
%then
!
!TOPS-20 likes to include ;P770000 at the end of the message file spec.
!This is ugly, so we search for the ";", and write a null in its place
!
p1 = CH$FIND_CH(.len*5,.ptr,%C';');
IF NOT CH$FAIL(.p1)
THEN
CH$WCHAR(0,.p1);
%fi
msg[msg_fil_spec] = copy_asciz(.ptr);
END;
$TRACE('The message file is %A', CH$PTR(.msg[msg_fil_spec]));
END;
GLOBAL ROUTINE get_dest (ptr, len, msg): NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine adds the destination string pointed to by ptr to the
! proper work request for the message specified by msg. The destination
! node is validated, and the destination string is added to the list
! of destination strings for the work request for that node. If no
! work request exists for the node, a new work request is created.
!
! FORMAL PARAMETERS:
!
! msg - message table entry block
! ptr - pointer to ASCIZ destination string
! len - length of the source string
!
! IMPLICIT INPUTS:
!
! NONE
!
! IMPLICIT OUTPUTS:
!
! NONE
!
! ROUTINE VALUE:
!
! NONE
!
! SIDE EFFECTS:
!
! NONE
!--
BEGIN ! BEGIN msg_dest
MAP
msg:REF message_table_entry;
STACKLOCAL
pobbuf: VECTOR[CH$ALLOCATION(max_string_length)];
LOCAL
list: REF list_blk,
domain,
rcpt_str,
node_str,
name_len,
sys_flg,
err_flg,
rcpt_data_blk: REF rb_block,
work_request: REF work_request_block;
err_flg = sys_flg = 0;
rcpt_str = copy_asciz(.ptr);
rcpt_data_blk = parse_rcpt(CH$PTR(.rcpt_str));
IF .rcpt_data_blk[rb_node_ptr] EQL 0 ![314]If there's no nodename
THEN ![314] then assume the local
BEGIN ![314] domain.
domain = $local; ![314]
node_str = 0; ![314]
END ![314]
ELSE ![314]
BEGIN
node_str =
nmu$memory_get(CH$ALLOCATION(.rcpt_data_blk[rb_node_len]+4, 8));
ptr = CH$PTR(.node_str,0,8);
CH$WCHAR_A(0,ptr);
CH$WCHAR_A(0,ptr);
CH$WCHAR_A(.rcpt_data_blk[rb_node_len], ptr);
ptr = CH$MOVE(.rcpt_data_blk[rb_node_len],
.rcpt_data_blk[rb_node_ptr],
.ptr);
CH$WCHAR(0,.ptr);
domain = mx$data_validate(.node_str,
.msg[msg_sender_domain],
-1);
domain = .domain<0,18,1>;
END;
IF .domain GEQ 0
THEN
BEGIN ![314]If there's no network
IF .node_str EQL 0 ![314] then there's only
THEN ![314] one work request
work_request = .msg[msg_work_req_list] ![314]
ELSE ![314]
work_request = find_work_req( .msg[msg_work_req_list],
CH$PTR(.node_str,3,8),
.rcpt_data_blk[rb_node_len]);
IF .domain EQL $local
THEN
BEGIN
IF NOT (sys_flg=mx$validate_local_user(.rcpt_data_blk[rb_name_len],
.rcpt_data_blk[rb_name_ptr],
pobbuf))
THEN
BEGIN
err_flg = 1;
$signal_error(
%(318)% SEVERITY=STS$K_WARNING,
%(318)% FACILITY=$err,
CODE=mg$nsu,
MESSAGE_DATA=(CH$PTR(UPLIT(%ASCIZ'LOCAL')),
CH$PTR(pobbuf)));
END
%IF %SWITCHES(TOPS10) %THEN
ELSE !Tops-10 Save the profile
rcpt_data_blk[rb_profile] = .pobbuf %FI ;
IF .sys_flg LSS 0
THEN
IF (.msg[msg_sender_domain] NEQ $local) OR
%IF %SWITCHES(TOPS20) %THEN
((.msg[msg_sender_caps] AND (sc_whl OR sc_opr)) EQL 0)
%ELSE
(((.msg[msg_sender_caps] AND ip$jac) EQL 0) AND
(.msg[msg_sender_uid] NEQ 1^18 + 2))
%FI
THEN
BEGIN
err_flg = $true;
$signal_error(
%(318)% SEVERITY=STS$K_WARNING,
%(318)% FACILITY=$err,
CODE=mg$ips);
END;
END;
END
ELSE
BEGIN
$signal_error( !Invalid Node Name
ID=.msg[msg_unique_id],
SEVERITY=STS$K_WARNING,
FACILITY=$err,
CODE=ls$inn,
MESSAGE_DATA=CH$PTR(.node_str,3,8));
err_flg = 1;
END;
IF .err_flg
THEN
BEGIN
mx$release_asciz(.node_str);
mx$release_asciz(.rcpt_str);
nmu$memory_release(.rcpt_data_blk, rb_block_size);
END
ELSE
BEGIN
if (.work_request EQL 0)
THEN
BEGIN
work_request = mx$get_work_request;
work_request[req_message_id] = 0;
work_request[req_domain_id] = .domain;
work_request[req_destination_node] = .node_str;
work_request[req_recipient_list] = 0;
work_request[req_state] = 0;
list = mx$get_list_blk;
list[lst_next] = .msg[msg_work_req_list];
list[lst_data] = .work_request;
msg[msg_work_req_list] = .list
END;
list = mx$get_list_blk;
list[lst_data] = .rcpt_str;
list[lst_next] = .work_request[req_recipient_list];
list[lst_xtra] = .rcpt_data_blk;
list[lst_stat] = 0;
work_request[req_recipient_list] = .list;
END;
$TRACE('Recipient %A', CH$PTR(.rcpt_str))
END; ! END get_dest
%global_routine('PARSE_RCPT', ptr) =
BEGIN
LOCAL
parse_data_blk: REF rb_block,
len,
err,
ep,
erstr;
erstr = .ptr;
err = $false;
parse_data_blk = mx$get_rb_block;
IF CH$RCHAR(.ptr) EQL %C'@'
THEN
BEGIN
ptr = ep = CH$PLUS(.ptr,1);
len = pnode(ep);
parse_data_blk[rb_node_ptr] = .ptr;
parse_data_blk[rb_node_len] = .len;
parse_data_blk[rb_name_len] = parse_data_blk[rb_name_ptr] = 0;
WHILE CH$RCHAR(.ep) EQL %C',' DO
BEGIN
IF CH$A_RCHAR(ep) NEQ %C'@'
THEN
BEGIN
err = $true;
EXITLOOP
END;
ep = CH$PLUS(.ep,1);
pnode(ep);
END;
IF CH$RCHAR_A(ep) EQL %C':'
THEN
BEGIN
pname(ep);
IF CH$RCHAR_A(ep) EQL %C'@'
THEN
BEGIN
pnode(ep);
IF CH$RCHAR(.ep) NEQ 0
THEN
err = $true;
END
ELSE
err = $true
END
ELSE
err = $true;
IF .err
THEN
$signal_error( !Invalid Destination String
%(318)% SEVERITY=STS$K_ERROR,
%(318)% FACILITY=$err,
CODE=ls$ids,
MESSAGE_DATA=.erstr);
END
ELSE
BEGIN
ep = .ptr;
len = pname(ep);
IF CH$RCHAR(.ptr) EQL %C'"'
THEN
BEGIN !Ignore the quotes
parse_data_blk[rb_name_ptr] = CH$PLUS(.ptr,1);
parse_data_blk[rb_name_len] = .len - 2;
END
ELSE
BEGIN
parse_data_blk[rb_name_ptr] = .ptr;
parse_data_blk[rb_name_len] = .len;
END;
SELECTONE CH$RCHAR(.ep) OF
SET
[0]: BEGIN
IF .nodnam EQL 0 ![315]If no network then
THEN ![314] clear parse data
BEGIN ![314]
parse_data_blk[rb_node_ptr] = 0;![314]
parse_data_blk[rb_node_len] = 0;![314]
END ![314]
ELSE ![314]
BEGIN
parse_data_blk[rb_node_ptr] = CH$PTR(nodnam);
parse_data_blk[rb_node_len] =
CH$LEN(CH$PTR(nodnam));
END
END;
[%C' ',%C'@']: BEGIN
parse_data_blk[rb_node_ptr] = ep = CH$PLUS(.ep,1);
parse_data_blk[rb_node_len] = pnode(ep);
END;
TES;
IF CH$RCHAR(.ep) NEQ 0
THEN
$signal_error( !Invalid Destination String
%(318)% SEVERITY=STS$K_ERROR,
%(318)% FACILITY=$err,
CODE=ls$ids,
MESSAGE_DATA=.erstr);
END;
RETURN .parse_data_blk
END;
GLOBAL ROUTINE pnode(ptr_) =
BEGIN
BIND
ptr = .ptr_;
LOCAL
len;
len = 0;
WHILE $true DO
SELECTONE CH$RCHAR(.ptr) OF
SET
[%C',', %C':', 0]: EXITLOOP;
[OTHERWISE]: BEGIN
ptr = CH$PLUS(.ptr, 1);
len = .len + 1;
END;
TES;
RETURN .len
END;
GLOBAL ROUTINE pname(ptr_) =
BEGIN
BIND
ptr = .ptr_,
atptr = CH$PTR(UPLIT(%ASCIZ' at '));
LOCAL
erstr,
qstr,
len;
erstr = .ptr;
len = 0;
qstr = 0;
IF CH$RCHAR(.ptr) EQL %C'"'
THEN
BEGIN
qstr = $true;
len = 1;
ptr = CH$PLUS(.ptr,1)
END;
WHILE $true DO
BEGIN
SELECTONE CH$RCHAR(.ptr) OF
SET
[%C'"']: IF .qstr
THEN
qstr = 0
ELSE
$signal_error( !Invalid Destination String
%(318)% SEVERITY=STS$K_ERROR,
%(318)% FACILITY=$err,
CODE=ls$ids,
MESSAGE_DATA=.erstr);
[%C'@']: IF NOT .qstr !If not inside quotes, exit
THEN
EXITLOOP;
[%C' ']: IF NOT .qstr
THEN
IF CH$EQL(4,.ptr,4,atptr)
THEN
BEGIN
ptr = CH$PLUS(.ptr,3);
EXITLOOP
END;
! ELSE
! $signal_error( !Invalid Destination String
! SEVERITY=STS$K_ERROR,
! FACILITY=$err,
! CODE=ls$ids,
! MESSAGE_DATA=.erstr);
[0]: EXITLOOP;
TES;
ptr = CH$PLUS(.ptr, 1);
len = .len + 1;
END;
RETURN .len
END;
GLOBAL ROUTINE copy_asciz (ptr) =
BEGIN
LOCAL
p,
len,
adr;
p = .ptr;
len = 0;
WHILE CH$RCHAR_A(p) NEQ 0 DO len = .len + 1;
adr = nmu$memory_get(CH$ALLOCATION(.len+1));
CH$MOVE(.len, .ptr, CH$PTR(.adr));
RETURN .adr
END;
GLOBAL ROUTINE copy_string (ptr, len) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine copies the specified string into a string block, and
! returns a pointer to that string block. The source string is assumed
! to be an ASCIZ string (terminated by a null). The destination string
! block is allocated based on the length of the source, including the null.
!
! FORMAL PARAMETERS:
!
! ptr - pointer to source string
! len - length of the source string
!
! IMPLICIT INPUTS:
!
! NONE
!
! IMPLICIT OUTPUTS:
!
! NONE
!
! COMPLETION CODES:
!
! address of string block
!
! SIDE EFFECTS:
!
! NONE
!--
BEGIN ! BEGIN copy_string
LOCAL
block, ! place to keep string block
dptr; ! pointer into string block
block = NMU$MEMORY_GET(CH$ALLOCATION(.len)); ! get a block
dptr = CH$PTR(.block); ! create a pointer to the block
CH$MOVE(.len, .ptr, .dptr); ! move the string
RETURN (.block); ! return pointer to string block
END; ! END copy_string
routine find_work_req (list, ptr, len) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will return the address of the work request that coresponds
! to the node name pointed to by ptr. The list of work requests is scanned
! until the work request for the specified node name is found.
!
! FORMAL PARAMETERS:
!
! list - address of first list block in the chain
! ptr - pointer to node name
! len - length of the node name
!
! IMPLICIT INPUTS:
!
! NONE
!
! IMPLICIT OUTPUTS:
!
! NONE
!
! COMPLETION CODES:
!
! address of work request, or 0.
!
! SIDE EFFECTS:
!
! NONE
!--
BEGIN ! BEGIN find_work_req
STACKLOCAL
nodb1: VECTOR[CH$ALLOCATION(max_string_length)],
nodb2: VECTOR[CH$ALLOCATION(max_string_length)];
LOCAL
list_ptr: REF list_blk, !save list block address here
req, !work request address
wnode_len; !length of work-req node string
CH$TRANSLATE(uc_tab, !Convert node to upper case
.len, .ptr,
0,
.len+1, CH$PTR(nodb1));
req = 0; !assume no match
list_ptr = .list; !copy list pointer
WHILE .list_ptr NEQ 0 AND .req EQL 0 DO
BEGIN ! BEGIN search loop
BIND
curr_req = .list_ptr[lst_data]: work_request_block;
wnode_len = CH$RCHAR(CH$PTR(.curr_req[ req_destination_node ],2,8));
CH$TRANSLATE(uc_tab,
.wnode_len, CH$PTR(.curr_req[ req_destination_node ],3,8),
0,
.wnode_len+1, CH$PTR(nodb2));
IF CH$EQL(.wnode_len, CH$PTR(nodb2),
.len, CH$PTR(nodb1), 0)
THEN
req = curr_req;
list_ptr = .list_ptr [ lst_next ];
END; ! END of search loop
RETURN (.req); ! return the work request
END; ! END find_work_req
ROUTINE get_sender (ptr, len, msg): NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine processes an IPCF sender record. If the originator has
! privileges, the sender string is copied into a string block and the
! existing sender string is superceded with this new string.
!
! FORMAL PARAMETERS:
!
! NONE
!
! IMPLICIT INPUTS:
!
! NONE
!
! IMPLICIT OUTPUTS:
!
! NONE
!
! COMPLETION CODES:
!
!
! SIDE EFFECTS:
!
! NONE
!--
BEGIN ! BEGIN msg_sender
MAP
msg:REF message_table_entry;
$TRACE('Routine GET_SENDER called');
%IF %SWITCHES(TOPS20) %THEN
IF (.msg[msg_sender_caps] AND (SC_WHL OR SC_OPR)) GTR 0
%ELSE
IF ((.msg[msg_sender_caps] AND IP$JAC) NEQ 0) OR
(.msg[msg_sender_uid] EQL 1^18 + 2)
%FI
THEN
BEGIN
$TRACE('Sender %A being changed to %A',
CH$PTR(.msg[msg_sender_string]),.ptr);
IF .msg[ msg_sender_string ] NEQ 0
THEN
mx$release_asciz(.msg[ msg_sender_string ]);
msg[ msg_sender_string ] = copy_asciz(.ptr);
END;
END; ! END msg_sender
ROUTINE get_subj (ptr, len, msg): NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine processes an IPCF sender record. If the originator has
! privileges, the sender string is copied into a string block and the
! existing sender string is superceded with this new string.
!
! FORMAL PARAMETERS:
!
! NONE
!
! IMPLICIT INPUTS:
!
! NONE
!
! IMPLICIT OUTPUTS:
!
! NONE
!
! COMPLETION CODES:
!
!
! SIDE EFFECTS:
!
! NONE
!--
BEGIN ! BEGIN get_subject
MAP
msg:REF message_table_entry;
$TRACE('SUBJECT: %A',.ptr);
msg[msg_subject_string] = copy_asciz(.ptr);
END; ! END get_subject
%global_routine ('LCLSPL'):NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
! This task takes WORK-REQUESTS from its input queue, and transmits the
! message to the appropriate users...
!
! FORMAL PARAMETERS:
!
! NONE
!
! IMPLICIT INPUTS:
!
! NONE
!
! IMPLICIT OUTPUTS:
!
! NONE
!
! COMPLETION CODES:
!
! NONE
!
! SIDE EFFECTS:
!
! NONE
!--
BEGIN
BIND
domain = .nettab[0]: domain_data_block;
LOCAL
state,
sleep_time,
did,
msg: REF message_table_entry,
entry: REF work_request_block;
WHILE 1 DO
BEGIN
entry = nmu$squeue_remove(.domain[dom_spooler_queue]);
$TRACE('LCLSPL running...');
nmu$table_fetch(active_message_table, .entry[req_message_id], msg);
IF .nodnam EQL 0 ![314]Init "domain id" in case of no net
THEN ![314]
did = 0 ![314]
ELSE ![314]
did = mx$data_validate(.entry[req_destination_node],
.msg[msg_sender_domain],
.entry[req_domain_id]);
IF NOT .did<0,18,1> GEQ 0
THEN
BEGIN !Invalid Node Name
$error(
%(318)% SEVERITY=STS$K_SEVERE,
%(318)% FACILITY=$err,
CODE=MG$NNK,
MESSAGE_DATA=(CH$PTR(UPLIT(%ASCIZ'LOCAL')),
CH$PTR(.entry[req_destination_node], 3, 8)),
ID=.msg[msg_unique_id]);
$mx$change_state(.entry, $reject);
END
ELSE
BEGIN
sleep_time = 0;
local_deliver(.entry, .msg);
IF .entry[req_state] EQL $defer
THEN
time_current(RTRYLC*60, sleep_time);
$mx$change_state(.entry,,.sleep_time);
END;
mx$message_queue_checkpoint(.msg);
END;
nmu$sched_deschedule();
END; !End of LCLSPL
%routine('LOCAL_DELIVER', entry: REF work_request_block,
msg: REF message_table_entry): NOVALUE =
BEGIN
LOCAL
head: list_blk,
plist: REF list_blk,
tlist: REF list_blk,
list: REF list_blk,
state,
temp;
$TRACE('Routine LOCAL_DELIVER called');
plist = head;
list = head[lst_next] = .entry[req_recipient_list];
WHILE .list NEQ 0 DO
BEGIN
nmu$sched_pause();
state = append_mail(.list, .msg);
IF (.state EQL $done) OR (.state EQL $nofile)
THEN
BEGIN
IF .state EQL $done
THEN
temp = CH$PTR(UPLIT(%ASCIZ ' '))
ELSE
BEGIN
temp = CH$PTR(UPLIT(%ASCIZ ' NOT '));
state = $done;
END;
$TRACE_ALWAYS(.msg[msg_unique_id],
'Mail%ADelivered to %A',
.temp,
CH$PTR(.list[lst_data])) ;
mx$release_asciz(.list[lst_data]);
nmu$memory_release(.list[lst_xtra],rb_block_size);
tlist = plist[lst_next] = .list[lst_next];
nmu$memory_release(.list,list_block_size);
list = .tlist;
END
ELSE
BEGIN
plist = .list;
list = .list[lst_next];
END;
entry[REQ_RECIPIENT_LIST] = .head[lst_next];
entry[REQ_STATE] = MAX(.entry[REQ_STATE], .state);
END;
END;
%global_routine('APPEND_MAIL', list: REF list_blk, msg: REF message_table_entry) =
BEGIN
STACKLOCAL
dirbuf: VECTOR[CH$ALLOCATION(max_string_length)],
nambuf: VECTOR[CH$ALLOCATION(max_string_length)],
iobuf: VECTOR[CH$ALLOCATION(max_string_length)],
cleanup_vector: VECTOR[3];
BIND
msgfil = cleanup_vector[0],
mailfil = cleanup_vector[1],
profile = cleanup_vector[2];
MACRO proppn(pf) = !Get the PPN from a user profile (T10)
BEGIN
BIND
_pf = (pf): VECTOR[];
._pf[1] ! .AEPPN == 1
END %;
KEYWORDMACRO
blast_tty(text,user=) =
BEGIN
%IF %ISSTRING(%REMOVE(text)) %THEN
BIND
tbuf = UPLIT(%ASCIZ %REMOVE(text)),
pt = CH$PTR(tbuf);
%ELSE
STACKLOCAL
tbuf: VECTOR[CH$ALLOCATION(132)];
BIND
pt = CH$PTR(tbuf);
LOCAL
tp;
tp = CH$PTR(tbuf);
$nmu$text(tp,132,%REMOVE(text));
%FI
%IF %NULL(user) %THEN
nag(-1,pt)
%ELSE
%IF %SWITCHES(TOPS20) %THEN
nag(user,pt)
%ELSE
nag(proppn(.profile),pt)
!NOTE: profile must be set up before this
%FI !macro is invoked! The value of user is irrelev
%FI
END
%;
LOCAL
msg_size,
byte_count,
written,
linlen,
error,
len,
state,
used,
qta,
pages_left,
jobnum,
ptr,
pqta,
wqta,
sys,
rcpt_data_blk: REF rb_block;
profile = mailfil = msgfil = 0;
state = $done;
rcpt_data_blk = .list[lst_xtra];
CH$WCHAR(0,CH$MOVE(.rcpt_data_blk[rb_name_len],
.rcpt_data_blk[rb_name_ptr],
CH$PTR(nambuf)));
%IF %SWITCHES(TOPS20) %THEN
IF (sys = mx$validate_local_user(.rcpt_data_blk[rb_name_len],
.rcpt_data_blk[rb_name_ptr],
dirbuf))
THEN
BEGIN
!
! If mx$validate_local_user returned 3, then one or more POBOX: structures
! were dismounted, and we couldn't validate the user. Try again later
!
IF .sys EQL 3
THEN
RETURN $defer;
!
! We were able to validate the recipient, but we may not be able to find
! the message file in the sender's directory. We'll look for it, but if we
! don't find it, we'll check POBSTS. If POBSTS indicates dismounted
! structures, then we'll defer this one.
!
IF NOT (msgfil = mx$file_open(
CH$PTR(.msg[msg_fil_spec]),
file_access_read_only,
error)) GTR 0
THEN
BEGIN
sys = $nofile;
IF .msg[msg_sender_domain] NEQ $local
THEN
sys = $defer
ELSE
BEGIN
IF .pobsts EQL ok_pobox
THEN
MX$UPDATE_POBOX_STATUS();
IF .pobsts NEQ ok_pobox
THEN
sys = $defer;
END;
$error(
SEVERITY=STS$K_INFO,
FACILITY=$err,
CODE=uf$fof,
ID=.msg[msg_unique_id],
MESSAGE_DATA=CH$PTR(.msg[msg_fil_spec]),
OPTIONAL_MESSAGE=(FAC=$mon),
OPTIONAL_DATA=.error);
kleanup(cleanup_vector);
RETURN .sys;
END;
!
! If we get here, then we have both a valid user, and an accessible message
! file. Check to see if it will fit in the recipients directory.
!
get_quota(dirbuf, pqta, wqta, used);
mx$file_size(.msg[msg_fil_spec], msg_size, byte_count);
IF .byte_count EQL 0
THEN
BEGIN
%(318)% $error( FACILITY = $err,
%(318)% SEVERITY = STS$K_SEVERE,
CODE = mx$mzb, !Message has Zero Bytes
MESSAGE_DATA = CH$PTR(.msg[msg_fil_spec]),
ID= .msg[msg_unique_id]);
kleanup(cleanup_vector);
RETURN $reject
END;
qta = (IF logged_in(CH$PTR(nambuf), jobnum)
THEN
.wqta
ELSE
.pqta);
IF .msg_size GEQ .qta
THEN
BEGIN
!
! Hmmm... The message is bigger than the user's entire directory. There's
! nothing the user can do about this without the help of his system
! manager. Reject this message.
!
%(318)% $error( FACILITY = $err,
%(318)% SEVERITY = STS$K_SEVERE,
CODE = mx$noq,
MESSAGE_DATA = CH$PTR(dirbuf),
ID= .msg[msg_unique_id]);
kleanup(cleanup_vector);
RETURN $reject
END;
!
! Now see if it will fit in the AVAILABLE space.
!
pages_left = .qta - .used;
IF .pages_left GTR .msg_size + 1
THEN
BEGIN
$TRACE('User not over quota');
linlen = get_header(CH$PTR(iobuf),
.byte_count,
CH$PTR(.msg[msg_sender_string]));
get_name(dirbuf);
IF NOT (mailfil = mx$file_open(
CH$PTR(dirbuf),
file_access_append_only,
error)) GTR 0
THEN
BEGIN
$error(FACILITY=$err,
SEVERITY=STS$K_WARNING,
CODE=uf$fof,
MESSAGE_DATA=CH$PTR(dirbuf),
OPTIONAL_MESSAGE=(FAC=$mon),
OPTIONAL_DATA=.error,
ID=.msg[msg_unique_id]);
kleanup(cleanup_vector);
RETURN $defer;
END;
if not mx$file_write(.mailfil, CH$PTR(iobuf), .linlen, error)
then
BEGIN
%(318)% $error(SEVERITY = STS$K_WARNING,
CODE = uf$fwf,
%(318)% FACILITY = $err,
MESSAGE_DATA = CH$PTR(dirbuf),
%(318)% optional_message = (FAC=$mon),
optional_data = .error,
ID=.msg[msg_unique_id]);
kleanup(cleanup_vector);
RETURN $defer;
END;
written = 0;
WHILE (
linlen = mx$file_read(.msgfil,
CH$PTR(iobuf),
max_string_length,
error)) GTR 0 DO
BEGIN
IF NOT mx$file_write(.mailfil, CH$PTR(iobuf), .linlen, error)
THEN
BEGIN
%(318)% $error(SEVERITY = STS$K_WARNING,
CODE = uf$fwf,
%(318)% FACILITY = $err,
MESSAGE_DATA = CH$PTR(dirbuf),
%(318)% optional_message = (FAC=$mon),
optional_data = .error,
ID=.msg[msg_unique_id]);
kleanup(cleanup_vector);
RETURN $defer;
END;
written = .written + .linlen;
END;
IF .linlen NEQ 0
THEN
BEGIN
%(318)% $error(FACILITY = $err,
%(318)% SEVERITY = STS$K_SEVERE,
CODE = uf$frf,
MESSAGE_DATA = CH$PTR(.msg[msg_fil_spec]),
%(318)% OPTIONAL_MESSAGE = (FAC=$mon),
OPTIONAL_DATA = .error,
ID=.msg[msg_unique_id]);
kleanup(cleanup_vector);
RETURN $reject;
END;
IF NOT mx$file_close(.mailfil, file_keep, error)
THEN
BEGIN
%(318)% $error(FACILITY = $err,
%(318)% SEVERITY = STS$K_WARNING,
CODE = uf$fcf,
MESSAGE_DATA = CH$PTR(dirbuf),
%(318)% OPTIONAL_MESSAGE = (FAC=$mon),
OPTIONAL_DATA = .error,
ID=.msg[msg_unique_id]);
kleanup(cleanup_vector);
RETURN $defer;
END;
mx$file_set_writer(CH$PTR(dirbuf),CH$PTR(.msg[msg_sender_string]));
mx$file_close(.msgfil, file_abort, error);
IF .sys EQL -1
THEN
blast_tty(TEXT = ('New SYSTEM mail available'))
ELSE
blast_tty(USER = CH$PTR(nambuf),
TEXT = ('You have mail from %A',
CH$PTR(.msg[msg_sender_string])) );
END
ELSE ! Over quota
BEGIN
![319] Make sure we release any open files here.
kleanup(cleanup_vector);
IF NOT .list[lst_quota]
THEN
BEGIN
$TRACE_ALWAYS(.msg[msg_unique_id],
%STRING('%A is overquota (%D/%D) (p/w)%/',
' %D pages in use.'),
CH$PTR(.list[lst_data]),.pqta,.wqta,.used);
list[lst_quota] = 1;
END;
blast_tty(USER = CH$PTR(nambuf),
TEXT = (%STRING('You have undeliverable mail from %A.',
'%/ The mail is %D pages long and it ',
'would put you over quota.'),
CH$PTR(.msg[msg_sender_string]),
.msg_size) );
state = $defer;
END;
END
ELSE
BEGIN
%(318)% $error(SEVERITY=STS$K_SEVERE,
%(318)% FACILITY=$err,
CODE=mg$nsu,
MESSAGE_DATA=(CH$PTR(UPLIT(%ASCIZ'LOCAL')),
CH$PTR(.list[lst_data])),
ID=.msg[msg_unique_id]);
RETURN $reject
END;
%ELSE !BEGIN TOPS10 CONDITIONAL
profile = .rcpt_data_blk[rb_profile];
IF NOT ufdcre(.profile)
THEN
BEGIN
%(318)% $error( FACILITY = $err,
%(318)% SEVERITY = STS$K_WARNING,
CODE = ufd$cr,
MESSAGE_DATA = .list[lst_data]);
kleanup(cleanup_vector);
RETURN $defer
END;
dirbuf = proppn(.profile);
get_name(dirbuf); ! on TOPS10, dirbuf contains the ppn...
!...here it contains "DSK:MAIL.TXT[p,pn]"
IF NOT (mailfil = mx$file_open( !Open the MAIL.TXT...
CH$PTR(dirbuf),
file_access_append_only,!...for append if it exists...
error)) GTR 0
THEN
BEGIN
SELECTONE .error OF
SET
[uf$lok]: !File is locked...
BEGIN !...try again later
kleanup(cleanup_vector);
RETURN $defer;
END;
[OTHERWISE]:
BEGIN
%(318)% $error(FACILITY=$err, !Oh well, rejct the message
%(318)% SEVERITY=STS$K_SEVERE,
CODE=uf$fof,
MESSAGE_DATA=CH$PTR(dirbuf),
%(318)% OPTIONAL_MESSAGE=(FAC=$mon),
OPTIONAL_DATA=(.error<0,18,0>,.error<18,18,0>),
ID=.msg[msg_unique_id]);
kleanup(cleanup_vector);
RETURN $reject;
END;
TES;
END;
!Here if MAIL.TXT file has been successfully opened...
pqta = mx$file_structure(.mailfil); !Put the SIXBIT structure in
!pqta for use by GET_QUOTA
get_quota(proppn(.profile), pqta, wqta, used);
IF NOT (error = mx$file_size(.msg[msg_fil_spec], msg_size, byte_count))
THEN
BEGIN
kleanup(cleanup_vector);
IF .error<left_half> EQL erfnf_
THEN
RETURN $done;
RETURN $defer
END;
IF .byte_count EQL 0
THEN
BEGIN
%(318)% $error( FACILITY = $err,
%(318)% SEVERITY = STS$K_SEVERE,
CODE = mx$mzb, !Message has Zero Bytes
MESSAGE_DATA = CH$PTR(.msg[msg_fil_spec]),
ID= .msg[msg_unique_id]);
kleanup(cleanup_vector);
RETURN $reject
END;
qta = (IF logged_in(proppn(.rcpt_data_blk[rb_profile]), jobnum)
THEN
.wqta
ELSE
.pqta);
IF .msg_size GEQ .qta
THEN
BEGIN
get_name(dirbuf);
%(318)% $error( FACILITY = $err,
%(318)% SEVERITY = STS$K_SEVERE,
CODE = mx$noq,
MESSAGE_DATA = CH$PTR(dirbuf),
ID= .msg[msg_unique_id]);
kleanup(cleanup_vector);
RETURN $reject
END;
pages_left = .qta - .used;
IF .pages_left GTR .msg_size + 1
THEN
BEGIN
$TRACE('User not over quota');
linlen = get_header(CH$PTR(iobuf),
.byte_count,
CH$PTR(.msg[msg_sender_string]));
IF NOT (msgfil = mx$file_open(
CH$PTR(.msg[msg_fil_spec]),
file_access_read_only,
error)) GTR 0
THEN
BEGIN
kleanup(cleanup_vector);
RETURN $done;
END;
if not mx$file_write(.mailfil, CH$PTR(iobuf), .linlen, error)
then
BEGIN
%(318)% $error(SEVERITY = STS$K_SEVERE,
CODE = uf$fwf,
%(318)% FACILITY = $err,
MESSAGE_DATA = CH$PTR(dirbuf),
%(318)% optional_message = (FAC=$mon),
optional_data = .error,
ID=.msg[msg_unique_id]);
kleanup(cleanup_vector);
RETURN $reject;
END;
written = 0;
WHILE (
linlen = mx$file_read(.msgfil,
CH$PTR(iobuf),
max_string_length,
error)) GTR 0 DO
BEGIN
IF NOT mx$file_write(.mailfil, CH$PTR(iobuf), .linlen, error)
THEN
BEGIN
%(318)% $error(SEVERITY = STS$K_SEVERE,
CODE = uf$fwf,
%(318)% FACILITY = $err,
MESSAGE_DATA = CH$PTR(dirbuf),
%(318)% optional_message = (FAC=$mon),
optional_data = .error,
ID=.msg[msg_unique_id]);
kleanup(cleanup_vector);
RETURN $reject;
END;
written = .written + .linlen;
END;
IF .linlen NEQ 0
THEN
BEGIN
%(318)% $error(FACILITY = $err,
%(318)% SEVERITY = STS$K_SEVERE,
CODE = uf$frf,
MESSAGE_DATA = CH$PTR(.msg[msg_fil_spec]),
%(318)% OPTIONAL_MESSAGE = (FAC=$mon),
OPTIONAL_DATA = .error,
ID=.msg[msg_unique_id]);
kleanup(cleanup_vector);
RETURN $reject;
END;
IF NOT mx$file_close(.mailfil, file_keep, error)
THEN
BEGIN
%(318)% $error(FACILITY = $err,
%(318)% SEVERITY = STS$K_SEVERE,
CODE = uf$fcf,
MESSAGE_DATA = CH$PTR(dirbuf),
%(318)% OPTIONAL_MESSAGE = (FAC=$mon),
OPTIONAL_DATA = .error,
ID=.msg[msg_unique_id]);
mailfil = 0;
kleanup(cleanup_vector);
RETURN $reject;
END;
mx$file_close(.msgfil, file_abort, error);
blast_tty(USER = CH$PTR(nambuf),
TEXT = ('You have mail from %A',
CH$PTR(.msg[msg_sender_string])) );
END
ELSE ! Over quota
BEGIN
kleanup(cleanup_vector);
IF NOT .list[lst_quota]
THEN
BEGIN
$TRACE_ALWAYS(.msg[msg_unique_id],
%STRING('%A is overquota (%D/%D) (p/w)%/',
' %D blocks in use.'),
CH$PTR(nambuf),.pqta,.wqta,.used);
list[lst_quota] = 1;
END;
blast_tty(USER = CH$PTR(nambuf),
TEXT = (%STRING('You have undeliverable mail from %A.',
'%/ The mail is %D blocks long and it ',
'would put you over quota.'),
CH$PTR(.msg[msg_sender_string]),
.msg_size) );
state = $defer;
END;
ufddel(.profile);
%FI !END of TOPS10 conditional...
RETURN .state
END;
%global_routine('kleanup',vec: REF vector): NOVALUE =
BEGIN
LOCAL
error;
BIND
msg_file = vec[0],
mai_file = vec[1],
profile = vec[2];
IF .msg_file GTR 0
THEN
mx$file_close(.msg_file, file_abort, error);
IF .mai_file GTR 0
THEN
mx$file_close(.mai_file, file_abort, error);
%IF %SWITCHES(TOPS10) %THEN
IF .profile GTR 0
THEN
ufddel(.profile);
%FI
END;
%global_routine('GET_HEADER', ptr, msglen, sndptr) =
BEGIN
STACKLOCAL
buffer: VECTOR[CH$ALLOCATION(30)] INITIAL(REP CH$ALLOCATION(30) OF
(0));
msglen = .msglen + 10 + CH$LEN(.sndptr,max_string_length);
%IF %SWITCHES(TOPS20) %THEN
$$odtim(CH$PTR(buffer),-1,ot_tmz);
%ELSE
udtdat(-1,buffer);
%FI
$nmu$text(ptr,max_string_length,'%A,%(11)U;000000000000%/Sender: %A%/',
CH$PTR(buffer),.msglen,.sndptr) - 1
END;
%routine('GET_NAME', adr) =
BEGIN
%IF %SWITCHES(TOPS20) %THEN
BIND
mptr = CH$PTR(UPLIT(%ASCIZ 'MAIL.TXT.1')),
mlen = %CHARCOUNT(%ASCIZ 'MAIL.TXT.1');
LOCAL
len;
len = CH$LEN(CH$PTR(.adr),max_string_length);
CH$MOVE(mlen,mptr,CH$PLUS(CH$PTR(.adr),.len));
RETURN .len
%ELSE
BIND
buf = .adr;
LOCAL
ptr,
ppn;
ppn = .buf;
ptr = CH$PTR(buf);
RETURN $nmu$text(ptr, max_string_length, 'DSK:MAIL.TXT[%O,%O]',
.ppn<18,18,0>, .ppn<0,18,0>);
%FI
END;
%routine('GET_QUOTA', ptr, perm_, working_, used_):NOVALUE =
BEGIN
%IF %SWITCHES(TOPS20) %THEN
BIND
perm = .perm_,
working = .working_,
used = .used_;
declare_jsys(rcdir,gtdal);
LOCAL
dirnum,
rcbits;
$$rcdir(rc_emo,CH$PTR(.ptr),0; rcbits,,dirnum);
IF (.rcbits AND rc_nom) EQL 0
THEN
$$gtdal(.dirnum; working, used, perm);
RETURN 0;
%ELSE
!NOTE ptr contains the ppn, and perm contains the SIXBIT structure name
BIND
perm = .perm_,
working = .working_,
used = .used_;
quotas(.ptr,.perm; working, perm, used)
%FI
END;
%global_routine('NAG', too, msg): NOVALUE =
BEGIN
%IF %SWITCHES(TOPS20) %THEN
declare_jsys(ttmsg,odtim,getji,rcusr,mtopr,getab);
LOCAL
jobs,
rcbits,
userno,
tim,
sysmsg,
ptr;
LITERAL
jibufsiz = 9;
STACKLOCAL
jibuf: VECTOR[jibufsiz],
buffer: VECTOR[CH$ALLOCATION(30)],
msgbuf: VECTOR[CH$ALLOCATION(max_string_length)];
tim = CH$PTR(buffer);
CH$WCHAR_A(%O'7',tim);
$$odtim(.tim,-1,ot_nda);
ptr = CH$PTR(msgbuf);
$nmu$text(ptr,max_string_length,'%/[%A %A - %A]%/',
CH$PTR(nodnam), CH$PTR(buffer), .msg);
IF .too EQL -1
THEN
$$ttmsg(-1, CH$PTR(msgbuf))
ELSE
BEGIN
IF NOT $$getab(actjob;jobs)
THEN
BEGIN !Just in case we're NOT running 7.0
jobs<left_half> = 1; !Minimum jobnumber
jobs<right_half> = 256; !Worst case maximum
END;
$$rcusr(rc_emo,.too,0;rcbits,,userno);
IF NOT (.rcbits AND (rc_dir OR rc_nom)) EQL 0
THEN
RETURN 0;
INCR jobnum FROM .jobs<left_half> TO .jobs<right_half> DO
BEGIN
REGISTER
t1 = 1;
sysmsg = 0;
IF $$getji(.jobnum,(-jibufsiz^18)+jibuf,$jitno)
THEN
BEGIN
IF .jibuf[$jiuno-$jitno] EQL .userno !Right user?
THEN
IF .jibuf[$jitno-$jitno] GTR 0 !Yes, Detached?
THEN
! IF .jibuf[$jicpj-$jitno] LSS 0 !No, PTY?
! THEN
! IF .jibuf[$jibat-$jitno] GEQ 0 !No, Batch?
! THEN
BEGIN
$$mtopr(%O'400000' + .jibuf[$jitno-$jitno],
$mornt;sysmsg);
IF .sysmsg EQL 0
THEN
$$ttmsg(%O'400000' + .jibuf[$jitno-$jitno],
CH$PTR(msgbuf));
jibuf[$jitno-$jitno] = 0;
END;
END
ELSE
IF .t1 EQL gtjix3
THEN
EXITLOOP;
END;
END;
RETURN 0;
%ELSE
BIND
ppn = too;
STACKLOCAL
tbuf: VECTOR[CH$ALLOCATION(40)],
msgbuf: VECTOR[CH$ALLOCATION(max_string_length)];
LOCAL
ptr,
jobnum;
udttim(-1,tbuf);
ptr = CH$PTR(msgbuf);
$nmu$text(ptr,max_string_length,'%C%/[%A %A - %A]%/',
%O'7', CH$PTR(nodnam), CH$PTR(tbuf), .msg);
IF .too EQL - 1
THEN
RETURN 0 !*** PUT "blast to everyone" code here
ELSE
BEGIN
REGISTER
jobnum;
jobnum = 0;
WHILE fndusr(.ppn,.jobnum; jobnum) DO
spltty(msgbuf,.jobnum);
END;
%FI
END;
%routine('LOGGED_IN', ptr, jobno_) =
BEGIN
%IF %SWITCHES(TOPS20) %THEN
BIND
jobno = .jobno_;
declare_jsys(rcusr,getji,getab);
LITERAL
jibufsiz = 9;
STACKLOCAL
jibuf: VECTOR[jibufsiz];
LOCAL
jobs,
rcbits,
userno;
IF NOT $$getab(actjob;jobs)
THEN
BEGIN !Just in case we're NOT running 7.0
jobs<left_half> = 1; !Minimum jobnumber
jobs<right_half> = 256; !Worst case maximum
END;
$$rcusr(rc_emo,.ptr,0;rcbits,,userno);
IF (.rcbits AND (rc_dir OR rc_nom)) EQL 0
THEN
BEGIN
INCR i FROM .jobs<left_half> TO .jobs<right_half> DO
BEGIN
REGISTER t1=1;
IF $$getji(.i,(-jibufsiz^18)+jibuf,$jitno)
THEN
BEGIN
IF .jibuf[$jiuno-$jitno] EQL .userno !Right user?
THEN
IF .jibuf[$jitno-$jitno] GTR 0 !Yes, Detached?
THEN
IF .jibuf[$jicpj-$jitno] LSS 0 !No, PTY?
THEN
IF .jibuf[$jibat-$jitno] GEQ 0 !No, Batch?
THEN
BEGIN !Found him!
jobno = .i;
RETURN 1;
END
END
ELSE
IF .t1 EQL gtjix3
THEN
EXITLOOP;
END;
END;
jobno = -1;
RETURN 0;
%ELSE !Begin TOPS-10 Conditional
BIND
ppn = ptr,
jobno = .jobno_;
IF NOT fndusr(.ppn, 0; jobno)
THEN
BEGIN
jobno = -1;
RETURN 0
END
ELSE
RETURN 1;
%FI
END;
%global_routine('MX$VALIDATE_LOCAL_USER', len, namptr, pobptr) =
BEGIN
%IF %SWITCHES(TOPS20) %THEN
declare_jsys(rcdir,lnmst);
STACKLOCAL
rcbits,
nambuf: VECTOR[CH$ALLOCATION(max_local_user_length)];
OWN
logbuf: VECTOR[CH$ALLOCATION(256)];
LOCAL
sptr,
eptr,
ptr,
done,
err;
BIND
pobox = CH$PTR(UPLIT(%ASCIZ'POBOX')),
poboxc = CH$PTR(UPLIT(%ASCIZ'POBOX:')),
logptr = CH$PTR(logbuf);
IF CH$RCHAR(.namptr) EQL %C'"'
THEN
BEGIN
len = .len - 2;
namptr = CH$PLUS(.namptr,1);
END;
IF NOT $$lnmst($lnssy,pobox,logptr;err)
THEN
IF .err EQL lnstx1 !Not a logical name
THEN
CH$MOVE(7,poboxc,logptr) !POBOX: might be a real structure
ELSE
%(318)% $error( SEVERITY = STS$K_SEVERE,
%(318)% FACILITY = $err,
CODE = mx$ctp,
%(318)% OPTIONAL_MESSAGE = (FAC=$mon),
OPTIONAL_DATA = .err);
CH$TRANSLATE(uc_tab,
.len, .namptr,
0,
.len+1, CH$PTR(nambuf));
IF CH$EQL(7,CH$PTR(UPLIT(%ASCIZ'SYSTEM')),
7, CH$PTR(nambuf),
0)
THEN
BEGIN
CH$MOVE(%CHARCOUNT('POBOX:<SYSTEM>') + 1,
CH$PTR(UPLIT(%ASCIZ'POBOX:<SYSTEM>')),
CH$PTR(.pobptr));
RETURN -1;
END;
eptr = sptr = logptr;
done = $false;
WHILE NOT .done DO
BEGIN
IF CH$RCHAR_A(eptr) EQL %C':'
THEN
BEGIN
IF CH$RCHAR(.eptr) EQL 0
THEN
done = $true
ELSE
CH$WCHAR(0,.eptr);
ptr = CH$PTR(.pobptr);
$nmu$text(ptr,max_string_length,'%A<%A>',.sptr,CH$PTR(nambuf));
IF NOT $$rcdir(rc_emo,CH$PTR(.pobptr),0;
rcbits)
THEN
EXITLOOP;
IF ((.rcbits AND (rc_dir OR rc_nom OR rc_amb)) EQL 0)
THEN
RETURN $true;
sptr = (eptr = CH$PLUS(.eptr,1));
END
END;
mx$update_pobox_status();
IF .pobsts EQL 1
THEN
RETURN 0
ELSE
RETURN 3
%ELSE ! Tops 10
STACKLOCAL
nambuf: VECTOR[CH$ALLOCATION(max_local_user_length)];
BIND
pobadr = .pobptr;
![303] ADD CHECK FOR QUOTED STRING
IF CH$RCHAR(.namptr) EQL %C'"'
THEN
BEGIN
len = .len - 2;
namptr = CH$PLUS(.namptr,1);
END;
CH$WCHAR(0, CH$MOVE(.len, .namptr, CH$PTR(nambuf,0,8)));
RETURN (namppn(nambuf; pobadr));
%FI
END;
![307] ADD PARAMETER INVFLG AND ROUTINE COMMENT
%global_routine('MX$GET_USERNAME', uid, vflg) = ![307]
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine returns an asciz string representing the userid. On
! TOPS-20 this is the output of a DIRST. On TOPS-10, this is either the
! username from the accounting system, or his PPN converted to a string if no
! accounting entry exists for the PPN. If the resulting string contains
! special characters, quotes are put around the offending string. An @
! followed by the local node name is appended to the string.
! In addition, MX's internal servers generate UID's that look like
! <-1,,ADDR> where ADDR is the address of an ASCIZ string. In this case, a
! copy of the asciz string beginning at ADDR will be returned. This is used
! by MX's internal servers (such as MAIL-11 and SMTP) to set up appropriate
! log file entries.
!
! FORMAL PARAMETERS:
!
! UID:
! TOPS-20: a user number/directory number suitable for DIRST or
! <-1,,ADDR>
! TOPS-10: a PPN or <-1,,ADDR>
!
! VFLG: An address in which to return 1 if this is a valid user, and
! 0 otherwise.
!
! IMPLICIT INPUTS:
!
! NONE
!
! IMPLICIT OUTPUTS:
!
! NONE
!
! COMPLETION CODES:
!
! NONE
!
! SIDE EFFECTS:
!
! NONE
!--
![303] ADD SPECIAL-CHARACTER TRANSLATION TABLE
![306] ADD "." TO SPECIAL-CHARACTER TABLE
BIND
trntbl = CH$TRANSTABLE(special_characters(' "(),.;<>@[\]'));
![314] All the possible USERNAME strings:
![314] - "User Name"@NODE
![314] - USERNAME@NODE
![314] - "User Name"
![314] - USERNAME
BIND ![314]
net_quotes = UPLIT(%ASCIZ %STRING('"%A"@%A')), ![314]
net_noquotes = UPLIT(%ASCIZ %STRING('%A@%A')), ![314]
nonet_quotes = UPLIT(%ASCIZ %STRING('"%A"')), ![314]
nonet_noquotes = UPLIT(%ASCIZ %STRING('%A')); ![314]
STACKLOCAL ![314]
user_string; ![314]
%IF %SWITCHES(TOPS20) %THEN
declare_jsys(dirst);
LOCAL
ptr,
nambuf: VECTOR[CH$ALLOCATION(max_string_length)],
tmpbuf: VECTOR[CH$ALLOCATION(max_string_length)],
quote,
len; ![306]
.vflg = $true; ![307] INITIALIZE VFLG TO TRUE
IF .uid LSS 0
THEN
RETURN copy_asciz(CH$PTR(.uid<0,18,0>));
![306] CALCULATE LENGTH OF USERNAME AND USE IT
uid = .uid OR %O'500000000000';
$$dirst(CH$PTR(nambuf), .uid; ptr); ![306] Save updated byte pointer
len = CH$DIFF(.ptr,CH$PTR(nambuf)); ![306]
![307] SET VFLG TRUE IF VALID, FALSE OTHERWISE
.vflg = mx$validate_local_user(.len, CH$PTR(nambuf), tmpbuf);
![303] QUOTE THE USERNAME IF IT CONTAINS SPECIAL CHARACTERS
ptr = CH$PTR(tmpbuf);
CH$TRANSLATE(trntbl,
.len, CH$PTR(nambuf), 0, ![306]
.len, .ptr); ![306]
quote = CH$FIND_CH(.len,.ptr,1);
![314] Pick the correct format username string
user_string = (IF CH$FAIL(.quote)
THEN
IF .nodnam NEQ 0 THEN net_noquotes
ELSE nonet_noquotes
ELSE
IF .nodnam NEQ 0 THEN net_quotes
ELSE nonet_quotes);
len = $nmu$text(ptr,max_string_length,'%I', ![314]Format the username
CH$PTR(.user_string), ![314]The control string
CH$PTR(nambuf), ![314]The user name
CH$PTR(nodnam)); ![314]The node name
RETURN
copy_asciz(CH$PTR(tmpbuf));
%ELSE
STACKLOCAL
tmpbuf: VECTOR[CH$ALLOCATION(max_string_length)],
len,
ptr,
adr,
quote; ![303]
.vflg = $true; ![307] SET VFLG TRUE
IF .uid LSS 0
THEN
RETURN copy_asciz(CH$PTR(.uid<0,18,0>));
IF ppnnam(uid; adr) !Adr contains the address of the user's profile
THEN
BEGIN
ptr = CH$PTR(tmpbuf);
![303] QUOTE THE USERNAME IF IT CONTAINS SPECIAL CHARACTERS
CH$TRANSLATE(trntbl,
39, CH$PTR(.adr,0,8), 0,
39, .ptr);
quote = CH$FIND_CH(39,.ptr,1);
![314] Pick the right username format...
user_string = (IF CH$FAIL(.quote)
THEN
IF .nodnam NEQ 0 THEN net_noquotes
ELSE nonet_noquotes
ELSE
IF .nodnam NEQ 0 THEN net_quotes
ELSE nonet_quotes);
len = $nmu$text(ptr,max_string_length,'%I', ![314]Format the username
CH$PTR(.user_string), ![314]The control string
CH$PTR(.adr,0,8), ![314]The user name
CH$PTR(nodnam)); ![314]The node name
RETURN copy_string(CH$PTR(tmpbuf),
CH$LEN(CH$PTR(tmpbuf), max_string_length) + 1);
END
![307] ADD "ELSE" CLAUSE SO THAT ALL USERS GET A STRING...
ELSE
BEGIN
.vflg = $false;
ptr = CH$PTR(tmpbuf);
$nmu$text(ptr,max_string_length,'"[%O,%O]"',
.uid<18,18,0>,
.uid<0,18,0>);
RETURN copy_asciz(CH$PTR(tmpbuf));
END;
%FI
END;
%global_routine('MX$BUILD_REPAIR_SPEC', msg: REF message_table_entry)=
BEGIN
%IF %SWITCHES(TOPS20) %THEN
STACKLOCAL
user_buffer: VECTOR[CH$ALLOCATION(50)];
LOCAL
len,
ptr;
BIND
p1 = CH$PTR(UPLIT('POBOX:<')),
p2 = CH$PTR(UPLIT('>')),
ps = CH$PTR(.msg[msg_sender_string]),
pe = CH$PTR(.msg[msg_env_spec],3),
pbuf = CH$PTR(user_buffer);
ptr = CH$FIND_CH(31, ps, %C'@');
IF CH$FAIL(.ptr)
THEN
len = CH$LEN( ps )
ELSE
len = CH$DIFF( .ptr, ps);
CH$COPY(%CHARCOUNT('POBOX:<'), p1,
.len, ps,
1, p2,
CH$LEN(pe), pe,
0,
50, pbuf);
copy_string(pbuf, CH$LEN(pbuf) + 1)
%ELSE
0
%FI
END;
GLOBAL ROUTINE getdat(ptr) =
BEGIN
%IF %SWITCHES(TOPS10) %THEN
STACKLOCAL
datbuf: VECTOR[CH$ALLOCATION(30)];
LOCAL
ch,
p;
udtdat(-1,datbuf);
p = CH$PTR(datbuf);
WHILE (ch = CH$RCHAR_A(p)) NEQ 0 DO CH$WCHAR_A(.ch, ptr);
RETURN .ptr;
%ELSE 0
%FI
END;
%IF %SWITCHES(TOPS10) %THEN
%global_routine('MXUFDE', prefix, text): UFD1 NOVALUE =
BEGIN
log(.text,0) %(318)%
END;
%FI
%global_routine('MX$TIME_TIL_SHUTDOWN') =
!This routine is not yet implemented...
BEGIN
RETURN 1234567;
END;
END
ELUDOM