         TITLE 'TATS FTP CLIENT'
*++
*
* Tibbits Avenue Terminal Site FTP client for MTS.
*
* -*-ASMH-*- (set tabs in SE editor)
*
* May 06/88    JMBW    Created (finals?  what, me worry?).
* Dec 03/91    JMBW    Lazy domain name resolver from BB.
* Jun 07/92    JMBW    Separated code for local base regs.
*                      (couldn't add any more code with static ones!)
*
* A TOPS-20 FTP client written by Gail Zacharias (GZ) at the
* MIT AI lab was used as a reference while writing this program.
* The source file was SLOC:FTP.MID.13 on host MIT-OZ (defunct).
*
*--
         PUNCH ' MSG Under construction, have fun! -- JMBW'
*
         GBLC  &NAME              ;domain name of this host
         GBLA  &FNDS(4)           ;friendly neighborhood dom. server
*
&NAME    SETC  'MTS.RPI.EDU'      ;domain name of this host
&FNDS(1) SETA  128,113,1,5        ;IP addr of NETSERV1.ITS.RPI.EDU
*
         GBLA  &LNAME
&LNAME   SETA  K'&NAME            ;len(&NAME)
*
TT       EQU   0                  ;accumulator definitions
A        EQU   1                  ;(indexable regs start at A)
B        EQU   2
C        EQU   3
D        EQU   4
E        EQU   5
F        EQU   6
G        EQU   7
H        EQU   8
LR       EQU   9                  ;link register (JSP)
B0       EQU   10                 ;local base reg
B1       EQU   11                 ;global code base reg
B2       EQU   12                 ;global data base reg
*
* well-known port numbers:
PFTPDATA EQU   20                 ;(TCP) FTP-DATA default data port
PFTP     EQU   21                 ;(TCP) FTP command port
PDOMAIN  EQU   53                 ;(UDP) DOMAIN name server port
*
ENL      EQU   X'15'              ;EBCDICK newline
*
* ASCII codes:
TAB      EQU   X'09'              ;tab
LF       EQU   X'0A'              ;line feed
CR       EQU   X'0D'              ;carriage return
QSP      EQU   X'20'              ;space
QCOM     EQU   X'2C'              ;",
QHYPH    EQU   X'2D'              ;"-
Q0       EQU   X'30'              ;"0
Q1       EQU   X'31'              ;"1
Q2       EQU   X'32'              ;"2
Q3       EQU   X'33'              ;"3
Q9       EQU   X'39'              ;"9
QLBR     EQU   X'5B'              ;"[
QRBR     EQU   X'5D'              ;"]
QCAR     EQU   X'5E'              ;"^
RUB      EQU   X'7F'              ;rubout
*
NL       EQU   X'25'              ;EBCDICK newline
*
         GBLC  &HNAMES,&HADDRS
&HNAMES  SETC  'GZ7V:HOST-NAMES'  ;host name lookup file
&HADDRS  SETC  'GZ7V:HOST-ADDRS'  ;host number lookup file
*
         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 '').NOPUNT
         LTR   15,15
         BNZ   &ERR
.NOPUNT  MEND
*
         MACRO
&LAB     CALL  &DEST,&ARGS        ;local call
&LAB     DS    0H
         AIF   ('&ARGS' EQ '').NOARGS
         LA    1,&ARGS
.NOARGS  BAS   14,&DEST
         MEND
*
         MACRO
&LAB     CALLF &DEST,&ARGS        ;far CALL
&LAB     DS    0H
         AIF   ('&ARGS' EQ '').NOARGS
         LA    1,&ARGS
.NOARGS  L     15,=A(&DEST)
         BASR  14,15
         MEND
*
         MACRO
&LAB     JSP   &DEST              ;local call through LR
&LAB     BAS   LR,&DEST
         MEND
*
         MACRO
&LAB     JSPF  &REG,&DEST         ;far JSP
&LAB     L     &REG,=A(&DEST)
         BASR  LR,&REG
         MEND
*
         MACRO
&LAB     J     &DEST              ;jump out of base range
&LAB     L     B0,=A(&DEST)
         BR    B0
         MEND
*
* Prefix string for CUINFO(PFXSTR)
         MACRO
&LAB     PFX   &STRING
         LCLA  &LEN
&LEN     SETA  K'&STRING-2
&LAB     DC    A(&LEN+8,&LEN),C&STRING
         MEND
*
* String and arg list for SPRINT etc.
         MACRO
&LAB     TXT   &STRING
         LCLA  &LEN
&LEN     SETA  K'&STRING-2
&LAB     DC    A(*+18,*+12,ZERO,DUMMY),Y(&LEN),C&STRING
         MEND
*
* $CONTROL string/arg list
         MACRO
&LAB     CONT  &STR,&FDUB
         LCLA  &LEN
&LEN     SETA  K'&STR-2
&LAB     DC    A(*+18,*+12,&FDUB,CTAREA),Y(&LEN),C&STR
         MEND
*
* $MOUNT string/arg list
* If FOO is MOUNT arg list,
* RFOO is RELEASE arg list,
* and PFOO is PDN name (for GETFD)
         MACRO
&LAB     MOU   &STR
         LCLC  &S
