         TITLE 'Big Brother is watching you'
*++
*
* -*-ASMH-*-
*
* Big Brother, by John Wilson.
*
* Program to read the Big Brother database
* maintained by ACM:WHO.
*
* This program was Gordon Greene's idea.
* He wrote his own snapshot program, but I didn't know
* that when I wrote mine.  The name was his idea too.
*
* Please send misfeature reports to "WHO Maintenance".
*
* Mar 22/88 JMBW:  Created.
* Apr 01/89 JMBW:  Added FINGER/WHOIS commands.
* Apr 23/89 JMBW:  Added Attn handling.
* Oct 09/91 JMBW:  Added lazy DN resolver (let NETSERV1 do it).
* Feb 25/92 JMBW:  Do single command and exit if PAR= defined.
* Aug 17/92 JMBW:  HOST command, cleaned up $REL *BB*.
* Sep 28/92 JMBW:  HOST now checks MX records.
* Jan 02/93 JMBW:  LIST command.
*
*--
         GBLA  &FNDS(4)           ;friendly neighborhood dom. server
&FNDS(1) SETA  128,113,1,5        ;NETSERV1.ITS.RPI.EDU (128.113.1.5)
*FNDS(1) SETA  128,113,5,81       ;AIX01.ECS.RPI.EDU
*
         GBLC  &MTS               ;hostname of this MTS
&MTS     SETC  'MTS.RPI.EDU'      ;for SMTP "HELO" cmd
*
         GBLC  &BBUSERS,&BBNAMES,&BBHELP,&WNID,&TTYLOC
         GBLC  &HOSTS,&HOST#S
&BBUSERS SETC  'ACM0:BB.USERS'    ;userID's data file
&BBNAMES SETC  'ACM0:BB.NAMES'    ;nameID's data file
&BBHELP  SETC  'ACM0:BB.HELP'     ;file displayed on HELP
&WNID    SETC  'ACM0'             ;loc of default WHO.NAMES
&TTYLOC  SETC  'GZ7V:TERMINALS'   ;term loc database
&HOSTS   SETC  'ACM0:HOSTS'       ;host names lookup file
&HOST#S  SETC  'ACM0:HOSTNUMS'    ;host numbers lookup file
*
TTLDR    EQU   17                 ;length of leader in &TTYLOC
*
*        PUNCH ' RIP  MMDVLSTL'   ;it's just not good enough
*
         MACRO
&LAB     JSYS  &DEST,&ARGS,&ERR   ;Jump to SYStem
&LAB     L     15,=V(&DEST)
         AIF   ('&ARGS' EQ '').NOARGS
         LA    1,&ARGS
.NOARGS  BASR  14,15
         AIF   ('&ERR' EQ '').NOERR
         LTR   15,15
         BNZ   &ERR
.NOERR   MEND
* Entry in command table.
* &STR contains exactly one '-' to indicate minimum abbreviation
* &ADDR is branch address
         MACRO
&LAB     CMD   &STR,&ADDR
         LCLA  &LEN,&I
         LCLC  &S
&LEN     SETA  K'&STR
&I       SETA  2
.A       AIF   (&I GE &LEN).X
         AIF   ('&STR'(&I,1) EQ '-').B
&I       SETA  &I+1
         AGO   .A
.B       ANOP
&LAB     DC    AL1(&LEN-4,&I-3)
&S       SETC  '&STR'(2,&I-2).'&STR'(&I+1,&LEN-&I-1)
         DC    C'&S'
         B     &ADDR
         MEXIT
.X       MNOTE 4,' missing "-" in string'
         MEND
*
         MACRO
&LAB     SPSTR &STR,&LUN          ;SPRINT-style list
&LAB     DC    A(C&LAB,L&LAB,ZERO,DUMMY)
         AIF   ('&LUN' EQ '').NOLUN
         DC    A(&LUN)
