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 ®,&DEST ;far JSP &LAB L ®,=A(&DEST) BASR LR,® 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" 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 : ' ;login prompt LTORG *+ * * MCMD * $ * * 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 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 . * *- 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 *+ * * 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 DCBA 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: * 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" ACCT DC X'4143435420' ;"ACCT " CDUP DC X'434455500D0A' ;"CDUP" CWD DC X'43574420' ;"CWD " PASS DC X'5041535320' ;"PASS " PORT DC X'504F525420' ;"PORT " QUIT DC X'515549540D0A' ;"QUIT" 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 ;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