GA.JPH@ISUMVS.BITNET ("John Hascall") (09/03/87)
$!
$!Fellow netters:
$!
$! Since I received multiple requests for my VMS foreign protocol mail
$!interface program, here it is... But first the caveats:
$!
$! 0) This file is ^ 100K.
$!
$! 1) This program is provided "AS IS". You are free to do whatever
$! NON-COMMERCIAL things to it that you desire. The program
$! appears to work correctly here, but of course that is no
$! guarantee.
$!
$! 2) This program needs another process to actually transmit and
$! receive the mail, all it does is interface with VMS MAIL and
$! produce an envelope around the message and place the message
$! in a spool directory and awaken the delivery process.
$!
$! 3) You will need to change some logical names and file names in
$! the .com files.
$!
$! 4) This program needs to be installed with privileges, so follow
$! appropriate coding practices.!
$!
$! 5) This program was derived from one given to me by Gerard K. Newman,
$! so there are, no doubt, some things which are done in a less than
$! optimal way due to interactions between his code and mine (in fact,
$! I believe there is even some code which is never used somewhere).
$! Feel free to make improvements.
$!
$!Enough of that, here are the files:
$!
$! BIT.OPT Linker options file
$! BITNET.MSG Message file
$! BITNET_MAILSHR.MAR The program
$! DEL.COM A command file to de-install the image
$! NEW.COM A command file to install the image
$! TEST.MAR A program I used to understand the protocol
$!
$! John Hascall
$! ISU Computation Center
$! GAJPH@ISUMVS.BITNET
$!
$create/log bit.opt
$deck/dollars="$END-OF-FILE"
UNIVERSAL=MAIL$PROTOCOL
UNIVERSAL=MAIL$C_PROT_MAJOR
UNIVERSAL=MAIL$C_PROT_MINOR
$END-OF-FILE
$!
$create/log bitnet.msg
$deck/dollars="$END-OF-FILE"
.Title Bitnet_MailShr_Msg Bitnet_MailShr error messages
.Ident "Bitnet_MailShr V01.00"
!+
!
! ----- Bitnet_MailShr_Msg: Bitnet_MailShr error messages
!
!
! Facility:
!
! VAX/VMS personal mail utility
!
! Abstract:
!
! This module contains the messages for the Bitnet_MailShr module
! which uses the undocumented Mail$protocol interface to deliver
! mail on the DoD internet.
!
! Environment:
!
! VAX/VMS native mode, VMS V4.0 or later
!
!
! Version: V01.000
! Date: 07-Sep-1985
!
! Gerard K. Newman 07-Sep-1985
! Science Applications International
! 800 Oak Ridge Turnpike
! Oak Ridge, TN 37830
! (615) 482-9031
!
!
! Modifications:
!
! Date: 22-Jun-1987
!
! John Hascall
! Iowa State University
! Ames, IA 50010
! (515) 294-9889
!
! Modified for the ISU environment
!-
.Facility Bitnet,100/Prefix=Bit$_
.Severity Fatal
UNKFUNC <Unknown function code !UL received from VMSmail>/FAO_Count=1
INTCODERR <Internal error, please report to Debug room, 1 Com Sci, 4-1314>
NOMCB <No Mail Control Block (MCB)>
OPENIN <Error opening !AS as input>/FAO_Count=1
INPERR <Error reading input file>
NOINFILE <No input file to deliver>
INVMSGFIL <Invalid format for inbound message file>
INVMSGTYP <Invalid type for inbound mail>
INVSOURCE <Invalid source User-ID and/or source node>
.Severity Error
INVADDR <Invalid destination address>
.Severity Informational
BADHDRITM <Illegal field in BITNET_MAIL.HEADER: "!AS">/FAO_Count=1
.End
$END-OF-FILE
$!
$create/log bitnet_mailshr.mar
$deck/dollars="$END-OF-FILE"
.Title Bitnet_MailShr BITNET mail protocol interface
.Ident /V01.000/
.Subtitle Introduction
.Enable SUP
;+
;
; ----- Bitnet_MailShr: BITNET mail protocol interface
;
;
; Facility:
;
; VAX/VMS personal mail utility.
;
; Abstract:
;
; This module provides a mechanism for the VAX/VMS personal
; Mail utility to send and receive mail on BITNET through
; the NAS AS/9160 using the undocumented Mail$Protocol
; interface.
;
; Thanks to Gerard K. Newman of the San Diego Supercomputer
; Center for providing his version of this program (for an
; ArpaNet site).
;
; (Thanks to Kevin Carosso at Hughes Aircraft for providing
; much of the inspiration for this software and for helping
; to document the inner workings of the Mail utility.)
;
; Environment:
;
; VAX/VMS native mode, VMS V4.0 or later, Installed (on all
; machines in a VAXcluster) in the SYS$SHARE: directory (the
; common directory on a VAXcluster) with SYSPRV, NETMBX, WORLD,
; and OPER privileges, merged via LIB$FIND_IMAGE_SYMBOL.
;
;
; Version: V01.000
; Date: 22-Jun-1987
;
; Modifications:
;
;-
.Page
.Subtitle Shareable image transfer vectors
.Psect CODE EXE,RD,NOWRT,PIC,SHR,PAGE
.Transfer MAIL$PROTOCOL ;Generate a transfer vector
.Mask MAIL$PROTOCOL ; and entry mask
JMP LMAIL$PROTOCOL+2 ;Jump to the real code
.Page
.Subtitle Local definitions
.NoCross ;Save a tree
$CHFDEF ;Define condition handler facility stuff
$DSCDEF ;Descriptor definitions
$FABDEF ;FAB definitions
$JPIDEF ;JPI item codes
$PRVDEF ;Privilege bit masks
$PSLDEF ;Processor status longword format
$RABDEF ;RAB definitions
$RMSDEF ;RMS junk
$SSDEF ;System service codes
$STSDEF ;Define error severity codes
$TPADEF ;TPARSE definitions
.Cross ;Turn CREF back on
; Local macros
; ITEM: Make an item list entry for $GETxxI
Macro ITEM TYPE=JPI,ITEM=,LENGTH=4,RETADR=,RETLEN=
.Word LENGTH,TYPE'$_'ITEM ;Length,,what
.Address RETADR ;Put it here
.If NB,RETLEN ;Have an explicit return length?
.Address RETLEN ; then use it
.Iff ; else
.Long 0 ; we don't care
.Endc ; ...
Endm ITEM ; ...
; .ascip: Create a pointer to an .ascic string
Macro .ascip STRING,?A ;Point to string descr in another PSECT
.Enable LSB ;Turn on the local symbol block
.Save ;Save the current PSECT
.Psect STRINGS NOEXE,RD,NOWRT,PIC,SHR,PAGE
A: .ascic \'STRING\ ;String
.Restore ;Restore the current PSECT
.Address A ;Store pointer to the string
.Disable LSB ;Turn off the local symbol block
Endm .ascip ; ...
; ADDRESS_MCB Get the address of the MCB (and check for error)
macro ADDRESS_MCB TO,OK
MOVL @MCB(AP),TO ;Address our MCB
BNEQ OK ;If NEQ OK
PUSHL #BIT$_NOMCB ;Error detail = No MCB
CLRL -(SP) ;No FAO parameters
PUSHL #BIT$_INTCODERR ;Error is Internal Coding Error
CALLS #3,GLIB$STOP ;Signal the error
endm ADDRESS_MCB
; Local definitions
; Mail major and minor protocol identifiers. These must be made univseral
; symbols via the linker to make MAIL happy.
MAIL$C_PROT_MAJOR == 1 ;Major version
MAIL$C_PROT_MINOR == 1 ;Minor version
; Mail function codes, taken from the SDL file for mail
LNK_C_FIRST = 0 ;First function code
LNK_C_OUT_CONNECT = 0 ;Outbound connect
LNK_C_OUT_SENDER = 1 ;Output the sender (From:) line
LNK_C_OUT_CKUSER = 2 ;Check for a valid user ID outbound
LNK_C_OUT_TO = 3 ;Output the recipient (To:) line
LNK_C_OUT_SUBJ = 4 ;Output the subject (Subject:) line
LNK_C_OUT_FILE = 5 ;Output a file
LNK_C_OUT_CKSEND = 6 ;Check to see if we can send a message
LNK_C_OUT_DEACCESS = 7 ;Clean up after ourselves
LNK_C_IN_CONNECT = 8 ;Inbound connect
LNK_C_IN_SENDER = 9 ;Return the sender (From:) line
LNK_C_IN_CKUSER = 10 ;Check for a valid user ID inbound
LNK_C_IN_TO = 11 ;Return the recipient (To:) line
LNK_C_IN_SUBJ = 12 ;Return the subject (Subject:) line
LNK_C_IN_FILE = 13 ;Input a file
LNK_C_IO_READ = 14 ;Read a line
LNK_C_IO_WRITE = 15 ;Write a line
LNK_C_LAST = 15 ;Last function code
; Argument list offsets
MCB = 4 ;MCB address
FUNC = 8 ;Function code
;func=0
F0_PROTOCOL = 12 ;-> descriptor of our protocol name
F0_NODE = 16 ;-> descriptor of our node name
F0_LOGLINK = 20 ;logical link (immediate)
F0_RAT = 24 ;RAT of mail file (immediate)
F0_RFM = 28 ;RFM of mail file (immediate)
F0_FLAG = 32 ;global flags (immediate)
F0_ATTFILE = 36 ;->descriptor of attached file
;func=1
F1_NODE = 12 ;->descriptor of senders node
F1_USER = 16 ;->descriptor of senders username
;func=2
F2_NODE = 12 ;->descriptor of recipients node
F2_USER = 16 ;->descriptor of recepients username
F2_ERROR = 20 ;address of routine if bad recipient
;func=3
F3_NODE = 12 ;->descriptor of local node
F3_LINE = 16 ;->descriptor of To: line
;func=4
F4_NODE = 12 ;->descriptor of local node
F4_LINE = 16 ;->descriptor of Subj: line
;func=5
F5_NODE = 12 ;->descriptor of local node
F5_RAB = 16 ;->RAB of file to be mailed
F5_ERROR = 20 ;->routine to call in case of I/O error
;func=6
;func=7
;func=8
F8_XLATE = 12 ;->descriptor of input translate table
F8_RAT = 16 ;FAB$B_RAT
F8_RFM = 20 ;FAB$B_RFM
F8_FLAGS = 24 ;MAIL$GL_SYSFLAGS
F8_PROTOCOL = 28 ;->descriptor of protocol
F8_SFLAGS = 32 ;server flags
;func=9
F9_LINE = 12 ;->descriptor to return From: line to
;func=10
F10_USER = 12 ;->descriptor to return recip username
;func=11
F11_LINE = 12 ;->descriptor to return To: line to
;func=12
F12_LINE = 12 ;->descriptor to return Subj: line to
;func=13
F13_UNUSED = 12 ;???
F13_RAB = 16 ;->output RAB
F13_ERROR = 20 ;->routine to report an I/O error
;func=14
F14_LINE = 12 ;->descriptor to return something
;func=15
F15_LINE = 12 ;->descriptor of something MAIL sent us
; Message Context Block (MCB)
;
; A message context block is allocated for each incoming or outgoing message.
; This structure contains the validated address fields, the FAB and RAB for
; the mail file and a few other assorted pieces of information.
;
; Mail provides us a context variable when it calls us, which we use to store
; the address of this structure.
;
; MCBs are linked together (via the VAX-11 queue instructions) so that we may
; include the entire list of recipents of a message in the To: header line.
;
; This block is rather large...
$DEFINI MCB ;Start of the MCB definitions
$DEF MCB$L_MCBQFL .Blkl ;MCB queue forward link
$DEF MCB$L_MCBQBL .Blkl ;MCB queue backward link
$DEF MCB$L_RBQFL .Blkl ;RB queue forward link
$DEF MCB$L_RBQBL .Blkl ;RB queue backward link
$DEF MCB$L_CUR_RB .Blkl ;Current RB address
$DEF MCB$B_FLAGS .Blkb ;Flags
.Blkb 3 ;Reserved
$DEF MCB$L_TPABLK .Blkb TPA$K_LENGTH0 ;Space for our TPARSE block
$DEF MCB$Q_USER .blkq ;These two are used by TPARSE
$DEF MCB$Q_NODE .blkq ; and thus must follow TPABLK
$DEF MCB$Q_DESC .Blkq ;Scratch descriptor for
; formatting things
$DEF MCB$Q_MSGID .Blkq ;Message ID (system time in
; hex plus some other stuff)
$DEF MCB$L_FAB .Blkb FAB$C_BLN ;Space for our FAB
$DEF MCB$L_RAB .Blkb RAB$C_BLN ;Space for our RAB
$DEF MCB$T_USERNAME .Blkb 16 ;Our username (filled in by
; OUT_SENDER and LOOKUP_USER)
$DEF MCB$L_FAOARGS .Blkl 20 ;An argument list for $FAOL
$DEF MCB$T_SUBJECT .Blkb 256 ;Subject string (counted, built
; by OUT_LINE and IN_FILE)
$DEF MCB$T_FROM .Blkb 256 ;From string (counted, built by
; OUT_SENDER and IN_SENDER)
$DEF MCB$T_TO .Blkb 256 ;To: string as Mail sees it
; (counted, filled in by
; IN_TO and OUT_LINE)
$DEF MCB$T_SCRATCH .blkb 512 ;Some working space
$DEF MCB$K_LENGTH ;Length of an MCB
; Flags in MCB$B_FLAGS (not currently used)
$VIELD MCB,0,<- ;Flags in MCB$B_FLAGS
<RETURNED,,1>,- ; This message was returned
<RTNRCP,,1>,- ; Return receipt requested
<DECNET,,1>,- ; We have a DECnet address
<ATTACHED,,1>,- ; We have an attached file
> ; ...
$DEFEND MCB ;End of the MCB
; Recipient Block (RB)
;
; An RB is allocated for each recipeint of a message. Mail attempts to
; cut overhead by calling us only once per node with the function code
; to write a file, and expects us to deliver multiple copies of that
; file (a reasonable thing to do).
$DEFINI RB ;Start of a Recipient Block
$DEF RB$L_RBQFL .Blkl ;RB queue forward link
$DEF RB$L_RBQBL .Blkl ;RB queue backward link
$DEF RB$L_RECORDS .Blkl ;# of records written to file
$DEF RB$L_MCB .Blkl ;Back pointer to the MCB
$DEF RB$L_FAB .Blkb FAB$C_BLN ;Output FAB
$DEF RB$L_RAB .Blkb RAB$C_BLN ;Output RAB
$DEF RB$T_DESTUSER .Blkb 256 ;The destination username
$DEF RB$T_NODENAME .Blkb 256 ;The destination node name
$DEF RB$K_LENGTH ;Length of the RB
$DEFEND RB ;End of the RB definitions
.Page
.Subtitle TPARSE state tables
$INIT_STATE INTERNET_STATES,INTERNET_KEYS
$STATE
$TRAN !NETWORK_STYLE,TPA$_EXIT,STORE_ADDRESS
$TRAN !DECNET_STYLE,TPA$_EXIT,STORE_ADDRESS
$STATE NETWORK_STYLE ;look for USER@NODE
$TRAN !NET_USER,,SET_USER ;Parse out the user-id
$STATE
$TRAN '@'
$TRAN TPA$_LAMBDA
$STATE ;Node next
$TRAN !TO_EOS,TPA$_EXIT,SET_NODE ;Store the node name
$STATE DECNET_STYLE ;look for NODE::USER
$TRAN !NET_NODE,,SET_NODE ;Parse out the node
$STATE
$TRAN !COLON2
$STATE ;then the user-id
$TRAN !TO_EOS,TPA$_EXIT,SET_USER ;Store the user-id
; Subexpression to parse a network user-id
$STATE NET_USER ;Here to parse the user id
$TRAN TPA$_LAMBDA,TPA$_EXIT,NET_SEP ;Quit when we find a node name.
$TRAN !COLON2,TPA$_FAIL ;Oh ... a DECnet address!
$TRAN TPA$_ANY,NET_USER ;ELSE accept anything else
$TRAN TPA$_EOS,TPA$_EXIT ;no nodename, assume next node
$STATE
$TRAN TPA$_EOS,TPA$_FAIL ;error if nothing after the @
$TRAN TPA$_LAMBDA,TPA$_EXIT
; Subexpression to parse a decnet node name
$STATE NET_NODE ;Here to parse a DECnet node
$TRAN TPA$_LAMBDA,TPA$_EXIT,DEC_SEP ;Quit when we find the '::'
$TRAN TPA$_ANY,NET_NODE ;any other character is ok
$STATE
$TRAN TPA$_EOS,TPA$_FAIL ;error if nothing after the ::
$TRAN TPA$_LAMBDA,TPA$_EXIT
$STATE COLON2 ;Here to search for '::'
$TRAN ':' ;Is there a first colon
$STATE
$TRAN ':',TPA$_EXIT ;and a second one?
$STATE TO_EOS ;get the rest of the address
$TRAN TPA$_ANY,TO_EOS ;accept any character
$TRAN TPA$_EOS,TPA$_EXIT ;Quit only at eos
$END_STATE ;End of the state table
.Page
.Subtitle Impure storage
.Psect IMPURE_DATA NOEXE,RD,WRT,PIC,NOSHR,PAGE
MCB_Q: .Address MCB_Q ;Our MCB
.Address MCB_Q ; queue
FLAGS: .Blkl ;Flags (only 1 so far)
NODE_DESC: .Long 64 ;Our local node name
.Address NODE_NAME ; descriptor
NODE_NAME: .Blkb 64 ;Our local nodename (from logical name)
TIME_ZONE: .Long 4 ;Our time zone
.Address TIME_ZONE_BUFF ; ...
TIME_ZONE_BUFF: .Blkl ;Our timezone
NEAR_DESC: .long 64 ;Our nearest neighbor node
.address NEAR_NODE_BUFF
NEAR_NODE_BUFF: .blkb 64
CUR_PRIVS: .Blkq ;My current privilege mask
SYSPRV: .Long 1@PRV$V_SYSPRV,0 ;SYSPRV bit mask
WORLD: .Long 1@PRV$V_WORLD,0 ;WORLD bit mask
MAILSERVER_PID: .Blkl ;Mail server PID
MAILSERVER_BUF: .Blkb 8 ;Mail server logical name
; Logical names which we need
SPOOL_DIR: .ascid \BITNET_SPOOL\ ;Also used in INCOMING/OUTGOING
BIT_NODE: .ascid \BITNET_NODENAME\ ;Should translate to something
; like ISUVAX.BITNET
NEAR_NODE: .ascid \BITNET_NEXTNODE\ ;Nearest bitnet neighbor
TIMEZONE: .ascid \BITNET_TIMEZONE\ ;Should translate to CST, CDT,
; EST, etc.
MAILSERV: .ascid \BITNET_SERVER_PID\ ;Should translate to the mail
; server pid
POSTMASTER: .ascid \BITNET_POSTMASTER\ ;Should translate to a username
; which will receive lost mail
; Stuff we need from $GETJPI
JPI_INFO: ITEM ITEM=PROCPRIV,- ;Get my current privilege mask
LENGTH=8,- ;8 bytes
RETADR=CUR_PRIVS ;Put them here
.Long 0 ;End of the table
; Days of the week
WEEKDAYS: .ascip <> ;Unknown
.ascip <Mon> ;Monday
.ascip <Tue> ;Tuesday
.ascip <Wed> ;Wednesday
.ascip <Thu> ;Thursday
.ascip <Fri> ;Friday
.ascip <Sat> ;Saturday
.ascip <Sun> ;Sunday
; FAO control strings and other stuff
; first the BSMTP header
FAO_HELO: .ascid \HELO !AD\
VERB: .ascic \VERB ON\
TICK: .ascic \TICK 0001\
FAO_MAIL_FROM: .ascid \MAIL FROM:<!AC@!AD>\
FAO_RCPT_TO: .ascid \RCPT TO:<!AC@!AC>\
DATA: .ascic \DATA\
; then the ARPANET header
FAO_DATE: .ascid \Date: !AC, !17%D !AS\
FAO_TO: .ascid \To: !AC@!AC!AC\
FAO_TO_CONT: .ascid \ !AC@!AC!AC\
COMMA: .ascic \,\
FAO_FROM: .ascid \From: <!AD%!AD@WISCVM.WISC.EDU> (!AD)\
FAO_REPLY_TO: .ascid \Reply-To: !AC\
FAO_SUBJECT: .ascid \Subject: !AC\
FAO_X_VMS_TO: .ascid \X-VMS-To: !AC\
; the message goes here (by the way), then the BSMTP trailer
NULL: .ascic \\
PERIOD: .ascic \.\
QUIT: .ascic \QUIT\
FAO_IN_FROM: .ascid \BITNET%"!AD"\
; Items searched for in the ARPA header
HDR_SUBJECT: .ascid \Subject\
HDR_FROM: .ascid \From\
HDR_TO: .ascid \To\
GATEWAY: .ascic \WISCVM.WISC.EDU\
INCOMING: .ascic \BITNET_SPOOL:INCOMING.MSG\
OUTGOING: .ascic \BITNET_SPOOL:OUTGOING.MSG\
RETURN_RCPT: .ascic \[Return Receipt Requested]\
CLI_TOLIST: .ascid \TOLIST\
CLI_FILE: .ascid \FILE\
RETURNED: .ascid \[Bitnet_MailShr: Returned Network Mail]\
.Page
.Subtitle MAIL$PROTOCOL - Bitnet mail dispatcher
.Psect CODE EXE,RD,NOWRT,PIC,SHR,PAGE
;+
;
; ----- MAIL$PROTOCOL: Foreign mail protocol handler
;
;
; This module is called by the VAX/VMS personal mail utility when it
; detects the presence of a string in the form:
;
; bitnet%"user@node"
;
; in the "to" line or the /Protocol=bitnet_mailshr (and we have DETACH and
; SYSPRV) to deliver incomming mail.
;
; Outbound mail is handled like this: The "to" string is parsed down into
; an internet address and stored in a structure representing an outgoing
; message (the MCB, or Message Context Block). The address of this block
; is stored in the context variable that mail passes to us. A file called
;
; SYS$SCRATCH:OUTGOING.MSG
;
; is opened and is submited to ISUMVS through a NJE interface.
;
; Inbound mail is somewhat more complicated: The NJE interface creates
; a detached process which runs a command file. We can replace that
; command file with one which contains a line like:
;
; MAIL/PROTOCOL=BITNET_MAILSHR filename
;
; which will be used to deliver inbound mail. Mail arrives in a file with
; a network header in the file BITNET_SPOOL:INCOMING.MSG. We pick apart
; the contents of this file, verify that the target user lives here, fix up
; a correct From: line (so that Reply will work) and deliver the mail.
;
; This routine merely dispatches to the correct routine based upon the
; function code that Mail passes us in the second argument (the first
; argument is our context pointer, which we are free to do whatever we
; wish with).
;
; Debugging this is 42 kinds of fun. Assemble and link this (assuming it
; isn't already), remembering to make this a shareable image and to promote
; MAIL$C_PROT_MAJOR and MAIL$C_PROT_MINOR to universal symbols (this is done
; for you if you use the command file that goes along with this). Then you
; have to patch this image and a private copy of MAIL.EXE thusly:
;
; $ Patch/Absolute BITNET_MAILSHR.EXE !Patch this image
; PATCH> Examine/Instr 80A !This should be the address of
; 0000080A: NOP !the NOP instructon below
; PATCH> Deposit/Instr 80A = "BPT" !Make it a BPT instruction
; PATCH> Update !Write the changed file
; PATCH> Exit !And now the MAIL.EXE
;
; $ Patch/Absolute SYS$LOGIN:MAIL.EXE !Patch a COPY!!
; PATCH> Deposit 20 = 1000029 !Set the debug bit (bit 0)
; PATCH> Examine 30 !1st Xfer address
; 00000030: 00001E10 !This is from V4.1 Mail
; PATCH> Deposit 30 = 7FFEDF68 !Make it the traceback handler
; PATCH> Deposit 34 = 00001E10 !Or whatever was in loc 30.
; PATCH> Update !Write it out
; PATCH> Exit !Ta dum
;
; Now define a logical name of MAIL to point to this patched version of
; Mail, copy BITNET_MAILSHR.EXE to SYS$SHARE: (the common directory if you
; are on a VAXcluster) and install the image as follows:
;
; $ Install :== $sys$system:install/command
; $ Install
; INSTALL> Add sys$share:bitnet_mailshr/open/head/share -
; /priv=(NETMBX,WORLD,SYSPRV,OPER)
; $ Exit
;
; There are several things which are important to remember:
;
; 1. Mail merges your shared image via LIB$FIND_IMAGE_SYMBOL at
; run time, so your code won't be loaded when the debugger
; announces itself (this is the reason for the BPT instruction).
;
; 2. Remember to do a SET EXECPTION BREAK command first thing in debug.
;
; 3. Remember to replace the BPT with a NOP when the exception
; hits, set a breakpoint there, and to a GO .+1 the first time
; to get past the exception !
;
; 4. You may want to remove the requirement for executive mode
; logical names while you're debugging (makes things that much
; easier).
;
;-------------------------------------------------------------------------
;
; Inputs:
;
; 0(AP) - Number of arguments (varies with the function code)
; 4(AP) - Context block pointer
; 8(AP) - Function code
;
; Outputs:
;
; Control is passed to the appropriate routine to handle things.
; Error messages are signalled (Mail catches them).
;
;-
.Entry MAIL$PROTOCOL,M<R2,R3,R4,R5,R6,R7,R8,R9,R10,R11> ;Entry here
NOP ;Replace this with BPT to debug!!
NOP ;One more for good measure
; Get a condition handler so that we can accurately report errors (can't trust
; Mail).
MOVAB COND_HANDLER,(FP) ;Establish our condition handler
; Dispatch to the correct spot based on function code:
CASEB FUNC(AP),#LNK_C_FIRST,#<LNK_C_LAST-LNK_C_FIRST>
; Outbound mail
10$: .Word OUT_CONNECT-10$ ;Establish an outbound link
; (allocate a MCB)
.Word OUT_SENDER-10$ ;Output the sender
; (parse username and personal name)
.Word OUT_DEST-10$ ;Validate a the destination username
.Word OUT_LINE-10$ ;Output the To: line
.Word OUT_LINE-10$ ;Output the Subject: line
.Word OUT_FILE-10$ ;Output a file (do all of the hard work)
.Word WAKE_VAXNJI-10$ ;Check on the status of a recently sent
; file (wake up mailer process)
.Word OUT_DEACCESS-10$ ;Clean up (deallocate an MCB)
; Inbound mail
.Word IN_CONNECT-10$ ;Inbound connect request
; (allocate an MCB)
.Word IN_SENDER-10$ ;Copy the From: line
.Word IN_RECIP-10$ ;Return the next recipient
.Word IN_TO-10$ ;Copy the To: line
.Word IN_SUBJ-10$ ;Copy the Subject: line
.Word IN_FILE-10$ ;Copy the file inbound (most of the
; work is done here)
.Word IO_READ-10$ ;Read a record
.Word IO_WRITE-10$ ;Write a record
; Unknown function code. Complain back at mail.
PUSHL FUNC(AP) ;Stack the offending function code
PUSHL #1 ;1 FAO parameter
PUSHL #BIT$_UNKFUNC ;Unknown function code
CALLS #3,GLIB$STOP ;Signal it back to mail
.Page
.Subtitle OUT_CONNECT - Outbound connect request
;+
;
; ----- OUT_CONNECT: Outbound connect request
;
;
; This routine is called by the main line dispatcher when mail has requested
; that we make an outbound connect request. Since all we do is to write a
; file in a specific spot, we don't really have to "connect" to anything.
; Instead, we allocate and initialize an MCB and stash it to use later.
;
; Inputs:
;
; 0(AP) - 9 (arguments)
; 4(AP) - MCB address
; 8(AP) - Function code
; 12(AP) - Address of our protocol name descriptor
; 16(AP) - Address of our node name descriptor
; 20(AP) - MAIL$_LOGLINK (immediate)
; 24(AP) - RAT for the mail file (immediate)
; 28(AP) - RFM for the mail file (immediate)
; 32(AP) - MAIL$GL_FLAGS (immediate)
; 36(AP) - Address of the attached file descriptor
;
; Implicit inputs:
;
; Registers saved by the MAIL$PROTOCOL entry point; Our call frame
; must still be current. We will return via a RET instruction.
;
; Outputs:
;
; @4(AP) - Gets the MCB address
; R0 - Status
;
;-
CONNECT_COMMON: .Word M<> ;Internal entry point.
OUT_CONNECT: ;Ref. label
MOVAQ -(SP),R7 ;Address some working storage
; Do some preliminaries like get our node name and privilege mask
BBSS #0,FLAGS,10$ ;Have we already done this?
BSBW RANDOM_INIT ;Else do random initializations
; Allocate an MCB
10$: MOVZWL #MCB$K_LENGTH,4(R7) ;Need this much memory
PUSHAL (R7)+ ;Return the address here
PUSHL R7 ;We want this much memory
CALLS #2,GLIB$GET_VM ;Go allocate some memory
BLBC R0,20$ ;Sigh.
; Initialize the MCB; do the FAB and RAB first
MOVL -(R7),R7 ;Address the MCB
MOVL R7,@MCB(AP) ;Store its address in the
; context variable
MOVC5 #0,#0,#0,#MCB$K_LENGTH,(R7) ;Zero the MCB
MOVAL MCB$L_FAB(R7),R0 ;Address the FAB
MOVB #FAB$C_BID,FAB$B_BID(R0) ;Fill in the RMS block ID
MOVB #FAB$C_BLN,FAB$B_BLN(R0) ;Fill in the RMS block length
MOVAL MCB$L_RAB(R7),R0 ;Address the RAB
MOVB #RAB$C_BID,RAB$B_BID(R0) ;Fill in the RMS block ID
MOVB #RAB$C_BLN,RAB$B_BLN(R0) ;Fill in the RMS block length
MOVAL MCB$L_FAB(R7),RAB$L_FAB(R0) ;Fill in the FAB address
; Initialize the TPARSE block
MOVAL MCB$L_TPABLK(R7),R0 ;Address our TPARSE block
MOVL #TPA$K_COUNT0+4,TPA$L_COUNT(R0) ;Fill in the argument count
MOVL #<1@TPA$V_BLANKS>,TPA$L_OPTIONS(R0) ;Process blanks explicitly
; Initialize the rest of the block
MOVAL MCB$L_RBQFL(R7),MCB$L_RBQFL(R7) ;Initialize the
MOVAL MCB$L_RBQFL(R7),MCB$L_RBQBL(R7) ; RB queue header
INSQUE (R7),@MCB_Q ;Tack onto the MCB queue
; We're done
MOVL #SS$_NORMAL,R0 ;Success !
20$: RET ;Back to MAIL
.Page
.Subtitle OUT_SENDER - Output the From: line
;+
;
; ----- OUT_SENDER: Output the From: line
;
;
; This routine is called by the main line dispatcher to provide the text
; for the From: line back to Mail. It is here that we must create a
; valid internet From: string in the form:
;
; <user%node@gateway.domain> (personal-name)
;i.e., <[EVAX::]GAJPH%ISUVAX.BITNET@WISCVM.WISC.EDU> (John Hascall)
;
; Inputs:
;
; 0(AP) - 4 (arguments)
; 4(AP) - MCB address
; 8(AP) - Function code
; 12(AP) - Node descriptor address (for those who use CCVAX::Bitnet%...)
; 16(AP) - Sender descriptor addres (username plus personal name in "")
;
; Implicit inputs:
;
; Registers saved by the MAIL$PROTOCOL entry point; Our call frame
; must still be current. We will return via a RET instruction.
;
; Outputs:
;
; MCB$T_FROM filled in.
;
;-
OUT_SENDER: ;Ref. label
ADDRESS_MCB R11,10$
; Parse down the username to locate the first trailing space and copy that
; into the line so far. Store this as the first FAO argument.
10$: MOVAB MCB$T_USERNAME(R11),R3 ;R3 -> username counted string
MOVQ @F1_USER(AP),R8 ;Retrieve the username descriptor
LOCC #A/ /,R8,(R9) ;Locate any trailing spaces
SUBW3 R0,R8,R6 ;Length of the username in R6
MOVB R6,(R3)+ ;Store count for username
MOVC3 R6,(R9),(R3) ;Copy in username
; Now construct the first part of the argument list, which is input to the
; first !AD in FAO_FROM...
MOVAL MCB$L_FAOARGS(R11),R10 ;Address the FAO argument list
MOVZWL R6,(R10)+ ;Length of the username
MOVAB MCB$T_USERNAME+1(R11),(R10)+ ;Address of the username
; Next argument in the FAO list is the local node name and domain, which was
; gotten earlier when OUT_CONNECT was called for the first time (it's the
; translation of the logical name BITNET_NODENAME).
MOVQ NODE_DESC,(R10)+ ;Store a descr of the node and domain
; The last argument is the personal name descriptor. If there is one, it will
; be at the end of the string mail fed us as the username wrapped up in a pair
; of ""s. We have two options of how we could construct an internet From:
; string. The first is the way we're doing it, which is to place the machine
; usable address first enclosed in <> and followed with the personal name in
; (). The () indicate that what's enclosed is a comment and for the incoming
; mailer to ignore it.
;
; The second option would be to put the personal name first (sans ()) followed
; by the machine usable address in <>. This scheme would require that we
; scan the personal name string for characters which require quoting and
; include the double quotes if any were found. All in all, I don't really
; think it matters all that much...
LOCC #A/"/,R8,(R9) ;Do we have a personal name?
BEQL 20$ ;If EQL no
INCL R1 ;Point past this character
SUBL #2,R0 ;Adjust the length to exclude both "s
20$: MOVQ R0,(R10)+ ;Store what LOCC left as
; the last FAO argument
MOVZBL #255,MCB$Q_DESC(R11) ;Set length of the buffer
MOVAB MCB$T_FROM+1(R11),MCB$Q_DESC+4(R11) ;Set address of the buffer
$FAOL_S CTRSTR=FAO_FROM,- ;Format the
OUTBUF=MCB$Q_DESC(R11),- ; From: line
OUTLEN=MCB$Q_DESC(R11),- ; ...
PRMLST=MCB$L_FAOARGS(R11) ; ...
MOVB MCB$Q_DESC(R11),MCB$T_FROM(R11) ;Make a counted string for
; the From: line
RET ;We're done (R0 has status)
.Page
.Subtitle OUT_DEST - Output the destination (To:) field
;+
;
; ----- OUT_DEST: Output the destination (To:) field
;
;
; This routine is called by the main line dispatcher when it is called by
; Mail with a function code of LNK_C_OUT_CKUSER. This function is really
; supposed to be used to check for a valid username on a remote node, but
; we use it to construct an appropriate To: line instead (and check the
; syntax of what the user fed us as a side-effect).
;
; This routine will be called more than once per connection, with the
; last call having a null byte as the username string. The idea behind
; this is that Mail will only have to ship the message across the link
; once for multiple recipients on a remote node. However, if Mail does
; detect that we're sending messages to multiple nodes under a foreign
; protocol it calls us once per node (this only seems to happen if the
; address is specified DECnet style, i.e., BITNET%ISUMVS::GAJPH).
;
; Because we allocate a seperate RB for each recipient we have no problem
; sending multiple messages to multiple recipients on the same node.
;
; Inputs:
;
; 0(AP) - 5 arguments
; 4(AP) - MCB address
; 8(AP) - Function code
; 12(AP) - Address of a string descriptor containing the node name
; 16(AP) - Address of a string descriptor containing the addressee
; 20(AP) - Address of UTIL$REPORT_ERROR
;
; Implicit inputs:
;
; Registers saved by the MAIL$PROTOCOL entry point; Our call frame
; must still be current. We will return via a RET instruction.
;
; Outputs:
;
; The To: line is copied into an RB, and the RB is added to the
; RB chain in the MCB.
;
;-
OUT_DEST: ;Ref. label
MOVL #SS$_NORMAL,R0 ; Assume all is OK
ADDRESS_MCB R11,20$
10$: RET ; status in R0
; Check for the null username string, and return if we find it
20$: MOVQ @16(AP),R1 ;Obtain the username descriptor
TSTB (R2) ;Does it start with a null byte ?
BEQL 10$ ;If EQL yes, we're done
; Ok. Allocate another RB for this guy.
MOVAQ -(SP),R2 ;Address some scratch space
MOVL #RB$K_LENGTH,4(R2) ;We need this much memory
PUSHAL (R2)+ ;Return the address here
PUSHL R2 ;We need this much memory
CALLS #2,GLIB$GET_VM ;Go allocate some memory
BLBC R0,10$ ;No!
MOVL -(R2),R10 ;Address the RB
MOVC5 #0,#0,#0,#RB$K_LENGTH,(R10) ;Zero the RB
MOVAL RB$L_FAB(R10),R0 ;Address the FAB in the RB
MOVB #FAB$C_BID,FAB$B_BID(R0) ;Make a FAB
MOVB #FAB$C_BLN,FAB$B_BLN(R0) ; ...
MOVAL RB$L_RAB(R10),R0 ;Address the RAB in the RB
MOVB #RAB$C_BID,RAB$B_BID(R0) ;Make a RAB
MOVB #RAB$C_BLN,RAB$B_BLN(R0) ; ...
MOVAL RB$L_FAB(R10),RAB$L_FAB(R0) ;Point back to the FAB
MOVL R11,RB$L_MCB(R10) ;Point back to the MCB
INSQUE (R10),@MCB$L_RBQBL(R11) ;Insert this RB onto the RB queue
; Ok. We have something that looks like it might be a real username. What
; we have to do next is to see if we have a node descriptor (eg - someone
; used the
;
; Bitnet%WISCVM.WISC.EDU::USERID
;
; form of the address. This makes our life that much easier since we don't
; have to feed the string we got to TPARSE. Regardless of what username
; we got fed we subject it to logical name translation just because we're
; such Nice Guys (and No, we don't always finish last).
MOVZWL #512,MCB$Q_DESC(R11) ;Create a descr of our scratch buffer
MOVAB MCB$T_SCRATCH(R11),MCB$Q_DESC+4(R11) ; ...
$TRNLOG_S LOGNAM=@16(AP),- ;Subject it to
RSLBUF=MCB$Q_DESC(R11),- ; logical name
RSLLEN=MCB$Q_DESC(R11) ; translation
; Store the UNtranslated form of our username argument for the To: string
; for the time being.
MOVQ @16(AP),R0 ;Obtain the username descriptor
MOVZBL R0,R0 ;Only 256 bytes, please
MOVB R0,MCB$T_TO(R11) ;Make a counted string
MOVC3 R0,(R1),MCB$T_TO+1(R11) ;Store the username string
; Now play around with the translation of the username to see what we can do...
MOVQ MCB$Q_DESC(R11),R6 ;Get a descriptor of the result
MOVZBL R6,R6 ;Only want up to 256 bytes...
MOVB R6,RB$T_DESTUSER(R10) ;Store what we have as the
MOVC3 R6,(R7),RB$T_DESTUSER+1(R10) ; destination username Just In Case
ADDL R6,MCB$Q_DESC+4(R11) ;Update the descriptor to use a
SUBL R6,MCB$Q_DESC(R11) ; different part of scratch buffer
MOVQ @12(AP),R8 ;Retrieve the node descriptor
TSTW R8 ;Do we have one ?
BEQL 40$ ;Have to look in the username
; Ok. We have a seperate node name. Copy it into the destination node name
; spot.
MOVZBL R8,R8 ;Only 255 characters please
MOVB R8,RB$T_NODENAME(R10) ;Make it an .ascic string
MOVC3 R8,(R9),RB$T_NODENAME+1(R10) ;Store the node name
; At some point we should do intellegent domain routing here !!!
30$: MOVL #SS$_NORMAL,R0 ;Success !
RET ;We're done
; Oh well. Feed the translation of the username string to TPARSE and
; see if it can isolate the node name...
40$: MOVL R10,MCB$L_CUR_RB(R11) ;Stash the current RB address
MOVAL MCB$L_TPABLK(R11),R2 ;Address our TPARSE block
CLRL TPA$L_OPTIONS(R2) ;Clear the options word
MOVQ R6,TPA$L_STRINGCNT(R2) ;Store a descr of the string to parse
PUSHAL INTERNET_KEYS ;Stack the keyword table address
PUSHAL INTERNET_STATES ;Stack the state table address
PUSHL R2 ;Stack the TPARSE block address
CALLS #3,GLIB$TPARSE ;Parse out the node name
BLBS R0,50$ ;Branch if we won
PUSHL #BIT$_INVADDR ;Else signal an
CALLS #1,GLIB$SIGNAL ; error message
MOVL #BIT$_INVADDR,R0 ;And return it
; We're done (at last)
50$: RET ;Back to Mail, status in R0
.Page
.Subtitle OUT_LINE - Output a known line
;+
;
; ----- OUT_LINE: Output a known line
;
;
; This routine is called by the main line dispatcher to output one of the
; Subject: or To: lines. In the case of the To: line, OUT_DEST has already
; been called to properly format the destination address and this information
; has been stored in the MCB. We don't have to do anything special for the
; subject line.
;
; Inputs:
;
; 0(AP) - 4 (arguments)
; 4(AP) - MCB address
; 8(AP) - Function code
; 12(AP) - Address of our node descriptor
; 16(AP) - Address of the descriptor of the line to copy
;
; Implicit inputs:
;
; Registers saved by the MAIL$PROTOCOL entry point; Our call frame
; must still be current. We will return via a RET instruction.
;
; Outputs:
;
; The appropriate field in the MCB is filled in with the line
; mail feeds us.
;
; R0 - Contains the return status
;
;-
OUT_LINE: ;Ref. label
ADDRESS_MCB R11,10$ ;Find our trusty MCB
10$: MOVQ @16(AP),R0 ;Retrieve a descr of the line to move
MOVZBL R0,R0 ;Clean out cruft.
; Check for either LNK_C_OUT_TO or LNK_C_OUT_SUBJECT...
MOVAB MCB$T_TO(R11),R10 ;Presume we need to fill in the To: line
CMPB #LNK_C_OUT_TO,FUNC(AP) ;Output the To: line?
BEQL 20$ ;If EQL yes, march onward
MOVAB MCB$T_SUBJECT(R11),R10 ;Else we fill in the Subject: line
20$: MOVB R0,(R10)+ ;Copy the string length
MOVC3 R0,(R1),(R10) ;Copy the string
MOVL #SS$_NORMAL,R0 ;Success !
RET ;Back to MAIL
.Page
.Subtitle OUT_FILE - Send a file
;+
;
; ----- OUT_FILE: Send a file
;
;
; This is where all of the real work for outbound mail goes on.
;
; Inputs:
;
; 0(AP) - 5 (arguments)
; 4(AP) - MCB address
; 8(AP) - Function code
; 12(AP) - Address of our node name descriptor
; 16(AP) - Address of the RAB for the message file
; 20(AP) - Address of a routine to call to report an I/O error
;
; Implicit inputs:
;
; Registers saved by the MAIL$PROTOCOL entry point; Our call frame
; must still be current. We will return via a RET instruction.
;
; Outputs:
;
; A internet-style file is created, the stuff from the MCB is copied
; into said file, and the mail delivery agent is awakened.
;
; R0 - Status.
;
;-
OUT_FILE: ;Ref. label
; First things first: Create the outgoing file.
ADDRESS_MCB R11,10$
; Ok. Walk through the RB chain and open each outgoing mail file.
10$: $GETTIM_S MCB$Q_MSGID(R11) ;Get the current time for the message ID
BSBW ENABLE_SYSPRV ;Turn on SYSPRV
PUSHAB WALK_RB_Q ;Set up a co-routine linkage
20$: JSB @(SP)+ ;Get the address of the next RB
BLBC R0,30$ ;Branch if there isn't one
MOVAB RB$L_FAB(R10),R9 ;Address the FAB
MOVAB OUTGOING,R0 ;Address the mail file name
MOVZBL (R0)+,R1 ;Obtain the length of said file name
$FAB_STORE FAB=(R9),- ;Store the
FNS=R1,- ; length of the file name and the
FNA=(R0),- ; address of the file name
FAC=<GET,PUT,UPD>,- ;Read, write and update access
FOP=<SQO>,- ;Sequential only
RAT=<CR>,- ;Implied carriage control
ORG=<SEQ>,- ;A sequential file
RFM=<VAR>,- ;Variable length records
LNM_MODE=#PSL$C_EXEC ;Executive mode logicals only (SYSPRV!)
$CREATE FAB=(R9),ERR=@20(AP) ;Create the outgoing mail file
BLBC R0,50$ ;Sigh.
$CONNECT RAB=RB$L_RAB(R10),ERR=@20(AP) ;Connect up a record stream
BLBC R0,50$ ;Oh well.
BRB 20$ ;Continue the loop
; Write out the header records
30$: BSBW DISABLE_SYSPRV ;Turn off SYSPRV
PUSHAB WALK_RB_Q ;Co-routine to walk through the RB queue
40$: JSB @(SP)+ ;Get the next RB address
BLBS R0,60$ ;Branch if we won
MOVL #SS$_NORMAL,R0 ;Success!
50$: RET ;Back to Mail
; Start writing the file header.
60$:
; Now write the ersatz BSMTP envelope, which looks like:
;
; HELO nodename
; MAIL FROM:<user@nodename>
; RCPT TO:<user@nodename>
; DATA
; HELO nodename
MOVQ NODE_DESC,MCB$L_FAOARGS(R11) ;Copy the node name descriptor
MOVAQ FAO_HELO,R5 ;Here's the format string
BSBW FAO_RCD ;FAO and write a record
; VERB ON
MOVAB VERB,R5
BSBW WRITE_RCD
; TICK 0001
MOVAB TICK,R5
BSBW WRITE_RCD
; MAIL FROM:<user>
MOVAB MCB$T_USERNAME(R11),MCB$L_FAOARGS(R11) ;1st parm is username
MOVQ NODE_DESC,MCB$L_FAOARGS+4(R11) ;2nd parm is the node
MOVAQ FAO_MAIL_FROM,R5 ;The control string
BSBW FAO_RCD ;Format & write it out
; RCPT TO:<destination>
MOVAB RB$T_DESTUSER(R10),MCB$L_FAOARGS(R11) ;1st parm is destination
; username
MOVAB RB$T_NODENAME(R10),MCB$L_FAOARGS+4(R11) ;2nd parm is the node
MOVAQ FAO_RCPT_TO,R5 ;The control string
BSBW FAO_RCD ;Format & write a record
; DATA
MOVAB DATA,R5 ;Address the DATA line
BSBW WRITE_RCD ;Write it out
; At this point we have completed writing out the mail header and the
; ersatz BSMTP header. The next thing we do is to write out our RFC-822
; header fields, which are:
;
; Date:
; From:
; To:
; Subject:
;
; Then we write out any user headers, and follow it with a header item
; of our own which reflects the string VMS Mail fed us for To:.
; Date: Needs formatting
PUSHAL MCB$L_FAOARGS(R11) ;Return the day number here
PUSHAQ MCB$Q_MSGID(R11) ;Use the current system time
CALLS #2,GLIB$DAY_OF_WEEK ;Get the day of the week
MOVL MCB$L_FAOARGS(R11),R0 ;Retrieve the day of the week
MOVL WEEKDAYS[R0],MCB$L_FAOARGS(R11) ;Store the address of the .ascic
; day of the week string
CLRL MCB$L_FAOARGS+4(R11) ;Use the current system time
MOVAQ TIME_ZONE,MCB$L_FAOARGS+8(R11) ;Here's our time zone
MOVAQ FAO_DATE,R5 ;Address the control string
BSBW FAO_RCD ;FAO and write a record
; From: (already formatted by OUT_SENDER)
MOVAB MCB$T_FROM(R11),R5 ;Address the From: line
BSBW WRITE_RCD ;Write it out
; To: This is a can of worms, because we have to walk through all of the
; MCBs associated with this message in order to accurately reflect
; all of the recipients in each message header. Let's call another
; routine to do all of this work...
BSBW RECIPIENTS ;Do all of the recipients
; Subject: Needs formatting
MOVAB MCB$T_SUBJECT(R11),MCB$L_FAOARGS(R11) ;Create the FAO arg list
MOVAQ FAO_SUBJECT,R5 ;Address the control string
BSBW FAO_RCD ;FAO and write a record
; One last header item: the X-VMS-Mail-To: string
MOVAB MCB$T_TO(R11),MCB$L_FAOARGS(R11) ;Only one argument - whatever
; VMS mail gave us for To:
MOVAQ FAO_X_VMS_TO,R5 ;The FAO control string
BSBW FAO_RCD ;FAO and write a record
; Now copy all of the data from the file Mail is feeding us into the current
; outbound mail file. Note that Mail may have wanted us to use block I/O
; on this message. While this is a nice gesture, I'm not really set up to
; cope with it correctly. Hence, we disconnect the RAB, twiddle the block
; I/O bit and reconnect it (Thank You Kevin Carosso).
CLRL R0 ;Write an
MOVL SP,R1 ; empty record
BSBW WRITE_RCD_1 ; ...
MOVL 16(AP),R9 ;Address Mail's RAB
$DISCONNECT RAB=(R9) ;Disconnect it for a second
BICL #RAB$M_BIO,RAB$L_ROP(R9) ;Clear the block I/O bit
$CONNECT RAB=(R9) ;Connect it back up
$REWIND RAB=(R9) ;Rewind it back to the beginning
$RAB_STORE RAB=(R9),- ;Store the
UBF=MCB$T_SCRATCH(R11),- ;record buffer address and the
USZ=#512 ; buffer size
70$: $GET RAB=(R9) ;Read a record
BLBC R0,90$ ;Hope for EOF
80$: MOVAB MCB$T_SCRATCH(R11),R1 ;Address the record text
MOVZWL RAB$W_RSZ(R9),R0 ;Get the length of the record
BSBW WRITE_RCD_1 ;Write it out
BRB 70$ ;Around and around we go
; Here when we got an RMS error. If it's EOF, it's not an error. If
; it's RMS$_RTB, ignore it. Anything else we feed to UTIL$REPORT_ERROR.
90$: CMPL #RMS$_RTB,R0 ;Record too big to fit ?
BEQL 80$ ;If EQL yes, ignore the error
CMPL #RMS$_EOF,R0 ;End of file ?
BNEQ 110$ ;If NEQ no, die a miserable death
; Write out the BSMTP trailer:
; <a blank line>
MOVAB NULL,R5
BSBW WRITE_RCD
; . <a line withg just a period>
MOVAB PERIOD,R5
BSBW WRITE_RCD
; QUIT
MOVAB QUIT,R5
BSBW WRITE_RCD
; all finished, close the file
BSBW ENABLE_SYSPRV ;VMS V4.2+ requires SYSPRV to close
; a file opened with SYSPRV !
$CLOSE FAB=RB$L_FAB(R10) ;Close the file !
BSBW DISABLE_SYSPRV ;Restore the previous state of SYSPRV
BRW 40$ ;Do the next RB
; Here on some hopeless I/O error. Let Mail cope with it.
110$: PUSHL R9 ;Stack the RAB address
CALLS #1,@20(AP) ;Call Mail back
MOVL RAB$L_STS(R9),R0 ;Copy the status back out of the RAB
RET ;Sigh
.Page
.Subtitle FAO_RCD - $FAOL and write a record
;+
;
; ----- FAO_RCD: $FAOL and write a record
;
;
; This routine is called to pass a string to $FAOL and then write the
; result to the outgoing mail file.
;
; Inputs:
;
; R11 - MCB address
; R10 - RB address
; R5 - FAO control string address
;
; Outputs:
;
; Record written to the outgoing mail file.
;
;-
FAO_RCD: ;Ref. label
MOVZWL #512,MCB$Q_DESC(R11) ;Build a descr of scratch buffer
MOVAB MCB$T_SCRATCH(R11),MCB$Q_DESC+4(R11) ; ...
$FAOL_S CTRSTR=(R5),- ;Format the
OUTBUF=MCB$Q_DESC(R11),- ; string
OUTLEN=MCB$Q_DESC(R11),- ; ...
PRMLST=MCB$L_FAOARGS(R11) ; ...
MOVQ MCB$Q_DESC(R11),R0 ;Retrieve a descriptor of the result
BRB WRITE_RCD_1 ;Write the record out
.Page
.Subtitle WRITE_RCD - Write a .ascic string
;+
;
; ----- WRITE_RCD: Write a .ascic string
;
;
; This routine will write a .ascic string to the file pointed to by
; the RAB in the current RB.
;
; Inputs:
;
; R10 - RB address
; R5 - .ascic string address
;
; Outputs:
;
; R0 - Status
; R1,R2 - Destroyed
;
;-
WRITE_RCD: ;Ref. label
MOVL R5,R1 ;Copy the string address
MOVZBL (R1)+,R0 ;Obtain the length of the string
WRITE_RCD_1: ;Ref. label
MOVAL RB$L_RAB(R10),R2 ;Address the RAB
$RAB_STORE RAB=(R2),- ;Store the
RBF=(R1),- ; record buffer address and the
RSZ=R0 ; record size
$PUT RAB=(R2),ERR=@20(AP) ;Write the record out
BLBC R0,10$ ;No!
INCL RB$L_RECORDS(R10) ;Count up another record written
RSB ;Done
10$: RET ;Sigh. Back to Mail
.Page
.Subtitle WALK_RB_Q - Coroutine to walk around an RB queue
;+
;
; ----- WALK_RB_Q: Coroutine to walk around an RB queue
;
;
; This routine will establish a co-routine linkage with it's caller,
; returning once for each RB attached to an MCB.
;
; Inputs:
;
; (SP) - Callback address
;
; Outputs:
;
; R0 - 0, no more RBs
; R0 - 1, R10 has another RB address
;
;-
WALK_RB_Q: ;Ref. label
MOVAL MCB$L_RBQFL(R11),R10 ;Address the RB queue header
MOVL R10,MCB$L_CUR_RB(R11) ;Save it somewhere safe
10$: CLRL R0 ;Default to no RB found
MOVL (R10),R10 ;Chain to the next RB
CMPL R10,MCB$L_CUR_RB(R11) ;Have we walked all the way around yet?
BEQL 20$ ;If EQL yes, give up.
INCL R0 ;Else indicate that we have another RB
JSB @(SP)+ ;Call the caller back
BRB 10$ ;And look for another RB
20$: RSB ;We're done
.Page
.Subtitle RECIPIENTS - Add in all of the recipients
;+
;
; ----- RECIPIENTS: Add in all of the recipients
;
;
; This routine is called by OUT_FILE when we are actually writing a file
; to be delivered outbound. What we have to do is to walk around our MCB
; queue and copy all of the recipients out of the RBs attached to those
; MCBs into the message. This could potentially be quite a few, but since
; we're trying to do this right we may as well go whole hog.
;
; According to RFC-822, if we have multiple recipients we're supposed to
; have just one To: line and seperate all of the recipients with commas.
; To make my life easier, all of the recipients get seperated with commas
; AND get put on seperate lines.
;
; Inputs:
;
; R11 - Current MCB address
; R10 - Current RB address
;
; Implicit Inputs:
;
; The outbound mail file is opened with the FAB being in the RB.
;
; Outputs:
;
; The MCB queue and all of the RB queues are walked through
; and all of the recipients are added to the To: string.
;
;-
RECIPIENTS: ;Here to add all of the recipients in
; First count the number of recipients
MOVAB MCB_Q,R8 ;Address the MCB queue header
MOVL R8,R7 ;Twice
CLRL R9 ;Clear the MCB count
; Outer loop: Walk the MCB queue
10$: MOVL (R8),R8 ;Chain to the next MCB
CMPL R8,R7 ;Have we wrapped around yet ?
BEQL 30$ ;If EQL yes.
MOVAL MCB$L_RBQFL(R8),R5 ;Address the RB queue header
MOVL R5,R4 ;Twice
; Inner loop: Walk the RB queue
20$: MOVL (R5),R5 ;Chain to the next RB
CMPL R5,R4 ;Have we walked all the way around yet ?
BEQL 10$ ;If EQL yes
INCL R9 ;Count up another RB
BRB 20$ ;And look for another
; Ok. At this point, we know how many recipients there are. Start at
; the first MCB and format the To: line...
30$: MOVAB FAO_TO,R5 ;Address the format string
MOVAL MCB_Q,R8 ;Address the MCB queue header
MOVL R8,R7 ;Twice
; Outer loop: Walk the MCB queue
40$: MOVL (R8),R8 ;Address the next MCB
CMPL R8,R7 ;Have we walked all the way around yet ?
BEQL 70$ ;If EQL yes, we're done
MOVAL MCB$L_RBQFL(R8),R6 ;Address the RB queue forward link
MOVL R6,MCB$L_CUR_RB(R8) ;Save it somewhere safe
; Inner loop: Walk the RB queue
50$: MOVL (R6),R6 ;Chain to the next RB
CMPL R6,MCB$L_CUR_RB(R8) ;Have we walked all the way around yet ?
BEQL 40$ ;If EQL yes, onward
MOVAB RB$T_DESTUSER(R6),MCB$L_FAOARGS(R11) ;First arg is To: string
MOVAB RB$T_NODENAME(R6),MCB$L_FAOARGS+4(R11) ;Second arg is the node
MOVAB NULL,MCB$L_FAOARGS+8(R11) ;Presume we're the last recipient
DECL R9 ;Are we the last recipient ?
BLEQ 60$ ;If LEQ yes
MOVAB COMMA,MCB$L_FAOARGS+8(R11) ;Else append a comma
60$: BSBW FAO_RCD ;Write out the next part of the To: line
MOVAB FAO_TO_CONT,R5 ;Use continuation next time (if any)
BRB 50$ ;To the next RB
; We're done.
70$: RSB ;Back to OUT_FILE.
.Page
.Subtitle WAKE_VAXNJI - Wake up VAXNJI
;+
;
; ----- WAKE_VAXNJI: Wake up VAXNJI
;
;
; This routine will awaken our mail delivery agent (VAXNJI).
;
; Inputs:
;
; Implicit inputs:
;
; Registers saved by the MAIL$PROTOCOL entry point; Our call frame
; must still be current. We will return via a RET instruction.
; WORLD privilege.
;
; Outputs:
;
; VAXNJI awakened to transport our mail.
;
;-
WAKE_VAXNJI: ;Ref. label
BBS #PRV$V_WORLD,CUR_PRIVS,10$ ;Branch if we already have WORLD
$SETPRV_S ENBFLG=S#1,- ;Else enable
PRVADR=WORLD,- ; WORLD for
PRMFLG=S#0 ; a bit
10$:
; $WAKE_S PIDADR=MAILSERVER_PID ;Wake up VAXNJI
BBS #PRV$V_WORLD,CUR_PRIVS,20$ ;Have to turn off WORLD?
$SETPRV_S ENBFLG=S#0,- ;Else disable
PRVADR=WORLD,- ; WORLD privs
PRMFLG=S#0 ; ...
20$: MOVL #SS$_NORMAL,R0 ;Ignore errors
RET ;Back to MAIL
.Page
.Subtitle OUT_DEACCESS - Clean up after mail delivery
;+
;
; ----- OUT_DEACCESS: Clean up after mail delivery
;
;
; This routine is called to perform any cleanup after the delivery of
; a mail message. We simply deallocate all of the RBs associated with
; the MCB, and then deallocate the MCB itself.
;
; Inputs:
;
; 0(AP) - 2 (arguments)
; 4(AP) - MCB address
; 8(AP) - Function code
;
; Implicit inputs:
;
; Registers saved by the MAIL$PROTOCOL entry point; Our call frame
; must still be current. We will return via a RET instruction.
;
; Outputs:
;
; Virtual memory returned.
;
;-
OUT_DEACCESS: ;Here to clean up
BSBW DISABLE_SYSPRV ;Just In Case
MOVAQ -(SP),R7 ;Address some scratch storage
ADDRESS_MCB R11,10$
; Walk around the MCB chain, deallocating them as we go...
10$: REMQUE @MCB$L_RBQFL(R11),R0 ;Remove the next RB
BVS 20$ ;If VS, deallocate the MCB next
MOVL #RB$K_LENGTH,(R7)+ ;The block is this big
MOVL R0,(R7) ;And the address is here
PUSHL R7 ;Stack the address of the block address
PUSHAL -(R7) ;Stack the address of the block size
CALLS #2,GLIB$FREE_VM ;Free up the RB
BRB 10$ ;Loop
; Free up the MCB
20$: REMQUE (R11),R11 ;Remove the MCB from the MCB queue
MOVL #MCB$K_LENGTH,(R7)+ ;An MCB is this big
MOVL R11,(R7) ;And ours is here
PUSHL R7 ;The MCB is here
PUSHAL -(R7) ;It's this big
CALLS #2,GLIB$FREE_VM ;Release the MCB
RET ;Back to Mail
.Page
.Subtitle TPARSE ACTION ROUTINES
.Subtitle CLEAR_BOTH
.Subtitle SET_USER
.Subtitle SET_NODE
.Subtitle STORE_ADDRESS
;+
;
; ----- CLEAR_BOTH: Zero both the username/nodename descriptors
; ----- SET_USER: Save a pointer and length to the destination user
; ----- SET_NODE: Save a pointer and length to the destination node
; ----- STORE_ADDRESS: Save the user/node in the RB
;
;
;
; The first three routines are called as action routines by LIB$TPARSE to:
; 1) clear the username/nodename pointers in the TPARSE block extension
; 2) store the address and length of the username portion of the destination
; address in the extension of the TPARSE parameter block.
; 3) store the address and length of the nodename portion of the destination
; address in the extension of the TPARSE parameter block
; The fourth routine is called to store the above information in the RB.
;
; Inputs:
;
; 0(AP) - 8 (arguments)
; 4(AP) - TPA$L_OPTIONS: Flags
; 8(AP) - TPA$L_STRINGCNT: Length of the input string remaining
; 12(AP) - TPA$L_STRINGPTR: Address of the input string remaining
; 16(AP) - TPA$L_TOKENCNT: Length of the current token
; 20(AP) - TPA$L_TOKENPTR: Address of the current token
; 24(AP) - TPA$B_CHAR: Character that matched last
; 28(AP) - TPA$L_NUMBER: Binary value of last numeric token
; 32(AP) - TPA$L_PARAM: Parameter supplied in the state table
;
; Outputs:
;
; 36(AP) A word to store the length of the username
; 40(AP) A longword to store the address of the username
; 44(AP) A word to store the length of the nodename
; 48(AP) A longword to store the address of the nodename
;
; The modified RB
;-
CLEAR_BOTH: .word M<> ; Clean up any left over descr
CLRQ 36(AP)
CLRQ 44(AP)
MOVL #SS$_NORMAL,R0
RET
SET_USER: .word M<> ; Store decsr for username
MOVZBL TPA$L_TOKENCNT(AP),36(AP)
MOVL TPA$L_TOKENPTR(AP),40(AP)
MOVL #SS$_NORMAL,R0
RET
SET_NODE: .word M<> ; Store descr for nodename
MOVZBL TPA$L_TOKENCNT(AP),44(AP)
MOVL TPA$L_TOKENPTR(AP),48(AP)
MOVL #SS$_NORMAL,R0
RET
NET_SEP: .word M<> ; Are we at a '@'?
CLRL R0
TSTL TPA$L_STRINGCNT(AP)
BEQL 99$
CMPB @TPA$L_STRINGPTR(AP),#A'@'
BNEQ 99$
INCL R0
99$: RET
DEC_SEP: .word M<R2> ; Are we at a '::'
CLRL R0
CMPL TPA$L_STRINGCNT(AP),#2
BLSS 99$
MOVL TPA$L_STRINGPTR(AP),R2
CMPB (R2),#A':'
BNEQ 99$
CMPB 1(R2),#A':'
BNEQ 99$
INCL R0
99$: RET
STORE_ADDRESS: .word M<R2,R3,R4,R5,R6,R7> ; Store all that stuff
MOVAB MCB$L_MCBQFL-MCB$L_TPABLK(AP),R6 ;R6 -> beginning of MCB
MOVL MCB$L_CUR_RB(R6),R7 ;R7 -> current RB
MOVB 36(AP),RB$T_DESTUSER(R7) ;store the length
MOVC3 36(AP),@40(AP),RB$T_DESTUSER+1(R7) ;and the text
TSTB 44(AP) ;is nodename null?
BNEQ 10$
MOVB NEAR_DESC,RB$T_NODENAME(R7) ;then use neighbor's
MOVC3 NEAR_DESC,@NEAR_DESC+4,RB$T_NODENAME+1(R7) ; nodename
BRB 20$
10$: MOVB 44(AP),RB$T_NODENAME(R7) ;store the length
MOVC3 44(AP),@48(AP),RB$T_NODENAME+1(R7) ;and the text
20$: MOVL #SS$_NORMAL,R0
RET
.Page
.Subtitle IN_CONNECT - Inbound connect request
;+
;
; ----- IN_CONNECT: Inbound connect request
;
;
; This routine is called by Mail for us to establish context to deliver
; inbound foreign mail. We allocate an MCB for this to keep track of
; things.
;
; $ Mail/Protocol=Bitnet_mailshr BITNET_SPOOL:INCOMING.MSG;ver
;
; It is our responsibility at that point to read the header records from
; the inbound mail file and fill in the appropriate fields in
; the MCB. Mail only calls IN_CONNECT once no matter how many recipients
; there are, since until we tell it how many, how does it know?
;
; Inputs:
;
; 0(AP) - 8 (arguments)
; 4(AP) - MCB address
; 8(AP) - Function code
; 12(AP) - Input translation table descriptor address
; 16(AP) - Record attributes (FAB$B_RAT)
; 20(AP) - Record format (FAB$B_RFM)
; 24(AP) - MAIL$GL_SYSFLAGS
; 28(AP) - Address of the protocol descriptor
; 32(AP) - Server flags
;
; Inplicit inputs:
;
; Registers saved by the MAIL$PROTOCOL entry point; Our call frame
; must still be current. We will return via a RET instruction.
;
; Outputs:
;
; An MCB is allocated and it's address is stored for later use.
; A RB is allocated for each recipient found in the mail header.
; The header from the input mail file is digested and the relevant
; information is stored in the MCB and RB(s) for later use.
;
;-
IN_CONNECT: ;Here to process an inbound connect
CALLG (AP),CONNECT_COMMON ;Let OUT_CONNECT do some of the work
BLBS R0,10$
RET ;Propagate any errors back to Mail
10$: MOVL @MCB(AP),R11 ;Address MCB(initialized by OUT_CONNECT)
; Retrieve the name of the file to deliver from DCL. This comment was in the
; original code: <<<Note that if this is not a fully-qualified file name
; (DEVICE:[DIRECTORY]FILENAME.TYPE;VERSION), CLI$GET_VALUE fails with an
; "Entity absent from command line" for some bizarre reason.>>>, I have not
; noticed this problem here (at ISU).
MOVAB MCB$T_SCRATCH(R11),MCB$Q_DESC+4(R11) ;Fill in the
MOVZWL #512,MCB$Q_DESC(R11) ; scratch descriptor
PUSHAQ MCB$Q_DESC(R11) ;Return the length here
PUSHL (SP) ;It's also the output descriptor address
PUSHAQ CLI_FILE ;We want this parameter
CALLS #3,GCLI$GET_VALUE ;Go retrieve the file name
BLBS R0,20$
RET ;Give up if $GET_VALUE fails
20$: MOVZWL MCB$Q_DESC(R11),R2 ;Obtain the length of the file name
BGTR 30$ ;
PUSHL #BIT$_NOINFILE ;Stack the error code
CALLS #1,GLIB$STOP ;Signal it
; Open the specified file
30$: MOVAL MCB$L_RAB(R11),R9 ;Address our RAB
$FAB_STORE -
FAB=MCB$L_FAB(R11),- ;Fill in the FAB:
FAC=<GET>,- ;Read only access
FNA=MCB$T_SCRATCH(R11),- ;File name address
FNS=R2,- ;File name size
LNM_MODE=#PSL$C_EXEC ;Exec mode logicals (SYSPRV!)
$OPEN FAB=MCB$L_FAB(R11) ;Open up the file
BLBC R0,40$
$CONNECT RAB=(R9) ;Connect up a record stream
BLBS R0,50$ ;Branch if success
40$: BRW 920$ ;Report RMS error
; Ok. Now we have to read the first several records from the input file,
; which comprise the mail header.
50$: $RAB_STORE -
RAB=(R9),- ;Store the
UBF=MCB$T_SCRATCH(R11),- ; address of and the
USZ=#512 ; size of our record buffer
CLRL MCB$T_SCRATCH(R11)
$GET RAB=(R9) ;Read the first record
BLBC R0,40$ ;Error?
CMPL MCB$T_SCRATCH(R11),#A'HELO' ;BSMTP?
BEQL 60$
BRW 91$ ;no BSMTP header, do our best
; Scan for BSMTP keywords here
60$: CLRL MCB$T_SCRATCH(R11)
$GET RAB=(R9)
BLBC R0,40$ ;I/O error
CMPL MCB$T_SCRATCH(R11),#A'RCPT'
BEQL 81$
CMPL MCB$T_SCRATCH(R11),#A'MAIL'
BEQL 82$
CMPL MCB$T_SCRATCH(R11),#A'TICK' ;Ignored
BEQL 60$
CMPL MCB$T_SCRATCH(R11),#A'VERB' ;Ignored
BEQL 60$
CMPL MCB$T_SCRATCH(R11),#A'DATA'
BNEQ 60$ ;If we don't know what it is, ignore it
BRW 90$
70$: BRW 910$ ;Don't know what to do with header item
80$: BRW 900$ ;Header Item has invalid format
; Here we have found a 'RCPT TO:<user@node>' record
81$: MOVAQ -(SP),R2 ;some scratch space
MOVL #RB$K_LENGTH,4(R2) ;#bytes to get
PUSHAL (R2)+ ;the address goes here
PUSHL R2 ;#bytes
CALLS #2,GLIB$GET_VM ;Get some memory
BLBC R0,70$
MOVL -(R2),R10 ;R10->newly allocated RB
MOVC5 #0,#0,#0,#RB$K_LENGTH,(R10) ;Zero the RB
MOVL R11,RB$L_MCB(R10) ;Point back to the MCB
INSQUE (R10),@MCB$L_RBQBL(R11) ;Insert RB onto the RB queue
LOCC #A'<',RAB$W_RSZ(R9),MCB$T_SCRATCH(R11) ;Find the leading '<'
BEQL 80$ ;Didn't find the '<'
DECL R0 ;don't include the '<'
ADDL3 #1,R1,R3 ;R3->user@node
LOCC #A'@',R0,(R3)
BEQL 80$ ;didn't find the '@'
SUBL3 R3,R1,R2 ;R2=length(user)
MOVB R2,RB$T_DESTUSER(R10) ;Build a .ascic string
MOVC3 R2,(R3),RB$T_DESTUSER+1(R10) ;Copy user into RB
BRW 60$
; Here we have found a 'MAIL FROM:<user@node>' record
82$: LOCC #A'<',RAB$W_RSZ(R9),MCB$T_SCRATCH(R11) ;Find the leading '<'
BEQL 80$ ;Didn't find the '<'
DECL R0 ;don't include the '<'
ADDL3 #1,R1,R3 ;R3->user@node
LOCC #A'>',R0,(R3)
BEQL 80$ ;didn't find the closing '>'
SUBL3 R3,R1,R2 ;R2=length(user@node)
MOVAB MCB$T_FROM+1(R11),MCB$Q_DESC+4(R11) ;Build the output descr
MOVZBL #255,MCB$Q_DESC(R11) ;Length of string is 255 bytes.
$FAO_S -
CTRSTR=FAO_IN_FROM,- ;Format the From: string
OUTBUF=MCB$Q_DESC(R11),- ;Output buffer is here
OUTLEN=MCB$Q_DESC(R11),- ;Return the length there, too
P1=R2,P2=R3 ;Use these 2 parameters
MOVB MCB$Q_DESC(R11),MCB$T_FROM(R11) ;Build a .ascic string
BRW 60$
; Here we have found the 'DATA' record and are finished with the BSMTP header
; Ok. Now save the RFA of this record and begin to scan forward to locate
; the Subject: line. If we don't find one before the end of the file, NBD.
90$: $GET RAB=(R9) ;Get past the 'DATA' record
BLBC R0,100$ ;error?
91$: PUSHAB MCB$T_SUBJECT(R11) ;where to put it, if we find it
PUSHAQ HDR_SUBJECT ;what to look for
PUSHAL (R9) ;Address of the RAB
CALLS #3,gSCANHDR
; maybe look at some of the other ARPA header items here?
100$: RET ;Back to Mail (finally!)
; Here is where we handle problems from IN_CONNECT
; Here when we have an illegally formatted user-ID or node name.
900$: PUSHL #BIT$_INVSOURCE ;Error detail
CLRL -(SP) ;No FAO parameters
PUSHL #BIT$_INVMSGFIL ;Error type
CALLS #3,GLIB$STOP ;Signal the error
; Here when we got an input error on the mail file. Punt.
910$: PUSHL R0 ;Stack the RMS error code
PUSHL #BIT$_INPERR ;Stack our own prefix
CALLS #2,GLIB$STOP ;Signal the error
; RMS errors reported here
920$: PUSHAQ MCB$Q_DESC(R11) ;Stack the file name descriptor address
PUSHL #1 ;1 FAO argument
PUSHL R0 ;The RMS error code
PUSHL #BIT$_OPENIN ;Stack our error code
CALLS #4,GLIB$STOP ;Signal the error
; Local subroutine to scan the file whose RAB is 4(AP) for the ARPA header
; item whose descriptor is at 8(AP) and store it (.ascic) at @12(AP)
SCANHDR: .word M<R2,R3,R4,R5,R6,R7,R8,R9>
MOVL 8(AP),R8 ;R8 -> item descriptor
MOVL 4(AP),R9 ;Put the RAB in R9
MOVL RAB$W_RFA(R9),R6 ;Stash the RFA
MOVZWL RAB$W_RFA+4(R9),R7 ; of this record somewhere safe
$RAB_STORE -
RAB=(R9),- ;Ensure that
UBF=MCB$T_SCRATCH(R11),- ; we have a valid
USZ=#512 ; input buffer
MOVAB MCB$T_SCRATCH(R11),MCB$Q_DESC+4(R11) ;Prepare to build a
; descriptor of the record
100$: $GET RAB=(R9) ;Read the next record
BLBC R0,130$ ;Maybe EOF?
CMPW (R8),RAB$W_RSZ(R9) ;Length look good ?
BGEQ 100$ ;If GEQ no, save some effort
MOVZWL (R8),MCB$Q_DESC(R11) ;Dummy up a descriptor
PUSHAQ MCB$Q_DESC(R11) ;Stack string 2
PUSHAQ (R8) ;Stack string 1
CALLS #2,GSTR$CASE_BLIND_COMPARE ;Compare the string, case blind
BLBS R0,100$ ;If LBS, not the item string.
MOVZWL RAB$W_RSZ(R9),MCB$Q_DESC(R11) ;Create a descriptor of the record
; Ok. Now scan past the XXXXXXX: string, and to the first non-blank after
; that. From there to the end of the string comprises what we will feed
; Mail for the item.
MOVZWL (R8),R0 ;Get the length of that string
ADDL R0,MCB$Q_DESC+4(R11) ;And point past it
SUBL R0,MCB$Q_DESC(R11) ;Remove it from the length
MOVQ MCB$Q_DESC(R11),R0 ;Retrieve a descr of the item:
LOCC #A/:/,R0,(R1) ;Is there a trailing : around?
BNEQ 110$ ;If NEQ yes.
MOVQ MCB$Q_DESC(R11),R0 ;Else pretend we saw one
110$: SKPC #A/:/,R0,(R1) ;Skip over the colon if there
SKPC #A/ /,R0,(R1) ;Skip over leading blanks
SKPC #A/ /,R0,(R1) ; and tabs
120$: MOVQ R0,MCB$Q_DESC(R11) ;Store a new string descriptor
MOVL 12(AP),R1 ;R1 -> where to store string
MOVB R0,(R1) ;Make counted string for item
MOVC3 R0,(R1),1(R1) ;Move the string
; Now restore the position within the file so that we return the
; right info to the user...
130$: $RAB_STORE -
RAB=(R9),- ;Convert to
RAC=<RFA> ; access by RFA for a few usec
MOVL R6,RAB$W_RFA(R9) ;Restore the
MOVW R7,RAB$W_RFA+4(R9) ; RFA of the end of the header
$FIND RAB=(R9) ;Position the file there
$RAB_STORE -
RAB=(R9),- ;And go back to
RAC=<SEQ> ; sequential access
RET
.Page
.Subtitle IN_SENDER - Input the From: line
.Subtitle IN_TO - Input the To: line
.Subtitle IN_SUBJ - Input the Subject: line
;+
;
; ----- IN_SENDER: Input the From: line
; ----- IN_TO: Input the To: line
; ----- IN_SUBJ: Input the Subject: line
;
;
; These routines are called to return the From: and To: lines to Mail.
; IN_CONNECT and IN_RECIP have already formatted the complete strings
; for us, so all we have to do is to copy it to Mail's address space.
;
; Inputs:
;
; 0(AP) - 3 (arguments)
; 4(AP) - MCB address
; 8(AP) - Function code
; 12(AP) - Place to return the string.
;
; Implicit inputs:
;
; Registers saved by the MAIL$PROTOCOL entry point; Our call frame
; must still be current. We will return via a RET instruction.
;
; Outputs:
;
; String returned to Mail.
;
;-
IN_TO:
MOVL #MCB$T_TO,R0 ;Address the proper string
BRB IN_LINE ;Return this line
IN_SENDER: ;Here to return the From: line
MOVL #MCB$T_FROM,R0 ;Address the From: string
BRB IN_LINE ;Join common code
IN_SUBJ: ;Here to return the Subject: string
MOVL #MCB$T_SUBJECT,R0 ;Address the Subject: string
IN_LINE: ;Ref. label
ADDRESS_MCB R11,10$
10$: ADDL R11,R0 ;Point to the correct string to copy
MOVAQ -(SP),R7 ;Address some scratch storage
MOVZBL (R0)+,(R7) ;Create a
MOVL R0,4(R7) ; string descriptor of the string
PUSHL 12(AP) ;Stack the destination string address
PUSHL R7 ;Stack the source string address
CALLS #2,GLIB$SCOPY_DXDX ;Copy the string
RET ;We're done
.Page
.Subtitle IN_RECIP - Input the next recipient
;+
;
; ----- IN_RECIP: Input the next recipient
;
;
; This routine is called by Mail to return the next recipient of a message.
; We simply remove the head of the RB queue and return RB$T_DESTUSER, which
; was filled in by IN_CONNECT when it digested the BSMTP header. If the
; queue is empty we return the NULL byte to mail to indicate no more
; recipients.
;
; Inputs:
;
; 0(AP) - 3 (arguments)
; 4(AP) - MCB address
; 8(AP) - Function code
; 12(AP) - Place to return the next recipient string
;
; Implicit inputs:
;
; Registers saved by the MAIL$PROTOCOL entry point; Our call frame
; must still be current. We will return via a RET instruction.
;
; Outputs:
;
; The next recipient string is returned to Mail.
; The first RB in the queue attached to the MCB is freed.
;
;-
IN_RECIP: ;Ref. label
ADDRESS_MCB R11,10$
10$: REMQUE @MCB$L_RBQFL(R11),R10
BVS 20$
MOVZBL RB$T_DESTUSER(R10),MCB$Q_DESC(R11)
MOVAB RB$T_DESTUSER+1(R10),MCB$Q_DESC+4(R11)
BRB 30$
; We've run out of recipients. Return the null string to mail.
20$: TSTB MCB$T_TO(R11) ;Were there any recipients?
BNEQ 21$
CLRL R10 ;No RB here
MOVQ POSTMASTER,MCB$Q_DESC(R11) ;No, let someone know
BRB 30$
21$: MOVQ @12(AP),R0 ;Obtain the descriptor
CLRB (R1) ;Return the null byte
MOVL #1,@12(AP) ; to Mail
MOVL #SS$_NORMAL,R0 ;Sort of success
RET ;Done
; Return the string to Mail.
30$: PUSHAQ MCB$Q_DESC(R11) ;Stack the source descriptor address
PUSHL 12(AP) ;Stack the destination descr address
CALLS #2,GSTR$UPCASE ;Copy the uppercase of the string
; Append this string onto the accumulating To: string
MOVZBL MCB$T_TO(R11),R6 ;Get the length of the To: string so far
SUBL3 R6,#255,R0 ;Get the room left in the buffer
CMPW R0,MCB$Q_DESC(R11) ;Is there enough room ?
BLEQ 50$ ;If LEQ no, just forget it
MOVAB MCB$T_TO+1(R11)[R6],R3 ;Get the address of the next free byte
TSTL R6 ;Is this the first one ?
BEQL 40$ ;If EQL yes, no comma the first time
MOVB #A',',(R3)+ ;Move in a comma
INCL R6 ;Increase the length to account for it
40$: MOVC3 MCB$Q_DESC(R11),@MCB$Q_DESC+4(R11),(R3) ;Move in this name
ADDL MCB$Q_DESC(R11),R6 ;Add in the length we moved
MOVB R6,MCB$T_TO(R11) ;Store it.
; free the RB (if any)
TSTL R10 ; No RB if going to POSTMASTER
BEQL 50$
MOVAQ -(SP),R2
MOVL #RB$K_LENGTH,(R2)+
MOVL R10,(R2)
PUSHL R2
PUSHAL -(R2)
CALLS #2,gLIB$FREE_VM
50$: MOVL #SS$_NORMAL,R0 ;Normal completion
RET ;Back to Mail
.Page
.Subtitle IN_FILE - Input the mail file
;+
;
; ----- IN_FILE: Input the mail file
;
;
; This routine is called by Mail to copy the text from the input file to
; the destination mail file. We basically just copy stuff from the input
; file to the output file and quit when we reach the end of the input file.
;
;
; Inputs:
;
; 0(AP) - 5 (arguments)
; 4(AP) - MCB address
; 8(AP) - Function code
; 12(AP) - Scratch (unused)
; 16(AP) - Pointer to the output RAB
; 20(AP) - Address of UTIL$REPORT_IO_ERROR
;
; Implicit inputs:
;
; Registers saved by the MAIL$PROTOCOL entry point; Our call frame
; must still be current. We will return via a RET instruction.
;
; Outputs:
;
; The contents of the inbound mail file are returned.
;
;-
IN_FILE: ;Ref. label
ADDRESS_MCB R11,10$
10$: MOVL 16(AP),R10 ;Address our output RAB
MOVAL MCB$L_RAB(R11),R9 ;Address our input RAB
; Now just loop copying text from our input RAB to the output RAB, and
; quit at EOF.
40$: $RAB_STORE -
RAB=(R10),- ;Store the
RBF=MCB$T_SCRATCH(R11) ; output buffer address
$RAB_STORE -
RAB=(R9),- ;Store the
UBF=MCB$T_SCRATCH(R11),-; input buffer address and the
USZ=#512 ; input buffer size
50$: $GET RAB=(R9) ;Get another record
BLBC R0,60$ ;Maybe EOF?
BSBB 100$ ;check for BSMTP '.' and/or 'QUIT'
BLBC R0,60$
$RAB_STORE -
RAB=(R10),- ;Store the size of
RSZ=RAB$W_RSZ(R9) ; this record
$PUT RAB=(R10),ERR=@20(AP) ;Write it out
BLBS R0,50$ ;Loop if success
; Here to check for EOF and gripe if not.
60$: CMPL #RMS$_EOF,R0 ;End of file ?
BNEQ 70$ ;If NEQ no, not an error
$CLOSE FAB=MCB$L_FAB(R11) ;Else close the input file
RET ;And return back to Mail
; Here when we have an error; Fake a call to UTIL$REPORT_IO_ERROR
70$: PUSHL R0 ;Save the error code
PUSHL R9 ;Stack the RAB address
CALLS #1,@20(AP) ;Call UTIL$REPORT_IO_ERROR
POPL R0 ;Restore the error code
80$: RET ;And return it to Mail
; check for BSMTP '.' and 'QUIT' records
100$: MOVZWL RAB$W_RSZ(R9),R0
BEQL 120$ ;record length is 0, can't be a '.'
CMPB MCB$T_SCRATCH(R11),#A'.' ;1st character a '.'?
BNEQ 120$
DECL R0 ;length after the '.'
SKPC #A' ',R0,MCB$T_SCRATCH+1(R11) ;is it the last non-blank char?
BNEQ 120$
$GET RAB=(R9) ; We found a lone '.'
BLBC R0,130$
MOVZWL RAB$W_RSZ(R9),R0
CMPW R0,#4 ; check length
BLSS 140$
CMPL MCB$T_SCRATCH(R11),#A'QUIT'
BNEQ 140$
SUBL2 #4,R0
SKPC #A' ',R0,MCB$T_SCRATCH+4(R11) ;any non-blanks after 'QUIT'?
BNEQ 140$
MOVL #RMS$_EOF,R0 ;No, this is the end
RSB
120$: MOVL #1,R0 ;Ordinary exit
130$: RSB
140$: MOVL RAB$L_RBF(R10),R4 ;Save RBF
MOVZBL #A'.',-(SP) ;A place for the period
$RAB_STORE -
RAB=(R10),- ;Store the
RBF=(SP),- ; address and
RSZ=#1 ; length of the record
$PUT RAB=(R10),ERR=@20(AP) ;Write it out
TSTL (SP)+
MOVL R4,RAB$L_RBF(R10) ;Restore the saved RBF
BRB 130$
.Page
.Subtitle IO_READ - Perform a read request for Mail
;+
;
; ----- IO_READ: Perform a read request for Mail
;
;
; This routine is never called by Mail as far as I can tell.
;
; Inputs:
;
; 0(AP) - 3 (arguments)
; 4(AP) - MCB address
; 8(AP) - Function code
; 12(AP) - String descriptor address to return something to Mail in
;
; Implicit inputs:
;
; Registers saved by the MAIL$PROTOCOL entry point; Our call frame
; must still be current. We will return via a RET instruction.
;
; Outputs:
;
; SS$_NORMAL.
;
;-
IO_READ: ;Ref. label
MOVL #SS$_NORMAL,R0 ;Success!
RET ;Back to Mail
.Page
.Subtitle IO_WRITE - Perform a write request for Mail
;+
;
; ----- IO_WRITE: Perform a write request for Mail
;
;
; This routine is called by Mail to return status information to us.
; Two kinds of arguments come to this routine: status codes (i.e.,
; things you might find in R0) and message text strings. Status codes
; are returned to Mail in R0. Error message strings are ignored since
; Mail has already output them once, and we have nobody to send them
; to.
;
; Inputs:
;
; 0(AP) - 3 (arguments)
; 4(AP) - MCB address
; 8(AP) - Function code
; 12(AP) - A descriptor of the information Mail wants to pass to us
;
; Implicit inputs:
;
; Registers saved by the MAIL$PROTOCOL entry point; Our call frame
; must still be current. We will return via a RET instruction.
;
; Outputs:
;
; As described above.
;
;-
IO_WRITE: ;Ref. label
MOVL #SS$_NORMAL,R0 ;Presume it's a text string
MOVQ @12(AP),R2 ;Obtain the descriptor
CMPW #4,R2 ;Is this a status code?
BNEQ 10$ ;If NEQ no, ignore it.
MOVL (R3),R0 ;Else return the status code to Mail
10$: RET ;Back to Mail
.Page
.Subtitle RANDOM_INIT - Perform random initializations
;+
;
; ----- RANDOM_INIT: Perform random initializations
;
;
; This routine is called by the outbound and inbound dispatcher to initialize
; things for us. We retrieve our privilege mask and translate a few logical
; names which are important to us.
;
; Inputs:
;
; R7 - Address of a quadword of scratch storage
;
; Implicit inputs:
;
; Registers saved by the MAIL$PROTOCOL entry point; Our call frame
; must still be current. We will return via a RET instruction.
;
; Outputs:
;
; Several logical names are translated and we retrieve our
; privilege mask.
;
;-
RANDOM_INIT: ;Random initializations
$GETJPI_S -
ITMLST=JPI_INFO ;Get my privilege mask
$TRNLOG_S -
LOGNAM=BIT_NODE,- ;Translate our
RSLBUF=NODE_DESC,- ; host node name
RSLLEN=NODE_DESC ; ...
$TRNLOG_S -
LOGNAM=TIMEZONE,- ;Translate our
RSLBUF=TIME_ZONE,- ; time zone
RSLLEN=TIME_ZONE ; ...
$TRNLOG_S -
LOGNAM=NEAR_NODE,- ; Translate our
RSLBUF=NEAR_DESC,- ; nearest neighbor's node name
RSLLEN=NEAR_DESC
MOVL #8,(R7) ;Stash the length of the buffer
MOVAB MAILSERVER_BUF,4(R7) ;Stash the address of the buffer
$TRNLOG_S -
LOGNAM=MAILSERV,- ;Translate our
RSLBUF=(R7) ; mail server's PID
PUSHAL MAILSERVER_PID ;Return the result here
PUSHAB MAILSERVER_BUF ;Here's the buffer
PUSHL #8 ;Here's the length
CALLS #3,GLIB$CVT_HTB ;Convert it to binary
RSB ;Done
.Page
.Subtitle ENABLE_SYSPRV - Turn on SYSPRV if we don't have it
;+
;
; ----- ENABLE_SYSPRV: Turn on SYSPRV if we don't already have it
;
;
; This routine will turn on SYSPRV if we don't already have it.
;
; Inputs:
;
; CUR_PRIVS - My current privilege mask
;
; Outputs:
;
; SYSPRV turned on if we don't already have it
;
;-
ENABLE_SYSPRV: ;Here to enable SYSPRV
BBS #PRV$V_SYSPRV,CUR_PRIVS,10$ ;Branch if we already have it
$SETPRV_S ENBFLG=S#1,- ;Enable SYSPRV
PRVADR=SYSPRV,- ; ...
PRMFLG=S#0 ; ...
10$: RSB ;Done; status in R0
.Page
.Subtitle DISABLE_SYSPRV - Disable SYSPRV if we didn't have it
;+
;
; ----- DISABLE_SYSPRV: Disable SYSPRV if we didn't have it to begin with
;
;
; This routine will turn off SYSPRV if we didn't have it to begin with.
;
; Inputs:
;
; CUR_PRIVS - Our current privilege mask
;
; Outputs:
;
; SYSPRV disabled if we didn't have it to begin with
;
;-
DISABLE_SYSPRV: ;Here to disable SYSPRV
BBS #PRV$V_SYSPRV,CUR_PRIVS,10$ ;Branch if we had it to begin with
$SETPRV_S ENBFLG=S#0,- ;Else turn off
PRVADR=SYSPRV,- ; SYSPRV
PRMFLG=S#0 ; ...
10$: RSB ;Done
.Page
.Subtitle COND_HANDLER - Condition handler
;+
;
; ----- COND_HANDLER: Condition handler
;
;
; This routine is the condition handler for this module. It seems that Mail
; ignores signals from time to time, causing bogus error messages to crop up
; and generally screwing up mail delivery (especially inbound mail). Hence,
; we establish our own condition handler which does what every red-blooded
; condition handler ought to: output an error message and exit with status
; if the error condition was severe.
;
; Inputs:
;
; CHF$L_SIGARGLST(AP) - Signal argument vector address
; CHF$L_MECARGLST(AP) - Mechanism argument vector address
;
; Outputs:
;
; An error message is output to SYS$OUTPUT and SYS$ERROR using
; $PUTMSG. Image exit will be forced if the error was SEVERE.
;
;-
COND_HANDLER: .Word M<R2> ;Here on a signalled error
MOVL CHF$L_SIGARGLST(AP),R2 ;Address the signal vector
SUBL #2,(R2) ;Never mind the PC and PSL
$PUTMSG_S MSGVEC=(R2) ;Output the error code(s)
CMPZV #STS$V_SEVERITY,#STS$S_SEVERITY,-
CHF$L_SIG_NAME(R2),#STS$K_SEVERE ;Severe (fatal) error ?
BEQL 10$ ;If EQL yes, force image exit
MOVL #SS$_CONTINUE,R0 ;Else contine the
RET ; previous thread of execution
10$: BISL3 #STS$M_INHIB_MSG,-
CHF$L_SIG_NAME(R2),R0 ;Don't output the message twice
$EXIT_S R0 ;Exit with status
.End
$END-OF-FILE
$!
$create/log del.com
$deck/dollars="$END-OF-FILE"
$ set noon
$ write sys$output "De-assigning system logical names"
$ deass/system/exec bitnet_spool
$ deass/system/exec bitnet_nodename
$ deass/system/exec bitnet_nextnode
$ deass/system/exec bitnet_timezone
$ deass/system/exec bitnet_postmaster
$ deass/system/exec bitnet_server_pid
$ write sys$output "De-installing bitnet protocol image"
$ ins*tall :== $sys$system:install/command
$ install
remove sys$share:bitnet_mailshr.exe
$ write sys$output "Removing bitnet protocol executable from sys$share"
$ set proc/priv=bypass
$ delete/noconfirm sys$share:bitnet_mailshr.exe.*
$ set proc/priv=nobypass
$ exit
$END-OF-FILE
$!
$create/log new.com
$deck/dollars="$END-OF-FILE"
$ set noon
$ write sys$output "Copying bitnet protocol executable to sys$share"
$ copy/read/write/nolog bitnet_mailshr.exe SYS$COMMON:[SYSLIB]
$ write sys$output "Setting world access to protocol executable"
$ set prot=(w:re) sys$common:[syslib]bitnet_mailshr.exe
$ write sys$output "Installing bitnet protocol image"
$ ins*tall :== $sys$system:install/command
$ install
add sys$share:bitnet_mailshr.exe/open/head/shar/priv=(world,netmbx,oper,sysprv)
$ write sys$output "Defining system logical names"
$ write sys$output " Bitnet_spool - Temporary file storage directory"
$ define/nolog/system/exec/trans=concealed bitnet_spool isu000:[jgajph.scratch]
$ write sys$output " Bitnet_nodename - Bitnet address of this node"
$ define/nolog/system/exec bitnet_nodename ISUVAX.BITNET
$ write sys$output " Bitnet_nextnode - Bitnet address of nearest neighbor"
$ define/nolog/system/exec/trans=terminal bitnet_nextnode ISUMVS.BITNET
$ write sys$output " Bitnet_timezone - Local timezone (i.e., CDT)
$ define/nolog/system/exec/trans=terminal bitnet_timezone CDT
$ write sys$output " Bitnet_postmaster - Local username to receive lost mail"
$ define/nolog/system/exec bitnet_postmaster GAJPH
$ write sys$output " Bitnet_server_pid - Process to signal to transmit mail"
$ define/nolog/system/exec bitnet_server_pid 0
$ exit
$END-OF-FILE
$!
$create/log test.mar
$deck/dollars="$END-OF-FILE"
.title BITNET_MAILER
.psect READWRITE,RD,WRT,NOEXE
null = 0
bell = 7
lf = 10
cr = 13
OUTBUF::
.blkb 256
FAOSTR::
.ascid \BITNET MAILER: Protocol message code !UL (!AS) received\
FAOSTR2::
.ascid \BITNET MAILER: Status message code !XL received\
FAOSTR3::
.ascid \BITNET MAILER: From: <[!AS]!AS>\
FAOSTR4::
.ascid \BITNET MAILER: To: <[!AS]!AS>\
MYUSERID::
.ascid \GAJPH\
NOMORE::
.ascid <null>
USERMSG::
.ascid \BITNET MAILER: Recipient is GAJPH\
NULLMSG::
.ascid \BITNET MAILER: No more recipients\
LNK_MSG0:: .ascid \Outbound Connect\
LNK_MSG1:: .ascid \Outbound From:\
LNK_MSG2:: .ascid \Outbound Userid Validate\
LNK_MSG3:: .ascid \Outbound To:\
LNK_MSG4:: .ascid \Outbound Subject:\
LNK_MSG5:: .ascid \Outbound File Send\
LNK_MSG6:: .ascid \Outbound Check Send\
LNK_MSG7:: .ascid \Disconnect\
LNK_MSG8:: .ascid \Inbound Connect\
LNK_MSG9:: .ascid \Inbound From:\
LNK_MSG10:: .ascid \Inbound Userid Validate\
LNK_MSG11:: .ascid \Inbound To:\
LNK_MSG12: .ascid \Inbound Subject:\
LNK_MSG13:: .ascid \Inbound File Receive\
LNK_MSG14:: .ascid \Read a line\
LNK_MSG15:: .ascid \Write a line\
LNK_ADDR::
.address LNK_MSG0
.address LNK_MSG1
.address LNK_MSG2
.address LNK_MSG3
.address LNK_MSG4
.address LNK_MSG5
.address LNK_MSG6
.address LNK_MSG7
.address LNK_MSG8
.address LNK_MSG9
.address LNK_MSG10
.address LNK_MSG11
.address LNK_MSG12
.address LNK_MSG13
.address LNK_MSG14
.address LNK_MSG15
INDSC::
.long 80
.address OUTBUF
OUTDSC::
.long 80
.address OUTBUF
MAIL$C_PROT_MAJOR == 1
MAIL$C_PROT_MINOR == 1
.psect CODE,RD,NOWRT,EXE
.entry MAIL$PROTOCOL,M<R2,R3>
MOVL 8(AP),R2 ; R2 has func code
MOVAL LNK_ADDR,R3
PUSHL (R3)[R2] ; get appropriate message text
PUSHL R2
PUSHAQ INDSC
PUSHAW OUTDSC
PUSHAQ FAOSTR
CALLS #5,gSYS$FAO
PUSHAQ OUTDSC
CALLS #1,gLIB$PUT_OUTPUT
MOVAQ FAOSTR3,R2
CMPL 8(AP),#1 ; message type #1
BEQL 11$
MOVAQ FAOSTR4,R2
CMPL 8(AP),#2 ; message type #2
BNEQ 13$
11$: PUSHL 16(AP)
PUSHL 12(AP)
PUSHAQ INDSC
PUSHAW OUTDSC
PUSHL R2
CALLS #5,GSYS$FAO
PUSHAQ OUTDSC
CALLS #1,GLIB$PUT_OUTPUT
13$: CMPL 8(AP),#15
BNEQ 88$
MOVQ @12(AP),R2
CMPW R2,#4
BNEQ 77$
PUSHL (R3)
PUSHAQ INDSC
PUSHAW OUTDSC
PUSHAQ FAOSTR2
CALLS #4,gSYS$FAO
PUSHAQ OUTDSC
CALLS #1,gLIB$PUT_OUTPUT
CLRQ -(SP)
PUSHAQ INDSC
PUSHAW OUTDSC
PUSHL (R3)
CALLS #5,gSYS$GETMSG
PUSHAQ OUTDSC
CALLS #1,gLIB$PUT_OUTPUT
MOVL #1,R0
BRB 99$
77$: PUSHL 12(AP)
CALLS #1,gLIB$PUT_OUTPUT
BRB 99$
88$: CMPB 8(AP),#10
BNEQ 99$
CMPL @4(AP),#5555
BEQL 89$
MOVL #5555,@4(AP)
PUSHAQ MYUSERID
PUSHL 12(AP)
CALLS #2,gSTR$COPY_DX
PUSHAQ USERMSG
CALLS #1,gLIB$PUT_OUTPUT
BRB 99$
89$: PUSHAQ NOMORE
PUSHL 12(AP)
CALLS #2,gSTR$COPY_DX
PUSHAQ NULLMSG
CALLS #1,gLIB$PUT_OUTPUT
BRB 99$
99$: RET
.end
$END-OF-FILEllonn, th,