.NOLUN   ANOP
C&LAB    DC    C&STR
L&LAB    DC    Y(L'C&LAB)
         MEND
*
         MACRO
&LAB     CTRL  &STR               ;$CONTROL string
&LAB     DC    A(C&LAB,L&LAB,NAMFD,CTAREA)
C&LAB    DC    C&STR
L&LAB    DC    Y(L'C&LAB)
         MEND
*
* Entry point.
*
BB       CSECT
         ENTER (11,12),SA=REGS
         L     2,0(1)             ;get PAR= string
         LM    0,1,=A(ATTN,ATNREG) ;ATTNTRP args
         JSYS  ATTNTRP            ;trap Attn's
         LH    3,0(2)             ;get length
         LA    2,2(2)             ;skip it
         STM   2,3,PARSTR         ;save
         LTR   3,3                ;get anything?
         BNZ   OPWN               ;yes, don't show banner
         JSYS  SPRINT,BAN1        ;say hello
         JSYS  SPRINT,BAN2
         JSYS  SPRINT,BLANK
*
* Open WHO.NAMES
*
OPWN     LA    9,3                ;3 strikes and we're out
OPWN1    LA    0,1                ;unit 1
         JSYS  GDINFO3            ;implicit open
         LTR   15,15              ;successful?
         BNZ   OPWN2              ;no
         CLC   4(4,1),=C'NONE'    ;not there?
         BNE   OPWN5              ;yes it is, skip
OPWN2    BCTR  9,0                ;update try #
         LTR   9,9                ;time to give up?
         BZ    OPWN4              ;yes, no names
         CH    9,=H'2'            ;was that the 1st try?
         BE    OPWN3              ;yes, skip
         MVC   SETLST+4(4),=A(MYNAMES) ;use my names file
OPWN3    JSYS  SETLIO,SETLST      ;reassign unit 1
         B     OPWN1              ;try again
OPWN4    MVC   SETLST+4(4),=A(DUMDEV) ;use *DUMMY*
         JSYS  SETLIO,SETLST      ;assign unit 1 (can't fail)
         JSYS  SERCOM,NOWHO       ;warn them
OPWN5    LTR   3,3                ;PAR= string defined?
         BNZ   LOOP2              ;jump into loop if so
*+
*
* Main loop.
*
* Get next command.
*
*-
LOOP     CLI   BBMNTD,0           ;*BB* mounted?
         BZ    LOOP0              ;no
         L     0,NAMFD            ;release *BB*
         JSYS  FREEFD
         JSYS  RELEASE,RELBB      ;$REL *BB*
         MVI   BBMNTD,0           ;not mounted now
LOOP0    CLI   PARSTR+7,0         ;entered with PAR=?
         BNZ   EXITA              ;quit now if so
         JSYS  SETPFX,INPFX       ;set prefix for input
LOOP1    JSYS  SCARDS,SCLIST      ;get input line
         LTR   15,15              ;EOF?
         BNZ   EXITA              ;yes, take off
         LH    3,LEN              ;get length
         LA    2,KBBUF            ;pt at KB buf
LOOP2    BAS   4,SKIP             ;skip blanks
         LTR   3,3                ;anything left?
         BZ    LOOP1              ;ignore line if not
         JSYS  SETPFX,OUTPFX      ;reset for output
         CLI   0(2),C'$'          ;MTS command?
         BE    MCMD               ;yes
* eat a keyword, see what it is
         LR    1,2                ;copy ptr
KW1      CLI   0(2),C' '          ;end of keyword?
         BE    KW2                ;yes, skip
         LA    2,1(,2)            ;otherwise advance
         BCT   3,KW1              ;loop
KW2      LR    4,2                ;copy ptr
         SR    4,1                ;find length
         BCTR  4,0                ;correct for MVC
         L     5,=V(CASECONV)     ;pt at low core table
         EX    4,KWUC             ;convert to u.c.
         LA    5,KWTAB            ;pt at table
         XR    6,6                ;load 0's
         XR    7,7                ;again
KW3      CLI   0(5),X'FF'         ;end of table?
         BE    KW6                ;yes
         IC    6,0(5)             ;no, get length
         CR    4,6                ;is our string too long?
         BH    KW4                ;yes, skip this one
         IC    7,1(5)             ;get min length
         CR    4,7                ;too short?
         BL    KW4                ;yes, skip
         EX    4,KWCLC            ;compare
         BE    KW7                ;got it, skip
KW4      LA    5,2+1+4+1(5,6)     ;skip lens, str, align, B addr
         N     5,=F'-2'           ;back to halfword boundary
         B     KW3                ;loop
KW6      JSYS  SERCOM,BADKW       ;gack
         B     LOOP               ;around for more
KW7      LA    5,2+1+1(5,6)       ;skip to B instruction
         N     5,=F'-2'           ;back to hw boundary
         BR    5                  ;dispatch
KWUC     TR    0(0,1),0(5)        ;translate to u.c.
KWCLC    CLC   0(0,1),2(5)        ;compare strings
*
MCMD     JSYS  CMDNOE,CMDLST      ;do the cmd
         B     LOOP               ;get next
*
         USING RECORD,8           ;record pointer
*+
*
* Search by user ID.
*
*-
LOOKID   BAS   6,PARSID           ;get ID
         BNZ   LKID1              ;got one
         L     1,=V(LASTJOB)      ;get ptr
         L     1,0(,1)            ;point at task tab entry
         USING TASKTAB,1
         MVC   NMCCID(4),TUSER    ;get our ID
         DROP  1
LKID1    JSYS  GETFD,NMFILE       ;get names file
         ST    0,BBFD             ;save FDUB ptr
         JSYS  READ,RLIST         ;get what we have
         LR    2,15               ;copy RC
         L     0,BBFD             ;get handle
         JSYS  FREEFD             ;release the file
         LTR   2,2                ;did we get anything?
         BNZ   NOSEE              ;no, get another cmd
         JSYS  GETFD,=C'&TTYLOC ' ;open loc file
         ST    0,TTYFDP           ;save
         LA    8,FBUF             ;point at record
         LH    7,LEN              ;get length of record
LKID2    BAS   4,FORMAT           ;display this entry
LKID3    JSYS  READ,FNDLST        ;read WHO.NAMES
         LTR   15,15              ;eof?
         BNZ   LKID4              ;skip if so
         CLC   WNBUF(4),RECID     ;is this us?
         BNE   LKID3              ;loop if not
         LH    5,LEN              ;get length
         SH    5,=H'2'            ;correct
         STH   5,LEN              ;replace
         MVC   WNBUF+2(3),=C'   ' ;car ctrl, 2 blanks
         JSYS  SPRINT,PNAME       ;print the name
LKID4    JSYS  REWIND,=A(WNUNIT)  ;rewind WHO.NAMES
         LA    8,RECLEN(,8)       ;skip to next record entry
         SH    7,=Y(RECLEN)       ;anything left?
         BNZ   LKID2              ;loop if so
         L     0,TTYFDP           ;get handle
         JSYS  FREEFD             ;release TTY loc file
         B     LOOP               ;get loopy
*+
*
* Search by name ID.
*
*-
LKNMID   BAS   6,PARSID           ;get ID
         BNZ   LKNI1              ;got one
* use default (current) name
DEFNAM   L     1,=V(LASTJOB)      ;get ptr
         L     1,0(,1)            ;pnt at task tab entry
         USING TASKTAB,1
         MVC   NMCCID(4),TNAME    ;get our nameID
         DROP  1
LKNI1    JSYS  READ,FNDLST        ;read WHO.NAMES
         LTR   15,15              ;eof?
         BNZ   LKNI2              ;yes, no problem
         CLC   WNBUF(4),NMCCID    ;is this it?
         BNE   LKNI1              ;loop if not
* print nameID and name
LKPNAM   LH    1,LEN              ;get length
         LA    1,1(,1)            ;add carr ctrl
         STH   1,LEN              ;update
         JSYS  SPRINT,CFNAME      ;confirm name
         JSYS  SPRINT,BLANK       ;blank line
LKNI2    JSYS  REWIND,=A(WNUNIT)  ;rewind WHO.NAMES
         JSYS  GETFD,IDFILE       ;get ID's file
         ST    0,BBFD             ;save FDUB ptr
         JSYS  READ,RLIST         ;get what info we have
         LR    2,15               ;copy RC
         L     0,BBFD             ;get handle
         JSYS  FREEFD             ;release the file
         LTR   2,2                ;anything?
         BNZ   NOSEE              ;nope, gack
         JSYS  GETFD,=C'&TTYLOC ' ;open loc file
         ST    0,TTYFDP           ;save
         LA    8,FBUF             ;pnt at rec
         LH    7,LEN              ;get length of record
LKNI3    BAS   4,FORMAT           ;dump a record
         LA    8,RECLEN(,8)       ;advance to next
         SH    7,=Y(RECLEN)       ;anything left?
         BNZ   LKNI3              ;loop if so
         L     0,BBFD             ;get handle
         JSYS  FREEFD             ;free ID's file
         L     0,TTYFDP           ;get handle
         JSYS  FREEFD             ;release TTY loc file
         B     LOOP               ;get next cmd
*+
*
* Search by name.
*
*-
DISPLY   BAS   4,SKIP             ;skip to name
         LTR   4,3                ;anything?
         BZ    DEFNAM             ;default if not
         BCTR  4,0                ;-1
         L     1,=V(CASECONV)     ;pt at low core table
         EX    4,DISUC            ;convert to upper
         IC    1,0(2)             ;get 1st char
         CLM   1,1,=C''''         ;apostrophe?
         BE    DIS1               ;yes
         CLM   1,1,=C'"'          ;quotation mark?
         BE    DIS1               ;yes
         IC    1,=C' '            ;no, look for a blank
         B     DIS2               ;skip
DIS1     LA    2,1(,2)            ;advance
         BCTR  3,0                ;count it
         LTR   3,3                ;is that it?
         BZ    DEFNAM             ;gack if so
DIS2     LR    6,2                ;copy start
DIS3     CLM   1,1,0(2)           ;are we there yet?
         BE    DIS5               ;yes, skip
         CLI   0(2),C'_'          ;no, check for backarrow
         BNE   DIS4               ;nope
         MVI   0(2),C' '          ;replace with blank
DIS4     LA    2,1(,2)            ;skip the char
         BCT   3,DIS3             ;get loopy
DIS5     LR    7,2                ;copy
         SR    7,6                ;find length
         BCTR  7,0                ;-1 for CLC below
         CLM   1,1,=C' '          ;quotes?
         BE    DIS6               ;no
         LTR   3,3                ;did we fall off end?
         BZ    DIS6               ;yes
         LA    2,1(,2)            ;no, eat the closing quote or apost
         BCTR  3,0                ;count it
DIS6     BAS   5,CONFRM           ;check it out
         XR    10,10              ;no matches yet
         JSYS  GETFD,IDFILE       ;get ID's file
         ST    0,BBFD             ;save FDUB ptr
         JSYS  GETFD,=C'&TTYLOC ' ;open loc file
         ST    0,TTYFDP           ;save FDUB ptr
* search WHO.NAMES for a name containing our string
* R6/ addr of compare string
* R7/ length-1 of compare string
* R10/ number of matches (NZ if any)
SRCH1    JSYS  READ,FNDLST        ;read WHO.NAMES
         LTR   15,15              ;eof?
         BNZ   SRCH7              ;too bad
         LH    1,LEN              ;copy
         SH    1,=Y(1+5)          ;-1 for MVC/TR, lose nameID
         EX    1,COPNAM           ;copy the name
         L     2,=V(CASECONV)     ;upper case table
         EX    1,CVTNAM           ;convert to upper case
         SR    1,7                ;find # happy posns (-1-(-1))
         BLT   SRCH1              ;skip if none
         LA    1,1(,1)            ;convert difference to count
         LA    2,FBUF             ;pt at buf
SRCH2    EX    7,CMPNAM           ;compare
         BE    SRCH3              ;got it, get laid
         LA    2,1(,2)            ;advance
         BCT   1,SRCH2            ;try every position (69!)
         B     SRCH1              ;get psyched
SRCH3    MVC   NMCCID(4),WNBUF    ;copy nameID
         LTR   10,10              ;is this the first?
         BZ    SRCH4              ;yes, skip
         JSYS  SPRINT,BLANK       ;no, add a blank line
SRCH4    LA    10,1(,10)          ;count it
         LH    1,LEN              ;get length
         LA    1,1(,1)            ;add cc
         STH   1,LEN              ;save
         JSYS  SPRINT,CFNAME      ;confirm name
         JSYS  SPRINT,BLANK       ;blank line
         JSYS  READ,RLIST         ;get info
         LTR   15,15              ;OK?
         BNZ   SRCH6              ;no, gack
         LA    8,FBUF             ;pt @ rec
         LH    9,LEN              ;get length
SRCH5    BAS   4,FORMAT           ;do one
         LA    8,RECLEN(,8)       ;advance to next
         SH    9,=Y(RECLEN)       ;done?
         BNZ   SRCH5              ;loop if not
         B     SRCH1              ;keep it up
SRCH6    JSYS  SPRINT,NOTFND      ;no info
         B     SRCH1              ;keep going
SRCH7    LTR   10,10              ;did we get anything?
         BNZ   SRCH8              ;skip if so
         JSYS  SPRINT,NOTFND      ;no such name
SRCH8    JSYS  REWIND,=A(WNUNIT)  ;rewind WHO.NAMES
         L     0,BBFD             ;get handle
         JSYS  FREEFD             ;free ID file
         L     0,TTYFDP           ;get handle
         JSYS  FREEFD             ;free TTY loc file
         B     LOOP               ;get next command
*
DISUC    TR    0(0,2),0(1)        ;translate to u.c.
COPNAM   MVC   FBUF(0),WNBUF+5    ;get name from WHO.NAMES
CVTNAM   TR    FBUF(0),0(2)       ;translate to upper case
CMPNAM   CLC   0(0,6),0(2)        ;check for match
*+
*
* Name or ID not found.
*
*-
NOSEE    JSYS  SPRINT,NOTFND      ;aww, too bad
         B     LOOP               ;get their next wimpy excuse
*+
*
* FINGER/WHOIS
*
* Get information about a user at a remote system, or about
* the whole system.  "WHOIS user" is like "FINGER user/W";
* the meaning is site-dependent but it generally gets more stuff.
* Most of the more recent Unix servers blow this off so you lose.
*
*-
FINGER   MVI   WSWIT,0            ;no /W switch
         B     WHOIS1             ;skip
WHOIS    MVI   WSWIT,1            ;include a /W switch
WHOIS1   MVC   PORTNO(2),=C'79'   ;set port # for :NAME server
         BAL   10,UNAME           ;lookup
* convert name to ASCII, add ["/W" and] CR, LF
         LA    6,WNBUF(5)         ;pt at end of where name will go
         LTR   5,5                ;is there anything there?
         BZ    WHOIS2             ;skip if not
         BCTR  5,0                ;-1 for MVC/TR
         EX    5,WMVNAM           ;move into buffer
         L     1,=V(EBCASC)       ;EBCDICK => ASCII table
         EX    5,WCVASC           ;convert
WHOIS2   CLI   WSWIT,0            ;should we add /W?
         BZ    WHOIS3             ;skip if not
         MVC   0(2,6),=X'2F57'    ;add /W
         LA    6,2(6)             ;count +2
WHOIS3   MVC   0(2,6),=X'0D0A'    ;ASCII CR, LF
         S     6,=A(WNBUF-2)      ;find length (incl. cr,lf)
         STH   6,NCMDLN           ;save
* send them the command line
         JSYS  WRITE,NAMCMD,WPUNT ;do it
         JSYS  CONTROL,PUSH,WPUNTC ;make sure it's sent
* get whatever they say until they close
         XR    4,4                ;nothing in line buf yet
WGET1    JSYS  READ,RDNET,WDONE   ;read a record, skip if done
         LA    2,FBUF             ;pt at buffer
         LH    3,LEN              ;get length
         LTR   3,3                ;anything?
         BZ    WGET1              ;loop if not
WGET2    NI    0(2),X'7F'         ;make sure 7 bits
         CLI   0(2),X'20'         ;ctrl char?
         BLT   WGET5              ;yes
WGET3    IC    0,0(2)             ;get the char
         STC   0,KBBUF+1(4)       ;save
         LA    4,1(4)             ;update
WGET4    LA    2,1(2)             ;advance ptr
         BCT   3,WGET2            ;loop
         B     WGET1              ;read more
* handle ctrl chars; cr, lf, tab: special, caret others.
WGET5    CLI   0(2),X'0A'         ;lf?
         BE    WGET9              ;yes, flush line
         CLI   0(2),X'0D'         ;cr?
         BE    WGET4              ;yes, ignore
         CLI   0(2),X'09'         ;tab?
         BE    WGET7              ;yes, expand
WGET6    LA    1,KBBUF+1(4)       ;pt at next char
         MVI   0(1),X'5E'         ;quote with uparrow
         LA    4,1(4)             ;skip it
         XI    0(2),X'40'         ;convert
         B     WGET3              ;go copy the char
WGET7    LA    0,X'20'            ;load an ASCII blank
WGET8    STC   0,KBBUF+1(4)       ;save it
         LA    4,1(4)             ;advance
         LR    1,4                ;copy
         N     1,=F'7'            ;are we there yet?
         BNZ   WGET8              ;loop if not
         B     WGET4              ;go skip the tab
WGET9    MVI   KBBUF,X'20'        ;add carriage control
* remap characters which are missing on a Courier.
         CLI   COURIER,0          ;are we on a Courier?
         BZ    WGET10             ;no, skip
          EX   4,WXCOUR           ;yes, translate for Courier
WGET10   L     1,=V(ASCEBC)       ;pt at translation table
         EX    4,WTRREP           ;translate the reply
         LA    4,1(4)             ;+1 (count cc)
         STH   4,LEN              ;save
         JSYS  SPRINT,SPRPLY      ;display the reply
         XR    4,4                ;back to left marg
         B     WGET4              ;loop
* finish up; close the connection and release it.
WDONE    LTR   4,4                ;anything still in buf?
         BZ    WDONE2             ;no, skip
* flush last line
         MVI   KBBUF,X'20'        ;add carr. ctrl
         CLI   COURIER,0          ;are we on a Courier?
         BZ    WDONE1             ;no, skip
          EX   4,WXCOUR           ;yes, translate
WDONE1   L     1,=V(ASCEBC)       ;pt at trans table
         EX    4,WTRREP           ;translate reply
         LA    4,1(4)             ;+1 (count cc)
         STH   4,LEN              ;save
         JSYS  SPRINT,SPRPLY      ;display
WDONE2   JSYS  CONTROL,CLOSE      ;close it
         B     LOOP
*
WPUNT    JSYS  SERCOM,NETERR      ;complain
         B     LOOP
*
WPUNTC   MVC   FBUF(15),=C' Network error:' ;msg
         L     1,CTAREA+4         ;get length of msg
         BCTR  1,0                ;-1 for MVC
         EX    1,WMVMSG           ;move it
         LA    1,15(1)            ;bump length
         STH   1,LEN              ;set length
         JSYS  SERCOM,NETMSG      ;print message
         B     LOOP               ;return
*
WMVNAM   MVC   WNBUF(0),0(4)      ;copy username
WCVASC   TR    WNBUF(0),0(1)      ;translate it to ASCII
WXCOUR   TR    KBBUF(0),FIXEBC    ;fix reply for Courier
WTRREP   TR    KBBUF(0),0(1)      ;xlat reply to EBCDICK
WMVMSG   MVC   FBUF+15(0),CTAREA+8 ;copy CONTROL error msg
*+
*
* Get expansion of a mailing list.
*
* E.g.:  "LIST ITS-LOVERS@MC.LCS.MIT.EDU".
*
*-
MLIST    MVC   PORTNO(2),=C'25'   ;port # for SMTP server
         BAL   10,UNAME           ;get Internet mailname
* build "EXPN" command using username
         MVC   WNBUF(5),=C'EXPN ' ;command
         BCTR  5,0                ;R5-1 for MVC
         EX    5,EXPNMV           ;copy name
         LA    5,5+1(5)           ;re-correct, add LEN('EXPN ')
         STH   5,NCMDLN           ;save length
* eat their signon banner
         XR    9,9                ;trash reply
         BAL   10,REPLY           ;do it
* say hello (they might freak otherwise)
         JSYS  WRITE,HELO,WPUNT   ;say hello
         JSYS  CONTROL,PUSH,WPUNTC ;make sure they get it
* eat their reply
         XR    9,9                ;trash reply
         BAL   10,REPLY           ;yep
* ask for the mailing list expansion
         JSYS  WRITE,NAMCMD,WPUNT ;write "EXPN" cmd
         JSYS  CONTROL,PUSH,WPUNTC ;push it through
* display the reply
         LA    9,1                ;show the reply
         BAL   10,REPLY           ;yep
* later dude
         JSYS  WRITE,QUIT,WPUNT   ;see you
         JSYS  CONTROL,CLOSE      ;we don't care about reply
         B     LOOP
*
EXPNMV   MVC   WNBUF+5,0(4)       ;copy list name into EXPN cmd
*+
*
* Receive a reply code from the SMTP server.
*
* R9/ NZ to display it, 0 to throw it away
* R10/ link
*
*-
REPLY    JSYS  READ,RDNET,WPUNT   ;read a line
         LA    1,FBUF             ;point at command
         LH    2,LEN              ;get length
         AR    2,1                ;pt at end
         XR    3,3                ;assume not final line
* see whether first non-digit is a hyphen or not
REPLY1   CLR   1,2                ;blank or just digits?
         BER   10                 ;done if so (don't bother printing)
         CLI   0(1),C'-'          ;hyphen?
         BE    REPLY3
         CLI   0(1),C'0'          ;digit?
         BL    REPLY2
         CLI   0(1),C'9'
         LA    1,1(1)             ;(advance)
         BLE   REPLY1             ;ignore if digit
REPLY2   BCTR  3,0                ;R3=-1 (final line of reply)
         CLI   0(1),C' '          ;blank?
         BE    REPLY4             ;yes, don't back up
         BCTR  1,0                ;back up
REPLY3   MVI   0(1),C' '          ;put a blank there
REPLY4   LTR   9,9                ;should we display the msg?
         BZ    REPLY5             ;no
         ST    1,HOSTNM           ;save ptr
         SR    2,1                ;find length
         STH   2,LEN
         JSYS  SPRINT,HOSTNM      ;display the msg
REPLY5   LTR   3,3                ;is there more?
         BZ    REPLY              ;get it if so
         BR    10
*+
*
* Get information about an Internet host.
*
* Same idea as the HOST program for TOPS-20 that
* used to be on MIT-OZ.#Chaosnet in the Good Old Days.
*
*-
HOST     BAS   4,SKIP             ;skip blanks
         LTR   3,3                ;anything left?
         BZ    LOOP               ;who cares
         MVI   HSTINF,1           ;don't release *BB*
         BAL   10,LOOKUP          ;do it
           B   HSTERR             ;error from server
         BCTR  4,0                ;-1
         MVI   0(4),C' '          ;add carriage control
         LA    5,1(5)             ;length +1
         ST    4,HOSTNM           ;save
         STH   5,LEN
         JSYS  SPRINT,HOSTNM      ;give name of host
* give IP address(es)
         LA    8,IPADDR           ;point at addr list
IPA1     CLC   0(4,8),=F'0'       ;end of table?
         BZ    IPA2
         LA    8,4(8)             ;skip to end of addr
         L     4,=A(FBUF+512+1)   ;free addr
         BAL   10,CVADDR          ;convert addr
         BCTR  4,0                ;-1
         MVI   0(4),C' '          ;add carr ctrl
         LA    5,1(5)             ;length +1
         ST    4,HOSTNM           ;save
         STH   5,LEN
         JSYS  SPRINT,HOSTNM      ;display
         LA    8,4(8)             ;skip to next addr
         B     IPA1               ;loop
* ask again for HINFO stuff
IPA2     LH    1,QLEN             ;get length
         LA    1,QRY-3(1)         ;point at QTYPE LSB
         MVI   0(1),13            ;QTYPE=HINFO
         BAL   10,SNDQRY          ;ask again
           B   NOHINF             ;no error messages
* unpack HINFO field if given
         L     3,HINFO            ;get it
         LTR   3,3                ;did we get it back?
         BZ    NOHINF             ;no
         MVC   KBBUF(6),=C' CPU: ' ;heading
         LA    4,KBBUF+6          ;point after it
         XR    5,5                ;init
         IC    5,0(3)             ;get length
         LA    3,1(3)             ;advance
         BCTR  5,0                ;-1 for MVC/TR
         EX    5,HSTMVC           ;copy to our buffer
         L     6,=V(ASCEBC)       ;conversion table
         EX    5,HSTTR            ;translate to EBCDICK
         LA    4,1(5,4)           ;advance
         MVC   0(6,4),=C', OS: '  ;2nd heading
         LA    4,6(4)             ;skip
         LA    3,1(5,3)           ;advance
         IC    5,0(3)             ;get OS length
         LA    3,1(3)             ;advance
         BCTR  5,0                ;-1 for MVC/TR
         EX    5,HSTMVC           ;copy to our buffer
         EX    5,HSTTR            ;translate to EBCDICK
         LA    4,1(5,4)           ;advance
         S     4,=A(KBBUF)        ;find length
         STH   4,LEN              ;save
         JSYS  SPRINT,SPRPLY      ;display CPU/OS
NOHINF   B     LOOP
* domain server error -- probably no such host
HSTERR   CL    1,=A(NAMERR)       ;is that it?
         BNE   NSERR              ;no, punt for sure
         LH    1,QLEN             ;get length
         LA    1,QRY-3(1)         ;point at QTYPE LSB
         MVI   0(1),15            ;QTYPE=MX
         BAL   10,SNDQRY          ;ask again
           B   NSERR              ;OK OK, I get the picture
         BCTR  4,0                ;-1
         MVI   0(4),C' '          ;carriage control
         LA    5,1(5)             ;length +1
         ST    4,HOSTNM           ;save
         AR    4,5                ;point at end
         MVC   0(12,4),=C' (MX record)' ;say it's an MX rec
         LA    5,12(5)            ;update length
         STH   5,LEN
         JSYS  SPRINT,HOSTNM      ;give name
* display next MX record
MX1      L     1,MX               ;get next
         LTR   1,1                ;is that it?
         BZ    IPA2               ;yes, now ask for HINFO
         LA    1,2(1)             ;skip preference
         BAL   14,CVNAME          ;convert name
         S     4,=F'2'            ;-2
         ST    4,HOSTNM           ;save
         MVC   0(2,4),=C' @'      ;carriage control +'@'
         LA    6,2(5)             ;count it
         AR    4,6                ;skip to end
         MVC   0(12,4),=C' preference=' ;label
         LA    6,12(6)            ;update length
         LA    7,12(4)            ;update + save ptr
         LA    5,5(7)             ;point at buffer
         LR    4,5                ;copy
         L     1,MX               ;get current record
         XR    3,3                ;high word=0
         ICM   3,B'11',0(1)       ;get preference
         LA    1,C'0'             ;EBC DICK 0
         BAL   14,CVDEC           ;convert to decimal
         SR    5,4                ;length
         EX    5,PRFMVC           ;copy (+1 junk char)
         AR    6,5                ;total length
         STH   6,LEN              ;length
         JSYS  SPRINT,HOSTNM      ;display entry
         MVC   MX(10*4),MX+4      ;scroll MX list
         B     MX1                ;loop
*
HSTMVC   MVC   0(0,4),0(3)        ;copy string
HSTTR    TR    0(0,4),0(6)        ;translate to EBCDICK
PRFMVC   MVC   0(0,7),0(4)        ;copy preference
*+
*
* Parse "NAME@HOST".
*
* On return (if any -- punts on error),
* R4/ points to EBCDICK username
* R5/ length of username
*
* If all went well then the "[HOST]" message has been displayed
* and the connection has been made.
*
*-
UNAME    BAS   4,SKIP             ;skip blanks
         LTR   3,3                ;anything left?
         BZ    LOOP               ;no, ignore the command
* parse off name (everything before @), if any
         LR    4,2                ;copy ptr
UNAME1   CLI   0(2),C'@'          ;end of name (if any)?
         BE    UNAME3             ;yes, skip
         LA    2,1(2)             ;no, advance
         BCT   3,UNAME1           ;loop
UNAME2   JSYS  SERCOM,NHNAME      ;no host name, gack
         B     LOOP               ;get next command
UNAME3   LR    5,2                ;copy ptr again
         SR    5,4                ;find # chars in name
* R4/ ptr to name, R5/length
         LA    2,1(2)             ;skip @
         BCTR  3,0                ;count it
         LTR   3,3                ;anything left?
         BZ    UNAME2             ;no, complain
* R2/ ptr to hostname in line, R3/ count of chars left in line
         STM   4,5,UNAMS1         ;save R4,R5
         ST    10,UNAMS2          ;and R10
* look up host
         MVI   HSTINF,0           ;no add'l stuff
         BAL   10,LOOKUP          ;look up the name
           B   NSERR              ;display error message
* R4/ host name or IP addr, R5/ length of name or addr
* see if we have an EBCDICK terminal
         CLI   SNSED,0            ;have we SENSEd *MSINK*?
         BNZ   UNAME5
         MVI   SNSED,1            ;don't do this again
         JSYS  GETFD,=C'*MSINK* ' ;SPRINT might be redirected
         ST    0,DUMMY            ;save FDUB ptr
         JSYS  CONTROL,SNSLST     ;get terminal info
         L     0,DUMMY            ;get FDUB ptr
         JSYS  FREEFD             ;close it
         CLC   SNSDVTYP(3),=C'327' ;327X or Courier?
         BE    UNAME4
         CLC   SNSDVTYP(3),=C'317' ;3178 then?
         BNE   UNAME5
UNAME4   MVI   COURIER,1          ;EBCDICK terminal
* display "[HOST]" (or "(HOST)" if EBCDICK) while we connect
UNAME5   LA    1,0(4,5)           ;pt at end
         S     4,=F'2'            ;back up for " ["
         CLI   COURIER,0          ;EBCDICK terminal?
         BNZ   UNAME6             ;yes, use paren's
         MVC   0(2,4),=C' ['      ;add carr. ctrl, brackets
         MVI   0(1),C']'
         B     UNAME7             ;skip
UNAME6   MVC   0(2,4),=C' ('      ;parens on Courier (no []'s)
         MVI   0(1),C')'
UNAME7   LA    5,3(5)             ;count bkts + cc
         STH   5,LEN              ;save length
         ST    4,HOSTNM           ;and addr
         JSYS  SPRINT,HOSTNM      ;display the line (should %ROLL?)
* set up the connection
         CLC   PORTNO(2),=C'79'   ;:NAME?
         BNE   UNAME8             ;no, SMTP uses TELNET
         JSYS  MOUNT,MNTTCP,WPUNT ;mount the connection
         B     UNAME9             ;skip
UNAME8   JSYS  MOUNT,MNTTLN,WPUNT ;mount the connection
UNAME9   MVI   BBMNTD,1           ;remember *BB* is mounted
         JSYS  GETFD,=C'*BB* '    ;get FDUB ptr
         ST    0,NAMFD            ;save it
* convert IP addr to EBCDICK
         LA    4,FBUF+35          ;allow space for cmd
         LA    8,IPADDR+4         ;pt past addr
         BAL   10,CVADDR          ;convert
         S     4,=F'20'           ;make room
         LA    5,20(5)            ;update length
         MVC   0(20,4),=C'DESTINATION_ADDRESS=' ;add cmd
         ST    4,DADDR            ;save addr
         STH   5,LEN              ;save
         JSYS  CONTROL,DADDR,WPUNTC ;set dest addr
         JSYS  CONTROL,DPORT,WPUNTC ;set port #
         JSYS  CONTROL,CONECT,WPUNTC ;actually connect
         LM    4,5,UNAMS1         ;restore R4,R5
         L     10,UNAMS2          ;and R10
         BR    10                 ;return
*+
*
* Look up host name/number.
*
* R2/ ptr to EBCDICK domain name or "a.b.c.d" IP addr.
* R3/ count of chars at (R2)
* R10/ link
* HSTINF/ NZ => get WKS and HINFO too, Z => just A or PTR
*
* Returns:
*  +0    domain server returned error
*        R1 set up for SERCOM call
*  +4    got at least a partial answer:
* R4/ ptr to EBCDICK domain name
* R5/ length
* IPADDR:  0-terminated table of fullword IP addresses
*
*-
LOOKUP   LR    4,2                ;copy ptr
         LR    5,3                ;copy len
* try parsing as A.B.C.D first
         LA    7,4                ;dot counter (IP addr in R6)
         XR    1,1                ;init this byte
ABCD1    CLI   0(4),C'.'          ;dot?
         BE    ABCD5
         CLI   0(4),C' '          ;end of string?
         BE    ABCD3
         CLI   0(4),C'0'          ;digit?
         BL    DNAM1
         CLI   0(4),C'9'
         BH    DNAM1
         M     0,=F'10'           ;*10
         IC    0,0(4)             ;get dig
         SH    0,=Y(C'0')         ;convert to dec
         AR    1,0                ;add it in
         CH    1,=H'255'          ;overflowed byte?
         BGT   DNAM1
ABCD2    LA    4,1(4)             ;skip char
         BCT   5,ABCD1            ;loop
ABCD3    SLL   6,8                ;left 8
         OR    6,1                ;OR in last byte
         BCT   7,DNAM1            ;we should be done, punt if not
* it was an IP addr, value in R6
         ST    6,IPADDR           ;save IP addr
         ST    7,IPADDR+4         ;(=0) mark end of addr list
* make a query:
* QNAME: D.C.B.A.IN-ADDR.ARPA, QTYPE: PTR, QCLASS: IN
         LA    4,INADDR           ;pt at buffer
         LA    1,X'30'            ;ASCII 0
         LA    7,4                ;loop count
         LA    8,IPADDR           ;point at addr
ABCD4    LR    0,4                ;copy ptr
         XR    3,3                ;zap
         IC    3,0(8)             ;get next #
         LA    8,1(8)             ;skip it
         BAL   14,CVDEC           ;convert
         SR    0,4                ;find length
         BCTR  4,0                ;-1
         STC   0,0(4)             ;save it
         BCT   7,ABCD4            ;loop
         LA    5,ENDINA-1         ;end of query -1 (for MVC)
         SR    5,4                ;find length
         EX    5,COPQNM           ;copy QNAME
         LA    5,QRYBUF-QRY+1(5)  ;add length of header, correct
         STH   5,QLEN             ;save length
         B     QUERY1             ;go send query
ABCD5    SLL   6,8                ;left 8
         OR    6,1                ;OR in the new byte
         XR    1,1                ;init for next one
         BCT   7,ABCD2            ;go skip the ., unless too many
* must be a domain name, parse and build query
DNAM1    MVC   IPADDR(4),=F'0'    ;don't know IP addr
         LA    4,QRYBUF           ;pt at buffer
         LR    5,2                ;init ptr
         L     7,=V(EBCASC)       ;xlat table
* parse next label
DNAM2    CLI   0(2),C' '          ;end?
         BE    DNAM4
         CLI   0(2),C'.'          ;end of label?
         BE    DNAM5
DNAM3    LA    2,1(2)             ;skip
         BCT   3,DNAM2
DNAM4    LR    6,2                ;copy
         SR    6,5                ;find length
         STC   6,0(4)             ;poke length
         BCTR  6,0                ;-1 for MVC/TR
         EX    6,COPLAB           ;copy label
         EX    6,TRLAB            ;xlat to ASCII
         LA    4,2(4,6)           ;skip
         MVC   0(5,4),=X'0000010001' ;end, QTYPE=A, QCLASS=IN
         S     4,=A(QRY-5)        ;find total length
         STH   4,QLEN             ;save
         B     QUERY1             ;go
DNAM5    LR    6,2                ;copy
         SR    6,5                ;find length
         STC   6,0(4)             ;poke it
         BCTR  6,0                ;-1 for MVC/TR
         EX    6,COPLAB           ;copy label
         EX    6,TRLAB            ;xlat to ASCII
         LA    4,2(4,6)           ;skip
         LA    5,1(2)             ;pt at next
         B     DNAM3
* whatever it was, build and send the query
* QRYBUF/ QNAME, QTYPE, and QCLASS fields
* QLEN/ length of above
* IPADDR is non-zero if we're looking up a name from a number,
* zero if we have the name and want the number(s).
QUERY1   MVC   QRY+10(2),=X'0001' ;QDCOUNT=1
         CLI   HSTINF,0           ;are we doing the hostinfo thing?
         BZ    QUERY2
         XR    0,0                ;get 0
         ST    0,TCPWKS           ;no TCP WKS's yet
         ST    0,UDPWKS           ;or UDP either
         ST    0,HINFO            ;or HINFO
         ST    0,MX               ;or MX records
QUERY2   JSYS  MOUNT,MNTUDP,DPUNT ;get a network device
         MVI   BBMNTD,1           ;mounted
         JSYS  GETFD,=C'*BB* '    ;get an FDUB ptr
         ST    0,NAMFD            ;save
         JSYS  CONTROL,WATYPE,DPUNT ;WRITE_ADDRESS_TYPE=BUFFER
         JSYS  CONTROL,TIMER,DPUNT ;set timeout
         JSYS  CONTROL,SOCKET,DPUNT ;SOCKET
* send the query
SNDQRY   LA    2,5                ;# retries
QUERY3   JSYS  WRITE,QUERY,DPUNT  ;yep
         JSYS  READ,RDNET         ;get reply
         LTR   15,15              ;OK?
         BZ    QUERY4             ;yes
         BCT   2,QUERY3           ;retry
DPUNT    L     0,NAMFD            ;close *BB*
         JSYS  FREEFD
         JSYS  RELEASE,RELBB      ;$REL *BB*
         MVI   BBMNTD,0           ;not mounted
         CLC   IPADDR(4),=F'0'    ;doing PTR lookup?
         BZ    DPUNT2             ;no, error for sure
         CLI   HSTINF,0           ;did we want more info?
         BNZ   LOOP               ;yes, give up quietly
* settle for the IP address they gave us if that's all we wanted
DPUNT1   LA    4,FBUF+17          ;allow space for no. +' ['
         LA    8,IPADDR+4         ;point at address
         B     CVADDR             ;cvt IP addr, return (R10)
DPUNT2   JSYS  SERCOM,LUKERR      ;lookup error
         B     LOOP
QUERY4   CLI   HSTINF,0           ;holding out for HINFO?
         BNZ   QUERY5             ;yes, don't release
         L     0,NAMFD            ;close *BB*
         JSYS  FREEFD
         JSYS  RELEASE,RELBB      ;$REL *BB*
         MVI   BBMNTD,0           ;not mounted
* server reply is in FBUF, length in LEN
QUERY5   IC    1,FBUF+3           ;get response code
         N     1,=F'15'           ;isolate low 4
         BZ    RESP               ;we won, parse RR's
         SLL   1,2                ;*4
         L     1,RSPDSP-4(1)      ;get SERCOM list
         BR    10                 ;return
* N.B. IPADDR may contain a valid address
NSERR    JSYS  SERCOM             ;jump here for error msg
         B     LOOP
RSPDSP   DC    A(FMTERR,SRVFLR,NAMERR,NOTIMP,REFUSD)
         DC    A(SRVERR,SRVERR,SRVERR,SRVERR,SRVERR)
         DC    A(SRVERR,SRVERR,SRVERR,SRVERR,SRVERR)
* things are OK, handle response
RESP     LA    1,FBUF+12          ;pt at returned info
         LH    9,FBUF+4           ;get QDCOUNT
* skip queries
         LTR   9,9                ;did they return it?
         BZ    RESP2              ;no
RESP1    BAL   14,SKNAME          ;skip QNAME
         LA    1,4(1)             ;skip QTYPE, QCLASS
         BCT   9,RESP1            ;loop
RESP2    ST    9,HNAME            ;no hostname yet
         LH    9,FBUF+6           ;get ANCOUNT
         LTR   9,9                ;non-zero, right?
         BZ    RR3                ;punt!
* scan answer RR's for the ones we want
RR1      CLC   HNAME(4),=F'0'     ;do we have a hostname?
         BNZ   *+8
           ST  1,HNAME            ;set default if not
         BAL   14,SKNAME          ;skip name
         CLC   0(2,1),=X'0001'    ;A?
         BE    RRA
         CLC   0(2,1),=X'0005'    ;CNAME?
         BE    RRCNAM
         CLC   0(2,1),=X'000B'    ;WKS?
         BE    RRWKS
         CLC   0(2,1),=X'000C'    ;PTR?
         BE    RRPTR
         CLC   0(2,1),=X'000D'    ;HINFO?
         BE    RRHINF
         CLC   0(2,1),=X'000F'    ;MX?
         BE    RRMX
RR2      XR    2,2                ;zap out R2
         ICM   2,3,8(1)           ;get RDLENGTH
         LA    1,10(2,1)          ;skip to next RR
         BCT   9,RR1              ;loop
* we're done, make sure we got the name
RR3      L     1,HNAME            ;get it
         LTR   1,1                ;anything?
         BZ    NONAME
         BAL   14,CVNAME          ;convert
         B     4(10)              ;happy return
NONAME   LA    1,NAMERR           ;point at msg
         BR    10                 ;error return
* address RR
RRA      ICM   2,15,10(1)         ;get IP addr
         LA    3,IPADDR           ;init ptr
RRA1     CLC   0(4,3),=F'0'       ;empty slot?
         BZ    RRA2               ;skip
         LA    3,4(3)             ;skip
         CL    3,=A(4*10+IPADDR)  ;off end?
         BL    RRA1               ;loop
         B     RR2                ;just lose it
RRA2     ST    2,0(3)             ;save
         MVC   4(4,3),=F'0'       ;zap next entry
         B     RR2                ;(space for F'0' after end)
* CNAME RR
RRCNAM   LA    2,10(1)            ;pt at CNAME
         ST    2,HNAME            ;definitely right
         B     RR2
* WKS RR
RRWKS    B     RR2                ;later...
* PTR RR
RRPTR    LA    2,10(1)            ;pt at PTR
         ST    2,HNAME            ;definitely right
         B     RR2
* HINFO RR
RRHINF   LA    0,10(1)            ;addr
         ST    0,HINFO            ;save ptr
         B     RR2
* MX RR
RRMX     LA    2,10(1)            ;pt at MX record
         LA    3,MX               ;init ptr
RRMX1    CLC   0(4,3),=F'0'       ;empty slot?
         BZ    RRMX2
         LA    3,4(3)             ;skip it if not
         CL    3,=A(4*10+MX)      ;off end?
         BL    RRMX1              ;loop
         B     RR2                ;just lose it
RRMX2    ST    2,0(3)             ;save
         MVC   4(4,3),=F'0'       ;zap next entry
         B     RR2                ;(space for F'0' after end)
*
COPLAB   MVC   1(0,4),0(5)        ;copy label to query
TRLAB    TR    1(0,4),0(7)        ;translate to ASCII
COPQNM   MVC   QRYBUF(0),0(4)     ;copy query into buf
*+
*
* Convert a hostname from query form to EBCDICK.
*
* R1/ pointer to hostname (RFC 1035 form)
* R14/ link
*
* Returns:
* R4/ pointer to name
* R5/ length
*
*-
CVNAME   L     4,=A(FBUF+2+512)   ;guaranteed free (RFC 1035) +' ['
         LR    5,4                ;save for length
         LM    2,3,=V(ASCEBC,CASECONV) ;conversion tables
CVN1     CLI   0(1),X'C0'         ;pointer?
         BGE   CVN2
         XR    6,6                ;init for length
         ICM   6,1,0(1)           ;get length, set CC
         BZ    CVN3               ;end
         LA    1,1(1)             ;skip length
         BCTR  6,0                ;-1 for MVC/TR
         EX    6,CVNMVC           ;copy label
         EX    6,CVNTR1           ;EBCDICK
         EX    6,CVNTR2           ;UPPER CASE!
         AR    4,6                ;skip to last char
         MVI   1(4),C'.'          ;add a .
         LA    4,2(4)             ;skip past it
         LA    1,1(6,1)           ;skip to next label
         B     CVN1               ;loop
CVN2     ICM   1,3,0(1)           ;get pointer
         N     1,=F'16383'        ;isolate
         LA    1,FBUF(1)          ;index into buf
         B     CVN1               ;continue
CVN3     CLR   4,5                ;have we moved?
         BE    *+6                ;no (?!), don't lose
           BCTR 4,0               ;un-put last .
         SR    5,4                ;find -length
         LPR   5,5                ;|length|
         SR    4,5                ;back up
         BR    14                 ;return
*
CVNMVC   MVC   0(0,4),0(1)        ;copy string
CVNTR1   TR    0(0,4),0(2)        ;xlat to EBCDICK
CVNTR2   TR    0(0,4),0(3)        ;xlat to u.c.
*+
*
* Skip a domain name.
*
* R1/ domain name (RFC 1035 form)
* R14/ link
*
* R1 is updated on return.
*
*-
SKNAME   XR    2,2                ;zap
SKN1     CLI   0(1),X'00'         ;end?
         BZ    SKN3
         CLI   0(1),X'C0'         ;pointer?
         BGE   SKN2
         IC    2,0(1)             ;get length
         LA    1,1(2,1)           ;skip
         B     SKN1
SKN2     LA    1,1(1)             ;+1 (+2 total)
SKN3     LA    1,1(1)             ;+1
         BR    14
*+
*
* Convert number to decimal.
*
* R1/ C'0' or ASCII '0'
* R3/ number
* R4/ end of buffer (predecrement)
* R14/ link
*
*-
CVDEC    XR    2,2                ;zero-extend
         D     2,=F'10'           ;divide
         AR    2,1                ;cvt to EBCDICK or ASCII
         BCTR  4,0                ;back up
         STC   2,0(4)             ;save
         LTR   3,3                ;anything left?
         BNZ   CVDEC              ;loop
         BR    14                 ;return
*+
*
* Convert IP addr to EBCDICK.
*
* R4/ end of buffer
* R8/ ptr to end of IP addr
* R10/ link
*
* On return:
* R4/ begn of buffer
* R5/ length
*
*-
CVADDR   LR    5,4                ;copy for subtract later
         LA    1,C'0'             ;EBCDICK 0
         LA    7,4                ;loop count
CVADR1   XR    3,3                ;zap
         BCTR  8,0                ;-1
         IC    3,0(8)             ;get next #
         BAL   14,CVDEC           ;convert
         BCTR  4,0                ;-1
         MVI   0(4),C'.'          ;dot
         BCT   7,CVADR1           ;loop
         LA    4,1(4)             ;skip 1st .
         SR    5,4                ;find length
         BR    10                 ;return
*+
*
* List help file.
*
*-
HELP     BAS   5,CONFRM           ;check for trash
         JSYS  GETFD,=C'&BBHELP ' ;open help file
         ST    0,HELPFD           ;save
HELP1    JSYS  READ,RHELP         ;read a line
         LTR   15,15              ;done?
         BNZ   HELP2              ;yes
         JSYS  SPRINT,WHELP       ;copy to screen
         B     HELP1              ;loop
HELP2    L     0,HELPFD           ;get handle
         JSYS  FREEFD             ;close file
         B     LOOP               ;get next cmd
 
*+
*
* Format and print the output line.
*
* Call:  BAS 4,FORMAT
*
* Enter at FORMA1 if the time field has already been set up.
*
* Accumulators 6 and above are preserved.
*
*-
FORMAT   L     1,RECTIM           ;get time/date
         JSYS  JULGRGTM           ;convert
         STM   0,3,TIMBUF         ;save
         IC    1,TIMBUF+1         ;get low dig of month
         N     1,=F'15'           ;zero-extend, chop off EBC DICK
         IC    2,TIMBUF           ;get high dig of month
         N     2,=F'1'            ;cvt to binary
         LNR   2,2                ;0 or -1
         N     2,=F'10'           ;get it
         AR    1,2                ;add
         LR    2,1                ;copy
         AR    1,2                ;*2
         AR    1,2                ;*3
         LA    1,MONTHS-3(1)      ;index
         ICM   1,7,0(1)           ;get month
         STCM  1,7,REPTIM         ;save it
         MVC   REPTIM+4(2),TIMBUF+3 ;copy DD
         MVC   REPTIM+7(2),TIMBUF+6 ;copy YY
         MVC   REPTIM+10(5),TIMBUF+8 ;copy HH:MM
FORMA1   MVC   REPID(4),RECID     ;copy ID
         MVC   REPDEV(4),RECDEV   ;copy device name
         MVC   TTYLIN(4),RECDEV   ;copy device #
         L     5,=F'-1'           ;assume none (-TRAILING)
         JSYS  READ,TTRLST        ;try to read location
         LTR   15,15              ;did we get it?
         BNZ   FORMA2             ;no, skip
         LH    5,LEN              ;get length
         SH    5,=Y(TTLDR)        ;subtract leader info
         EX    5,CMVCTT           ;copy TTY loc
FORMA2   LA    5,REPLOC-REPORT(,5) ;total length
         STH   5,LEN              ;save length
         JSYS  SPRINT,FMTSPR      ;print the line
         BR    4                  ;return
*+
*
* Parse a 4-character ID.
*
* Call: BAS 6,PARSID
*
* Returns Z=1 if eol reached (use default ID).
*
*-
PARSID   BAS   4,SKIP             ;skip blanks
         LTR   3,3                ;anything left?
         BZR   6                  ;no, return Z=1
         MVC   NMCCID(4),=C'$.$.' ;init in case < 4 chars
         LR    4,2                ;save ptr
PRSID1   CLI   0(2),C' '          ;end of ID?
         BE    PRSID2             ;skip if so
         LA    2,1(,2)            ;advance ptr
         BCT   3,PRSID1           ;get loopy
PRSID2   LR    1,2                ;copy ptr
         SR    1,4                ;find # chars
         CH    1,=H'4'            ;too long?
         BH    CNFRM1             ;yep, extra stuff
         BCTR  1,0                ;-1 for MVC
         EX    1,MVCID            ;copy
         L     5,=V(CASECONV)     ;pt at low core table
         TR    NMCCID(4),0(5)     ;convert to upper case
         BAS   5,CONFRM           ;anything left?
         LTR   6,6                ;set Z=0
         BR    6                  ;return
MVCID    MVC   NMCCID(0),0(4)     ;copy 1-4 chars of ID
*+
*
* Skip blanks.  Ptr in 2, remaining length in 3.
*
* Call:  BAS 4,SKIP
*
*-
SKIP     LTR   3,3                ;anything to skip?
         BZR   4                  ;return now if not
SKIP1    CLI   0(2),C' '          ;blank?
         BNER  4                  ;return if not
         LA    2,1(,2)            ;skip it
         BCT   3,SKIP1            ;get loopy
         BR    4                  ;ran out of stuff
*+
*
* Check for confirmation.
*
* Call:  BAS 5,CONFRM
*
*-
CONFRM   BAS   4,SKIP             ;skip blanks
         LTR   3,3                ;end of line?
         BZR   5                  ;yes, good
CNFRM1   JSYS  SERCOM,NOTCNF      ;complain
         B     LOOP               ;around for more
*
EXITA    EXIT  ,                  ;die
*+
*
* Attn vector.
*
* We come here on an Attn.
*
*-
         DROP  11,12              ;just for a second
         USING ATTN,15
ATTN     LM    11,12,=A(BB,BB+X'1000') ;reload base regs
         DROP  15                 ;forget it
         USING BB,11,12           ;we're back
         LA    13,REGS            ;pt at savearea (so EXIT works)
         JSYS  SETPFX,ATNPFX      ;prefix = !
         JSYS  SERCOM,BLANK       ;say hello (at left marg)
         LM    0,1,=A(ATTN,ATNREG) ;pt at region
         JSYS  ATTNTRP            ;reenable
         B     LOOP               ;continue
*
         LTORG                    ;dump constant pool
*
KWTAB    CMD   'D-ISPLAY',DISPLY  ;show data for a name
         CMD   'E-XPLAIN',HELP    ;syn. for HELP
         CMD   'F-INGER',FINGER   ;get :NAME info (network)
         CMD   'HE-LP',HELP       ;print help file
         CMD   'HO-ST',HOST       ;get info about host
         CMD   'I-D',LOOKID       ;show data for a CCID
         CMD   'L-IST',MLIST      ;show mailing list members
         CMD   'M-TS',EXITA       ;syn. for STOP
         CMD   'N-AMEID',LKNMID   ;show data for a nameID
         CMD   'S-TOP',EXITA      ;exit the program
         CMD   'W-HOIS',WHOIS     ;get :WHOIS info (network)
         CMD   ':N-AME',FINGER    ;ITS-style synonyms (whee)
         CMD   ':W-HOIS',WHOIS
         CMD   '?-',HELP          ;syn. for HELP
         DC    X'FF'              ;end of table
*
MONTHS   DC    C'JanFebMarAprMayJunJulAugSepOctNovDec'
*
FIXEBC   EQU   *-X'20'            ;table to fix for EBCDICK terms
         DC    X'202122232425262728292A2B2C2D2E2F'
         DC    X'303132333435363738393A3B3C3D3E3F'
         DC    X'404142434445464748494A4B4C4D4E4F'
         DC    X'505152535455565758595A282F29A25F' ;[\]^ => (/)"
         DC    X'276162636465666768696A6B6C6D6E6F' ;` => '
         DC    X'707172737475767778797A3C7C3EAC7F' ;{}~ => <>,
*
CMVCTT   MVC   REPLOC(0),TTBUF+TTLDR ;copy term loc
IDFILE   DC    C'&BBUSERS '       ;userID file
NMFILE   DC    C'&BBNAMES '       ;nameID file
HLPFIL   DC    C'&BBHELP '        ;help file
RLIST    DC    A(FBUF,LEN,RMODS,NMCCID,BBFD)
WLIST    DC    A(FBUF,LEN,@I,NMCCID,BBFD)
NMCCID   DS    F                  ;use nameID or CCID as line #
RMODS    DC    XL4'08000002'      ;@MAXLEN @I
@MAXLEN  DC    XL4'08000000'      ;@MAXLEN
@I       DC    XL4'00000002'      ;@I
NETMOD   DC    XL4'48000000'      ;@ERRRTN @MAXLEN
LEN      DS    H                  ;length read
         DC    Y(L'FBUF)          ;length of buffer
         DS    H                  ;useless
*
BAN1     SPSTR ' Big Brother, by John Wilson'
BAN2     SPSTR ' Version: &SYSDATE'
NOWHO    SPSTR ' ??? UNABLE TO ACCESS WHO.NAMES ???'
BLANK    DC    A(BLANKC,ONEH,ZERO,DUMMY)
ONEH     DC    H'1'
*
INPFX    DC    A(*+4)             ;SCARDS input prefix
         DC    C'*'
OUTPFX   DC    A(BLANKC)          ;SPRINT output prefix
BLANKC   DC    C' '
ATNPFX   DC    A(*+4)             ;Attn prefix
         DC    C'!'
*
SCLIST   DC    A(KBBUF,LEN,@MAXLEN,DUMMY) ;SCARDS args
CMDLST   DC    A(KBBUF,LEN)       ;CMDNOE args
BADKW    SPSTR ' I beg your pardon?'
NOTCNF   SPSTR ' Extra character(s) on command line'
CFNAME   DC    A(WNCC,LEN,ZERO,DUMMY) ;SPRINT confirm name
NOTFND   SPSTR ' No information available'
NHNAME   SPSTR ' Name must end in "@host"'
LUKERR   SPSTR ' Name server lookup error'
FMTERR   SPSTR ' Name format error'
SRVFLR   SPSTR ' Name server failure'
NAMERR   SPSTR ' No such host'
NOTIMP   SPSTR ' Query type unimplemented in name server'
REFUSD   SPSTR ' Fascist name server refuses access'
NETERR   SPSTR ' Network error'
SRVERR   SPSTR ' Host name server error'
HELO     SPSTR 'HELO &MTS',NAMFD  ;say hi to SMTP server
QUIT     SPSTR 'QUIT',NAMFD       ;then blow it off
*
NAMCMD   DC    A(WNBUF,NCMDLN,ZERO,DUMMY,NAMFD) ;:NAME cmd
RDNET    DC    A(FBUF,LEN,NETMOD,DUMMY,NAMFD) ;read net
SPRPLY   DC    A(KBBUF,LEN,ZERO,DUMMY) ;echo reply
RDHNUM   DC    A(FBUF,LEN,@I,TTBUF,NAMFD) ;read HOSTNUMS
RDHNAM   DC    A(KBBUF,LEN,@I,DUMMY,NAMFD) ;read HOSTS
RDHOST   DC    A(KBBUF+2,LEN,@I,HOST,NAMFD) ;again
HOSTNM   DC    A(0,LEN,ZERO,DUMMY) ;echo host name
NETMSG   DC    A(FBUF,LEN,ZERO,DUMMY) ;net error message
*
SNSLST   DC    A(SNSBUF,SNSLEN,DUMMY,0) ;$CONTROL SNS *MSINK* args
SNSLEN   DC    H'56'
SNSED    DC    X'00'              ;Z => haven't SNS'ed *MSINK* yet
COURIER  DC    X'00'              ;NZ => *MSINK* is a Courier (no [])
*
HSTINF   DS    X                  ;NZ => LOOKUP gets WKS & HINFO too
*
SNSBUF   DC    C'SNS'
SNSMDSET DS    X                  ;=0 for terminals
SNSDVNAM DS    CL4                ;device name ('N001', &c.)
SNSDVTYP DS    CL4                ;device type ('VTP ', &c.)
SNSCUNAM DS    CL4                ;ctrl unit name ('NET0', &c.)
SNSCUTYP DS    CL4                ;ctrl unit type
SNSLAID  DS    CL4                ;line adapter ID ('DIAL', &c.)
SNSTRNAM DS    CL24               ;terminal name (yeah right)
SNSTRTYP DS    CL8                ;term type (Vol. IV)
*
         DS    16C                ;space for 4 3-dig numbers (+cnt)
INADDR   DC    X'07494E2D41444452044152504100' ;QNAME=IN-ADDR.ARPA
         DC    X'000C'            ;QTYPE=PTR
         DC    X'0001'            ;QCLASS=IN
ENDINA   EQU   *
*
QUERY    DC    A(QRY,QLEN,ZERO,DUMMY,NAMFD)
QLEN     DS    H                  ;length of query
QRY      DC    X'0035'            ;port 53
         DC    AL1(&FNDS(1),&FNDS(2),&FNDS(3),&FNDS(4)) ;server
         DC    X'1234'            ;handle (who cares)
         DC    X'0100'            ;QUERY (RD=1)
         DC    X'0001'            ;QDCOUNT (1 question)
         DC    X'0000'            ;ANCOUNT (0 answers)
         DC    X'0000'            ;NSCOUNT (0 NS authorities)
         DC    X'0000'            ;ARCOUNT (0 add'l records)
QRYBUF   DS    500C               ;query goes here
*
TCPWKS   DS    F                  ;TCP WKS's
UDPWKS   DS    F                  ;UDP WKS's
HINFO    DS    F                  ;CPU/OS
*
HELPFD   DS    F                  ;help file FDUB ptr
RHELP    DC    A(WNBUF,LEN,ZERO,DUMMY,HELPFD) ;read help file
WHELP    DC    A(WNBUF,LEN,ZERO,DUMMY) ;print help file
*
TIMLST   DC    A(TIMKEY,ZERO,CURTIM) ;TIME arg list
TIMKEY   DC    F'14'              ;minutes since 03/01/00 00:00
ZERO     DC    F'0'               ;constant 0
*
TTRLST   DC    A(TTBUF,LEN,@I,TTYLIN,TTYFDP) ;read TTY loc
FMTSPR   DC    A(REPORT,LEN,ZERO,DUMMY) ;formatted report
*
SETLST   DC    A(WNUNIT,WHO#NAMES) ;assign unit 1
MYNAMES  DC    C'&WNID:'          ;"offical" WHO.NAMES
WHO#NAMES DC   C'WHO.NAMES '      ;filename
DUMDEV   DC    C'*DUMMY* '        ;use when can't find WHO.NAMES
FNDLST   DC    A(WNBUF,LEN,@MAXLEN,DUMMY,WNUNIT)
PNAME    DC    A(WNBUF+2,LEN,ZERO,DUMMY)
WNUNIT   DC    F'1'               ;WHO.NAMES unit #
*
LILIST   DC    A(LTYP,LNAM,LBOUT,LREG) ;LOADINFO parm list
LTYP     DC    F'257'             ;symbol type = resident system
LNAM     DC    CL8'MMDVLSTL'      ;name of symbol
LBOUT    DS    F
LREG     DS    20F                ;output region
*
* $MOUNT and $CONTROL strings
*
MNTTCP   DC    A(NREQ,TCPBB,LTCPBB),X'80',AL3(MOPT) ;MOUNT TCP *BB*
MNTUDP   DC    A(NREQ,UDPBB,LTCPBB),X'80',AL3(MOPT) ;MOUNT UDP *BB*
MNTTLN   DC    A(NREQ,TLNBB,LTLNBB),X'80',AL3(MOPT) ;MOUNT TELNET *BB*
NREQ     DC    F'1'               ;1 request
TCPBB    DC    C'TCP *BB*'        ;this is it
UDPBB    DC    C'UDP *BB*'        ;again for UDP
LTCPBB   DC    Y(L'TCPBB)         ;length (of either)
TLNBB    DC    C'TELNET *BB*'     ;let the HIM handle TELNET
LTLNBB   DC    Y(L'TLNBB)         ;length
MOPT     DC    XL4'E800'          ;no messages or prompts
*
DADDR    DC    A(0,LEN,NAMFD,CTAREA)
DPORT    CTRL  'DESTINATION_PORT=79' ;skt 79=:NAME server, 25=SMTP
PORTNO   EQU   CDPORT+17          ;patch socket # at PORTNO
CONECT   CTRL  'CONNECT'
PUSH     CTRL  'PUSH'
CLOSE    CTRL  'CLOSE'
WATYPE   CTRL  'WRITE_ADDRESS_TYPE=BUFFER' ;fewer CONTROL calls
SOCKET   CTRL  'SOCKET'           ;establish socket
TIMER    CTRL  'TIMER=5SECONDS'   ;timeout
*
RELBB    DC    A(CBB,LBB,RELFLG)  ;RELEASE arg
CBB      DC    C'*BB*'
LBB      DC    A(L'CBB)
RELFLG   DC    XL4'10'            ;no messages
BBMNTD   DC    X'00'              ;NZ => *BB* is mounted
*
CURID    DS    F                  ;current nameID or CCID
CURDEV   DS    F                  ;current device name
CURTIM   DS    F                  ;curr time (TIME(14,0,CURTIM))
*
BBFD     DS    F                  ;FDUB ptr for curr data file
*
DUMMY    DS    F                  ;dummy line # buf
WSWIT    DS    X                  ;NZ => use /W switch on :NAME
NAMFD    DS    F                  ;:NAME server connection
NCMDLN   DS    H                  ;length of cmd to :NAME server
HNAME    DS    F                  ;ptr to host name in server reply
PARSTR   DS    2F                 ;addr, len of PAR= parm
*
UNAMS1   DS    2F                 ;UNAME save area for R2, R3
UNAMS2   DS    F                  ;UNAME save area for R10
*
REGS     DS    18F                ;R13 save area
CTAREA   DS    27F                ;return area for CONTROL
ATNREG   DS    18F                ;save area for ATTNTRP
IPADDR   DS    10F                ;list of IP addr's to try
         DS    F                  ;F'0' marks end
MX       DS    10F                ;list of MX records
         DS    F                  ;F'0' marks end
*
REPORT   DC    C' '    ;carriage control
REPID    DS    CL4     ;nameID or CCID
         DC    C' '
REPTIM   DC    C'Mmm DD/YY HH:MM' ;time of last sighting
         DC    C' from '
REPDEV   DS    CL4     ;device name
         DC    C' '
REPLOC   DS    CL80    ;device location
*
WNCC     DC    C' '               ;car ctrl when dumping WNBUF
WNBUF    DS    CL80               ;WHO.NAMES buffer
*
KBBUF    DS    CL132              ;keyboard buffer
*
TIMBUF   DS    4F                 ;time buffer (JULGRGTM)
*
TTYLIN   DS    F                  ;ACM:TERMINALS line #
TTYFDP   DS    F                  ;      "   FDUB ptr
TTBUF    DS    CL80               ;      "   buf (FW aligned!)
*
         DS    15C                ;space for 255.255.255.255
HNUME    EQU   *                  ;end of host number
*
         DS    0H                 ;halfword-align
FBUF     DS    CL1200             ;file record buffer
*
HASHT    DS    4092F              ;space for 1023 entries
HASHE    DS    4F                 ;1024th entry
*
* Record format for the data files.
* The line number is the userID, and the line consists
* of one or more records of the following form
* (the number of records can be obtained from the physical
* length of the line).
*
RECORD   DSECT
RECID    DS    F         ;nameID or userID (line # is other)
RECDEV   DS    F         ;device last seen at
RECTIM   DS    F         ;time last seen (from "CALL TIME(14,0,I)")
RECLEN   EQU   12        ;length of a record
*
* Entry format of our own hash table.
* Offset is taken from low 10 bits of task number.
*
HASHDS   DSECT
CCID     DS    F         ;user ID (F'0' if unused)
NAMEID   DS    F         ;name ID
DEVICE   DS    F         ;*MSOURCE*/*MSINK* device name
TASKNO   DS    H         ;task #
FLAGS    DS    H         ;random flags
HARDWR   EQU   1         ;1 => hardwired terminal
HASHL    EQU   16        ;length of a record
*
* The task table is always large enough to hold the maximum
* allowable number of jobs;  unused entries are left blank
* (CCID=F'0' or F'-1').
* NBRJBTBL DC Y(size)       gives the size of the job table;
* this number is 640 at RPI, last time I checked - JMBW 5/24/87.
*
TASKTAB  DSECT
TSLOT    DS    1X        ;slot # (00 to FF, then FF till end)
TFLAG    DS    1X        ;seems to be flag bits (FF => end, *usu.*)
TTASK    DS    H         ;task number
TJOBNM   DS    CL8       ;job name
         DS    60X
TUSER    DS    CL4       ;user ID (+X'48')
TPROJ    DS    CL4       ;project number (+X'4C')
         DS    16X
TNAME    DS    CL4       ;*UD name ID (+X'60')
         DS    32X
TSTAT    DS    CL12      ;job status string (sometimes) (+X'84')
         DS    192X
TENTL    DS    0C        ;total length =X'150'
*
* Device list entry format:
*
DEVLST   DSECT
DEVTYP   DS    4C      ;device type ('3270', etc.)
DEVNAM   DS    4C      ;device name ('I008', etc.)
         DS    2C      ; ???
DEVOWN   DS    H       ;task # of owner
         DS    8C      ; ???
STUSSY   DS    A       ;Dieter says this is a ptr?
         DS    A       ; ???
DEVCON   DS    A       ;ptr to CONSDEVS record
         DS    4A      ; ???
*
* MM device list entry format:
*
MMDSECT  DSECT
MMTYPE   DS    CL4     ;connection type ('VTP ', 'X.29', etc.)
MMNAME   DS    CL4     ;port name ('N001' etc.)
MMFLAG   DS    Y       ;flags - bit 0 seems to indicate direction
MMOWNR   DS    Y       ;owner's task #
         DS    A       ;seems to be 0
MMTTAB   DS    A       ;addr of owner's task table entry
         DS    7A      ;seems to be 0
*
         END   BB