&S       SETC  '&STR'(2,K'&STR-2)
&LAB     DC    A(ONE,C&LAB,L&LAB),X'80',AL3(MOPT)
C&LAB    DC    C'&S '             ;blank for GETFD
L&LAB    DC    Y(L'C&LAB-1)       ;not included in count
R&LAB    DC    A(P&LAB,M&LAB,RELFLG) ;RELEASE arg list
P&LAB    EQU   C&LAB+4            ;PDN
M&LAB    DC    A(L'C&LAB-5)       ;PDN length
         MEND
*
* Set Attn trap vector
         MACRO
&LAB     ATTN  &ADDR
&LAB     MVC   ATNVEC,=A(&ADDR)
         MEND
*
* Entry in command table (passed in E to GETKW)
* &STR contains exactly one '-' to indicate minimum length
* &NOISE is noise for command completion on 327X's (doesn't work!)
* &ADDR is branch address
         MACRO
&LAB     CMD   &STR,&NOISE,&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
&S       SETC  '&STR'(2,&I-2).'&STR'(&I+1,&LEN-&I-1)
&LAB     DC    AL1(&LEN-4,&I-3),C'&S',A(&ADDR)
         MEXIT
.X       MNOTE 4,' missing "-" in string'
         MEND
*
         EJECT
*+
*
* Code begins here.
*
* Throughout program:
* B2/ global base reg (global data)
* B1/ base reg for global utility routines
* B0/ local base reg (points to current command's code)
*
*-
FTP      CSECT
*        ENTER (11,12),SA=REGS    ;ENTER does it wrong
         USING *,B0               ;temp base reg (reaches 1st LTORG)
         STM   14,12,12(13)       ;save regs
         LR    B0,15              ;copy base
         LM    B1,B2,=A(UTIL,GLOBAL) ;set up global base regs
         USING UTIL,B1            ;throughout program
         USING GLOBAL,B2          ;     "        "
         LR    15,13              ;get old save area
         LA    13,REGS            ;point at ours
         ST    15,4(13)           ;backward link
         ST    13,8(15)           ;forward link
* enough of that
         L     C,0(A)             ;get PAR= arg
         MVI   PFXP,255           ;don't know if PFX is on
* set up Attn trap
         LM    0,1,=A(ATTNT,AREG) ;set up attn vec
         JSYS  ATTNTRP            ;do it
* find out if we have an EBCDICK terminal (SNSDVTYP=C'327X')
* (so we can remap characters which will piss it off)
         MVC   FBUF(3),=C'SNS'    ;command
         JSYS  CONTROL,=A(FBUF,SNSLEN,SPUNIT,0) ;SENSE(SPRINT)
         CLC   FBUF+8(3),=C'327'  ;ITT Courier (3278 clone) or 327X?
         BNE   *+8                ;no, skip
           MVI COURIER,1          ;yes, remember that
         CALL  PFXOFF             ;turn off prefix
         JSYS  SPRINT,BAN1        ;say hello
* interpret PAR= field as implicit CONNECT
         L     B0,=A(CNCT)        ;just in case
         LH    D,0(C)             ;get length
         LA    C,2(C)             ;skip it
         AR    D,C                ;pt at end
         CLR   C,D                ;anything?
         BNER  B0                 ;yes, go connect
*+
*
* Command prompt.
*
*-
LOOP     BASR  B0,0               ;set base reg
         USING *,B0
         ATTN  CMDATN             ;be snide if they Attn us now
         L     A,CMDPRM           ;get command prompt
         CALL  PREFIX             ;set it
         CALL  PFXON              ;enable prefix
LOOP1    JSYS  SCARDS,KBIN        ;read KB
         LTR   15,15              ;eof?
         BNZ   STOP1              ;yes, stop
         LA    C,KBBUF            ;pt at buf
         LH    D,KBLEN            ;get length
         AR    D,C                ;pt at eol
         JSP   SKIP               ;skip blanks
         BZ    LOOP1              ;null
         ATTN  LOOP               ;just come back if they Attn us
         CLI   0(C),C'$'          ;MTS command?
         BE    MCMD1
         CLI   0(C),C''''         ;QUOTE command?
         BE    QUOTE1
         LA    E,CMDS             ;pt at command table
         B     GETKW              ;get keyword, dispatch
MCMD1    J     MCMD               ;go handle it
QUOTE1   LA    C,1(C)             ;skip the '
         J     QUOTE              ;go handle it
STOP1    J     STOP               ;go stop
*
BAN1     TXT   ' TATS FTP Client (&SYSDATE.), by John Wilson.'
*
* Command keyword table for GETKW.
* Form:
*  .BYTE  total length -1, length to match -1
*  .EBCDIC  keyword
*  .ALIGN LONG
*  .LONG PROMPT  ;prompt address, check for confirmation if b0 set
*  .LONG ADDR  ;dispatch address
*
* Table ends with a 255 byte.
*
CMDS     CMD   'C-','TO HOST',CNCT ;CONNECT
         CMD   'CON-NECT','TO HOST',CNCT
*        CMD   'CW-D','TO DIRECTORY',CDIR
*        CMD   'DES-TROY','FILE',DESTRY
*        CMD   'DI-SCONNECT','FROM CURRENT HOST',DCON
         CMD   'DO-','DIRECTORY',DO
         CMD   'E-XPLAIN','FTP COMMAND',HELP ;HELP
*        CMD   'F-ILESTATUS','OF FILES',DIR
         CMD   'G-ET','REMOTE FILE',RETRVE ;RETRIEVE
RETRVE   EQU   LOOP
         CMD   'H-ELP',,HELP
         CMD   'MC-MD',,MCMD      ;$
         CMD   'MT-S',,STOP       ;STOP
         CMD   'P-UT','LOCAL FILE',STORE ;syn. for STORE
STORE    EQU   LOOP
         CMD   'Q-UOTE','SERVER COMMAND',QUOTE
*        CMD   'REN-AME','FROM',RENAME
         CMD   'RET-RIEVE','REMOTE FILE',RETRVE
*        CMD   'SEN-D','LOCAL FILE',STORE
         CMD   'SET-','OPTION',SET
SIGNON   CMD   'SIG-NON','AS USER',LOGIN
SIGNOFF  CMD   'SIGNOF-F','FROM CURRENT HOST',DCON
         CMD   'SOA-K','A SERVER REPLY',REPRET
*        CMD   'SOU-RCE','OF COMMANDS',SOURCE
         CMD   'STOP-','FTP EXECUTION',STOP
         CMD   'STOR-E','LOCAL FILE',STORE
         CMD   'U-P','TO PARENT DIRECTORY',UP
         CMD   'X-',,DATCON
         CMD   '?-',,HELP         ;syn. for HELP
         DC    X'FF'
         LTORG                    ;dump what we have so far
*+
*
* Attn at command prompt.
*
*-
         USING CMDATN,B0
CMDATN   JSYS  SERCOM,OUCH        ;what are you doing?!
         B     LOOPA
OUCH     TXT   ' Ouch!'            ;unnecessary Attn
         LTORG
*
         EJECT
         TITLE 'Commands'
*+
*
* CONNECT { hostname | a.b.c.d }
*
*-
         USING CNCT,B0
CNCT     CLI   CNCTED,0           ;are we already connected?
         BZ    CNCT1              ;no
         JSPF  A,DISCON           ;disconnect
CNCT1    JSP   SKIP               ;anything?
         BNZ   CNCT2              ;yes, get it
         LA    A,HOSTQ            ;pt at prompt
         JSP   PROMPT             ;prompt and read string
         B     CNCT1              ;loop
CNCT2    MVI   ANON,0             ;not anonymous (might QUOTE USER)
         JSP   LOOKUP             ;look up our host
           B   CNCLUK             ;error
* loop through the list of IP addr's until we find one which works
         MVC   IPAPTR,=A(IPADDR)  ;init ptr
CNCT3    L     F,IPAPTR           ;get ptr
         CLC   0(4,F),=F'0'       ;end of table?
         BZ    CPUNT              ;yes, punt
         LA    F,4(F)             ;skip
         ST    F,IPAPTR           ;update ptr
         LA    B,SBUF+35          ;pt into buffer
         CALLF CVADDR             ;convert #
         S     B,=F'20'           ;make space for string
         LA    G,20(G)
         MVC   0(20,B),=C'DESTINATION_ADDRESS=' ;add it
         STH   G,LEN              ;save
         ST    B,DADDR            ;set address
* connect to command port
         JSYS  MOUNT,CMND,CNCT5   ;$MOUNT the cmd connection
         JSYS  GETFD,PCMND        ;get FDUB ptr
         ST    TT,COMAND          ;save
         JSYS  CONTROL,DADDR,CNCT4 ;DESTINATION_ADDRESS
         JSYS  CONTROL,CPORT,CNCT4 ;DESTINATION_PORT
         JSYS  CONTROL,CONECT,CNCT4 ;CONNECT
* display their banner
         JSP   GETRP0             ;get reply
           B   CNCT4              ;net error
         JSP   DISREP             ;display it
           B   CNCT4              ;net error
         MVI   CNCTED,1           ;we're connected now
* set up prompt
         LA    TT,HSTPRM          ;pt at prompt area
         ST    TT,CMDPRM          ;this will be command prompt
         CL    TT,PFX             ;was it HSTPRM before?
         BNE   LOOPA
         MVC   PFX,=F'0'          ;yes, guarantee CUINFO call
         B     LOOPA
* network I/O error
CNCT4    CALL  ATNOFF             ;don't screw this up
         L     TT,COMAND          ;;pt at it
         JSYS  FREEFD             ;;release
         MVC   COMAND,=F'0'       ;;closed
         CALL  ATNON              ;;OK
         JSYS  RELEASE,RCMND      ;$REL it
CNCT5    B     CNCT3              ;try next address
* tried all possible dests, give up
CPUNT    MVC   SBUF(15),=C' Network error:' ;msg
         L     A,CTAREA+4         ;get length of msg
         BCTR  A,0                ;-1 for MVC
         EX    A,CMVMSG           ;move it
         LA    A,15(A)            ;bump length
         STH   A,LEN              ;save
         LA    A,=A(SBUF,LEN,ZERO,DUMMY) ;SERCOM arg list
* name lookup error, SERCOM arglist at (A)
CNCLUK   LR    B,A                ;copy
         CALL  PREFIX,QUESTN      ;set prefix
         LR    A,B                ;restore
         JSYS  SERCOM             ;msg
         B     LOOPA
*
CMVMSG   MVC   SBUF+15(0),CTAREA+8 ;copy CONTROL err msg
HOSTQ    PFX   'To host: '        ;host prompt
         LTORG
*+
*
* DISCONNECT
* SIGNOFF
*
* Send a QUIT to the remote host, and hang up the connection.
*
*-
         USING DCON,B0
DCON     JSP   CONFRM             ;make sure confirmed
         JSP   CNCTP              ;should be connected
         L     LR,=A(LOOP)        ;return addr
*        B     DISCON             ;disconnect & return
*
         USING DISCON+2,B0
DISCON   BASR  B0,0               ;set base reg
         ST    LR,DISCRA          ;save r.a.
         STM   C,D,DISCCD         ;and C,D
         MVC   CMDPRM,=A(FTPPRM)  ;reset prompt
         ATTN  LOOP               ;handle Attn
         MVC   SBUF+1(6),QUIT     ;copy QUIT command
         LA    A,SBUF+1           ;pt at it
         LA    B,4                ;length
         JSP   SNDCM1             ;send command
         JSP   GETRP0             ;get reply
           B   DC1
         JSP   DISREP             ;display it
           B   DC1
DC1      JSYS  CONTROL,CLOSE      ;close it
* none of this should block so ATNOFF is OK
* (actually RELEASE blocks bigtime but I can't fix it!)
* we want to make sure that COMAND is NZ iff
* there is a connection
         CALL  ATNOFF             ;make sure COMAND is current
         L     TT,COMAND          ;;FDUB ptr
         MVC   COMAND,=F'0'       ;;(closed now)
         JSYS  FREEFD             ;;close it
         MVI   CNCTED,0           ;;say no longer connected
         CALL  ATNON              ;;OK
* actually shouldn't set CNCTED=0 until after we $RELEASE the
* connection, but RELEASE tends to block for a really long time
* (why?!) so why not let them Attn as long as they don't mind a
* msg from MTS next time they connect
         JSYS  RELEASE,RCMND      ;release the connection
         L     LR,DISCRA          ;get return addr
         LM    C,D,DISCCD         ;restore C,D
         BR    LR
* include our home CCID in the prompt so that people will get
* used to seeing it and will be able to remember where FTP is!
FTPPRM   PFX   'GZ7V:FTP>'        ;no host
         LTORG
*+
*
* DO directory
*
* MTS doesn't have a command name for this that I can emulate, CD
* certainly doesn't belong here (Unix pussies go to hell!), so I'll use
* "DO" because DO/UP/OVER are defined in .COM files on my company's VMS
* machines and everyone likes them much better than SET DEFAULT.
*
* If you're a girly-man and want "CD", then it seems only fitting that
* you should write an effeminate MTS command macro to do it.
*
*-
         USING DO,B0
DO       JSP   CNCTP              ;connected
         JSP   SKIP               ;skip blanks
         BNZ   DO1                ;got something
         LA    A,DOPFX            ;prefix
         JSP   PROMPT             ;get string
         BZ    LOOPA              ;blank
DO1      SR    D,C                ;find length
         BCTR  D,0                ;-1 for MVC/TR
         MVC   SBUF+1(4),CWD      ;"CWD "
         EX    D,DOMVC            ;copy
         L     B,=V(EBCASC)       ;xlat to ASCII
         EX    D,DOTR             ;yep
         LA    A,SBUF+1           ;addr
         LA    B,4+1(D)           ;length
         JSP   SNDCMD             ;send
         J     REPRET
*
DOMVC    MVC   SBUF+5(0),0(C)     ;copy
DOTR     TR    SBUF+5(0),0(B)     ;xlat
DOPFX    PFX   'Directory: '      ;DO prompt
         LTORG
*+
*
* HELP [command]
* syn: EXPLAIN
*
* Give help on the command or on commands in general.
*
*-
         USING HELP,B0
HELP     CALL  PFXOFF             ;no prefix
         JSP   SKIP               ;skip blanks
         BNE   HELP1              ;no, see what they want help with
* give them the general help text
         B     LOOPA              ;around for more
HELP1    EQU   *                  ;look for more stuff
         B     LOOPA              ;around for more
         LTORG
*+
*
* SIGNON username
*
* Log in to foreign host.
*
* If no username is given, prompt for one,
* offering 'anonymous' as the default.
*
*-
         USING LOGIN,B0
LOGIN    JSP   CNCTP              ;must be connected
         MVI   ANON,0             ;not using ANONYMOUS yet
         JSP   SKIP               ;skip blanks
         BNZ   LOG1               ;something there, use it
         LA    A,UNPFX            ;prompt
         JSP   PROMPT             ;prompt and get string
         BNZ   LOG1               ;got something, skip
* use default: "USER anonymous"<CRLF>
         MVC   SBUF+1,=X'5553455220616E6F6E796D6F75730D0A'
         LA    A,SBUF+1           ;pt at it
         LA    B,14               ;length
         MVI   ANON,1             ;remember for default password
         JSP   SNDCM1             ;send the command
         J     REPRET             ;get reply
* they typed a username, build command in SBUF+1
LOG1     SR    D,C                ;find length
         BCTR  D,0                ;-1 for TR/MVC
         EX    D,LOGMOV           ;copy to SBUF
         L     B,=V(EBCASC)       ;translate to ASCII
         EX    D,LOGASC           ;yep
         LA    A,SBUF+1           ;pt @ buf
         MVC   0(5,A),USER        ;copy command
         LA    B,5+1(D)           ;correct, add len("USER ")
         JSP   SNDCMD             ;send the command
         J     REPRET             ;show reply, return
*
LOGMOV   MVC   SBUF+6(0),0(C)     ;copy
LOGASC   TR    SBUF+6(0),0(B)     ;translate to ASCII
UNPFX    PFX   'Username <anonymous>: ' ;login prompt
         LTORG
*+
*
* MCMD <MTS command>
* $<MTS command>
*
* Execute MTS command.
*
*-
         USING MCMD,B0
MCMD     JSP   SKIP               ;skip blanks
         SR    D,C                ;find length
         ST    C,CMDLST           ;save addr
         STH   D,AREA             ;and len
         JSYS  CMDNOE,CMDLST      ;do the cmd
         B     LOOPA              ;next
         LTORG
*+
*
* QUOTE command
*
* Send command to server, unscathed.
*
*-
         USING QUOTE,B0
QUOTE    JSP   CNCTP              ;must be connected
         JSP   SKIP               ;skip blanks
         BNZ   QUOTE2             ;something there
         LA    A,QUPFX            ;prefix
         JSP   PROMPT             ;get string
         BZ    LOOPA              ;never mind
QUOTE2   SR    D,C                ;find length
         BCTR  D,0                ;-1 for MVC/TR
         EX    D,QUMVC            ;copy
         L     B,=V(EBCASC)       ;xlat to ASCII
         EX    D,QUTR             ;yep
         LA    A,SBUF+1           ;addr
         LA    B,1(D)             ;length
         JSP   SNDCMD             ;send
         J     REPRET
*
QUMVC    MVC   SBUF+1(0),0(C)     ;copy
QUTR     TR    SBUF+1(0),0(B)     ;xlat
QUPFX    PFX   'Server command: ' ;QUOTE prompt
         LTORG
*+
*
* STOP
*
* Return to MTS command prompt, disconnecting if we're connected.
*
*-
         USING STOP,B0
STOP     CLI   CNCTED,0           ;connected?
         BZ    STOP2              ;no
           JSPF A,DISCON          ;disconnect
STOP2    EXIT
         DROP  B0
*+
*
* SET option
*
*-
         USING SET,B0
SET      JSP   SKIP               ;skip blanks
         BNZ   SET1               ;got something
         LA    A,SETPFX           ;prefix
         JSP   PROMPT             ;get string
         BZ    LOOPA              ;never mind
SET1     LA    E,SETKW            ;keyword table
         B     GETKW
SETPFX   PFX   'What? '
*
SETKW    CMD   'B-LOCKSIZE','OF IMAGE TRANSFERS',BLK
         CMD   'D-EBUG','OUTPUT',DBG
         CMD   'TA-BS','AT COLUMN(S)',SETTAB
*        CMD   'TY-PE','OF DATA',SETTYP
         DC    X'FF'
*+
*
* SET BLOCKSIZE n
*
* Sets the size of the lines written to the local file when
* receiving a binary file (the last line may be shorter).
*
*-
BLK      JSP   SKIP               ;skip blanks
         B     LOOPA
*+
*
* SET DEBUG { OFF | ON }
*
* With debugging on we show slightly more stuff.
*
*-
         USING DBG,B0
DBG      JSP   SKIP               ;skip blanks
         BNZ   DBG1               ;got something
         LA    A,DBPFX            ;prefix
         JSP   PROMPT             ;get string
         BZ    LOOPA              ;never mind
DBG1     LA    E,DBGKW            ;pt at keyword table
         B     GETKW              ;(can't return)
*
DBPFX    PFX   'ON or OFF? '      ;DEBUG prompt
DBGKW    CMD   'ON-',,DBGON
         CMD   'OF-F',,DBGOFF
         DC    X'FF'
*
         USING DBGON,B0
DBGON    JSP   CONFRM             ;make sure confirmed
         MVI   DEBUG,1            ;DEBUG ON
         B     LOOPA
*
         USING DBGOFF,B0
DBGOFF   JSP   CONFRM             ;make sure confirmed
         MVI   DEBUG,0            ;DEBUG OFF
         B     LOOPA
*+
*
* SET TABS { OFF | ON }
* SET TABS n1 n2 n3 ...
* SET TABS EVERY n
*
* Set columns for tab expansion on PRINT files.
*
*-
         USING SETTAB,B0
SETTAB   JSP   SKIP               ;skip blanks
         BNZ   STAB1
         LA    A,TABPFX           ;get string
         JSP   PROMPT
         BZ    LOOPA              ;forget it
STAB1    LR    E,C                ;save C
         JSP   GWORD              ;get word
         CALL  VAL                ;parse as number
           B   STAB2              ;not number, skip
*** A has first tab stop
         B     LOOPA
STAB2    LR    C,E                ;restore line ptr
         LA    E,TABKW            ;look up keyword
         B     GETKW
TABPFX   PFX   'Where? '
*
TABKW    CMD   'E-VERY','MULTIPLE OF',TABEVR
         CMD   'OF-F',,TABOFF
         CMD   'ON-',,TABON
         DC    X'FF'
*
         USING TABEVR,B0
TABEVR   JSP   CONFRM             ;make sure confirmed
         B     LOOPA
*
         USING TABOFF,B0
TABOFF   JSP   CONFRM             ;make sure confirmed
         B     LOOPA
*
         USING TABON,B0
TABON    JSP   CONFRM             ;make sure confirmed
         B     LOOPA
*+
*
* UP
*
* Change to parent directory.
*
*-
         USING UP,B0
UP       JSP   CONFRM             ;check for eol
         JSP   CNCTP              ;must be connected
         MVC   SBUF+1(6),CDUP     ;copy command
         LA    A,SBUF+1           ;pt at it
         LA    B,4                ;length
         JSP   SNDCM1             ;send it
         J     REPRET             ;show reply, return
         LTORG
*
         EJECT
         TITLE 'Command utility routines'
*
UTIL     DS    0H                 ;B0 points here
*
LOOPA    J     LOOP               ;back to main loop
*+
*
* Make sure we have a connection.
* Return to command prompt if not (print message).
*
* LR/ link
*
*-
CNCTP    CLI   CNCTED,0           ;connected?
         BNZR  LR                 ;yes, fine
         CALL  PREFIX,PERCNT      ;error msg prefix
         CALL  PFXON              ;turn it on
         JSYS  SERCOM,NCNCTD      ;not connected
         B     LOOPA              ;around for more
NCNCTD   TXT   ' Not connected to a host'
         LTORG
*+
*
* Read and display reply, and return to command prompt.
*
* REPRT1 should be called if GETREP has been already.
*
*-
         USING REPRET,B0
REPRET   JSP   GETRP0             ;get it
           B   LOOPA              ;error
REPRT1   JSP   DISREP             ;display it
           B   LOOPA              ;punt
         CLC   REPCOD,=X'333331'  ;331?
         BE    PSWORD             ;get password & proceed
         CLC   REPCOD,=X'353331'  ;531?
         BE    PSWORD             ;get password and punt
         CLC   REPCOD,=X'333332'  ;332?
         BE    ACOUNT             ;get acct & proceed
         CLC   REPCOD,=X'353332'  ;532?
         BE    ACOUNT             ;get acct & punt
         B     LOOPA
*+
*
* PASSWORD password.
*
* Called automatically on 331 reply to USER.
*
* Read password from GUSER instead of SCARDS so that they
* can redirect SCARDS to a file without having to put the
* password in the file.  If they really care they can
* redirect GUSER too.
*
* Offer their username@host as a default if they accepted
* our "anonymous" default in LOGIN.
* (Use ID=CCID if they have no name $SET.)
*
*-
PSWORD   CLI   ANON,0             ;are we anonymous?
         BZ    PWPRM1             ;no, just ask for password
* most sites don't care what the anonymous password is,
* some want "guest" (TOPS-20), but most of the more common
* (unix - bletch!) sites want your real mailbox name,
* so we'll offer that as the default
         MVC   FBUF+8(10),=C'Password <' ;begn of prompt
         MVC   SBUF(4),=A(4+4+64) ;set length of buf
         JSYS  GUINFO,=A(UNITM,SBUF) ;get username
         ICM   C,15,SBUF+4        ;get length, set CC
         BZ    DEFPW3             ;no name, use ID
* username@host
         LA    A,SBUF+8           ;pt at name
         AR    C,A                ;pt past end
         BCTR  C,0                ;-1 (for TRT)
         L     E,=V(TRTBLANK)     ;low core TRT table (undoc'ed!)
DEFPW1   LR    D,C                ;copy
         SR    D,A                ;find # to go -1
*        ;BLT  DEFPW2             ;not needed -- no trailing blanks
         EX    D,FNDBL            ;find (next) blank
         BZ    DEFPW2             ;no more
         MVI   0(A),C'_'          ;replace with '_'
         LA    A,1(A)             ;skip it
         B     DEFPW1             ;get the rest
DEFPW2   LR    A,C                ;copy
         S     A,=A(SBUF+8)       ;find total length -1
         EX    A,MOVUN            ;copy username
         LA    B,FBUF+18+1(A)     ;pt at end
         B     DEFPW4             ;go add @host
* ID=CCID@host
DEFPW3   MVC   FBUF+18(3),=C'ID=' ;ID
         JSYS  GUSERID            ;A=CCID
         STCM  A,15,FBUF+21
         LA    B,FBUF+25
DEFPW4   MVC   0(1+&LNAME+3,B),=C'@&NAME>: ' ;add "@host>: "
         S     B,=A(FBUF+8-(1+&LNAME+3)) ;find length
         ST    B,FBUF+4           ;save len(prompt)
         LA    B,8(B)             ;find len(buffer)
         ST    B,FBUF             ;save
         MVC   PFX,=F'0'          ;zap out prefix
         CALL  PREFIX,FBUF        ;set it
         B     PWPRM2             ;get line
* just get password, no prompt
PWPRM1   CALL  PREFIX,PWPFX       ;set prefix
* whatever, now see what they say
PWPRM2   CALL  PFXON
         JSYS  CONTROL,=A(BLANK,LBLNK,GUNIT,0) ;%BLANK
         JSYS  GUSER,KBIN         ;get a line
         LTR   15,15              ;eof => forget it
         BNZ   LOOPA
         LA    C,KBBUF            ;addr
         LH    D,KBLEN            ;len
         AR    D,C                ;pt past end
         JSP   SKIP               ;skip blanks
         BNZ   PW1                ;got something, skip
         CLI   ANON,0             ;was there a default?
         BZ    PW4                ;no, send the blankness
         LA    C,FBUF+18          ;pt at name
         L     D,FBUF+4           ;get len(prompt)
         SH    D,=Y(10+3+1)       ;remove "Password <", ">: ", -1
         B     PW2                ;go copy
* we have something to send, move it to SBUF+1
PW1      SR    D,C                ;find length
         BCTR  D,0                ;-1 for MVC
PW2      L     B,=V(EBCASC)       ;translate to ASCII
         EX    D,TRPW             ;yep
         EX    D,MOVPW            ;copy into buf
         LA    B,5+1(D)           ;find length
PW3      LA    A,SBUF+1           ;pt at buf
         MVC   SBUF+1(5),PASS     ;command
         JSP   SNDCMD             ;send the command
         B     REPRET             ;get reply, try again
* send a null password
PW4      LA    B,5                ;length (leave the blank, might help)
         B     PW3                ;go send it
*
FNDBL    TRT   0(0,A),0(E)        ;find blanks
MOVUN    MVC   FBUF+18(0),SBUF+8  ;copy username
TRPW     TR    0(0,C),0(B)        ;translate password to ASCII
MOVPW    MVC   SBUF+6(0),0(C)     ;copy password
PWPFX    PFX   'Password: '       ;password prompt
*+
*
* Get account name.
*
*-
ACOUNT   MVC   SBUF+1(5),ACCT     ;set up string
         CALL  PFXON              ;make sure prefix will be OK
         CALL  PROMPT,ACPFX       ;get account
         BZ    AC3                ;null, whatever
         SR    D,C                ;find length
         STC   D,ACCNT            ;save it
         BCTR  D,0                ;-1 for MVC/TR
         EX    D,ACMVC1           ;save for next time
AC1      EX    D,ACMVC2           ;copy into command
         L     A,=V(EBCASC)       ;translate to ASCII
         EX    D,ACTR             ;yep
         LA    B,5+1(D)           ;length ("ACCT "+correct from EX)
AC2      LA    A,SBUF+1           ;pt at string
         JSP   SNDCMD             ;send it
         B     REPRET             ;try again
AC3      LA    B,5                ;length=5
         B     AC2                ;go
*
ACMVC1   MVC   ACCNT+1(0),0(C)    ;copy to buffer
ACMVC2   MVC   SBUF+6(0),0(C)     ;copy into command
ACTR     TR    SBUF+6(0),0(C)
ACPFX    PFX   'Account: '        ;account prompt
*
         LTORG                    ;for all REPRET code
         DROP  B0
*
         EJECT
         TITLE 'Keyboard input routines'
*+
*
* Parse a keyword.
*
* C/ cmd line pointer
* D/ eol pointer
* E/ keyword table
*
* Call through R14, return will be taken iff the line is empty.
*
*-
GETKW    BASR  15,0               ;set up base reg
         USING *,15
         JSP   SKIP               ;skip blanks
         BZR   14                 ;nothing, return
         JSP   GWORD              ;get a word
         XR    A,A                ;load 0's
GETKW2   ICM   A,1,0(E)           ;get length, set CC
         BLT   GETKW5             ;end of table
         CLR   F,A                ;is our string too long?
         BGT   GETKW3             ;yes, skip this one
         CLM   F,1,1(E)           ;is it too short?
         BLT   GETKW3             ;yes, skip
         EX    F,KWCLC            ;compare
         BE    GETKW4             ;got it, skip
GETKW3   LA    E,1+1+4+4(A,E)     ;skip lens, str, align, addr
         N     E,=F'-4'           ;FW align
         B     GETKW2             ;loop
GETKW4   LA    E,1+1+4(A,E)       ;skip lens, str, align
         N     E,=F'-4'           ;back to FW boundary
*** skip noise here
         L     B0,0(E)            ;get addr (base reg)
         BR    B0                 ;dispatch
GETKW5   ST    G,BADKW            ;save addr
         LA    G,1(F,G)           ;index
         MVI   0(G),C'?'          ;add question mark
         LA    F,2(F)             ;update length
         STH   F,AREA             ;save
         CALL  PFXOFF             ;kill prefix
         DROP  15                 ;R15 probably shot
         USING *,14               ;but R14 was r.a.
         JSYS  SERCOM,BADKW       ;gack
         B     LOOPA              ;get more (calls PFXON)
*
KWCLC    CLC   0(0,G),2(E)        ;compare
         LTORG
         DROP  14
*+
*
* Get a word, convert to upper case.
*
* This routine assumes that leading blanks have
* been skipped and that the line is not null.
*
* C/ cmd line ptr
* D/ eol ptr
* LR/ link
*
* Returns:
* E/ preserved
* F/ len-1
* G/ ptr
*
*-
GWORD    BASR  H,0                ;set up base reg
         USING *,H
         LR    F,D                ;copy
         SR    F,C                ;find length
         BCTR  F,0                ;fix for TRT
         L     B,=V(TRTBLANK)     ;TRT table for C' '
         LR    G,C                ;copy ptr
         LR    A,D                ;eol if no blank
         EX    F,BLTRT            ;find first blank
         LR    C,A                ;skip to end
         LR    F,C                ;copy ptr
         SR    F,G                ;find length
         BCTR  F,0                ;-1 for TR/CLC
         L     A,=V(CASECONV)     ;lc => uc table
         EX    F,KWUC             ;convert to upper
         BR    LR                 ;return
*
KWUC     TR    0(0,G),0(A)        ;convert to upper
         LTORG
         DROP  H
*+
*
* Make sure we're at eol.
*
* C/ cmd line pointer
* D/ eol pointer
*
* Call through LR.
*
*-
CONFRM   BASR  H,0                ;set up base reg
         USING *,H
         LR    A,D                ;copy
         SR    A,C                ;find length
         BZR   LR                 ;eol, cool
         BCTR  A,0                ;fix for TRT
         L     B,=V(TRTNBLNK)     ;TRT table for ^-C' '
         EX    A,BLTRT            ;skip leading blanks (B=trash)
         BZR   LR                 ;just blanks
         CALL  PFXOFF             ;prefix off
         JSYS  SERCOM,NOTCFM      ;not confirmed
         B     LOOPA              ;loop
NOTCFM   TXT   ' Extra character(s) on line'
         LTORG
         DROP  H
*+
*
* Set prefix and get string (assumes PFXON).
*
* A/ prefix
* LR/ link
*
* Jumps to LOOP on EOF.
*
* Otherwise drops through to SKIP.
*
*-
PROMPT   BASR  H,0                ;set up base reg
         USING *,H
         CALL  PREFIX             ;set prompt
         JSYS  SCARDS,KBIN        ;get more
         LTR   15,15              ;eof?
         BNZ   LOOPA              ;yeah, never mind
         LA    C,KBBUF            ;pt at line
         LH    D,KBLEN            ;get length
         AR    D,C                ;pt past end
*        ;B    SKIP               ;drop through to SKIP
         DROP  H
*+
*
* Skip blanks.
*
* C/ command line ptr
* D/ eol ptr
* F/ trashed
* LR/ link
*
* Return with CC set from CLR C,D.
* So BZ will branch if the line was blank.
*
*-
SKIP     BASR  H,0                ;set up base reg
         USING *,H
         LR    F,D                ;find length
         SR    F,C
         BZR   LR                 ;null (CC set)
         BCTR  F,0                ;-1 for TRT
         LR    A,D                ;skip to end if nothing
         L     B,=V(TRTNBLNK)     ;addr of table
         EX    F,BLTRT            ;skip blanks
         LR    C,A                ;bump ptr
         CLR   C,D                ;set CC
         BR    LR
BLTRT    TRT   0(0,C),0(B)        ;skip (GWORD & SKIP)
         LTORG
         DROP  H
*+
*
* Parse a number.
*
* F,G/ set up by GWORD
* 14/ link
*
* Returns:
* +0 invalid number
* +4 valid, value in A
*
*-
VAL      BASR  15,0               ;set up base reg
         USING *,15
         LA    F,1(F)             ;fix length
         XR    A,A                ;init value
VAL1     CLI   0(G),C'0'          ;digit?
         BLR   14                 ;return +0 if not
         CLI   0(G),C'9'
         BHR   14
         M     TT,=F'10'          ;*10
         XR    TT,TT              ;init high 24
         IC    TT,0(G)            ;get char
         LA    G,1(G)             ;ptr +1
         SH    TT,=Y(C'0')        ;convert
         AR    A,TT               ;add it in
         BCT   F,VAL1             ;loop
         B     4(14)              ;return +4
         LTORG
         DROP  15
*+
*
* Set prefix if necessary.
*
* A/ prefix
* 14/ link
*
*-
PREFIX   BASR  15,0               ;set up base reg
         USING *,15
         C     A,PFX              ;is this it?
         BER   14                 ;return if so
         ST    A,PFX              ;save
         LA    1,PFXLST           ;pt at list
         L     15,=V(CUINFO)      ;pt at routine
         BR    15                 ;call, return
*+
*
* Make sure prefix is on.
*
*-
PFXON    BASR  15,0               ;set up base reg
         USING *,15
         CLI   PFXP,1             ;is the prefix on?
         BER   14                 ;yes, return
         MVI   PFXP,1             ;no, it will be soon
         LA    1,=A(PXOFF,ZERO)   ;args
         L     15,=V(CUINFO)      ;call CUINFO
         BR    15                 ;and return
*+
*
* Make sure prefix is off.
*
*-
PFXOFF   BASR  15,0               ;set up base reg
         USING *,15
         CLI   PFXP,0             ;is prefix off?
         BZR   14                 ;yes, return
PFXOF1   MVI   PFXP,0             ;no, it will be soon
         LA    1,=A(PXOFF,ONE)    ;args
         L     15,=V(CUINFO)      ;call CUINFO
         BR    15                 ;and return
*
         LTORG
         DROP  15
*
         EJECT
         TITLE 'Attn processing'
*+
*
* Attention interrupt.
*
* 15/ addr of this routine (base reg to reload others)
*
* Cleans up and vectors through ATNVEC.
*
*-
         USING ATTNT,B0
ATTNT    LM    10,13,ATNREG-ATTNT(15) ;reload base regs, R13
         LM    0,1,=A(ATTNT,AREG) ;set up vector
         JSYS  ATTNTRP            ;reenable trap
         MVI   PFXP,1             ;don't optimize PFXOFF
         CALL  PFXOFF             ;make sure prefix is off
         MVC   PFX,=F'0'          ;don't know what it was anyway
         JSYS  SERCOM,BANG        ;acknowledge the Attn
         CALL  PREFIX,PERCNT      ;set up error prefix
         CALL  PFXON
         L     B0,ATNVEC          ;get vector
         ATTN  LOOP               ;punt on 2nd Attn
         BR    B0                 ;follow vector (R11=base reg)
ATNREG   DC    A(ATTNT,UTIL,GLOBAL,REGS) ;R10-R13 values
BANG     TXT   ' !'               ;Attn
*+
*
* Attn before 1st prompt, forget it.
*
*-
         USING FORGET,B0
FORGET   JSYS  SERCOM,NEVMND      ;never mind
         EXIT  ,
*
NEVMND   TXT   ' Fine, suit yourself!' ;Attn before 1st prompt
         LTORG
         DROP  B0
*+
*
* Defer Attn handling until next ATNON call.
*
* Call this before doing something which shouldn't
* be interrupted (better be something quick!).
*
* 14/ link
*
*-
ATNOFF   BASR  15,0               ;set up base reg
         USING *,15
         LA    A,=A(ATTNOFF,ONE)  ;args
         L     15,=V(CUINFO)      ;call CUINFO
         BR    15                 ;and return
*+
*
* Reenable immediate Attn's, process any which are queued.
*
* 14/ link
*
*-
ATNON    BASR  15,0               ;set up base reg
         USING *,15
         LA    A,=A(ATTNOFF,ZERO) ;args
         L     15,=V(CUINFO)      ;call CUINFO
         BR    15
*
         LTORG
         DROP  15
*+
*
* Send ABORt command.
*
* Send Attn first in case they're not listening (see RFC).
*
* B0/ A(ABORT)
*
*-
         USING ABORT,B0
ABORT    JSYS  WRITE,=A(IP,L2,ZERO,DUMMY,COMAND) ;TELNET IAC IP
         JSYS  CONTROL,PUSH
         JSYS  WRITE,=A(SYN,L1,ZERO,DUMMY,COMAND) ;ASCII SYN
         JSYS  CONTROL,PUSH
         JSYS  WRITE,=A(ABOR,L6,ZERO,DUMMY,COMAND) ;ABOR<CRLF>
         JSYS  CONTROL,PUSH
         ATTN  LOOP               ;let them Attn if this punts
         JSP   GETRP0             ;get msg
           B   LOOPA
         JSP   DISREP             ;display
           B   LOOPA
         B     LOOPA              ;around for more
*
         LTORG
         DROP  B0
*+
*
* Open data connection.
*
*-
         USING DATCON,B0
DATCON   JSYS  MOUNT,FDAT,DPUNT1  ;$MOUNT the data connection
         JSYS  GETFD,PFDAT        ;get FDUP ptr
         ST    TT,DATA            ;save
         JSYS  CONTROL,ACCEPT,DPUNT ;declare incoming port
         MVC   SBUF+128(L'SNSSKT),SNSSKT ;copy SENSE command
         JSYS  CONTROL,=A(SBUF+128,LENSKT,DATA,0),DPUNT ;get sock #
         MVC   SBUF+128+6(2),SBUF+128 ;copy port # after host #
         LA    B,SBUF+128         ;pt @ buf
         LA    C,Q0               ;ASCII '0
         LA    E,SBUF+128+8       ;end of port info
         LA    F,6                ;loop count
         LR    G,B                ;save posn for len
DATC1    BCTR  E,0                ;-1
         XR    A,A                ;0-extend
         IC    A,0(E)             ;get #
         CALL  DECOUT             ;convert
         BCTR  B,0                ;-1
         MVI   0(B),QCOM          ;,
         BCT   F,DATC1            ;loop
         S     B,=F'4'            ;space for command
         MVC   0(5,B),PORT        ;copy (zap 1st comma)
         SR    G,B                ;find length
         LR    A,B                ;addr
         LR    B,G                ;len
         JSP   SNDCMD             ;send it
         JSP   GETRP0             ;get reply
           B   DPUNT
         JSP   EATREP             ;eat it
           B   DPUNT
         B     LOOPA
* network I/O error
DPUNT    CALL  ATNOFF             ;don't screw this up
         L     TT,DATA            ;;get FDUB ptr
         JSYS  FREEFD             ;;release
         MVC   DATA,=F'0'         ;;closed
         CALL  ATNON              ;;OK
         JSYS  RELEASE,RFDAT      ;$REL it
DPUNT1   JSYS  SERCOM,NETERR      ;complain (should be diff msg)
         B     LOOPA
NETERR   TXT   ' Network error'
         LTORG
         DROP  B0
*
         EJECT
         TITLE 'FTP command send/receive'
*+
*
* Send command to the foreign host.
*
* A/ addr (space for SP at beg and CRLF at end)
* B/ length
* LR/ link
*
* Enter at SNDCM1 if CRLF is already at end (not included in B).
*
*-
SNDCMD   BASR  H,0                ;set up base reg
         USING *,H
         LA    C,0(A,B)           ;pt at end
         MVC   0(2,C),CRLF        ;add CRLF
* CRLF there already
SNDCM1   BASR  H,0                ;set up base reg
         USING *,H
         ST    A,SNDLST           ;set addr
         LA    C,2(B)             ;find new length
         STH   C,LEN              ;set length
         JSYS  WRITE,SNDLST       ;send the line
         JSYS  CONTROL,PUSH
         CLI   DEBUG,0            ;debugging?
         BZR   LR                 ;return if not
         CALL  PREFIX,CMDPFX      ;set prefix
         CALL  PFXON
         L     A,SNDLST           ;get addr
         CLC   0(4,A),PASS        ;password?
         BE    SCMD2              ;yes, don't echo it
         BCTR  B,0                ;B=len-1
* remap printing chars
* we made the string so we know there are no ctrl chars
         CLI   COURIER,0          ;Courier?
         BZ    SCMD1              ;no
           EX  B,CMDMAP           ;map chars
SCMD1    L     C,=V(ASCEBC)       ;translate table
         EX    B,CMDEBC           ;cvt to EBCDICK
         BCTR  A,0                ;A-1
         ST    A,SNDLST           ;set new addr
         MVI   0(A),C' '          ;carr ctrl
         LA    B,1+1(B)           ;+1 again, +carr ctrl
         STH   B,LEN              ;save length
         JSYS  SPRINT,SNDLST      ;echo command to SPRINT
         BR    LR                 ;later
SCMD2    JSYS  SPRINT,ECHPAS      ;echo PASS command
         BR    LR
*
CMDMAP   TR    0(0,A),ASCMAP      ;map non-EBCDICK chars
CMDEBC   TR    0(0,A),0(C)        ;translate to EBCDICK
CMDPFX   PFX   '>> '              ;pfx for echoing our cmds
ECHPAS   TXT   ' PASS XXXXXX'     ;echo password in debug mode
         LTORG
         DROP  H
*+
*
* Get a reply from the foreign host.
* Strip control characters (Multics, BBN).
*
* B/ curr ptr in input buf (ignored if C=0)
* C/ count of chars in buf
* LR/ link
* JSP GETREP
* +0 net read error
* +4 successful return
* B,C/ updated
*
* ASCII reply code (or '000' if none) is left in REPCOD.
* Reply is left in REPLY, length in REPLEN (halfword).
* CONTD (byte) is NZ if the reply is to be continued (multi-line).
*
*-
GETRP0   BASR  H,0                ;base reg
         USING *,H
         MVC   REPCOD,=X'303030'  ;initial reply code='000'
         MVI   CONTD,0            ;not continued
         XR    C,C                ;count=0
GETREP   BASR  H,0                ;base reg
         USING *,H
         MVC   REPLEN,=H'0'       ;zap length
         LA    D,REPLY            ;buf ptr
         LA    E,L'REPLY          ;length
         CALL  GETNET             ;fill buffer
GREP1    CLI   0(B),X'FF'         ;TELNET IAC
         BE    TELIAC
         NI    0(B),X'7F'         ;guarantee ASCII
         CLI   0(B),LF            ;done?
         BE    GREP4
         CLI   0(B),TAB           ;save tabs
         BE    GREP2
         CLI   0(B),QSP           ;lose other ctrl chars (BBN)
         BLT   GREP3
         CLI   0(B),RUB           ;and rubouts (Multics)
         BE    GREP3
* save the char
GREP2    LTR   E,E                ;don't overflow buf
         BZ    GREP3
         MVC   0(1,D),0(B)        ;copy char
         LA    D,1(D)             ;advance
         BCTR  E,0                ;count
GREP3    LA    B,1(B)             ;bump ptr
         BCT   C,GREP1            ;loop
         CALL  GETNET             ;refill buf
         B     GREP1
* end of line -- check for reply code
GREP4    LR    E,D                ;copy
         LA    D,REPLY            ;pt at it
         SR    E,D                ;find length
         CH    E,=H'3'            ;long enough for reply?
         BLT   GREP7
         LR    A,D                ;copy
         LA    F,3                ;loop count
GREP5    CLI   0(A),Q0            ;digit?
         BL    GREP7
         CLI   0(A),Q9
         BH    GREP7
         LA    A,1(A)             ;skip
         BCT   F,GREP5
         MVC   REPCOD(3),REPLY    ;it's a reply code, save
         LA    D,3(D)             ;skip it
         SH    E,=H'3'
         BZ    GREP9              ;nothing left
         CLI   0(A),QSP           ;not continued?
         BE    GREP6
         CLI   0(A),QHYPH         ;continued?
         BNE   GREP7
         MVI   CONTD,1            ;remember this
         B     GREP8              ;skip the '-'
GREP6    MVI   CONTD,0            ;not cont'd
         B     GREP8              ;skip the ' '
* trim one leading blank, if any
GREP7    LTR   E,E                ;anything left?
         BZ    GREP9
         CLI   0(D),QSP           ;space?
         BNE   GREP9
GREP8    LA    D,1(D)             ;skip it
         BCTR  E,0
* shift into place if moved
GREP9    LTR   E,E                ;anything left?
         BZ    GREP10             ;who cares
         CL    D,=A(REPLY)        ;moved?
         BE    GREP10
         BCTR  E,0                ;-1 for MVC
         EX    E,GRPMVC           ;move to where we expect it
         LA    E,1(E)             ;restore
GREP10   STH   E,REPLEN           ;save
         LA    B,1(B)             ;skip the LF
         BCTR  C,0                ;count -1
         B     4(LR)              ;skip-return
*
GRPMVC   MVC   REPLY(0),0(D)      ;copy
*+
*
* Handle TELNET IAC (Interpret As Command) escapes.
*
* We ignore everything except WILL and DO.
* For these we reply with DON'T and WON'T, respectively.
*
* D/ link (pts to LA B,1(B) : BCT C,loop)
*
*-
TELIAC   LA    B,1(B)             ;skip the IAC
         BCTR  C,0                ;-1
         CALL  GETNET             ;make sure we have more
         CLI   0(B),251           ;WILL, WON'T, DO, DON'T?
         BLT   GREP3              ;return if not
         CLI   0(B),254
         BGT   GREP3
         MVC   IACCMD,0(B)        ;save
         LA    B,1(B)
         BCTR  C,0
         CALL  GETNET             ;make sure we have more
         MVC   IACOPT,0(B)        ;get option
         CLI   IACCMD,251         ;WILL?
         BE    TIAC1
         CLI   IACCMD,253         ;DO?
         BNE   GREP3
         MVI   IACCMD,252         ;DO => WON'T
         B     TIAC2
TIAC1    MVI   IACCMD,254         ;WILL => DON'T
TIAC2    MVC   LEN,=H'3'          ;length
         JSYS  WRITE,=A(IAC,LEN,ZERO,DUMMY,COMAND) ;write it
         JSYS  CONTROL,PUSH       ;push it out
         B     GREP3
*+
*
* Make sure we have at least one byte from the net;
* read a buffer if not.
*
* B/ addr in buf (ignored if C=0)
* C/ count of chars remaining in buf
* LR/ link (failure), C=0 (drops out of GETREP)
* 14/ link (success), C non-zero (returns to GETREP)
*
*-
GETNET   LTR   C,C                ;any?
         BNZR  14                 ;yes, return
         LR    B,14               ;save link
GNET1    JSYS  READ,=A(RBUF,LEN,@ERRRTN,DUMMY,COMAND) ;read more
         LTR   15,15              ;err?
         BNZR  LR                 ;punt if so
         LH    C,LEN              ;get length
         LTR   C,C                ;NZ?
         BZ    GNET1              ;try again if not
         LR    14,B               ;copy back
         L     B,=A(RBUF)         ;pt at buffer
         BR    14                 ;skip
*
         LTORG                    ;dump all GETREP stuff
         DROP  H
*+
*
* Display reply.
*
* B,C/ still set up from GETREP
* LR/ link
*
* Skip returns on success, no skip means we head a
* net read error reading the rest of a multi-line reply.
*
*-
DISREP   BASR  H,0                ;base reg
         USING DREP1,H
DREP1    CALL  PREFIX,REPPFX      ;set prefix
         CALL  PFXON              ;make sure it's on
         ST    LR,REPRA           ;save return addr
DREP2    LR    F,B                ;save
         LR    G,C
         LA    A,REPLY            ;pt at reply
         LH    B,REPLEN           ;length
         CLI   DEBUG,0            ;debugging?
         BNZ   DREP4              ;yes
         LA    C,SBUF+1           ;addr
         LA    D,L'SBUF-1         ;# chars free
DREP3    CALL  FORMAT             ;format the line
         JSYS  SPRINT,=A(SBUF,LEN,ZERO,DUMMY) ;display
         CLI   CONTD,0            ;was that the last line?
         BZ    RPRT4              ;return if so
         LR    B,F                ;restore
         LR    C,G
         JSPF  D,GETREP           ;get reply
         DROP  H                  ;GETREP nuked H
         USING *,LR               ;but set up LR
           B   RPRT0              ;error return
         L     H,=A(DREP1)        ;reset base reg
         DROP  LR
         USING DREP1,H
         B     DREP2              ;loop
DREP4    MVI   SBUF+1,QLBR        ;[
         MVC   SBUF+2(3),REPCOD   ;abc
         MVC   SBUF+5(2),=AL1(QRBR,QSP) ;"] "
         LA    C,SBUF+7           ;addr
         LA    D,L'SBUF-7         ;# chars left
         B     DREP3              ;continue
*
REPPFX   PFX   '<< '              ;pfx for displaying replies
*+
*
* Eat reply.
*
* B,C/ still set up from GETREP
* LR/ link
*
* Skip-returns on success, no skip means net read
* error fetching rest of multi-line reply.
*
* This turns into DISREP if DEBUG ON.
*
EATREP   BASR  H,0                ;temp base reg
         USING EREP1,H
EREP1    CLI   DEBUG,0            ;debugging?
         BNZ   EREP3              ;yes, display everything
         ST    LR,REPRA           ;save return addr
EREP2    CLI   CONTD,0            ;was that all?
         BZ    RPRT4              ;return if so
         JSPF  D,GETREP           ;get one
         DROP  H                  ;GETREP nuked H
         USING *,LR               ;but LR is set up
           B   RPRT0              ;no skip
         L     H,=A(EREP1)        ;reset base reg
         B     EREP2-EREP1(H)     ;loop
         DROP  LR
RPRT0    BASR  H,0                ;reset base reg
         USING *,H
         L     LR,REPRA           ;get ret addr
         BR    LR                 ;return
RPRT4    BASR  H,0                ;reset base reg
         USING *,H
         L     LR,REPRA           ;get ret addr
         B     4(LR)              ;skip + return
         USING EREP1,H
EREP3    L     A,=A(DISREP)       ;display everything
         BR    A
*
REPRA    DS    F                  ;DISREP/EATREP ret addr
         LTORG
         DROP  H
*+
*
* Format an ASCII line for display.
*
* Expand tabs, quote ctrl characters, and remap characters
* that would come up as ?'s on Couriers (the output will
* be wrong, but better than ???, and this is just for display).
*
* A/ input line
* B/ length
* C/ addr in SBUF where EBCDICK line goes
* D/ # bytes free at (C)
* 14/ link
*
* Return with LEN and SBUF set up.
*
*-
FORMAT   BASR  15,0               ;set up base reg
         USING *,15
         MVI   SBUF,QSP           ;carriage control
         LTR   B,B                ;check for null line
         BZ    FMT4
* get next char
FMT1     NI    0(A),X'7F'         ;force 7-bit ASCII
         CLI   0(A),QSP           ;ctrl chars are special
         BLT   FMT6
         CLI   0(A),RUB           ;rubout too
         BE    FMT6
* save it (printing char)
FMT2     MVC   0(1,C),0(A)        ;copy char
         LA    C,1(C)             ;bump ptr
         BCTR  D,0                ;count -1
         LTR   D,D                ;quit if buf full
         BZ    FMT4
FMT3     LA    A,1(A)             ;advance input ptr
         BCT   B,FMT1             ;loop
FMT4     S     C,=A(SBUF)         ;find length
         STH   C,LEN              ;save
         BCTR  C,0                ;-1 for TR
         CLI   COURIER,0          ;Courier?
         BZ    FMT5               ;no
           EX  C,FMTMAP           ;map { ] ~ etc. to something
FMT5     L     D,=V(ASCEBC)       ;table
         EX    C,FMTXLT           ;translate to EBCDICK
         BR    14                 ;later
* handle ctrl chars
FMT6     CLI   0(A),CR            ;ignore cr
         BE    FMT3
         CLI   0(A),TAB           ;tab is special case
         BE    FMT7
         XI    0(A),X'40'         ;flip to printing char
         MVI   0(C),QCAR          ;prefix with ^
         LA    C,1(C)             ;bump ptr
         BCT   D,FMT2             ;go store char
         B     FMT4               ;buf full, done
* tab
FMT7     LR    TT,C               ;get output ptr
         S     TT,=A(SBUF+1)      ;find distance from base
         N     TT,=F'7'           ;get low 3 bits
         LA    E,8                ;width of tab field
         SR    E,TT               ;find # cols to go
         CLR   E,D                ;space in buf?
         BLT   FMT8               ;yep
           LR  E,D                ;stop at end
FMT8     BCTR  E,0                ;-1
         EX    E,FMTTAB           ;add 1 to 8 blanks
         LA    C,1(C,E)           ;skip past end
         SR    D,E                ;update length (+1)
         BCT   D,FMT3             ;-1, still space left
         B     FMT4               ;done
*
FMTXLT   TR    SBUF(0),0(D)       ;translate from ASCII to EBCDICK
FMTMAP   TR    SBUF(0),ASCMAP     ;map annoying chars for Couriers
FMTTAB   MVC   0(0,C),=X'2020202020202020' ;add 1 to 8 blanks
         LTORG
         DROP  15
*+
*
* Convert a number to decimal.
*
* A/ number
* B/ buffer (predecrement)
* C/ C'0' for EBCDICK or Q0 for ASCII
* 14/ link
*
* Uses TT, D.
*
*-
DECOUT   LA    D,10               ;radix
DOUT1    XR    TT,TT              ;zero-extend
         DR    TT,D               ;/10
         AR    TT,C               ;convert to digit
         BCTR  B,0                ;B-1
         STC   TT,0(B)            ;save digit
         LTR   A,A                ;anything left?
         BNZ   DOUT1              ;loop if so
         BR    14
         LTORG
*
         EJECT
         TITLE 'Data receive routines'
*+
*
* Routines are called as follows:
*
* L H,address of routine
* BASR LR,H
* +0/ EOF or EOR (flags set in C)
* +4/ C=address, D=length (non-zero)
*
*-
         SPACE
*+
*
* Read to end of buffer or <CRLF>.
*
*-
RCRLF    LR    B,D                ;copy end ptr
         SR    B,C                ;find # bytes
*        BE    ...                ;none, refill buffer
         CL    B,=F'256'          ;small enough for a single TRT?
         BLE   *+8                ;yes
           LA  B,256              ;no
         BCTR  B,0                ;-1 for TRT
*        L     A,=A(EOLTRT)       ;point at TRT table
*        EX    B,CRTRT            ;look for <CR>
*+
*
* MODE S, STRU F
*
* Data bytes are passed through transparently.
*
*-
         USING MODSF,H
MODSF    JSYS  READ,=A(RBUF,LEN,@ERRRTN,DUMMY,DATA)
         LTR   15,15              ;happy return?
         BNZR  LR                 ;no
         XR    D,D                ;D=0
         ICM   D,B'11',LEN        ;get length
* ICM sets CC right?
         BZ    MODSF              ;try again if 0
         L     C,=A(RBUF)         ;OK
         AR    D,C                ;point at end
         B     4(LR)
         LTORG
*+
*
* MODE S, STRU R
*
* Data bytes are passed transparently except for the X'FF' escape.
*
*-
         USING MODSR,H
MODSR    DS    0H
*
         LTORG
         DROP  H
*
         EJECT
         TITLE 'Domain name resolver'
*+
*
* Domain name resolver.
*
* MTS's resolver (if any) is undocumented, so we'll do it ourselves.
*
* Asks for:
* HINFO  (CPU/OS type -- friend or foe?)
* A      if we have the name and want the IP address, or
* PTR    if we have the IP address and want the name
* (might get CNAME even if we didn't ask for it)
*
* If they gave us the IP addr and we can't get the name, we'll
* make do, there just won't be a cute prompt.
* We can live without the HINFO too but it might help us guess
* whether EBCDIC mode is a win or what the word size is.
*
* C/ addr of name
* D/ length
* LR/ link
*
* Skips on success, otherwise returns with A set up for SERCOM call.
*
* We'll be paranoid about believing the links in the data files,
* since although our Attn processing should be pretty good at
* keeping us from stopping halfway through the job, they can
* always %QUIT.  So sooner or later someone will get us while
* we're linking something in.  Try to minimize the damage.
*
* This is assuming I ever write the cache code, for now we always
* phone home to do the lookup.
*
*-
LOOKUP   LR    A,LR               ;get ret addr
         BASR  LR,0               ;set up base reg
         USING LOOK1,LR
LOOK1    ST    A,LOOKRA           ;save ret addr
         LR    B,C                ;copy ptr
* try parsing as A.B.C.D first
         XR    A,A                ;init this byte
         LA    F,4                ;dot counter (IP addr in E)
ABCD1    CLI   0(B),C'.'          ;dot?
         BE    ABCD5
         CLI   0(B),C' '          ;end of string?
         BE    ABCD3
         CLI   0(B),C'0'          ;digit?
         BL    DNAM1
         CLI   0(B),C'9'
         BH    DNAM1
         M     TT,=F'10'          ;*10
         IC    TT,0(B)            ;get dig
         SH    TT,=Y(C'0')        ;convert to dec
         AR    A,TT               ;add it in
         CH    A,=H'255'          ;overflowed byte?
         BGT   DNAM1
ABCD2    LA    B,1(B)             ;skip char
         CLR   B,D                ;off end?
         BNE   ABCD1              ;loop
ABCD3    SLL   E,8                ;left 8
         OR    E,A                ;OR in last byte
         BCT   F,DNAM1            ;we should be done, punt if not
* it was an IP addr, value in E
         ST    E,IPADDR           ;save IP addr
         ST    F,IPADDR+4         ;(=0) mark end of addr list
         LR    C,B                ;bump cmd line ptr to skip name
* make a query:
* QNAME: D.C.B.A.IN-ADDR.ARPA, QTYPE: PTR, QCLASS: IN
         LA    B,INADDR           ;pt at buffer
         LA    E,Q0               ;ASCII '0'
         LA    F,4                ;loop count
         LA    G,IPADDR           ;pt at addr
ABCD4    LR    H,B                ;copy ptr
         XR    A,A                ;zap
         IC    A,0(G)             ;get next #
         LA    G,1(G)             ;skip it
         CALL  CVDEC              ;convert
         SR    H,B                ;find length
         BCTR  B,0                ;-1
         STC   H,0(B)             ;save it
         BCT   F,ABCD4            ;loop
         L     E,=A(FBUF)         ;pt at buffer
         MVC   0(QRYL,E),QRY      ;copy query
         LA    A,ENDINA-1         ;end of query -1 (for MVC)
         SR    A,B                ;find length
         EX    A,COPQNM           ;copy QNAME
         LA    A,QRYL+1(A)        ;+ len(header), correct
         STH   A,QLEN             ;save length
         B     QUERY1             ;go send query
* remember me?  handle '.' in IP addr
ABCD5    SLL   E,8                ;left 8
         OR    E,A                ;OR in the new byte
         XR    A,A                ;init for next one
         BCT   F,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
         L     B,=A(FBUF)         ;pt at query buffer
         MVC   0(QRYL,B),QRY      ;copy query header
         LA    B,QRYL(B)          ;skip it
         LR    E,C                ;remember posn
         L     F,=V(EBCASC)       ;xlat table
* parse next label
DNAM2    CLI   0(C),C' '          ;end?
         BE    DNAM4
         CLI   0(C),C'.'          ;end of label?
         BE    DNAM5
DNAM3    LA    C,1(C)             ;skip
         CLR   C,D                ;done?
         BNE   DNAM2              ;loop if not
DNAM4    LR    A,C                ;copy
         SR    A,E                ;find length
         STC   A,0(B)             ;save
         BCTR  A,0                ;-1 for MVC/TR
         EX    A,COPLAB           ;copy label
         EX    A,TRLAB            ;xlat to ASCII
         LA    B,1+1(B,A)         ;skip the label
         MVC   0(5,B),=X'0000010001' ;end, QTYPE=A, QCLASS=IN
         S     B,=A(FBUF-5)       ;find total length
         STH   B,QLEN             ;save
         B     QUERY1             ;go
* end of non-final label
DNAM5    LR    A,C                ;copy
         SR    A,E                ;find length
         STC   A,0(B)             ;save
         BCTR  A,0                ;-1 for MVC/TR
         EX    A,COPLAB           ;copy label
         EX    A,TRLAB            ;xlat to ASCII
         LA    B,1+1(B,A)         ;skip the label
         LA    E,1(C)             ;pt at next
         B     DNAM3
* whatever it was, build and send the query
* FBUF/ contains QNAME, QTYPE, and QCLASS fields
* QLEN/ total length
* 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   ATTN  DOMATN             ;handle Attn properly
         JSYS  MOUNT,NMNT,DNPUNT  ;get a network device
         JSYS  GETFD,PNMNT        ;get an FDUB ptr
         ST    TT,NAME            ;save
         JSYS  CONTROL,WATYPE,DNPUNT ;WRITE_ADDRESS_TYPE=BUFFER
         JSYS  CONTROL,TIMER,DNPUNT ;set timeout
         JSYS  CONTROL,SOCKET,DNPUNT ;SOCKET
* send the query
         LA    B,5                ;# retries
QUERY2   JSYS  WRITE,=A(FBUF,QLEN,ZERO,DUMMY,NAME),DNPUNT ;yep
         JSYS  READ,=A(RBUF,LEN,@ERRRTN,DUMMY,NAME) ;get reply
         LTR   15,15              ;OK?
         BZ    QUERY3             ;yes
         BCT   B,QUERY2           ;retry
* error, forget it
DNPUNT   L     TT,NAME            ;close *DOMAIN*
         JSYS  FREEFD
         JSYS  RELEASE,RNMNT      ;$REL *DOMAIN*
         CLC   IPADDR(4),=F'0'    ;doint PTR lookup?
         BZ    DNPNT2             ;no, error for sure
* enter here to return dotted decimal IP address as name
DNPNT1   LA    B,SBUF+16          ;buf for #
         MVI   0(B),C'>'          ;ends with '>'
         LA    F,IPADDR+4         ;pt at addr
         CALL  CVADDR             ;go convert IP addr
         EX    G,COPADR           ;copy IP addr to prompt area
         LA    G,1(G)             ;count the '>'
         ST    G,HSTPRM+4         ;save length
         LA    G,8(G)             ;length of blk
         ST    G,HSTPRM           ;save
         L     LR,LOOKRA          ;get ret addr
         B     4(LR)              ;happy return
DNPNT2   LA    A,LUKERR           ;lookup error
         L     LR,LOOKRA          ;get ret addr
         BR    LR                 ;sad return
* answer received, process it
QUERY3   L     TT,NAME            ;won't be needing *DOMAIN* again
         JSYS  FREEFD
         JSYS  RELEASE,RNMNT      ;$REL *DOMAIN*
* server reply is in RBUF, length in LEN
         L     B,=A(RBUF)         ;pt at it (base regs can't reach)
         IC    A,3(B)             ;get response code
         N     A,=F'15'           ;isolate low 4
         BZ    RESP               ;we won, parse RR's
         CLC   IPADDR(4),=F'0'    ;did we have the addr?
         BNZ   DNPNT1             ;yes, return it
         SLL   A,2                ;*4
         L     A,RSPDSP-4(A)      ;get SERCOM list
         L     LR,LOOKRA          ;get ret addr
         BR    LR                 ;unhappy return
* things are OK, handle response (pointed to by B)
RESP     LA    A,12(B)            ;pt at returned info
         LH    E,4(B)             ;get QDCOUNT
* skip queries
         LTR   E,E                ;did they return it
         BZ    RESP2              ;no
RESP1    CALL  SKNAME             ;skip QNAME
         LA    A,2+2(A)           ;skip QTYPE, QCLASS
         BCT   E,RESP1            ;loop
RESP2    ST    A,HNAME            ;set default name
         LH    E,6(B)             ;get ANCOUNT
         LTR   E,E                ;non-zero, right?
         BZ    RR3                ;punt!
* scan answer RR's for whatever we were looking for
RR1      CALL  SKNAME             ;skip name
         CLC   0(2,A),=X'0001'    ;A?
         BE    RRA
         CLC   0(2,A),=X'0005'    ;CNAME?
         BE    RRCNAM
         CLC   0(2,A),=X'000C'    ;PTR?
         BE    RRPTR
         CLC   0(2,A),=X'000D'    ;HINFO?
         BE    RRHINF
RR2      XR    F,F                ;0
         ICM   F,3,8(A)           ;get RDLENGTH
         LA    A,10(A,F)          ;skip to next RR
         BCT   E,RR1              ;loop
* we're done, make sure we got the name
RR3      L     A,HNAME            ;get it
         LA    E,HSTNAM
         CALL  CVNAME             ;convert
         LA    TT,C'>'            ;add '>'
         STC   TT,HSTNAM(E)       ;to end
         LA    E,1(E)             ;add to length
         ST    E,HSTPRM+4         ;set length
         LA    E,8(E)             ;total length for CUINFO
         ST    E,HSTPRM
         L     LR,LOOKRA          ;get ret addr
         B     4(LR)              ;happy return
* address RR
RRA      ICM   F,15,10(A)         ;get IP addr
         LA    G,IPADDR           ;init ptr
RRA1     CLC   0(4,G),=F'0'       ;empty slot?
         BZ    RRA2               ;skip
         CL    F,0(G)             ;duplicate?
         BE    RR2                ;yes, forget it
         LA    G,4(G)             ;skip
         CL    G,=A(4*10+IPADDR)  ;off end?
         BL    RRA1               ;loop
         B     RR2                ;just lose it
RRA2     ST    F,0(G)             ;save
         MVC   4(4,G),=F'0'       ;zap next entry
         B     RR2                ;(space for F'0' after end)
* CNAME RR
RRCNAM   EQU   *                  ;drop through
* PTR RR
RRPTR    LA    F,10(A)            ;pt at PTR
         ST    F,HNAME            ;definitely right
         B     RR2
* HINFO RR
RRHINF   LA    TT,10(A)           ;addr
***      ST    TT,HINFO           ;save ptr
         B     RR2
* Attn during domain lookup
DOMATN   B     DNPUNT             ;;; but not always
*
COPQNM   MVC   QRYL(0,E),0(B)     ;copy query into buf
COPLAB   MVC   1(0,B),0(E)        ;copy label to query
TRLAB    TR    1(0,B),0(F)        ;translate to ASCII
COPADR   MVC   HSTNAM(0),0(B)     ;copy IP addr
*+
*
* Convert a hostname from query form to EBCDICK.
*
* A/ pointer to hostname (RFC 1035 form)
* B/ ptr to base of UDP packet (RBUF)
* E/ buffer to store it in
* 14/ link
*
* On return:
* E/ length
*
*-
CVNAME   LR    TT,E               ;save ptr for length
         LM    F,G,=V(ASCEBC,CASECONV) ;conversion tables
CVN1     CLI   0(A),X'C0'         ;pointer?
         BGE   CVN2
         XR    H,H                ;init for length
         ICM   H,1,0(A)           ;get length, set CC
         BZ    CVN3               ;end
         LA    A,1(A)             ;skip length
         BCTR  H,0                ;-1 for MVC/TR
         EX    H,CVNMVC           ;copy label
         EX    H,CVNTR1           ;EBCDICK
         EX    H,CVNTR2           ;UPPER CASE!  Goddammit!
         AR    E,H                ;skip to last char
         MVI   1(E),C'.'          ;add a .
         LA    E,1+1(E)           ;skip past it (correct length)
         LA    A,1(A,H)           ;skip to next label
         B     CVN1               ;loop
CVN2     ICM   A,3,0(A)           ;get ptr
         N     A,=F'16383'        ;isolate
         AR    A,B                ;index into RBUF
         B     CVN1               ;continue
CVN3     CLR   E,TT               ;have we moved?
         BE    *+6                ;no (?!), don't lose
           BCTR E,0               ;un-put last .
         SR    E,TT               ;find length
         BR    14
CVNMVC   MVC   0(0,E),0(A)        ;copy string
CVNTR1   TR    0(0,E),0(F)        ;xlat to EBCDICK
CVNTR2   TR    0(0,E),0(G)        ;xlat to u.c.
*+
*
* Skip a domain name.
*
* A/ domain name (RFC 1035 form)
* 14/ link
*
* A is updated on return.
*
*-
SKNAME   XR    F,F                ;zap
SKN1     CLI   0(A),X'00'         ;end?
         BZ    SKN3
         CLI   0(A),X'C0'         ;pointer?
         BGE   SKN2
         IC    F,0(A)             ;get length
         LA    A,1(A,F)           ;skip
         B     SKN1
SKN2     LA    A,1(A)             ;+1 (+2 total)
SKN3     LA    A,1(A)             ;+1
         BR    14
*+
*
* Convert a number to decimal.
*
* A/ number
* B/ end of buffer (predecrement)
* E/ C'0' or Q0
* 14/ link
*
*-
CVDEC    XR    TT,TT              ;0-extend
         D     TT,=F'10'          ;divide
         AR    TT,E               ;cvt to EBCDICK or ASCII
         BCTR  B,0                ;back up
         STC   TT,0(B)            ;save
         LTR   A,A                ;anything left?
         BNZ   CVDEC              ;loop
         BR    14                 ;loop
*
* errors returned from domain name server:
RSPDSP   DC    A(FMTERR,SRVFLR,NAMERR,NOTIMP,REFUSD)
         DC    A(SRVERR,SRVERR,SRVERR,SRVERR,SRVERR)
         DC    A(SRVERR,SRVERR,SRVERR,SRVERR,SRVERR)
FMTERR   TXT   ' Name format error'
SRVFLR   TXT   ' Name server failure'
NAMERR   TXT   ' No such host'
NOTIMP   TXT   ' Query type unimplemented in name server'
REFUSD   TXT   ' Fascist name server refuses access'
SRVERR   TXT   ' Name server error'
LUKERR   TXT   ' Name server timeout'
*
LOOKRA   DS    F                  ;return addr
         LTORG
         DROP  LR
*+
*
* Convert IP addr to EBCDICK.
*
* B/ end of buffer (predecrement)
* F/ ptr past end of IP addr (predecrement)
* 14/ link
*
* On return:
* B/ begn of buffer
* G/ length
*
*-
CVADDR   BASR  15,0               ;base reg
         USING *,15
         LR    G,B                ;copy for subtract later
         LA    E,C'0'             ;EBCDICK '0'
         LA    H,4                ;loop count
CVADR1   XR    A,A                ;zap
         BCTR  F,0                ;-1
         IC    A,0(F)             ;get next #
CVADR2   XR    TT,TT              ;0-extend
         D     TT,=F'10'          ;divide
         AR    TT,E               ;cvt to EBCDICK
         BCTR  B,0                ;back up
         STC   TT,0(B)            ;save
         LTR   A,A                ;anything left?
         BNZ   CVADR2             ;loop if so
         BCTR  B,0                ;-1
         MVI   0(B),C'.'          ;dot
         BCT   H,CVADR1           ;loop
         LA    B,1(B)             ;skip 1st .
         SR    G,B                ;find length
         BR    14
         DROP  15
*
* Here's the original code, some day I should mix the two together
         AGO   .NODNS
LOOKUP   MVC   CCHENT,=F'0'       ;nothing from cache yet
         LR    E,C                ;copy
         LR    F,D
* try to parse it as a.b.c.d (IP address)
         MVC   IPADDR,=F'0'       ;IP addr
         XR    A,A                ;init curr byte
         LA    B,3                ;# of dots
ABCD1    CLI   0(E),C'.'          ;dot?
         BE    ABCD3              ;yes
         CLI   0(E),C'0'          ;digit?
         BL    NAM1               ;no
         CLI   0(E),C'9'
         BG    NAM1
         M     TT,=F'10'          ;A*10, TT=0
         IC    TT,0(E)            ;get dig
         SH    TT,=Y(C'0')        ;convert
         AR    A,TT               ;add in
         CH    A,=H'255'          ;overflowed?
         BG    NAM1               ;can't be host #
ABCD2    LA    E,1(E)             ;skip char
         BCT   F,ABCD1            ;loop
         LTR   B,B                ;seen 3 dots?
         BNZ   NAM1               ;no, invalid
* it's an IP addr
         MVC   IPADDR(3),IPADDR+1 ;shift left
         STC   A,IPADDR+3         ;4th byte
* see if it's in &HNAMES (index by IPADDR)
         CALL  ATNOFF             ;don't leave &HNAMES hanging
         JSYS  GETFD,=C'&HNAMES ',ABCDL4 ;;open name list file
         ST    TT,CACHE           ;;save FDUB ptr
         MVC   DUMMY,IPADDR       ;;copy line #
* run around the IP addr circle until we find the complete entry
         LA    B,50               ;;don't be gullible
ABCDL1   JSYS  READ,=A(FBUF,LEN,@I,DUMMY,CACHE),ABCDL3
         CLC   LEN,=H'4'          ;;complete entry or just link?
         BGT   ABCDL2             ;;complete, skip
         MVC   DUMMY(4),FBUF      ;;link, copy it
         BCT   B,ABCDL1           ;;not out of patience yet?
         B     ABCDL3             ;;give up
* found it, see if expired and use it if not
ABCDL2   L     TT,CACHE           ;;FDUB ptr
         JSYS  FREEFD             ;;release file
         CALL  ATNON              ;;reenable Attn
         MVC   CCHENT,DUMMY       ;save line #
         JSYS  TIME,TIMLST        ;get time
         CLC   FBUF+HEXPR(4),NOW  ;expired?
         BL    ABCDL5             ;yes, keep looking (but save it)
         B     CCHHIT             ;no, use it
* file error or cache miss
ABCDL3   L     TT,CACHE           ;;FDUB ptr
         JSYS  FREEFD             ;;close it
ABCDL4   CALL  ATNON              ;;Attn back on
* build NS query - (PTR, HINFO) D.C.B.A.IN-ADDR.ARPA
ABCDL5   LA    B,HSTNAM+16        ;allow for <len>D<len>C<len>B<len>A
         MVC   0(13,B),=X'07494E2D414444520441525041' ;IN-ADDR.ARPA
         LA    C,Q0               ;ASCII
         XR    E,E                ;offset
         XR    A,A                ;zap A
ABCDL6   IC    A,IPADDR(E)        ;get next byte
         LR    F,B                ;copy addr
         CALL  DECOUT             ;prepend #
         SR    F,B                ;length
         BCTR  B,0                ;-1
         STC   F,0(B)             ;add length
         LA    E,1(E)             ;+1
         CH    E,=F'4'            ;done?
         BL    ABCDL6             ;loop if not
         ST    B,AHNAM            ;save addr
         LA    A,HSTNAM+29        ;pt at end
         SR    A,B                ;find length
         STH   A,LHNAM            ;save length
         MVI   QUERY,QA+QHNAME    ;query = PTR, HNAME
         B     ...                ;go ask
* remember me?  '.' in host number - shift in the new byte
ABCD3    MVC   IPADDR(3),IPADDR+1 ;shift left
         STC   A,IPADDR+3         ;new byte
         BCTR  B,0                ;count the dot
         B     ABCD2              ;continue
* must be a domain name
NAM1     MVC   IPADDR,=F'0'       ;zero out IP addr
         LR    F,C                ;save C
         CALL  HASH               ;compute hash
         LR    C,F                ;restore
         ST    A,DUMMY            ;save line #
 
         CALL  ATNOFF             ;don't leave files hanging
 
*** read &HADDRS line, if any
*** read each &HNAMES line, check each name
 
 
* actually checking servers:
 
 
 
* LA A,IP addr table entry
*        MVC   QUERY+2(4),0(A)    ;copy address
         LH    A,QUERY+6          ;get seq
         LA    A,1(A)             ;+1
         STH   A,QUERY+6
         JSYS  WRITE,=A(QUERY,QLEN,ZERO,DUMMY,DNS) ;send command
         LTR   15,15              ;write error?
         BNZ   ...                ;assume unreachable
         JSYS  READ,=A(FBUF,LEN,ZERO,DUMMY,DNS) ;get reply
         LTR   15,15              ;read error?
         BNZ   ...                ;assume timeout
 
         LH    A,QUERY+12         ;get # answers
         LTR   A,A                ;any?
         BZ    ...                ;no, get hand job
* parse answers, exit if we're satisfied
*** look for CNAME first
*** then HINFO
 
 
* read NS and AR RR's
* make two tables:  one of NS hosts whose A's we have in AR
* and one of NS hosts whose A's we don't know (probably null)
 
* restart loop from the outside with the A list
 
* unreachable:  drop from list
         LR    C,A                ;copy
         LR    D,B
         B     BB
AA       MVC   0(4,C),4(C)        ;back 1
         LA    C,4(C)             ;bump ptr
BB       BCT   D,AA
**** # entries -1
         B     ... BCT            ;(but skip the advance)
* timeout:  advance to next
         LA    A,4(A)             ;skip to next
         BCT   B,...
*** check retry count and # entries count, loop if both NZ
*** if we had buffered NS records with no A records,
start processing them recursively --
save context (query/success flags), eat one NS record and copy it to
query.
 
 
*+
*
* Compute hash of a hostname.
*
* We convert the first 6 chars of the host name into
* 'radix-50' code, so that it fits in a 32-bit word.
* 50 is octal, so it's really base 40., with these digits:
* <SP>ABCDEFGHIJKLMNOPQRSTUVWXYZ$.%0123456789
*
* We'll pad the host name to the right with SP's (if necessary),
* convert "-" to "$", and replace anything else with "%".
*
* C/ ptr to hostname (u.c. EBCDICK)
* D/ ptr past end of hostname
* 14/ link
*
* A/ returns hash
*
*-
HASH     XR    A,A                ;init hash
         LA    B,6                ;# chars to get
HASH1    CLI   0(C),C'.'          ;dot?
         BE    HASH3
         CLI   0(C),C'-'          ;hyphen?
         BE    HASH4
         XR    E,E                ;0's
         CLI   0(C),C'A'          ;A-I?
         BLT   HASH2
         CLI   0(C),C'I'
         BLE   HASH5
         CLI   0(C),C'J'          ;J-R?
         BLT   HASH2
         CLI   0(C),C'R'
         BLE   HASH6
         CLI   0(C),C'S'          ;S-Z?
         BLT   HASH2
         CLI   0(C),C'Z'
         BLE   HASH7
         CLI   0(C),C'0'          ;0-9?
         BLT   HASH2
         CLI   0(C),C'9'
         BLE   HASH8
HASH2    LA    E,29               ;%
         B     HASH9
HASH3    LA    E,28               ;.
         B     HASH9
HASH4    LA    E,27               ;$
         B     HASH9
HASH5    IC    E,0(C)             ;get A-I
         SH    E,=Y(C'A'-1)
         B     HASH9
HASH6    IC    E,0(C)             ;get J-R
         SH    E,=Y(C'J'-10)
         B     HASH9
HASH7    IC    E,0(C)             ;get S-Z
         SH    E,=Y(C'S'-19)
         B     HASH9
HASH8    IC    E,0(C)             ;get 0-9
         SH    E,=Y(C'0'-30)
HASH9    XR    TT,TT              ;0-extend
         M     TT,=F'40'          ;*40
         AR    A,E                ;add in new digit
         LA    C,1(C)             ;advance
         CLR   C,D                ;anything left?
         BE    HASH11             ;skip if not
         BCT   B,HASH1            ;loop
         BR    14
HASH10   XR    TT,TT              ;0-extend
         M     TT,=F'40'          ;*40
HASH11   BCT   B,HASH10           ;left-justify
         BR    14
.NODNS   ANOP
*
         EJECT
         TITLE 'Pure data'
*
* Data not addressable through any static base register.
*
EOLTRT   DC    X'00000000000000000000000000040000'
         DC    X'00000000000000000000000000000000'
         DC    X'00000000000000000000000000000000'
         DC    X'00000000000000000000000000000000'
         DC    X'00000000000000000000000000000000'
         DC    X'00000000000000000000000000000000'
         DC    X'00000000000000000000000000000000'
         DC    X'00000000000000000000000000000000'
         DC    X'00000000000000000000000000000000'
         DC    X'00000000000000000000000000000000'
         DC    X'00000000000000000000000000000000'
         DC    X'00000000000000000000000000000000'
         DC    X'00000000000000000000000000000000'
         DC    X'00000000000000000000000000000000'
         DC    X'00000000000000000000000000000000'
         DC    X'00000000000000000000000000000000'
*
* CUINFO item numbers
ATTNOFF  DC    F'51'              ;CUINFO(ATTNOFF)
PXOFF    DC    F'57'              ;CUINFO(PFXOFF)
PFXITM   DC    F'257'             ;CUINFO(PFXSTR)
UNITM    DC    F'298'             ;GUINFO(USERNAME)
*
@NOCC    DC    X'00000040'        ;modifiers
@MAXLEN  DC    X'08000000'
@ERRRTN  DC    X'40000000'
@I       DC    X'00000002'
*
* Global data (addressed through B2).
*
GLOBAL   LTORG                    ;addressable through B2
*
PERCNT   PFX   '% '               ;for warnings after Attn
QUESTN   PFX   '? '               ;for errors
*
KBIN     DC    A(KBBUF,KBLEN,@MAXLEN,DUMMY)
*
BLANK    DC    C'BLANK'           ;tell term to zap input field
LBLNK    DC    Y(L'BLANK)
GUNIT    DC    CL8'GUSER'         ;use GUSER instead of SCARDS
*
GETIME   DC    A(THRTN,ZERO,NOW)  ;TIME arg list (NOW=time in sec)
*
ZERO     DC    F'0'               ;handy constants
ONE      DC    F'1'
THRTN    DC    F'13'
*
* change ASCII printing chars which will annoy EBC DICK terminals
ASCMAP   EQU   *-X'20'
         DC    X'202122232425262728292A2B2C2D2E2F'
         DC    X'303132333435363738393A3B3C3D3E3F'
         DC    X'404142434445464748494A4B4C4D4E4F'
         DC    X'505152535455565758595A282F29A25F' ;[\]^ => (/) cents
* the following codes are a problem only on 3277's (3278/3279 OK)
         DC    X'276162636465666768696A6B6C6D6E6F' ;` => '
         DC    X'707172737475767778797A3C7C3EAC'   ;{}~ => <> NOT
*
* Keywords, in ASCII
*
ABOR     DC    X'41424F520D0A'    ;"ABOR"<CRLF>
ACCT     DC    X'4143435420'      ;"ACCT "
CDUP     DC    X'434455500D0A'    ;"CDUP"<CRLF>
CWD      DC    X'43574420'        ;"CWD "
PASS     DC    X'5041535320'      ;"PASS "
PORT     DC    X'504F525420'      ;"PORT "
QUIT     DC    X'515549540D0A'    ;"QUIT"<CRLF>
RETR     DC    X'5245545220'      ;"RETR "
STRU     DC    X'5354525520'      ;"STRU "
TYPE     DC    X'5459504520'      ;"TYPE "
USER     DC    X'5553455220'      ;"USER "
CRLF     DC    X'0D0A'            ;Telnet end-of-line
L6       DC    H'6'               ;length of ABOR, QUIT etc.
*
* Abort strings
IP       DC    X'FFF4'            ;IAC IP (TELNET Interrupt Process)
L2       DC    H'2'
SYN      DC    X'16'              ;SYN (TELNET synchronize)
L1       DC    H'1'
*
* $MOUNT commands
MOPT     DC    XL4'E800'          ;no messages or prompts
CMND     MOU   'TCP *FTP*'        ;FTP command port
FDAT     MOU   'TCP *FTP-DATA*'   ;FTP-DATA data port
NMNT     MOU   'UDP *DOMAIN*'     ;DOMAIN name server port
*
RELFLG   DC    XL4'10'            ;no messages
*
* command port control strings
CPORT    CONT  'DESTINATION_PORT=21',COMAND
CONECT   CONT  'CONNECT',COMAND
PUSH     CONT  'PUSH',COMAND
CLOSE    CONT  'CLOSE',COMAND
*
* data port control strings
ACCEPT   CONT  'ACCEPT',DATA
SNSSKT   DC    C'SENSE "SOCKET"'
LENSKT   DC    Y(L'SNSSKT)
LISTEN   CONT  'WAIT_FOR_CALL',DATA
*
* domain name resolver control strings
WATYPE   CONT  'WRITE_ADDRESS_TYPE=BUFFER',NAME ;fewer CONTROL calls
TIMER    CONT  'TIMER=5SECONDS',NAME ;timeout
SOCKET   CONT  'SOCKET',NAME      ;establish socket
*
SNSLEN   DC    H'56'              ;length of SPRINT sense buffer
SPUNIT   DC    CL8'SPRINT'        ;unit name for SPRINT
*
         EJECT
         TITLE 'Some of both (initialized storage)'
*
DEBUG    DC    X'00'              ;NZ => debug mode
COURIER  DC    X'00'              ;NZ => SPRINT is Courier or 327X
CNCTED   DC    X'00'              ;NZ => connected to a host
*
CMDPRM   DC    A(FTPPRM)          ;command prompt
ATNVEC   DC    A(FORGET)          ;Attn vec
*
CMDLST   DC    A(0,AREA)
BADKW    DC    A(0,AREA,@NOCC,DUMMY)
*
DADDR    DC    A(0,LEN,COMAND,0)  ;set destination addr
*
PFXP     DC    X'01'              ;NZ => $set pfx=on
*
PFXLST   DC    A(PFXITM)          ;CUINFO(PFXSTR) list
PFX      DC    F'0'               ;addr of curr pfx string
*
KBLEN    DS    H                  ;length goes here
         DC    Y(L'KBBUF)         ;max allowable
         DS    H                  ;useless!
*
SNDLST   DC    A(0,LEN,ZERO,DUMMY,COMAND) ;WRITE args to cmd port
*
* contradict the server's TELNET WILL/DO commands
IAC      DC    X'FF'              ;TELNET Interpret-As-Command
IACCMD   DS    X                  ;DON'T or WON'T
IACOPT   DS    X                  ;option
*
QRY      DC    X'0035'            ;DOMAIN = 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)
QRYL     EQU   *-QRY
*
         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   *
*
         EJECT
         TITLE 'Pure storage'
*
COMAND   DS    A                  ;FDUB ptr for command connection
DATA     DS    A                  ;FDUB ptr for data connection
CACHE    DS    A                  ;FDUB ptr for cache lookup file
FILEFD   DS    A                  ;FDUB ptr for data file
NAME     DS    A                  ;FDUB ptr for name server UDP port
*
IPAPTR   DS    F                  ;ptr into IPADDR (CNCT)
IPADDR   DS    11F                ;list of IP addr's to try
*                                 ;F'0' marks end
HNAME    DS    F                  ;ptr to hostname in DNS reply
*
HSTPRM   DS    2A                 ;lengths of host prompt
HSTNAM   DS    256C               ;hostname+">" (QNAME for resolver)
*
AHNAM    DS    A                  ;addr of start of QNAME in HSTNAM
LHNAM    DS    H                  ;length of query in HSTNAM
*
LEN      DS    H                  ;length for I/O calls
QLEN     DS    H                  ;length of DNS query
DUMMY    DS    F                  ;catch line #'s
AREA     DS    2F                 ;random parameters
DISCRA   DS    F                  ;DISCON return addr
DISCCD   DS    2F                 ;C, D during DISCON
NOW      DS    F                  ;time of day after JSYS TIME,GETIME
*
KBBUF    DS    CL80               ;keyboard buffer
CMDBUF   DS    CL80               ;command buffer
         DS    0F                 ;F-align SBUF
SBUF     DS    CL256              ;scratch buffer
*
REPCOD   DS    XL3                ;reply code
CONTD    DS    X                  ;NZ => reply is continued
REPLEN   DS    H                  ;length of reply
REPLY    DS    XL255              ;server reply
*
ANON     DS    X                  ;NZ => we're ANONYMOUS
*
ACCNT    DS    (1+L'KBBUF)C       ;<len>account name
*
AREG     DS    18F                ;ATTNTRP region
REGS     DS    18F                ;R13 save area
CTAREA   DS    27F                ;CONTROL area
*
         DS    0F                 ;fullword-align
FBUF     DS    32767X             ;file buffer
*
* stuff below here is not addressable with our base registers
RBUF     DS    32767X             ;reply buffer
*
TRTEOL   DS    XL256              ;text eol lookup table
*
         EJECT
         AGO   .NOHNAM
* Line in &HNAMES file
HNAME    DSECT
HNEXT    DS    F                  ;IP addr of next entry in circle
* data below this line appears only in complete entry
* (one per host, linked into circle with other IP addrs)
HMORE    DS    F                  ;IP addr of next MRU host
HLESS    DS    F                  ;IP addr of next LRU host
HEXPR    DS    F                  ;expiration time of this record
HCNAM    DS    X                  ;CNAME begins here
* list of hostnames, starting with primary name
* each name is a byte length followed by a string
* list ends with a 0 byte
* CPU and OS follow in same format as names
.NOHNAM  ANOP
         END   FTP
