[comp.os.vms] VMS MAIL Foreign protocol code

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,