home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
mtsasm
/
mtsker.asm
next >
Wrap
Assembly Source File
|
2020-01-01
|
44KB
|
1,635 lines
KERMIT TITLE 'Kermit -- MTS Version'
* The Kermit protocol was designed at Columbia University in
* in New York by Frank da Cruz, Bill Catchings and Daphne Tzoar.
*
* Copyright (c) 1983 Myrias Research Corporation
* All rights reserved.
*
* This grotty piece of trash thrown together by Chris Thomson.
SPACE 2
* This program is invoked by:
*
* $run kermit [scards=in] [sprint=out] [0=*net*] [par={s|m}]
*
* s=server mode; m=master mode
*
* If no par= is given, and 0 is assigned, then the default is
* master mode; if 0 is not assigned, the default is server.
* In master mode, commands are read from scards and output is
* sent to sprint. If you want to set any non-default parameters
* before entering server mode, use par=m. See set command for
* parameters.
TITLE 'Initialization'
PRINT NOGEN
KERMIT CSECT
REQU TYPE=DEC
SAVE (14,12),,* Standard linkage
LR R12,R15
USING KERMIT,R12
LA R11,2048(,R12)
LA R11,2048(,R11)
USING KERMIT+4096,R11
LA R10,2048(,R11)
LA R10,2048(,R10)
USING KERMIT+8192,R10
LA R15,SAVEAREA
ST R13,4(,R15)
ST R15,8(,R13)
LR R13,R15
LR R2,R1 Save parameter, if any
MVI SERVER,1 Server if no unit 0
MVI NETDEV,X'FF' Assume no net device
MVI FILETYPE,C'T' Default to filetype=text
MVI EOLCHAR,13 Default to eolchar=13 (CR)
MVI EOLCHAR2,13
XC NPAD,NPAD No outbound padding
MVI PADCHAR,0 Pad character of NUL
MVI DEBUG,0 Debugging output off
LA R1,=C'-DEBUG(*L+1) ' But set up unit just in case
CALL GETFD
ST R0,DEBUNIT
SR R0,R0 Get info about unit 0
CALL GDINFO
LTR R15,R15
BNZ INIT30
MVI SERVER,0
CLI 13(R1),9 Error if not net
BE INIT10
SPRINT ' Unit 0 must be a network device'
B ERREXIT
INIT10 L R3,36(,R1) FDname of device
LH R4,0(,R3) Length of it
S R4,=F'1'
C R4,=F'31'
BNH INIT20
SPRINT ' Unit 0 FDname too long'
B ERREXIT
INIT20 MVC NETDEV(32),=CL32' ' Copy device name for connect cmd
EX R4,NDMVC
SR R0,R0 Free gdinfo area
CALL FREESPAC
B INIT30
NDMVC MVC NETDEV(*-*),2(R3)
INIT30 LTR R2,R2
BZ INIT60 No parameter
L R2,0(,R2)
LTR R2,R2
BZ INIT60
CLC 0(2,R2),=H'0'
BE INIT60
CLC 0(2,R2),=H'1' Parameter must be 1 character
BNE INIT50
CLI 2(R2),C'S' Parameter can override server/master
BNE INIT40 default value
MVI SERVER,1
B INIT60
INIT40 CLI 2(R2),C'M'
BNE INIT50
MVI SERVER,0
B INIT60
INIT50 SERCOM ' Invalid par field'
B ERREXIT
INIT60 LA R1,PFXPAR Set prefix to Kermit-MTS>
CALL CUINFO
B MAINLOOP
TITLE 'Main command loop'
MAINLOOP CLI SERVER,0 Are we a server?
BZ LOCCMD No -- read a local command
B REMCMD Yes -- read a remote command
SPACE 1
ABORT CLI NETDEV,X'FF'
BE ABORT10
SPRINT ' Aborted -- try again'
MVI PACKET,ASCB Send break packet
MVI WPCKTNUM,0
LA R1,1
BAL R9,WRPACKET
B MAINLOOP
ABORT10 MVC PACKET(21),=C'EAborted -- try again'
MVI WPCKTNUM,0
LA R1,21
BAL R9,TRETOA
BAL R9,WRPACKET
B MAINLOOP
SPACE 1
ERRPCKT BAL R9,TRATOE
MVC SCBUF(15),=C' Remote error: ' Use scards buffer
S R1,=F'2'
BL ERRP10
EX R1,ERRPMVC
ERRP10 LA R1,16(,R1)
STH R1,SCLEN
CALL SPRINT,(SCBUF,SCLEN,SCMOD,SCLNUM)
B MAINLOOP
ERRPMVC MVC SCBUF+15(*-*),PACKET+1
SPACE 1
WRTFERR CLI NETDEV,X'FF'
BE WRTFE10
SPRINT ' Bad return code writing to file'
MVI PACKET,ASCB Send break packet
MVI WPCKTNUM,0
LA R1,1
BAL R9,WRPACKET
B MAINLOOP
WRTFE10 MVC PACKET(32),=C'EBad return code writing to file'
MVI WPCKTNUM,0
LA R1,32
BAL R9,TRETOA
BAL R9,WRPACKET
B MAINLOOP
SPACE 1
PTOOLONG CLI NETDEV,X'FF'
BE PTL10
SPRINT ' Packet too long -- aborting'
MVI PACKET,ASCB Send break packet
MVI WPCKTNUM,0
LA R1,1
BAL R9,WRPACKET
B MAINLOOP
PTL10 MVC PACKET(28),=C'EPacket too long -- aborting'
MVI WPCKTNUM,0
LA R1,28
BAL R9,TRETOA
BAL R9,WRPACKET
B MAINLOOP
SPACE 1
ERREXIT LA R15,4
B COMEXIT
EXIT SR R15,R15
COMEXIT L R13,4(,R13) Standard return sequence
L R14,12(,R13)
LM R0,R12,20(R13)
BR R14
TITLE 'Server command loop'
REMCMD MVI WPCKTNUM,0
BAL R9,RDPACKET Get a packet -- this may take a while
BNZ REMCMDE
BAL R9,TRATOE
CLI PACKET,C'S' Send-initiate
BE GOTS
CLI PACKET,C'R' Receive-initiate
BE GOTR
CLI PACKET,C'C'
BE DOCMD
CLI PACKET,C'G'
BE GOTG
MVC PACKET(38),=C'EUnsupported or invalid server request'
LA R1,38
BAL R9,TRETOA
BAL R9,WRPACKET
B MAINLOOP
REMCMDE MVI PACKET,ASCN
LA R1,1
BAL R9,WRPACKET
B MAINLOOP
SPACE 1
GOTR LR R2,R1 Set up to merge with SEND
LA R1,PACKET+1
S R2,=F'1'
LA R3,0(R1,R2)
MVI 0(R3),X'FF'
BH SENDSRV *** cc set above ***
MVC PACKET(37),=C'EMissing file spec in rcv-init packet'
LA R1,37
BAL R9,TRETOA
BAL R9,WRPACKET
B MAINLOOP
SPACE 1
DOCMD S R1,=F'1' Execute an MTS command
ST R1,CMDLEN
LA R1,PACKET+1
ST R1,CMDPTR
LA R1,CMDPTR
CALL CMD
MVI PACKET,ASCY Send ack
LA R1,1
BAL R9,WRPACKET
B MAINLOOP
SPACE 1
GOTG CLI PACKET+1,C'L'
BE SLOGOUT
CLI PACKET+1,C'F'
BE SFINISH
MVC PACKET(42),=C'EOnly F and L server generics supported'
LA R1,42
BAL R9,TRETOA
BAL R9,WRPACKET
B MAINLOOP
SPACE 1
SFINISH MVI PACKET,ASCY Send acknowledgement
LA R1,1
BAL R9,WRPACKET
B EXIT
SPACE 1
SLOGOUT MVI PACKET,ASCY Send acknowledgement
LA R1,1
BAL R9,WRPACKET
CMD '$SIGNOFF $'
DC H'0'
TITLE 'Master command loop'
LOCCMD CALL SCARDS,(SCBUF,SCLEN,SCMOD,SCLNUM)
LA R1,SCBUF
LH R2,SCLEN
EX R2,CMDTR
LA R3,0(R1,R2)
MVI 0(R3),X'FF' Delimit the command for easy parsing
BAL R9,SPNBL Span blanks on the front
CLI 0(R1),C'$' Check for MTS command
BNE CMD10
CMD (R1),(R2) Perform MTS command
B MAINLOOP
CMD10 LR R3,R1
BAL R9,BRKBL Break on a blank
LR R4,R1 Length of word
SR R4,R3
S R4,=F'1' (-1 for ex)
BL MAINLOOP Line was all blank
LA R5,CMDTAB Point at command table
CMD20 C R4,4(,R5) Meet minimum length requirement?
BL CMD30 No
EX R4,CMDCLC Match prefix of command?
BNE CMD30 No
L R3,0(,R5) Yes -- branch to handler
BR R3
CMD30 LA R5,CMDELEN(,R5) Next command table entry
CLC 0(4,R5),=F'0' Error if end of table
BNE CMD20
SPRINT ' Invalid command. Valid commands are:'
SPRINT ' bye, connect, display, exit, finish, help, logout,'
SPRINT ' receive, set, send, server, show, stop, and ?'
B MAINLOOP
CMDTR TR 0(*-*,R1),LCUC
CMDCLC CLC 0(*-*,R3),8(R5)
SPACE 1
SPNBL CLI 0(R1),C' ' Skip over blanks to end of line
BNER R9
LA R1,1(,R1)
S R2,=F'1'
BH SPNBL
BR R9
SPACE 1
BRKBL CLI 0(R1),C' ' Stop at a blank or end of line
BER R9
LTR R2,R2
BZR R9
LA R1,1(,R1)
S R2,=F'1'
BH BRKBL
BR R9
SPACE 1
BRKEQ CLI 0(R1),C'=' Stop at an = or end of line
BER R9
LTR R2,R2
BZR R9
LA R1,1(,R1)
S R2,=F'1'
BH BRKEQ
BR R9
SPACE 1
* First word is handler address
* Second word is minimum abbreviation length minus one
* Third part is string; must have at least one trailing blank
* for the parsing code to work correctly
CMDTAB DC A(BYE),F'0',CL16'BYE'
DC A(CONNECT),F'0',CL16'CONNECT'
DC A(SHOW),F'0',CL16'DISPLAY'
DC A(EXIT),F'0',CL16'EXIT'
DC A(FINISH),F'0',CL16'FINISH'
DC A(HELP),F'0',CL16'HELP'
DC A(LOGOUT),F'0',CL16'LOGOUT'
DC A(RECEIVE),F'0',CL16'RECEIVE'
DC A(SET),F'2',CL16'SET'
DC A(SEND),F'2',CL16'SEND'
DC A(ENSERV),F'2',CL16'SERVER'
DC A(SHOW),F'1',CL16'SHOW'
DC A(EXIT),F'1',CL16'STOP'
DC A(HELP),F'0',CL16'?'
DC A(0)
CMDELEN EQU 24
TITLE 'Commands -- server, bye, logout, finish'
ENSERV MVI SERVER,1
B MAINLOOP
SPACE 1
BYE XC RETRYCNT,RETRYCNT
BYEL L R1,RETRYCNT
LA R1,1(,R1)
ST R1,RETRYCNT
C R1,MAXRETRY
BH ABORT
MVC PACKET(2),=C'GL' Send generic logout packet
MVI WPCKTNUM,0
LA R1,2
BAL R9,TRETOA
BAL R9,WRPACKET
BAL R9,RDPACKET Read response
BNZ BYEL
BAL R9,TRATOE
CLI PACKET,C'Y'
BE EXIT Shut down if ack
CLI PACKET,C'N' Loop if nak
BE BYEL
B ABORT Others are errors
SPACE 1
LOGOUT XC RETRYCNT,RETRYCNT
LOGOUTL L R1,RETRYCNT
LA R1,1(,R1)
ST R1,RETRYCNT
C R1,MAXRETRY
BH ABORT
MVC PACKET(2),=C'GL' Send generic logout packet
MVI WPCKTNUM,0
LA R1,2
BAL R9,TRETOA
BAL R9,WRPACKET
BAL R9,RDPACKET Read response
BNZ LOGOUTL
BAL R9,TRATOE
CLI PACKET,C'Y'
BE MAINLOOP Next command if ack
CLI PACKET,C'N'
BE LOGOUTL
B ABORT
SPACE 1
FINISH XC RETRYCNT,RETRYCNT
FINISHL L R1,RETRYCNT
LA R1,1(,R1)
ST R1,RETRYCNT
C R1,MAXRETRY
BH ABORT
MVC PACKET(2),=C'GF' Send generic finish packet
LA R1,2
BAL R9,TRETOA
BAL R9,WRPACKET
BAL R9,RDPACKET Read response
BNZ FINISHL
BAL R9,TRATOE
CLI PACKET,C'Y'
BE MAINLOOP Next command if ack
CLI PACKET,C'N'
BE FINISHL
B ABORT
TITLE 'Commands -- help, connect, show'
HELP SPRINT ' The following commands are supported:'
SPRINT ' $... an MTS command'
SPRINT ' bye log out remote and exit local kermit'
SPRINT ' connect emulate terminal on remote system'
SPRINT ' display display various set parameters'
SPRINT ' exit exit local kermit; remote unaffected'
SPRINT ' finish exit but don''t log out remote kermit'
SPRINT ' help what you''re reading'
SPRINT ' receive receive one or more files'
SPRINT ' send send one or more files'
SPRINT ' server make local kermit into a server'
SPRINT ' set set various parameters'
SPRINT ' show save as display'
SPRINT ' stop same as exit'
SPRINT ' ? same as help'
SPRINT ' For more on parameters, enter set ?'
B MAINLOOP
SPACE 1
CONNECT CLI NETDEV,X'FF' Is there a network device?
BNE CONN10 Yes
SPRINT ' Unit 0 not assigned to network device'
B MAINLOOP
CONN10 SPRINT ' Calling net dsr; use @stop to return to kermit'
LA R1,NETCMD
CALL CMD
B MAINLOOP
SPACE 1
SHOW SPRINT ' The following parameter values are set:'
MVC SCBUF(12),=C' filetype='
CLI FILETYPE,C'T'
BNE SHOW10
MVC SCBUF+12(5),=C'text '
B SHOW20
SHOW10 MVC SCBUF+12(5),=C'saved'
SHOW20 LA R1,17
STH R1,SCLEN
CALL SPRINT,(SCBUF,SCLEN,SCMOD,SCLNUM)
MVC SCBUF(13),=C' endofline='
SR R1,R1
IC R1,EOLCHAR
CVD R1,WORK
UNPK SCBUF+13(2),WORK(8)
OI SCBUF+14,C'0'
LA R1,15
STH R1,SCLEN
CALL SPRINT,(SCBUF,SCLEN,SCMOD,SCLNUM)
MVC SCBUF(9),=C' debug='
CLI DEBUG,0
BNE SHOW30
MVC SCBUF+9(3),=C'off'
B SHOW40
SHOW30 MVC SCBUF+9(3),=C'on '
SHOW40 LA R1,12
STH R1,SCLEN
CALL SPRINT,(SCBUF,SCLEN,SCMOD,SCLNUM)
B MAINLOOP
TITLE 'Commands -- set'
SET BAL R9,SPNBL Extract parameter=value pair
CLI 0(R1),C'?'
BNE SET10
SPRINT ' Set parameters are:'
SPRINT ' filetype set to text for normal, readable files,+
'
SPRINT ' or saved for unformatted byte streams'
SPRINT ' that have originated on another system'
SPRINT ' and contain embedded formatting data;'
SPRINT ' default is text'
SPRINT ' endofline set to decimal value of a control'
SPRINT ' character to be used as end of line'
SPRINT ' (packet) terminator in send operations;+
'
SPRINT ' default is 13 (CR), some systems want'
SPRINT ' 10 (LF); must be 0-31'
SPRINT ' debug on or off; puts all packets in -debug'
B MAINLOOP
SET10 LR R3,R1
BAL R9,BRKEQ
LR R4,R1 Length of parameter
SR R4,R3
S R4,=F'1' (-1 for ex)
BL SETERR No operand
CLI 0(R1),C'=' Must be an =
BNE SETERR
LA R1,1(,R1)
S R2,=F'1'
LA R5,SETTAB Point at parameter table
SET20 C R4,4(,R5) Meet minimum length requirement?
BL SET30 No
EX R4,SETCLC Match prefix of parameter?
BNE SET30 No
L R3,0(,R5) Yes -- branch to handler
BR R3
SET30 LA R5,SETELEN(,R5) Next parameter table entry
CLC 0(4,R5),=F'0' Error if end of table
BNE SET20
SETERR SPRINT ' Invalid set parameter. Valid parameters are:'
SPRINT ' filetype=text, filetype=saved'
SPRINT ' endofline=dd (dd=0-31)'
SPRINT ' debug=on, debug=off'
B MAINLOOP
SETCLC CLC 0(*-*,R3),8(R5)
SPACE 1
* Parameter table. Same format as command table.
SETTAB DC A(SETFT),F'0',CL16'FILETYPE'
DC A(SETEOL),F'0',CL16'ENDOFLINE'
DC A(SETDEB),F'0',CL16'DEBUG'
DC A(0)
SETELEN EQU 24
SPACE 1
SETFT LTR R2,R2 Must be something there
BNH SETERR
CLI 0(R1),C'T' Accept anything that starts with
BE SETFTOK t or s
CLI 0(R1),C'S'
BNE SETERR
SETFTOK MVC FILETYPE(1),0(R1)
BAL R9,BRKBL Might be more parameters to set
BAL R9,SPNBL
LTR R2,R2
BNH MAINLOOP
B SET10
SPACE 1
SETEOL LTR R2,R2 Must be something there
BNH SETERR
SR R3,R3 Convert from decimal to binary
SETEOL10 CLI 0(R1),C'0' the hard way
BL SETERR
CLI 0(R1),C'9'
BH SETERR
MH R3,=H'10'
SR R4,R4
IC R4,0(R1)
S R4,=A(C'0')
AR R3,R4
C R3,=F'31' Maximum allowed is 31
BH SETERR
LA R1,1(,R1)
S R2,=F'1'
BNH SETEOL20
CLI 0(R1),C' '
BNE SETEOL10
SETEOL20 STC R3,EOLCHAR
BAL R9,BRKBL Might be more parameters to set
BAL R9,SPNBL
LTR R2,R2
BNH MAINLOOP
B SET10
SPACE 1
SETDEB LTR R2,R2 Must be something there
BNH SETERR
CLC 0(2,R1),=C'ON' Accept anything that starts with
BE SETDEB10 on or of
CLC 0(2,R1),=C'OF'
BNE SETERR
MVI DEBUG,0
B SETDEB20
SETDEB10 MVI DEBUG,1
SETDEB20 BAL R9,BRKBL Might be more parameters to set
BAL R9,SPNBL
LTR R2,R2
BNH MAINLOOP
B SET10
TITLE 'Commands -- send'
SEND BAL R9,SPNBL
SENDSRV LR R3,R1 Extract filespec
BAL R9,BRKBL
LR R4,R1
BAL R9,SPNBL
LTR R2,R2
BNH SEND20
CLI SERVER,1
BE SEND10
SPRINT ' Send takes a single file spec argument'
B MAINLOOP
SEND10 MVC PACKET(37),=C'EExtra junk at end of rcv-init packet'
MVI WPCKTNUM,0
LA R1,37
BAL R9,TRETOA
BAL R9,WRPACKET
B MAINLOOP
SEND20 LR R1,R3 Point at filespec
LR R2,R4
SR R2,R1
BAL R9,EXPFSPC Expand filespec
CLC NFILES(4),=F'0'
BH SEND40
CLI SERVER,1
BE SEND30
SPRINT ' File not found'
B MAINLOOP
SEND30 MVC PACKET(15),=C'EFile not found'
MVI WPCKTNUM,0
LA R1,15
BAL R9,TRETOA
BAL R9,WRPACKET
B MAINLOOP
SEND40 MVI WPCKTNUM,0 Reset output packet number
XC RETRYCNT,RETRYCNT and retry counter
SEND50 L R1,RETRYCNT
LA R1,1(,R1)
ST R1,RETRYCNT
C R1,MAXRETRY
BH ABORT
MVI PACKET,ASCS Send-init packet
MVI PACKET+1,94+32 My max packet length
MVI PACKET+2,5+32 Time out in 5 seconds
MVI PACKET+3,4+32 4 turnaround pad characters needed
MVI PACKET+4,0+64 Use null for pad character
MVI PACKET+5,13+32 End of line character (CR)
MVI PACKET+6,35 Control character quote (#)
MVI PACKET+7,ASCY I can do 8-bit quoting
MVI PACKET+8,49 1-character checksum (1)
MVI PACKET+9,126 Repeat prefix character (tilde)
LA R1,10
BAL R9,WRPACKET
BAL R9,RDPACKET
BNZ SEND50
CLI PACKET,ASCN
BE SEND50
CLI PACKET,ASCY
BNE ABORT
CLC RPCKTNUM(1),WPCKTNUM
BNE SEND50
MVC MPLEN(4),=F'94' Set defaults
MVC NPAD(4),=F'0'
MVI PADCHAR,0
MVC EOLCHAR2(1),EOLCHAR
MVI CTLQT,35
MVI BINQT,ASCN
MVI RPTCHAR,32
LR R2,R1
S R2,=F'1'
BNH SENDNXTF
SR R1,R1 Copy his parameters
IC R1,PACKET+1
S R1,=F'32'
ST R1,MPLEN Maximum packet length
S R2,=F'2'
BNH SENDNXTF
IC R1,PACKET+3
S R1,=F'32'
ST R1,NPAD Number of pad characters
S R2,=F'1'
BNH SENDNXTF
IC R1,PACKET+4
X R1,=F'64'
STC R1,PADCHAR Pad character
S R2,=F'1'
BNH SENDNXTF
IC R1,PACKET+5
S R1,=F'32'
STC R1,EOLCHAR2 End of line character
S R2,=F'1'
BNH SENDNXTF
MVC CTLQT(1),PACKET+6 Control character quote
S R2,=F'1'
BNH SENDNXTF
MVC BINQT(1),PACKET+7 Binary (8-bit) quote character
S R2,=F'2'
BNH SENDNXTF
MVC RPTCHAR(1),PACKET+9 Compression prefix character
SENDNXTF L R1,NFILES Open next file
S R1,=F'1'
ST R1,NFILES
BL SBREAK Sent all of them
SLL R1,6 Point at FDname (64 characters)
A R1,=A(FILES)
MVC FILENAME(64),0(R1) Copy name for file header
LA R1,FILENAME
CALL GETFD
LTR R15,R15
BZ SEND80
SEND60 CLI NETDEV,X'FF'
BE SEND70
SPRINT ' Unable to open file'
B SBREAK
SEND70 MVC PACKET(20),=C'EUnable to open file'
MVI WPCKTNUM,0
LA R1,20
BAL R9,TRETOA
BAL R9,WRPACKET
B MAINLOOP
SEND80 ST R0,FDUB
CALL GDINFO Open the file
LTR R15,R15
BNZ SEND60
MVC WORK(1),13(R1)
SR R0,R0 Free gdinfo block
CALL FREESPAC
CLI WORK,X'FF' Check for type=none
BE SEND60
XC BUFFCNT,BUFFCNT File buffer is empty
MVI EOFFLAG,0 Not at end of file
XC RETRYCNT,RETRYCNT
IC R1,WPCKTNUM
LA R1,1(,R1)
STC R1,WPCKTNUM
NI WPCKTNUM,63
CLI NETDEV,X'FF'
BE SENDFHDR
MVC SCBUF(9),=C' Sending '
MVC SCBUF+9(64),FILENAME
LA R2,73
SPRINT SCBUF,(R2)
SENDFHDR L R1,RETRYCNT
LA R1,1(,R1)
ST R1,RETRYCNT
C R1,MAXRETRY
BH ABORT
MVI PACKET,C'F' Send file header packet
MVC PACKET+1(64),FILENAME
LA R1,PACKET+64 Trim trailing blanks off name
SEND90 CLI 0(R1),C' '
BNE SEND100
S R1,=F'1'
B SEND90
SEND100 S R1,=A(PACKET)
LA R1,1(,R1)
BAL R9,TRETOA
BAL R9,WRPACKET
BAL R9,RDPACKET
BNZ SENDFHDR
CLI PACKET,ASCN
BNE SEND110
IC R2,RPCKTNUM Nak for next packet is same as
A R2,=F'63' ack for this packet
STC R2,WORK
NI WORK,63
CLC WORK(1),WPCKTNUM
BNE SENDFHDR
B SEND120
SEND110 CLI PACKET,ASCY
BNE ABORT
CLC WPCKTNUM(1),RPCKTNUM
BNE SENDFHDR
SEND120 XC RETRYCNT,RETRYCNT
IC R1,WPCKTNUM
LA R1,1(,R1)
STC R1,WPCKTNUM
NI WPCKTNUM,63
XC PCKTLEN,PCKTLEN
SEND130 L R1,BUFFCNT Get next character from file
LTR R1,R1
BNZ SEND160
CLI EOFFLAG,0 End of line; also end of file?
BE SEND140
CLC PCKTLEN(4),=F'0' End of file; anything in packet?
BE SENDEOF
B SENDDATA
SEND140 CALL READ,(BUFFER,BUFLEN,BUFMOD,BUFLNUM,FDUB)
LTR R15,R15
BZ SEND150
MVI EOFFLAG,1
B SEND130
SEND150 LH R1,BUFLEN
ST R1,BUFFCNT
SEND160 LH R0,BUFLEN Point at next char in buffer
SR R0,R1
A R0,=A(BUFFER)
LR R4,R0
CLI RPTCHAR,32 Is compression allowed?
BE SEND180 No
IC R3,0(,R4) Tricky clcl to see how many of
SLL R3,24 this character there are
CLCL R0,R2
SR R0,R4 There are this many
C R0,=F'4'
BL SEND180 Not worth the bother
C R0,=F'94' Can't have too many either
BNH SEND170
LA R0,94
SEND170 L R1,BUFFCNT Consume this many characters
SR R1,R0
ST R1,BUFFCNT
L R1,PCKTLEN Put out prefix and count
LA R2,PACKET+1(R1)
MVC 0(1,R2),RPTCHAR
A R0,=F'32'
STC R0,1(,R2)
LA R1,2(,R1)
ST R1,PCKTLEN
B SEND190
SEND180 L R1,BUFFCNT Consume one character
S R1,=F'1'
ST R1,BUFFCNT
SEND190 MVC WORK(1),0(R4) Translate char if filetype=text
CLI FILETYPE,C'T'
BNE SEND200
TR WORK(1),ETOA
B SEND210 No parity quoting needed
SEND200 TM WORK,X'80'
BZ SEND210
CLI BINQT,ASCN Is binary quoting allowed?
BE SEND210 No -- send it the way it is
L R1,PCKTLEN Put out 8-bit prefix
LA R2,PACKET+1(R1)
MVC 0(1,R2),BINQT
LA R1,1(,R1)
ST R1,PCKTLEN
NI WORK,X'7F'
SEND210 CLI WORK,127 See if control quoting needed
BE SEND220
CLI WORK,31
BNH SEND220
CLC WORK(1),CTLQT
BE SEND230
CLI BINQT,ASCN
BE SEND215
CLC WORK(1),BINQT
BE SEND230
SEND215 CLI RPTCHAR,32
BE SEND240
CLC WORK(1),RPTCHAR
BNE SEND240
B SEND230
SEND220 XI WORK,64 Not a control char anymore
SEND230 L R1,PCKTLEN Put out control prefix
LA R2,PACKET+1(R1)
MVC 0(1,R2),CTLQT
LA R1,1(,R1)
ST R1,PCKTLEN
SEND240 L R1,PCKTLEN Finally, put in the character
LA R2,PACKET+1(R1)
MVC 0(1,R2),WORK
LA R1,1(,R1)
ST R1,PCKTLEN
CLC BUFFCNT(4),=F'0' One last thing -- put crlf at eol
BNE SEND250
CLI FILETYPE,C'T' if filetype=text
BNE SEND250
L R1,PCKTLEN
LA R2,PACKET+1(R1)
MVC 0(1,R2),CTLQT
MVI 1(R2),77
MVC 2(1,R2),CTLQT
MVI 3(R2),74
LA R1,4(,R1)
ST R1,PCKTLEN
SEND250 L R1,PCKTLEN Have we about filled a packet?
A R1,=F'10'
C R1,MPLEN
BL SEND130 No, loop
SENDDATA L R1,RETRYCNT
LA R1,1(,R1)
ST R1,RETRYCNT
C R1,MAXRETRY
BH ABORT
MVI PACKET,ASCD Send data packet
L R1,PCKTLEN
A R1,=F'1'
BAL R9,WRPACKET
BAL R9,RDPACKET
BNZ SENDDATA
CLI PACKET,ASCN
BNE SEND260
IC R2,RPCKTNUM Nak for next packet is same as
A R2,=F'63' ack for this packet
STC R2,WORK
NI WORK,63
CLC WORK(1),WPCKTNUM
BNE SENDDATA
B SEND120
SEND260 CLI PACKET,ASCY
BNE ABORT
CLC WPCKTNUM(1),RPCKTNUM
BNE SENDDATA
XC PCKTLEN,PCKTLEN Packet now empty
B SEND120 Loop through whole file
SENDEOF XC RETRYCNT,RETRYCNT
SENDEOFL L R1,RETRYCNT
LA R1,1(,R1)
ST R1,RETRYCNT
C R1,MAXRETRY
BH ABORT
MVI PACKET,ASCZ Send end of file packet
LA R1,1
BAL R9,WRPACKET
BAL R9,RDPACKET
BNZ SENDEOFL
CLI PACKET,ASCN
BNE SEND270
IC R2,RPCKTNUM Nak for next packet is same as
A R2,=F'63' ack for this packet
STC R2,WORK
NI WORK,63
CLC WORK(1),WPCKTNUM
BNE SENDEOFL
B SEND280
SEND270 CLI PACKET,ASCY
BNE ABORT
CLC WPCKTNUM(1),RPCKTNUM
BNE SENDEOFL
SEND280 L R0,FDUB Close the file
CALL FREEFD
B SENDNXTF Send next file, if any
SBREAK XC RETRYCNT,RETRYCNT
IC R1,WPCKTNUM
LA R1,1(,R1)
STC R1,WPCKTNUM
NI WPCKTNUM,63
SBREAKL L R1,RETRYCNT
LA R1,1(,R1)
ST R1,RETRYCNT
C R1,MAXRETRY
BH ABORT
MVI PACKET,ASCB Send break (EOT) packet
LA R1,1
BAL R9,WRPACKET
BAL R9,RDPACKET
BNZ SBREAKL
CLI PACKET,ASCN
BNE SEND290
IC R2,RPCKTNUM Nak for next packet is same as
A R2,=F'63' ack for this packet
STC R2,WORK
NI WORK,63
CLC WORK(1),WPCKTNUM
BNE SBREAKL
B MAINLOOP
SEND290 CLI PACKET,ASCY
BNE ABORT
CLC WPCKTNUM(1),RPCKTNUM
BNE SBREAKL
B MAINLOOP
TITLE 'Commands -- receive'
RECEIVE BAL R9,SPNBL Extract file spec, if any
LR R3,R1
BAL R9,BRKBL
CR R1,R3
BE REC10 No file spec
LR R4,R1
SR R4,R3
S R4,=F'1' Copy file spec into packet
EX R4,RECFSMVC
MVI PACKET,C'R'
MVI WPCKTNUM,0
LA R1,2(,R4)
BAL R9,TRETOA
BAL R9,WRPACKET Send rcv-init packet
REC10 XC RETRYCNT,RETRYCNT
REC20 L R1,RETRYCNT
LA R1,1(,R1)
ST R1,RETRYCNT
C R1,MAXRETRY
BH ABORT
BAL R9,RDPACKET Wait for send-init packet
BNE REC20
CLI PACKET,ASCN
BE REC20
CLI PACKET,ASCS
BNE ABORT
XC RETRYCNT,RETRYCNT
B REC30
RECFSMVC MVC PACKET+1(*-*),0(R3)
GOTS BAL R9,TRETOA
XC RETRYCNT,RETRYCNT
REC30 L R1,RETRYCNT
LA R1,1(,R1)
ST R1,RETRYCNT
C R1,MAXRETRY
BH ABORT
MVC MPLEN(4),=F'94' Set defaults
MVC NPAD(4),=F'0'
MVI PADCHAR,0
MVC EOLCHAR2(1),EOLCHAR
MVI CTLQT,35
MVI BINQT,ASCN
MVI RPTCHAR,32
LR R2,R1
S R2,=F'1'
BNH REC50
SR R1,R1 Copy his parameters
IC R1,PACKET+1
S R1,=F'32'
ST R1,MPLEN Maximum packet length
S R2,=F'2'
BNH REC50
IC R1,PACKET+3
S R1,=F'32'
ST R1,NPAD Number of pad characters
S R2,=F'1'
BNH REC50
IC R1,PACKET+4
X R1,=F'64'
STC R1,PADCHAR Pad character
S R2,=F'1'
BNH REC50
IC R1,PACKET+5
S R1,=F'32'
STC R1,EOLCHAR2 End of line character
S R2,=F'1'
BNH REC50
MVC CTLQT(1),PACKET+6 Control character quote
S R2,=F'1'
BNH REC50
MVC BINQT(1),PACKET+7 Binary (8-bit) quote character
CLI BINQT,ASCY
BNE REC40
MVI BINQT,38 Use & if he said Y
REC40 S R2,=F'2'
BNH REC50
MVC RPTCHAR(1),PACKET+9 Compression prefix character
REC50 MVI PACKET,ASCY Send back ack with parameters
L R1,MPLEN
A R1,=F'32'
STC R1,PACKET+1 Use his max packet length
MVI PACKET+2,5+32 Time out in 5 seconds
MVI PACKET+3,4+32 4 turnaround pad characters needed
MVI PACKET+4,0+64 Use null for pad character
MVI PACKET+5,13+32 End of line character I want (CR)
MVC PACKET+6(1),CTLQT Control character quote
MVC PACKET+7(1),BINQT 8-bit quote
MVI PACKET+8,49 1-character checksum (1)
MVC PACKET+9(1),RPTCHAR Repeat prefix character
MVI WPCKTNUM,0
LA R1,10
BAL R9,WRPACKET
BAL R9,RDPACKET Read for first F packet
BNZ REC30
CLI PACKET,ASCN
BE REC30
CLI PACKET,ASCS
BE REC30
CLI PACKET,ASCF
BNE ABORT
REC60 MVC FILENAME(64),=CL64' ' Extract file name from packet
BAL R9,TRATOE
S R1,=F'2'
BH REC70
MVC PACKET(18),=C'EMissing file name'
MVI WPCKTNUM,0
LA R1,18
BAL R9,WRPACKET
B ABORT
RECFMVC MVC FILENAME(*-*),PACKET+1
REC70 EX R1,RECFMVC
REC80 LA R1,FILENAME
CALL GETFD Attempt to open the file
LTR R15,R15
BZ REC110
REC90 CLI NETDEV,X'FF'
BE REC100
SPRINT ' Unable to open file'
B ABORT
REC100 MVC PACKET(20),=C'EUnable to open file'
MVI WPCKTNUM,0
LA R1,20
BAL R9,TRETOA
BAL R9,WRPACKET
B MAINLOOP
REC110 ST R0,FDUB
CALL GDINFO Open the file
LTR R15,R15
BNZ REC90
MVC WORK(1),13(R1)
SR R0,R0 Free gdinfo block
CALL FREESPAC
CLI WORK,X'FF' Check for type=none
BNE REC120
CALL CREATE,(FILENAME,CRESIZE,CREVOL,CRETYPE) Try to create
LTR R15,R15 the file
BNZ REC90 Too bad
B REC80 Try the open again
REC120 L R0,FDUB Empty the file
CALL EMPTY
XC BUFLEN,BUFLEN
MVI CRFLAG,0
IC R1,WPCKTNUM
LA R1,1(,R1)
STC R1,WPCKTNUM
NI WPCKTNUM,63
XC RETRYCNT,RETRYCNT
CLI NETDEV,X'FF'
BE REC130
MVC SCBUF(11),=C' Receiving '
MVC SCBUF+11(64),FILENAME
LA R2,75
SPRINT SCBUF,(R2)
REC130 L R1,RETRYCNT
LA R1,1(,R1)
ST R1,RETRYCNT
C R1,MAXRETRY
BH ABORT
MVI PACKET,ASCY
LA R1,1
BAL R9,WRPACKET Ack the F packet
BAL R9,RDPACKET
BNZ REC130
CLI PACKET,ASCN
BE REC130
CLC WPCKTNUM(1),RPCKTNUM Ack again if F again
BE REC130
RECDATA CLI PACKET,ASCD Expecting D or Z packet
BE REC140
CLI PACKET,ASCZ
BE RECEOF
B ABORT Sequence error
REC140 LR R2,R1 Length of packet
S R2,=F'1' Account for D at front
LA R3,PACKET+1
REC150 LTR R2,R2 Anything left in packet?
BNH REC290 No
MVC WORK(1),0(R3) Copy char with/out parity
MVC WORK+1(1),0(R3)
NI WORK+1,X'7F'
LA R4,1 Default repeat count
CLI RPTCHAR,32 Compression allowed?
BE REC160 No
CLC WORK+1(1),RPTCHAR Repetition prefix?
BNE REC160 No
IC R4,1(,R3) Get repeat count
N R4,=F'127'
S R4,=F'32'
S R2,=F'2'
BNH ABORT
LA R3,2(,R3)
MVC WORK(1),0(R3)
MVC WORK+1(1),0(R3)
NI WORK+1,X'7F'
REC160 SR R5,R5 Default high-order bit value
CLI BINQT,ASCN 8-bit quoting enabled?
BE REC170 No
CLC WORK+1(1),BINQT
BNE REC170
LA R5,128 Turn on high bit later
S R2,=F'1'
BNH ABORT
LA R3,1(,R3)
MVC WORK(1),0(R3)
MVC WORK+1(1),0(R3)
NI WORK+1,X'7F'
REC170 CLC WORK+1(1),CTLQT Is it a control quote?
BNE REC210 No
MVC WORK(1),1(R3)
MVC WORK+1(1),1(R3)
NI WORK+1,X'7F'
CLC WORK+1(1),CTLQT May be quoting a literal
BE REC200
CLI RPTCHAR,32
BE REC180
CLC WORK+1(1),RPTCHAR
BE REC200
REC180 CLI BINQT,ASCN
BE REC190
CLC WORK+1(1),BINQT
BE REC200
* Will not get here if control quote is followed by
* quote with high order bit on (eg X'23A3').
REC190 XI WORK,64 Make it into a control char
REC200 S R2,=F'1'
BNH ABORT
LA R3,1(,R3)
REC210 SR R6,R6
IC R6,WORK Diddle with high bit
CLI BINQT,ASCN Straight through if no bin quote
BE REC215
N R6,=F'127' Otherwise 0 if no quote seen
OR R6,R5 or 1 if quote seen
REC215 CLI FILETYPE,C'T' Translate to ebcdic if filetype=text
BNE REC220
IC R6,ATOE(R6)
REC220 STC R6,WORK WORK has char, R4 has count
LA R3,1(,R3) Account for the character
S R2,=F'1'
BL ABORT
CLI FILETYPE,C'T' Look for CRLF in text files
BNE REC260
CLI WORK,13 Is this a CR?
BNE REC230 No
C R4,=F'1' Better not be repeated
BNE ABORT
MVI CRFLAG,1 Set flag to say we've seen CR
B REC150
REC230 CLI WORK,X'25' Is this a LF?
BNE REC250
C R4,=F'1' Better not be repeated
BNE ABORT
CLI CRFLAG,1 Was last char a CR?
BNE ABORT Don't like LF's without CR's
LH R1,BUFLEN
LTR R1,R1 Replace zero-length lines with blank
BH REC240
LA R1,1
STH R1,BUFLEN
L R1,=A(BUFFER)
MVI 0(R1),C' '
REC240 CALL WRITE,(BUFFER,BUFLEN,BUFMOD,BUFLNUM,FDUB)
LTR R15,R15
BNE WRTFERR Error writing to file
XC BUFLEN,BUFLEN
MVI CRFLAG,0
B REC150
REC250 CLI CRFLAG,0 Don't like CR's without LF's
BNE ABORT
REC260 LH R5,BUFLEN Point into buffer
LR R6,R5
A R6,=A(BUFFER)
REC270 MVC 0(1,R6),WORK Copy character to buffer
LA R6,1(,R6)
LA R5,1(,R5)
C R5,=F'32767' Don't overflow buffer
BL REC280
STH R5,BUFLEN
CALL WRITE,(BUFFER,BUFLEN,BUFMOD,BUFLNUM,FDUB)
LTR R15,R15
BNE WRTFERR Error writing to file
SR R5,R5
L R6,=A(BUFFER)
REC280 BCT R4,REC270 Repeat as necessary
STH R5,BUFLEN New buffer length
B REC150 Next character from packet
REC290 IC R1,WPCKTNUM Bump write packet number
LA R1,1(,R1)
STC R1,WPCKTNUM
NI WPCKTNUM,63
XC RETRYCNT,RETRYCNT
REC300 L R1,RETRYCNT
LA R1,1(,R1)
ST R1,RETRYCNT
C R1,MAXRETRY
BH ABORT
MVI PACKET,ASCY
LA R1,1
BAL R9,WRPACKET Ack the D packet
BAL R9,RDPACKET
BNZ REC300
CLI PACKET,ASCN
BE REC300
CLC WPCKTNUM(1),RPCKTNUM Ack again if last packet again
BE REC300
B RECDATA Loop until Z packet
RECEOF CLC BUFLEN(2),=H'0' Write out contents of buffer, if any
BE REC310
CALL WRITE,(BUFFER,BUFLEN,BUFMOD,BUFLNUM,FDUB)
LTR R15,R15
BNZ WRTFERR
REC310 L R0,FDUB Close the file
CALL FREEFD
IC R1,WPCKTNUM Bump write packet number
LA R1,1(,R1)
STC R1,WPCKTNUM
NI WPCKTNUM,63
XC RETRYCNT,RETRYCNT
REC320 L R1,RETRYCNT
LA R1,1(,R1)
ST R1,RETRYCNT
C R1,MAXRETRY
BH ABORT
MVI PACKET,ASCY
LA R1,1
BAL R9,WRPACKET Ack the Z packet
BAL R9,RDPACKET
BNZ REC320
CLI PACKET,ASCN
BE REC320
CLC WPCKTNUM(1),RPCKTNUM Ack again if last packete again
BE REC320
CLI PACKET,ASCF Expecting F or B packet
BE REC60 Process next file
CLI PACKET,ASCB
BNE ABORT
IC R1,WPCKTNUM Bump write packet number
LA R1,1(,R1)
STC R1,WPCKTNUM
NI WPCKTNUM,63
MVI PACKET,ASCY
LA R1,1
BAL R9,WRPACKET Ack the B packet
B MAINLOOP All done the receive
TITLE 'WRPACKET -- write out a packet'
WRPACKET LA R2,PACKET2 Build output packet here
L R3,NPAD Put pads in first
LTR R3,R3
BZ WRP20
WRP10 MVC 0(1,R2),PADCHAR
LA R2,1(,R2)
BCT R3,WRP10
WRP20 MVI 0(R2),1 SOH character
SR R4,R4 Checksum
LA R3,34(,R1) Length byte (R1+2+32)
STC R3,1(,R2)
AR R4,R3
IC R3,WPCKTNUM Sequence id
LA R3,32(,R3)
STC R3,2(,R2)
AR R4,R3
LA R2,3(,R2)
LA R5,PACKET Copy the packet proper
WRP30 MVC 0(1,R2),0(R5)
IC R3,0(,R5)
AR R4,R3
LA R2,1(,R2)
LA R5,1(,R5)
BCT R1,WRP30
N R4,=F'255' Crunch checksum to 6 bits
LR R3,R4
SRL R3,6
AR R4,R3
N R4,=F'63'
A R4,=F'32'
STC R4,0(,R2)
MVC 1(1,R2),EOLCHAR2 Line terminator
LA R2,2(,R2)
LA R1,PACKET2 Length of finished packet
SR R2,R1
CLI SERVER,1 Select unit based on server flag
BE WRP40 Server always uses sprint,
CLI NETDEV,X'FF' non-server uses 0 if assigned,
BE WRP40 and sprint otherwise
MVC RWPKUNIT(4),=F'0'
B WRP50
WRP40 MVC RWPKUNIT(8),=C'SPRINT '
WRP50 STH R2,RWPKLEN
CALL WRITE,(PACKET2,RWPKLEN,RWPKMOD,RWPKLNUM,RWPKUNIT)
CLI DEBUG,0
BER R9
LA R2,1(,R2)
STH R2,DEBLEN
CALL WRITE,(DEBPK2,DEBLEN,DEBMOD,DEBLNUM,DEBUNIT)
BR R9
TITLE 'RDPACKET -- read a packet'
RDPACKET CLI SERVER,1 Select unit based on server flag
BE RDP10 Server always uses scards,
CLI NETDEV,X'FF' non-server uses 0 if assigned,
BE RDP10 and scards otherwise
MVC RWPKUNIT(4),=F'0'
B RDP20
RDP10 MVC RWPKUNIT(8),=C'SCARDS '
RDP20 CALL READ,(PACKET3,RWPKLEN,RWPKMOD,RWPKLNUM,RWPKUNIT)
LH R1,RWPKLEN
*
*#### Merit READ@BIN returns data in EBCDIC so restore to ASCII
*
L R4,=V(EBCMASC)
STEP#1 EX R1,TREBMASC
*
CLI DEBUG,0
BE RDP30
LA R2,1(,R1)
STH R2,DEBLEN
CALL WRITE,(DEBPK3,DEBLEN,DEBMOD,DEBLNUM,DEBUNIT)
LH R1,RWPKLEN
RDP30 LTR R1,R1
BNH RDPFAIL
C R1,=F'120' Generous overlength check
BH PTOOLONG
MVI WORK+1,X'7F' Mask to turn off parity, as nec
CLI FILETYPE,C'T'
BE RDP40
CLI BINQT,ASCN
BNE RDP40
MVI WORK+1,X'FF'
RDP40 LA R2,PACKET3
RDP50 MVC WORK(1),0(R2)
NC WORK(1),WORK+1
CLI WORK,1 Look for soh
BE RDP60
LA R2,1(,R2)
BCT R1,RDP50
B RDPFAIL
RDP60 LA R2,1(,R2)
S R1,=F'1'
BNH RDPFAIL
MVC WORK(1),0(R2)
NC WORK(1),WORK+1
SR R3,R3 Length byte
IC R3,WORK
LR R4,R3 This will be checksum
S R3,=F'34'
BNH RDPFAIL
ST R3,PCKTLEN Save packet length
LA R2,1(,R2)
S R1,=F'1'
BNH RDPFAIL
MVC WORK(1),0(R2)
NC WORK(1),WORK+1
SR R5,R5 Packet sequence number
IC R5,WORK
AR R4,R5
S R5,=F'32'
STC R5,RPCKTNUM
LA R2,1(,R2)
S R1,=F'1'
BNH RDPFAIL
LA R6,PACKET
RDP70 MVC WORK(1),0(R2) Copy the packet proper
NC WORK(1),WORK+1
IC R5,WORK
AR R4,R5
STC R5,0(,R6)
LA R6,1(,R6)
LA R2,1(,R2)
S R1,=F'1'
BNH RDPFAIL
BCT R3,RDP70
MVC WORK(1),0(R2) Check the checksum
NC WORK(1),WORK+1
IC R5,WORK
S R5,=F'32'
N R4,=F'255'
LR R6,R4
SRL R6,6
AR R4,R6
N R4,=F'63'
CR R4,R5
BNE RDPFAIL
L R1,PCKTLEN Return with CC Z and len in R1
CLI PACKET,ASCE Is it an error packet?
BE ERRPCKT Boom
SR R0,R0
BR R9
RDPFAIL SR R1,R1 Return with CC NZ
LTR R11,R11
BR R9
TITLE 'Translation from/to ascii/ebcdic'
TRETOA S R1,=F'1'
BL TRETOA10
EX R1,TRETOATR
TRETOA10 A R1,=F'1'
BR R9
TRETOATR TR PACKET(*-*),ETOA
SPACE 1
TRATOE S R1,=F'1'
BL TRATOE10
EX R1,TRATOETR
TRATOE10 A R1,=F'1'
BR R9
TRATOETR TR PACKET(*-*),ATOE
SPACE 1
TREBMASC TR PACKET3(*-*),0(R4)
TITLE 'Routine to expand a file spec'
EXPFSPC XC NFILES,NFILES Init number of files found
MVC FILESPEC(64),=CL64' ' Copy the file spec
S R2,=F'1'
BLR R9
C R2,=F'59'
BH EXPFERR
EX R2,EXPFMVC
A R2,=F'1'
TR FILESPEC(64),LCUC
CALL GUINFO,(TWO,MYUID) Determine current signon userid
CLI FILESPEC,C'*'
BNE EXPF10
MVC USERID(4),=C'*SYS'
B EXPF60
EXPFMVC MVC FILESPEC(*-*),0(R1)
EXPF10 CLI FILESPEC,C'-'
BNE EXPF20
MVC USERID(4),=C'*TMP'
B EXPF60
EXPF20 LA R1,FILESPEC Copy userid if any
LA R2,4
MVC USERID(4),=C'$.$.' Userid pad characters
EXPF30 CLI 0(R1),C':'
BE EXPF40
MVC 0(1,R3),0(R1)
LA R1,1(,R1)
LA R3,1(,R3)
BCT R2,EXPF30
CLI 0(R1),C':' If no colon here, no userid given
BNE EXPF50
EXPF40 MVC FILESPEC(60),1(R1) Crunch out userid
B EXPF60
EXPF50 MVC USERID(4),MYUID Default is current signonid
EXPF60 XC GFINFR(24),GFINFR
EXPF70 CALL GFINFO,(USERID,GFINFR,THREE,GFINFZ,GFINFZ,GFINFZ),VL
LTR R15,R15
BNZR R9 No more files
MVC FILENAME(64),=CL64' '
CLC USERID(4),MYUID Gfinfo includes userid only if it's
BE EXPF80 not for this task (sweet, eh)
CLC USERID(4),=C'*SYS'
BE EXPF80
CLC USERID(4),=C'*TMP'
BE EXPF80
MVC FILENAME(4),GFINFR
MVI FILENAME+4,C':'
MVC FILENAME+5(16),GFINFR+4
LA R1,FILENAME+5
B EXPF90
EXPF80 MVC FILENAME(20),GFINFR
LA R1,FILENAME
* Allow single ? in file spec -- matches any substring
EXPF90 LA R2,FILESPEC
SR R3,R3 No ? yet
SR R4,R4
EXPF100 CLI 0(R1),C' ' End of filename?
BNE EXPF110 No
CLI 0(R2),C' ' End of file spec?
BNE EXPF70 No -- doesn't match
L R1,NFILES Found a matching file name
LR R2,R1
SLL R2,6
A R2,=A(FILES)
MVC 0(64,R2),FILENAME
LA R1,1(,R1)
C R1,=F'64' Check for too many
BH EXPFERR
ST R1,NFILES
B EXPF70 Look for more
EXPF110 CLC 0(1,R1),0(R2) Characters match?
BNE EXPF120 No
LA R1,1(,R1) Yes -- move along
LA R2,1(,R2)
B EXPF100 Loop
EXPF120 CLI 0(R2),C'?' ? in file spec?
BNE EXPF130
LTR R3,R3 Seen one before?
BNZ EXPFERR Yes -- error
LA R2,1(,R2) Point past ?
LR R3,R2 and save this address
LA R4,1(,R1) This is where to continue after fail
B EXPF100 Continue matching
EXPF130 LTR R3,R3 Mismatch -- have we seen a ?
BZ EXPF70 No -- names can't match
LR R2,R3 Lengthen string matched by ?
LR R1,R4
LA R4,1(,R1)
B EXPF100 and try again
SPACE 1
EXPFERR CLI NETDEV,X'FF'
BE EXPF140
SPRINT ' Error expanding file spec'
MVI PACKET,ASCB Send break packet
MVI WPCKTNUM,0
LA R1,1
BAL R9,WRPACKET
B MAINLOOP
EXPF140 MVC PACKET(26),=C'EError expanding file spec'
MVI WPCKTNUM,0
LA R1,26
BAL R9,TRETOA
BAL R9,WRPACKET
B MAINLOOP
TITLE 'Constants and variable storage'
SAVEAREA DS 18F
TWO DC F'2'
THREE DC F'3'
PFXPAR DC A(PFXITEM,PFXDATA)
PFXITEM DC CL8'PFXSTR '
PFXDATA DC F'19',F'11',CL11'Kermit-MTS>'
WORK DS D
NETCMD DC A(*+12),A(*+4),F'37',C'$NET '
NETDEV DS CL32
SERVER DS X
FILETYPE DS X
DEBUG DS X
RETRYCNT DS F
MAXRETRY DC F'10'
CMDPTR DS A
DC A(CMDLEN) MUST FOLLOW CMDPTR
CMDLEN DS F
SCBUF DS CL256
SCLEN DC H'0',H'255',H'0'
SCMOD DC A(X'08000000') Maxlen
SCLNUM DS F
NFILES DS F
FILENAME DS CL64
FILESPEC DS CL64
USERID DS CL4
MYUID DS CL4
DS 0F
CRESIZE DC H'0',H'1'
CREVOL DC XL6'00'
CRETYPE DC F'256'
RPCKTNUM DS X
WPCKTNUM DS X
PCKTLEN DS F
PACKET DS CL150
DEBPK2 DC X'E2' MUST PRECEED PACKET2
PACKET2 DS CL150
DEBPK3 DC X'D9' MUST PRECEED PACKET3
PACKET3 DS CL150
RWPKLEN DC H'0',H'150',H'0'
RWPKMOD DC A(X'08000008') Maxlen, binary
RWPKLNUM DS F
RWPKUNIT DS CL8
DEBLEN DS H
DEBMOD DC F'0'
DEBLNUM DC F'0'
DEBUNIT DS A
MPLEN DS F
NPAD DS F
PADCHAR DS X
EOLCHAR DS X What user wants me to send
EOLCHAR2 DS X What other kermit wants me to send
CTLQT DS X
BINQT DS X
RPTCHAR DS X
FDUB DS A
EOFFLAG DS X
CRFLAG DS X
BUFFCNT DS F
BUFLEN DS H
BUFMOD DC A(X'40000000')
BUFLNUM DS F
GFINFZ DC F'0'
GFINFR DS 6F
LTORG
SPACE 1
LCUC DC X'000102030405060708090A0B0C0D0E0F'
DC X'101112131415161718191A1B1C1D1E1F'
DC X'202122232425262728292A2B2C2D2E2F'
DC X'303132333435363738393A3B3C3D3E3F'
DC X'404142434445464748494A4B4C4D4E4F'
DC X'505152535455565758595A5B5C5D5E5F'
DC X'606162636465666768696A6B6C6D6E6F'
DC X'707172737475767778797A7B7C7D7E7F'
DC X'80C1C2C3C4C5C6C7C8C98A8B8C8D8E8F'
DC X'90D1D2D3D4D5D6D7D8D99A9B9C9D9E9F'
DC X'A0A1E2E3E4E5E6E7E8E9AAABACADAEAF'
DC X'B0B1B2B3B4B5B6B7B8B9BABBBCBDBEBF'
DC X'C0C1C2C3C4C5C6C7C8C9CACBCCCDCECF'
DC X'D0D1D2D3D4D5D6D7D8D9DADBDCDDDEDF'
DC X'E0E1E2E3E4E5E6E7E8E9EAEBECEDEEEF'
DC X'F0F1F2F3F4F5F6F7F8F9FAFBFCFDFEFF'
SPACE 1
ATOE DC X'00010203372D2E2F1605250B0C0D0E0F' Use AD/BD for sq br
DC X'101112133C3D322618193F271C1D1E1F' Use 8B/9B for braces
DC X'405A7F7B5B6C507D4D5D5C4E6B604B61' Use 4F for stick
DC X'F0F1F2F3F4F5F6F7F8F97A5E4C7E6E6F' Use E0 for backslash
DC X'7CC1C2C3C4C5C6C7C8C9D1D2D3D4D5D6' Use 5F for tilde
DC X'D7D8D9E2E3E4E5E6E7E8E9ADE0BD716D' Use 71 for circumflx
DC X'79818283848586878889919293949596' Use 79 for grave
DC X'979899A2A3A4A5A6A7A8A98B4F9B5F07' NOTE: This mapping
DC X'00000000000000000000000000000000' is not the
DC X'00000000000000000000000000000000' same as in the
DC X'00000000000000000000000000000000' kermit manual.
DC X'00000000000000000000000000000000'
DC X'00000000000000000000000000000000'
DC X'00000000000000000000000000000000'
DC X'00000000000000000000000000000000'
DC X'00000000000000000000000000000000'
SPACE 1
ETOA DC X'000102030009007F0000000B0C0D0E0F' Use AD/BD for sq br
DC X'1011121300000800181900001C1D1E1F' Use 8B/9B for braces
DC X'00000000000A171B0000000000050607' Use 4F for stick
DC X'0000160000000004000000001415001A' Use E0 for backslash
DC X'20000000000000000000002E3C282B7C' Use 5F for tilde
DC X'2600000000000000000021242A293B7E' Use 71 for circumflx
DC X'2D2F00000000000000007C2C255F3E3F' Use 79 for grave
DC X'005E00000000000000603A2340273D22' Also use:
DC X'00616263646566676869007B00000000' C0/D0 for braces
DC X'006A6B6C6D6E6F707172007D00000000' A1 for tilde
DC X'007E737475767778797A0000005B0000' NOTE: This mapping
DC X'000000000000000000000000005D0000' is not the
DC X'7B414243444546474849000000000000' same as in the
DC X'7D4A4B4C4D4E4F505152000000000000' kermit manual.
DC X'5C00535455565758595A000000000000'
DC X'303132333435363738397C0000000000'
SPACE 1
FILES DS 64CL64
BUFFER DS 32768X
SPACE 1
ASCB EQU 66
ASCD EQU 68
ASCE EQU 69
ASCF EQU 70
ASCN EQU 78
ASCS EQU 83
ASCY EQU 89
ASCZ EQU 90
END KERMIT