!*
!*
!********************************************************************
!* *
!* *
!* F T R A N S E X E C U T I V E *
!* * * * * * * * * * * * * * * * *
!* *
!* *
!********************************************************************
!*
! C O N S T A N T S
! - - - - - - - - -
!*
conststring (15) version = "12 : 20/03/85"
conststring (1) snl = "
"; !A STRING NEWLINE
constinteger amdahl = 369, xa = 371
INCLUDE "TARGET"
if TARGET = 2900 start { machine specific constants }
constinteger MAX LINE = 132
constinteger line len = 41 {for oper screen driving}
conststringname DATE = X'80C0003F'
conststringname TIME = X'80C0004B'
constinteger SEG SHIFT = 18
constinteger uinf seg = 9
finish { 2900 }
!
if TARGET = 370 start
constinteger SEG SHIFT = 16
finish
!
if TARGET = XA or TARGET = AMDAHL start
constinteger SEG SHIFT = 20
finish
!
unless TARGET = 2900 start
constinteger line len = 40 {for oper screen driving}
constinteger com seg = 31
conststringname DATE = COM SEG << SEG SHIFT + X'3B'
conststringname TIME = COM SEG << SEG SHIFT + X'47'
constinteger MAX LINE = 80 { for convenience on terminals }
constinteger uinf seg = 239
finish
constinteger max fsys = 99
constinteger max stations = 512
ownstring (1) null string = ""
if TARGET = 2900 start
conststring (15) private code = "INTER EMAS"
finish else start
conststring (15) private code = "INTER EMAS-A"
finish
conststring (17) array stream status type(0 : 24) = c
"Idle",
"Allocated",
"Active",
"Connecting",
"Disconnecting",
"Aborting",
"Suspending",
"Deallocating",
"Aborted",
"Selected",
"Awaiting SFT",
"SFT sent",
"Awaiting STOP",
"STOP sent",
"RPOS sent",
"RNEG sent",
"STOPACK sent",
"GO sent",
"Receiving data",
"Transmitting data",
"Last block sent",
"End data sent",
"Quit sent",
"End data ack sent",
"Spooler called"
constinteger n modes = 2
conststring (3) array modes(0 : n modes) = c
"ISO", "EBC", "BIN"
conststring (15) array doc state(0 : 6) = c
"Deleted",
"Queued",
"Sending",
"Running",
"Receiving",
"Processing",
"Transferring"
conststring (25) array start mess(1 : 10) = c
"System Full",
"Invalid Username",
"Invalid Password",
"Already Running",
"Cannot Start Process",
"Work File Failure",
"No User Service",
"FTRANS File Not Available",
"Usergroup Full",
"No Resource Left"
conststring (24) array FTP errors(32:52) = c
"R error resume",
"R error no resume",
"protocol R detected",
"","","","","",
"S error resume",
"S error no resume",
"protocol S detected",
"","","","","",
"Awaiting MR",
"Awaiting RR after reset",
"Await ER[OK] aft ES[OK]",
"Await ER[E] aft ES[E]",
"Await ER[H] aft ES[H]"
conststring (24) array FTP aborts(48:54) = c
"Awaiting data",
"",
"Awaits ES[OK] aft QR[OK]",
"Awaits ES[H] aft QR[H]",
"Awaits ES[E] aft QR[E]",
"After GO",
""
conststring (15) array comms stream status(0:11) = c
"Unused",
"Disconnecting",
"Connecting",
"Connected",
"Suspending",
"Aborting",
"Claiming",
"Enabling",
"Enabled",
"Queued",
"Paging in",
"Active"
constinteger n priorities = 5
conststring (5) array priorities(1 : n priorities) = c
"VLOW",
"LOW",
"STD",
"HIGH",
"VHIGH"
conststring (7)array FTP type desc(1:3) = "MAIL","JOB","OUTPUT"
conststring (2) array ocp type(0 : 15) = c
"??", "50", "60", "70", "80", "72", "72", "??", "??", "??", "??", "??", "??", "??",
"??", "??"
conststring (3)array comms type (0:2) = "???","NSI","TS"
constinteger on = 1
constinteger off = 0
constinteger no = 0
constinteger yes = 1
constinteger special = 3
constinteger no address = 0
conststring (35) array my errs(201 : 241) = c
"Bad Parameters",
"No Such Queue",
"Queue Full",
"All Queues Full",
"Not In Queue",
"User Not Known",
"No Files In Queue",
"File Not Valid",
"No Free Document Descriptors",
"Not Enough Privilege",
"Invalid Password",
"Invalid Filename",
"Invalid Descriptor",
"Command Not Known",
"Invalid Username",
"Username Not Specified",
"Not Available From A Process",
"Invalid Length",
"Document Destination Not Specified",
"Invalid Destination",
"Invalid Source",
"Invalid Name",
"Invalid Delivery",
"Invalid Time",
"Invalid Priority",
"Invalid Copies",
"Invalid Forms",
"Invalid Mode",
"Invalid Order",
"Invalid Start",
"Invalid Rerun",
"Invalid Tapes",
"Invalid Discs",
"Invalid Start After",
"Invalid Fsys",
"FTRANS File Create Fails",
"Invalid Out",
"Invalid Outlim",
"Invalid Outname",
"Descriptor Full",
"Invalid DAP mins"
conststring (20) array FTP act(87:103) = c
"Connect",
"Input Connected",
"Output Connected",
"Input Control Mess.",
"Output Control Mess.",
"Input Disconnected",
"Output Disconnected",
"P Command Reply",
"P Command Sent",
"Q Command Reply",
"Q Command Sent",
"Data Input",
"Command Overflow",
"Input Aborted",
"Output Aborted",
"Timeout",
"SPOOLR reply"
constintegerarray prtys(1 : n priorities) = c
1, 1000001, 2000001, 3000001, 4000001
constbyteintegerarray fail type(1 : 10) = c
1, 2, 2, 0, 2, 2, 1, 2, 0, 2
!* 0 NO ERROR MESSAGE REQUIRED CAN TRY AGAIN
!* 1 ERROR MESSAGE REQUIRED BUT CAN TRY AGAIN
!* 2 ERROR MESSAGE REQUIRED BUT DO NOT TRY AGAIN
constinteger already exists = 16; !DIRECTOR FLAG
constinteger already connected = 34
constinteger does not exist = 32; !DIRECTOR FLAG
constinteger user not acreditted = 37; !DIRECTOR FLAG
constinteger max documents = 1000; !MAX DOCUMENT DESCRIPTORS ON EACH FILE SYSTEM
constinteger document entry size = 256;!SIZE IN BYTES OF A DOCUMENT DESCRIPTOR
constinteger password document entry size = 144 ; !Size of the PASSWORD descriptors.
constinteger info size = 256; !SIZE IN BYTES OF INFO RETURNED TO USERS
constinteger max priority = 10000; !PRIORITY ADDED TO BASE PRIORITY IF RESOURCE = 0
constinteger small weight = 4; !THIS SHOULD BE INCREASED TO FAVOUR SMALL JOBS
constinteger requested = 255
constinteger comm connected = 3; !comms conn stream status.
constinteger comm claiming = 6
constinteger comm enabling = 7
constinteger no route = 0
constinteger user call = 1
constinteger job call = 2
constinteger ok = 0; !GENERAL SUCCESSFUL REPLY FLAG
constinteger rejected = 3
constinteger unused = 0; !DESCRIPTOR STATUS
constinteger queued = 1; !DITTO
constinteger transferring = 6; !FTP file transfer activity
constinteger set = 1
constinteger lp = 1
constinteger jrnl = 0
constinteger closed = 0; !REMOTE STATUS
constinteger open = 1; !DITTO
constinteger logging on = 2; !DITTO
constinteger logged on = 3; !DITTO
constinteger switching = 4; !DITTO
constinteger logging off = 5; !DITTO
constinteger unallocated = 0; !STREAM STATUS
constinteger allocated = 1; !DITTO
constinteger active = 2; !DITTO
constinteger connecting = 3; !DITTO
constinteger disconnecting = 4; !DITTO
constinteger aborting = 5; !DITTO
constinteger suspending = 6; !DITTO
constinteger deallocating = 7; !DITTO
constinteger aborted = 8; !used by FTP line only
constinteger selected = 9; !USED ONLY FOR FTP STREAMS
constinteger awaiting sft = 10
constinteger sft sent = 11
constinteger awaiting stop = 12
constinteger stop sent = 13
constinteger rpos sent = 14
constinteger rneg sent = 15
constinteger stopack sent = 16
constinteger go sent = 17
constinteger receiving data = 18
constinteger transmitting data = 19
constinteger last block sent = 20
constinteger end of data sent = 21
constinteger quit sent = 22
constinteger end of data acknowledge sent = 23
constinteger spooler called = 24
constinteger all queues = 1; !WHICH DISPLAY TYPE
constinteger all streams = 2; !DITTO
constinteger individual queue = 3; !DITTO
constinteger individual stream = 4; !DITTO
constinteger non empty queues = 5; !DITTO
constinteger active streams = 6; !DITTO
constinteger individual document = 7; !DITTO
constinteger full individual queue = 8;!DITTO
constinteger all remotes = 9; !DITTO
constinteger logged on remotes = 10; !DITTO
constinteger individual remote = 11; !DITTO
constinteger FTP status = 12
constinteger bad params = 201; !GENERAL BAD PARAMETER REPLY FLAG
constinteger no such queue = 202; !QUEUE REQUESTED DOES NOT EXIST
constinteger queue full = 203; !OUTPUT REQUESTS LISTS FULL REPLY FLAG
constinteger all queues full = 204; !NO FREE LIST CELLS OR INDEX FULL
constinteger not in queue = 205; !FIND DOCUMENT IN QUEUE FAILURE FLAG
constinteger user not known = 206; !PROCESS NOT KNOWN IN CONFIGURATION
constinteger no files in queue = 207
constinteger file not valid = 208
constinteger no free document descriptors = 209
constinteger not enough privilege = 210
constinteger invalid password = 211
constinteger invalid filename = 212
constinteger invalid descriptor = 213
constinteger command not known = 214
constinteger invalid username = 215
constinteger username not specified = 216
constinteger not available from a process = 217
constinteger invalid length = 218
constinteger document destination not specifed = 219
constinteger invalid destination = 220
constinteger invalid srce = 221
constinteger invalid name = 222
constinteger invalid delivery = 223
constinteger invalid time = 224
constinteger invalid priority = 225
constinteger invalid copies = 226
constinteger invalid forms = 227
constinteger invalid mode = 228
constinteger invalid order = 229
constinteger invalid start = 230
constinteger invalid rerun = 231
constinteger invalid decks = 232
constinteger invalid tapes or discs = 233
constinteger invalid start after = 234
constinteger invalid fsys = 235
constinteger FTRANS file create fails = 236
constinteger invalid out = 237
constinteger invalid outlim = 238
constinteger invalid outname = 239
constinteger descriptor full = 240
constinteger invalid dap mins = 241
constinteger not assigned = x'80808080'; !INTERNAL UNASSIGNED VARIABLE PATTERN
constinteger file header size = 32; !SS STANDARD FILE HEADER SIZE
constinteger r = b'00000001'; !READ PERMITION
constinteger w = b'00000010'; !WRITE PERMITION
constinteger sh = b'00001000'
constinteger zerod = b'00000100'; !ZERO FILE ON CREATION
constinteger tempfi = b'00000001'; !TEMP FILE ON CREATION
constinteger list size = 1000; !SIZE OF QUEUE CELLS LIST
constinteger header size = 2048; !NUMBER OF BYTES ALLOCATED For AN OUTPUT FILE HEADER
constinteger default oper update rate = 0;!REFRESH OPER EVERY 0 SECS(IE DONT)
constinteger fep io buff size = 4096; !NUMBER OF BYTES IN THE RJE CONTROL BUFFERS FOR EACH FEP
constinteger max fep = 7; !MAXIMUM FEPS SUPPORTED
constinteger max oper = 7; !MAXIMUM OPERS SUPPORTED
constinteger oper display size = 21; !NUMBER OF LINES IN AN OPER DISPLAY
constinteger last q per stream = 15; !NUMBER OF QUEUES BEING SERVED BY ONE STREAM
constinteger connect stream = x'370001'
constinteger disconnect stream = x'370005'; !DISCONNECT COMMUNICATIONS STREAM
constinteger stream control message = x'370007'; !STREAM HIGH LEVEL CONTROL MESSAGE
constinteger enable stream = x'370002';!START TRANSFER ON COMMUNICAIONS STREAM
constinteger disable stream = x'370004'; !DISABLE A TRANSFER ON COMMUNICATIONS STREAM
constinteger suspend = 4; !MODE OF DISABLING A COMMS STREAM
constinteger abort = 5; !DITTO
!----------------------------------------!
! OPER Picture driving declarations
constinteger max pic types = 4
constinteger max pic files = 16
constinteger max pic lines = 798 { because of the 32k limit on file size }
constinteger max screen = 31
constinteger picture act = 24
constinteger oper dest = x'00320000'
constinteger screens per oper = 4
constinteger FTP status summary display = 1
constinteger FTP line status display = 2
constinteger individual queue display = 3
constinteger individual document display = 4
!
!
!
recordformat picturef(integer base, { connect address }
p2, p3, { DA and pages-1 for comms controllers enable }
screens, { bit map showing where this pic is being displayed }
count, { the number of interactive processes looking at it }
picture type, { which type of picture it is }
tick, { for picture ageing }
id1,
string (15) id2 ) { to identify precisely what picture is of }
recordformat screenf(integer picture, { number of picture on display or }
stream,
top)
recordformat pe ( integer dest,srce,p1,p2,p3,p4,p5,p6)
recordformat uinff(string (6)user, string (31) batchfile,
integer mark, fsys, procno, isuff, reason, batchid,
sessiclim, scidensad, scidens, oper,
msgfad, sct date, sync1 dest, sync2 dest, async dest)
constrecord (uinff)name uinf = uinf seg << seg shift
!
!
!
externalroutinespec dpon ( record (pe) name p)
externalroutinespec dout(record (pe)name p)
!----------------------------------------!
constinteger FTP in control stream = 6
constinteger FTP out control stream = 7
constinteger clock tick = 11; !ACTIVITY NUMBER TO UPDATE OPER ON CLOCK TICK
constinteger default clock tick = 60; !IE THE TIME INTERVAL.
constinteger descriptor update = 12; !UPDATE THE DOC DESCRIPTORS ON THE FILE SYSTEMS.
constinteger solicited oper message = 19; !OPER MESSAGE ACTIVITY IN REPLY TO PROMPT
constinteger unsolicited oper message = 20; !OPER MESSAGE OUT OF THE BLUE
constinteger open fsys = 21; !ACTIVITY NUMBER OF OPEN FILE SYSTEM
constinteger user mess = 22; !ACTIVITY NUMBER OF USER MESSAGE ROUTINE
constinteger spooler reply act = 23; !Reply when spooler gets kick for DEXECMESS.
constinteger picture maintainance = 24
constinteger fep input control connect = 25
constinteger FTP input mess = 80; !CONTROL MESSAGE FROM FEP FTP ACTIVITY
constinteger FTP output reply mess = 81
!FTP OUTPUT CONTROL MESSAGE REPLY ACTIVITY.
constinteger FTP input control connect = 82
!CONNECT FTP INPUT CONTROL STREAM.
constinteger FTP input control connect reply = 83
!CONNECT FTP INPUT CONTROL STREAM FREPLY.
constinteger FTP output control connect reply = 84
!CONNECT FTP OUTPUT CONTROL STREAM REPLY.
constinteger FTP input control enable reply = 85
!ENABLE FTP INPUT CONTROL STREAM ENABLE REPLY.
constinteger FTP output control enable reply = 86
constinteger close control = 58
constinteger FTP connect = 87
constinteger FTP input connected = 88
constinteger FTP output connected = 89
constinteger FTP input control message = 90
constinteger FTP output control message = 91
constinteger FTP input disconnected = 92
constinteger FTP output disconnected = 93
constinteger FTP p command reply = 94
constinteger FTP p command sent = 95
constinteger FTP q command reply = 96
constinteger FTP q command sent = 97
constinteger FTP data input = 98
constinteger FTP command overflow = 99
constinteger FTP input aborted = 100
constinteger FTP output aborted = 101
constinteger FTP timed out = 102
constinteger FTP confirmation from spooler = 103
constinteger elapsed int = x'000A0002';!ELASPED INTERVAL TIME SERVICE
constinteger display dest = x'00320006'; !OPER DISPLAY SERVICE
constinteger display no flash dest = x'0032000B'
constinteger FTP block division = 16; !none emas to emas FTP transfers transfer limiter..
constinteger FTP emastoemas block division = 8
!NOTE these values MUST be 2/4/8/16/32 .
!The FTP local control flags (user facility) follow.
!---------------------------
!First set
constbyteinteger FTP no mail = x'01'
constbyteinteger FTP fail mail = x'02'
constbyteinteger FTP overwrite = x'04'
constbyteinteger FTP non text or data = x'08'
constbyteinteger FTP binary data = x'20'
constbyteinteger FTP ANSI = x'10'
constbyteinteger FTP local output = x'40'
constbyteinteger FTP binary read only = x'80'
!Second set
constbyteinteger FTP text read only = x'01'
constbyteinteger FTP fixed term delay = x'80'
constbyteinteger FTP no fixed term delay = x'7F'
constinteger viable = 0; !these are FTP transfer states
conststring (15) spoolFTP = "FTP"
conststring (15) spoolmail = "MAIL"
conststring (15) thisukac = "UK.AC"
constinteger FTP mail = 1
constinteger FTP job = 2
constinteger FTP output = 3
!--------------------------------------------
!Consts for FTP eval
conststring (16) array qual descr(0:3) = C
"Att. unknown",
"No val available",
"Bitfield",
"String"
conststring (3) array op descr(2:7) = c
"EQ",
"LE",
"",
"NE",
"GE",
"ANY"
conststring (11) array mon descr(0:1) = c
"",
" / monitor"
conststring (4) array type descr(0:4) = c
"STOP",
"",
"RPOS",
"RNEG",
"SFT"
constbyteinteger attribute unknown = x'00'
constbyteinteger no val available = x'10'
constbyteinteger op mask = x'07'
constbyteinteger form mask = x'70'
constinteger iso text = 3
constinteger data = 4
constbyteinteger unknown type = 0
constbyteinteger NSI type = 1
constbyteinteger TS type = 2
constbyteinteger BASE type = 3
constbyteintegerarray connect retry times(0 : 10) = c
0,5,10,10,15,20,20,30,30,30,60
! 0,1,2,2,5,5,5,8,8,10,10
constinteger rejected info = x'1001'
constinteger rejected attribute = x'1002'
constinteger rejected deferred = x'1003'
constinteger rejected no resume = x'1004'
constinteger satisfactory termination = x'2000'
constinteger problem termination = x'2001'
constinteger aborted no retry = x'3010'
constinteger aborted retry possible = x'3011'
constinteger p station = 0
constinteger q station = 1
if TARGET = 2900 start
constinteger FTP std mess len = 7; !THE LENGTH OF THE BASIC FTP CONTROL MESSAGE.
finish else start
constinteger FTP std mess len = 127
finish
constbyteinteger hold = x'10'
constinteger FTP data = x'40'; !OTHER DATA control FOR ENABLE.
constinteger translate = x'40'
constinteger no translation = x'50'; !EMAS TO EMAS MODE or free text
constinteger FTP command = x'60'; !COMMAND(NEGOTIATION).
constbyteinteger FTP stop = x'00'; !THESE ARE FTP CONTROL BYTES
constbyteinteger FTP go = x'01'
constbyteinteger FTP rpos = x'02'
constbyteinteger FTP rneg = x'03'
constbyteinteger FTP sft = x'04'
constbyteinteger FTP stopack = x'05'
constbyteinteger FTP ss = x'40'
constbyteinteger FTP ms = x'41'
constbyteinteger FTP cs = x'42'
constbyteinteger FTP es = x'43'
constbyteinteger FTP qr = x'46'
constbyteinteger FTP er = x'47'
constbyteinteger bits = x'20'
constbyteinteger strings = x'30'
constbyteinteger eq = x'02'
constbyteinteger le = x'03'
constbyteinteger ne = x'05'
constbyteinteger ge = x'06'
constbyteinteger any = x'07'
constbyteinteger monitor = x'80'
constinteger sender = 0; !FTP OUTGOING.
constinteger receiver = 1; !FTP INCOMING.
constinteger ready = 0
constinteger already enabled = 1
constinteger read and remove = x'8001'
constinteger take job output = x'4001'
constinteger take job input = x'2001'
constinteger give job output = x'C001'
constbyteinteger FTP data error = x'20'
constbyteinteger R error resume = x'20'
constbyteinteger R error no resume = x'21'
constbyteinteger S error resume = x'28'
constbyteinteger S error no resume = x'29'
constbyteinteger protocol R detected = x'22'
constbyteinteger protocol S detected = x'2A'
constbyteinteger FTP data abort = x'30'
constbyteinteger awaiting data = x'30'
constbyteinteger ER ok expected = x'32'
constbyteinteger ER e expected = x'33'
constbyteinteger ES e expected = x'34'
constbyteinteger FTP default timeout = 7
constinteger FTP selected timeout = 5
!FTP timeout values follow.
constbyteinteger station capacity retry time = 1; !max lines active for station.
constbyteinteger connect delay = 1; !the station already being tried.
constbyteinteger connect fail delay = 5; !the connection failed.
constbyteinteger auto poll delay = 5 {for auto output return from remote jobmills}
constbyteinteger transfer fail delay = 10; !the last transfer there failed.
constbyteinteger deferred delay = 15; !the transfer was deferred by the other end.
constbyteinteger allocate fail delay = 10; !the last allocate failed
constinteger successful = 1
constinteger display start line = 72; !START LINE OF DISPLAY
ownstring (255) ns1
conststring (11) FTP work dest = "FTPWORKDOC"
!*
!**********************************************************************
!* *
!* F T A M A N A C T I V I T I E S *
!* -*-*-*-*-*- -*-*-*-*-*-*-*-*-*- *
!* *
!* 11 - CLOCK TICK *
!* 12 - PERIODIC DESCRIPTOR UPDATING (BY FSYS) *
!* 19 - OPERATOR MESSAGE IN REPLY TO A PROMPT *
!* 20 - UNSOLICITED OPERATOR MESSAGE *
!* 21 - OPEN FILE SYSTEM *
!* 22 - USER MESSAGE *
!* 58 - WILL USE FOR FEP/FSYS GOING DOWN(FSYS = P_P3) *
!**********************************************************************
!*
!*
!*
! R E C O R D F O R M A T S
! - - - - - - - - - - - - -
!* COMMUNICATIONS RECORD FORMAT - EXTANT FROM CHOPSUPE 20A ONWARDS *
if TARGET = 2900 start
recordformat c
COMF(integer OCPTYPE, IPLDEV, SBLKS, SEPGS,
NDISCS, DLVNADDR, GPCTABSIZE, GPCA,
SFCTABSIZE, SFCA, SFCK, DIRSITE,
DCODEDA, SUPLVN, TOJDAY, DATE0,
DATE1, DATE2, TIME0, TIME1,
TIME2, EPAGESIZE, USERS, CATTAD,
SERVAAD, byteinteger NSACS, RESV1, SACPORT1, SACPORT0,
NOCPS, RESV2, OCPPORT1, OCPPORT0,
integer ITINT,
CONTYPEA, GPCCONFA, FPCCONFA, SFCCONFA,
BLKADDR, RATION, SMACS, TRANS,
longinteger KMON, integer DITADDR, SMACPOS,
SUPVSN, PSTVA, SECSFRMN, SECSTOCD,
SYNC1DEST, SYNC2DEST, ASYNCDEST, MAXPROCS,
KINSTRS, ELAPHEAD, COMMSRECA, STOREAAD,
PROCAAD, SFCCTAD, DRUMTAD, TSLICE,
FEPS, MAXCBT, PERFORMAD,
INTEGER SP0,SP1,SP2,SP3,SP4,SP5,
integer LSTL, LSTB, PSTL,
PSTB, HKEYS, HOOT, SIM,
CLKX, CLKY, CLKZ, HBIT,
SLAVEOFF, INHSSR, SDR1, SDR2,
SDR3, SDR4, SESR, HOFFBIT,
BLOCKZBIT, BLKSHIFT, BLKSIZE, END)
finish else start
recordformat C
COMF(integer OCPTYPE, SLIPL, TOPS, SEPGS,
NDISCS, NSLDEVS, DLVNADDR, DITADDR,
SLDEVTABAD, STEER INT, DIRSITE, DCODEDA,
exSUPLVN, TOJDAY, DATE0, DATE1,
DATE2, TIME0, TIME1, TIME2,
PAGESIZE, USERS, CATTAD, SERVAAD,
NOCPS, ITINT, RATION, TRANS,
longinteger KMON, integer SUPVSN, SECSFRMN,
SECSTOCD, SYNC1DEST, SYNC2DEST, ASYNCDEST,
MAXPROCS, KINSTRS, ELAPHEAD, COMMSRECA,
STOREAAD, PROCAAD, TSLICE, FEPS,
MAXCBT, PERFORMAD, END)
finish
!*
if TARGET = 2900 start
recordformat tran document descriptorf(STRING (7) HEADER, byteinteger state,
string (6) user,
(string (15) dest or integer spare1,spare2,spare3,spare4),
{these spare integers are for FTP use only and will be lost in SPOOLR calls}
(integer date and time received, date and time started or c
byteinteger FTRANS action, confirm, type, tfsys, integer transfer ident),
{the FTRANS units are set by us when requesting SPOOLR to do something}
integer specific fep, date and time deleted,
start after date and time, priority, data start, data length,
integer time, (integer output limit or integer FTP data record),
halfinteger mode of access,
byteinteger priority requested, forms, mode, copies, order,
rerun, decks, drives, fails, outdev,
srce, output, delivery, name,
byteintegerarray vol label(1:8),
byteinteger external user, external password, external name,
FTP alias, storage codename, device type, device qualifier,
data type, text storage,
FTP user flags, FTP file password,special options, auto requeue,
guest address,sp4,sp5,
byteinteger properties,
byteinteger try emas to emas, FTP retry level,
(byteinteger string ptr or string (148) string space))
!*
recordformat document descriptorf(byteinteger state,
string (6) user,
(string (15) dest or integer spare1,spare2,spare3,spare4),
{these spare integers are for FTP use only and will be lost in SPOOLR calls}
(integer date and time received, date and time started or c
byteinteger FTRANS action, confirm, type, tfsys, integer transfer ident),
{the FTRANS units are set by us when requesting SPOOLR to do something}
integer specific fep, date and time deleted,
start after date and time, priority, data start, data length,
integer time, (integer output limit or integer FTP data record),
halfinteger mode of access,
byteinteger priority requested, forms, mode, copies, order,
byteinteger rerun, decks, drives, fails, outdev,
srce, output, delivery, name,
byteintegerarray vol label(1:8),
byteinteger external user, external password, external name,
FTP alias, storage codename, device type, device qualifier,
data type, text storage,
FTP user flags, FTP file password,special options, auto requeue,
guest address, FTP user flags2, sp5,
byteinteger properties,
byteinteger try emas to emas, FTP retry level,
(byteinteger string ptr or string (148) string space))
finish else start
recordformat tran document descriptorf(STRING (7) HEADER, byteinteger state,
string (6) user,
(string (15) dest or integer spare1,spare2,spare3,spare4),
{these spare integers are for FTP use only and will be lost in SPOOLR calls}
(integer date and time received, date and time started or c
byteinteger FTRANS action, confirm, type, tfsys, integer transfer ident),
{the FTRANS units are set by us when requesting SPOOLR to do something}
integer specific fep, date and time deleted,
start after date and time, priority, data start, data length,
integer time, (integer output limit or integer FTP data record),
shortinteger mode of access,
byteinteger priority requested, forms, mode, copies, order,
rerun, decks, drives, fails, outdev,
srce, output, delivery, name,
byteintegerarray vol label(1:8),
byteinteger external user, external password, external name,
FTP alias, storage codename, device type, device qualifier,
data type, text storage,
FTP user flags, FTP file password,special options, auto requeue,
guest address, FTP user flags2,sp5,
byteinteger properties,
byteinteger try emas to emas, FTP retry level,
(byteinteger string ptr or string (148) string space))
!*
recordformat document descriptorf(byteinteger state,
string (6) user,
(string (15) dest or integer spare1,spare2,spare3,spare4),
{these spare integers are for FTP use only and will be lost in SPOOLR calls}
(integer date and time received, date and time started or c
byteinteger FTRANS action, confirm, type, tfsys, integer transfer ident),
{the FTRANS units are set by us when requesting SPOOLR to do something}
integer specific fep, date and time deleted,
start after date and time, priority, data start, data length,
integer time, (integer output limit or integer FTP data record),
shortinteger mode of access,
byteinteger priority requested, forms, mode, copies, order,
byteinteger rerun, decks, drives, fails, outdev,
srce, output, delivery, name,
byteintegerarray vol label(1:8),
byteinteger external user, external password, external name,
FTP alias, storage codename, device type, device qualifier,
data type, text storage,
FTP user flags, FTP file password,special options, auto requeue,
guest address, FTP user flags2,sp5,
byteinteger properties,
byteinteger try emas to emas, FTP retry level,
(byteinteger string ptr or string (148) string space))
finish
!*
recordformat password document descriptor f(byteinteger external password,
FTP file password, special options, spareb,
integer spareI1, spareI2, spareI3,
(byteinteger string ptr or string (127) string space))
!*
if TARGET = 2900 start
recordformat infof(integer vsn, state,
string (7) ident, user,
string (15) dest, srce, output,
string (31) name, delivery, string (7) array vol label(1:8),
integer date and time received, date and time started,
halfinteger dap mins, dap c exec time, integer date and time deleted,
data start, data length, time, output limit, physical size,
priority, start after date and time, ahead,
byteinteger forms, mode, copies, order, rerun, decks,
drives, fails)
finish else start
!*
recordformat infof(integer vsn, state,
string (7) ident, user,
string (15) dest, srce, output,
string (31) name, delivery, string (7) array vol label(1:8),
integer date and time received, date and time started,
shortinteger dap mins, dap c exec time, integer date and time deleted,
data start, data length, time, output limit, physical size,
priority, start after date and time, ahead,
byteinteger forms, mode, copies, order, rerun, decks,
drives, fails)
finish
!*
if TARGET = 2900 start
recordformat queuef(string (15) name,
(halfintegerarray streams(0 : 15) or halfintegerarray lines(0 : 15)),
string (7) default user,
string (31) default delivery,
integer default start, default priority, default time,
default output limit, default forms, default mode, default copies,
default rerun, length, head, max length, maxacr,
halfinteger q by, general access, integer resource limit,
amount)
finish else start
recordformat queuef(string (15) name,
(shortintegerarray streams(0 : 15) or shortintegerarray lines(0 : 15)),
string (7) default user,
string (31) default delivery,
integer default start, default priority, default time,
default output limit, default forms, default mode, default copies,
default rerun, length, head, max length, maxacr,
shortinteger q by, general access, integer resource limit,
amount)
finish
!*
!*
!Note that the FTP line tables are in two sections.
!The first gives basic information used on stream 'scans', ie in
!response to a QUEUE user command for active documents. The first section
!will fit in a single page. The second sections contains the meaty bits.
!
!
recordformat line f(string (15) name, string (7) unit name,
string (6) user, byteinteger parity,
integer status, (integer bytes sent or integer records received),
integer bytes to go, block, part blocks,
document, bin offset,
byteinteger service, user abort, unit size, fep,
integer abort retry count, offset, station ptr,
(integer vrecord length, vbytes to go, split vrecord length or c
integer current vrecord length, current vrecord length addr,known to have records),
integer data transfer start {for timing the transfer},account,
integer in comms stream, out comms stream,
integer in stream ident, out stream ident,
integer transfer status, tcc subtype,
in block addr, out block addr,
byteinteger activity, station type, spb2, suspend,
in stream status, out stream status,
timer, output buffer status, output transfer pending,
new FTP data record, byteintegerarray bspare(0:9),
integer aux document, pre abort status, bytes transferred,
record (pe) output transfer record)
!*
!*
recordformat fepf(byteinteger incomming calls accepted, outgoing calls permitted,
FTP available, closing, comms type,
integer FTP input stream, FTP output stream,
FTP in buff disc addr, FTP out buff disc addr,
FTP in buff disc blk lim, FTP out buff disc blk lim,
FTP in buff con addr, FTP out buff con addr, FTP in buff offset,
FTP out buff offset, FTP in buff length, FTP out buff length,
FTP input cursor, FTP output cursor, FTP suspend on output)
!*
if TARGET = 2900 start
recordformat FTP bits(byteinteger qual, set, halfinteger value)
finish else start
recordformat FTP bits(byteinteger qual, set, shortinteger value)
finish
recordformat FTP strings(byteinteger qual, set, string (39) value)
recordformat FTP tablef(integer user fsys, binary data record, spare1, spare2,
byteinteger emastoemas, data control,mail,mail to send, mail displ, sp1,sp2,sp3,
string (73) stopack message, calling address, byteintegerarray emastoemas header (0:31),
record (FTP bits) protocol id,mode,data type,text tran code,
text format,del pres,max tran rec size,tran limit,
file size,facilities,timeout,restart mark,
binary word size, binary format, Ispare,
record (FTP strings) username,username password,filename,file password,
private code name,device type,device type qualifier,
special options)
!*
record format FTP pointers f(integer link list displ, ftp table displ, queues, queue entry size,
queue displ, queue name displ, streams, stream entry size, stream displ, hash length,
sp1, sp2,sp3, stations, station entry size, station displ,
control entry, station addresses displ, guest entry, byte integer array discs(0:max fsys),
string (63) dead letters, this full host, integer expanded address displ, integer array hash t(0:1023))
record format FTP station f(byte integer max lines ,
byteinteger status, byteinteger service ,
byteinteger connect retry ptr, fep,
address type, SERVICES,
byteinteger q lines ,
integer limit , integer last call, last response, system loaded,
connect attempts, connect retry time, integer array ispare(0:4),
integer seconds, bytes,
integer last q response by us,
p transfers, q transfers, p kb, q kb, p mail, q mail, integer name, shortest name,
integerarray address(1:4), integer pss entry, integer mail, integer ftp,
integer description, (integer queue or integer route), integer flags,
byteintegerarray string space(0 : 375){decrement this if more fields added, keep to 512 total})
recordformat name f(integer link, host entry, string (255) name)
recordformat exp addr f( integer address type, integerarray ptr (1:4))
!that is an index into the string store in the database that contains
!all the expaned TS addresses for the stations.
!*
recordformat lcf(integer document, priority, size, station ptr,
(byteinteger SPB1,FTP timer,FTP flags,gen flags or integer flags),
integer link,string (6) user, byteinteger order)
!
if TARGET = 2900 start
recordformat file inff(string (11)NAME,
integer SD,halfinteger PGS, H0,
byteinteger CODES, CODES2, DAYNO, USE,
OWNP, EEP, PHEAD, ARCH,
byteinteger CCT, SSBYTE, halfinteger PREFIX)
finish else start
recordformat file inff(string (11)NAME, integer SD,
shortinteger PGS, H0,
byteinteger CODES, CODES2, DAYNO, USE,
OWNP, EEP, PHEAD, ARCH,
CCT, SSBYTE, shortinteger PREFIX)
finish
if TARGET # 2900 start
RECORDFORMAT FINFF((INTEGER NKB, RUP, EEP, APF, USE, ARCH, FSYS, CONSEG,
CCT, CODES, DAYNO, CODES2,
SSBYTE or INTEGERARRAY i(0:12)),STRING (6)OFFER)
finish else start
RECORDFORMAT FINFF(INTEGER NKB, RUP, EEP, APF, USE, ARCH, FSYS, CONSEG,
CCT, CODES, BYTEINTEGER SP1, DAYNO, SP2, CODES2,
INTEGER SSBYTE ,STRING (6)OFFER)
finish
!*
recordformat daf((integer blksi, nblks, last blk, spare,
integerarray da(1 : 512) or integer sparex, integerarray i(0:514)))
!*
!*
recordformat fhf(integer end, start, size, type, free hole,
datetime, binary record, records)
!*
if TARGET = 2900 start
recordformat FTP f(byteinteger length, type, halfinteger pair ref,
in ident, out ident, string (127) address)
finish else start
recordformat FTP f( shortinteger control, type, pair ref, in ident, out ident,
fail or status, spare, string (113) address)
finish
recordformat opf(integer update rate, prompt on, display type,
which display, which page, string (10) specific user,
string (41) command)
!*
recordformat f systems f(integer addr, password addr, closing)
!*
! S Y S T E M R O U T I N E S P E C S
! - - - - - - - - - - - - - - - - - -
if TARGET = 2900 start
system string (255) fn spec substring(string name s,integer i,j)
systemroutinespec move(integer length, from, to)
systemroutinespec fill(integer length, from, filler)
finish else start
externalstring (255)fnspec substring(Stringname s, integer i,j)
externalroutinespec move(integer length, from, to)
externalroutinespec fill(integer length, from, filler)
finish
external integerfnspec pack date and time(string (8) date, time)
external integerfnspec current packed dt
external string (8) fnspec unpack date(integer p)
external string (8) fnspec unpack time(integer p)
!*
! E X T E R N A L R O U T I N E S P E C S
! - - - - - - - - - - - - - - - - - - - -
!
if TARGET = 2900 start
externalstringfnspec derrs(integer flag)
externalintegerfnspec dexecmess(string (6) user,integer sact,len,addr)
externalintegerfnspec ddap(integerfn a(integer a,b,c), integer act, addr)
externalintegerfnspec dsfi(string (6) user,
integer fsys, integer type, set, address)
!%externalintegerfnspec change context
externalintegerfnspec d check bpass(string (6) user,
string (63) bpass, integer fsys)
externalintegerfnspec dpon3(string (6) user,
record (pe)name p, integer invoc, msgtype, outno)
externalroutinespec dpoff(record (pe)name p)
externalroutinespec dtoff(record (pe)name p)
externalintegerfnspec dgetda(string (6) user,
string (11) file, integer fsys, address)
externalintegerfnspec dchsize(string (6) user,
string (11) file, integer fsys, newsize)
externalroutinespec get av fsys(integername n,
integerarrayname a)
externalintegerfnspec dfsys(string (6) user, integername fsys)
externalintegerfnspec dpermission( c
string (6) owner, user, string (8) date,
string (11) file, integer fsys, type, adrprm)
externalintegerfnspec ddestroy(string (6) user,
string (11) file, string (8) date, integer fsys, type)
externalintegerfnspec ddisconnect(string (6) user, string (11) file c
integer fsys, destroy)
externalintegerfnspec drename(string (6) user,
string (11) oldname, newname, integer fsys)
externalintegerfnspec dfstatus(string (6) user,
string (11) file, integer fsys, act, value)
externalintegerfnspec dfilenames(string (6) user,
record (file inff)arrayname inf,
integername filenum, maxrec, nfiles, integer fsys, type)
externalintegerfnspec dfinfo(string (6) user,
string (11) file, integer fsys, address)
externalintegerfnspec dcreate(string (6) user,
string (11) file, integer fsys, nkb, type)
externalintegerfnspec dconnect(string (6) user,
string (11) file, integer fsys, mode, apf,
integername seg, gap)
externalintegerfnspec dmessage(string (6) user,
integername l, integer act, fsys, adr)
externalintegerfnspec dtransfer( c
string (6) user1, user2,
string (11) file, newname, integer fsys1, fsys2, type)
externalintegerfnspec dnewgen(string (6) user, string (11) file, c
newgen of file, integer fsys)
finish else start
EXTERNALINTEGERFNSPEC D AV FSYS(INTEGERNAME N, INTEGERARRAYNAME A)
EXTERNALINTEGERFNSPEC DCHECKBPASS(STRINGNAME USER, BPASS, INTEGERNAME FSYS)
EXTERNALINTEGERFNSPEC DCHSIZE(STRINGNAME FILE INDEX, FILE, INTEGERNAME FSYS, NKB)
! The physical size of file FILE belonging to file index FILE INDEX on
! disc-pack FSYS (or -1) is altered (if necessary) so that its new size
! is NEWKB Kbytes. The size may not be reduced to zero. The file may
! be connected in the caller's virtual memory (only). If the caller is
! not the file owner, he must either have W access to the file index or
! be privileged.
!%EXTERNALINTEGERFNSPEC CHANGE CONTEXT
EXTERNALINTEGERFNSPEC DCONNECT(STRINGNAME FILE INDEX, FILE, INTEGERNAME FSYS, MODE, SEG, GAP)
EXTERNALINTEGERFNSPEC DCREATE(STRINGNAME FILE INDEX, FILE, INTEGERNAME FSYS, NKB, TYPE, DA)
! A file of name FILE is created, in file index FILE INDEX on disc-pack
! FSYS, of E Epages, where E is the smallest number of Epages containing
! NKB Kbytes. The maximum size of file allowed is 16 Mbytes. Subsystems
! requiring larger files should arrange that they be made up of subfiles
! comprising files created by this procedure.
!
! Bits in TYPE may be set:
!
! 2**0 For a temporary file (destroyed when the creating process
! stops if the file was connected, or at System start-up).
!
! 2**1 For a very temporary file (destroyed when the file is
! disconnected).
!
! 2**2 For a file which is to be zeroed when created.
!
! 2**3 To set "CHERISHed" status for the file.
!
!
! Temporary files are made into ordinary files (that is, the "temporary"
! attribute is removed) on being RENAMEd, OFFERed, TRANSFERred or
! PERMITted, and also explicitly by an appropriate call on procedure
! DFSTATUS.
!
! The disc address of the first section of the file is returned in DA.
EXTERNALINTEGERFNSPEC DDESTROY(STRINGNAME FILE INDEX, FILE, DATE, INTEGERNAME FSYS, TYPE)
! File FILE belonging to file index FILE INDEX on disc-pack FSYS, is
! destroyed. TYPE should be set to 1 to destroy a file from archive
! storage, otherwise it should be set to zero. When TYPE=1, DATE should
! be set to the archive date. DATE is ignored if TYPE=0.
!
! The procedure fails if 'OWNP' for the file is either zero (no access)
! or 8 (do not destroy).
EXTERNALINTEGERFNSPEC DDISCONNECT(STRINGNAME FILE INDEX, FILE, INTEGERNAME FSYS, DSTRY)
! The file of name FILE belonging to file index FILE INDEX on disc-pack
! FSYS is disconnected from the caller's virtual memory. Parameter
! DESTROY should be set either to 0 or 1. If set to 1 the file will be
! destroyed, provided that it belongs to the process owner (not necessary
! if the process is privileged) and the "use-count" for the file is zero
! after disconnection. Otherwise the parameter is ignored.
EXTERNALINTEGERFNSPEC DFILENAMES(STRINGNAME GROUP, INTEGERNAME FILENO, MAXREC, C
NFILES, FSYS, TYPE, RECORD (file inff)ARRAYNAME INF)
! This procedure delivers, in the record array INFS (which should be
! declared (0:n)), a sequence of records describing the on-line files
! (for TYPE=0), archived files (for TYPE=1) or backed-up files (for
! TYPE=2) belonging to group GROUP on fsys FSYS (or -1 if not known).
!
! The procedure works differently for on-line files (TYPE=0) and
! off-line files (TYPE>0).
!
! For on-line files, the records returned give the names of files and
! groups belonging to GROUP but not the contents of any of these groups.
! DFILENAMES must be called again with GROUP set to the name of the
! subgroup to determine these. Thus
!
! FLAG = DFILENAMES(ERCC99,...
!
! returns the names of files and groups in ERCC99's main file index. If
! there is a group called PROJ:, the contents of it can be found with
!
! FLAG = DFILENAMES(ERCC99.PROJ:,...
!
! The group separator, :, may be omitted if desired.
!
! Note that the usage of . and : (USEP and GSEP) is reversed in EMAS3.
! The UINF fields USEP, USEPCH etc allow utilities to be written which
! will work for both EMAS2 and EMAS3.
!
! MAXREC is set by the caller to specify the maximum number of records he
! is prepared to accept in the array INFS, and is set by Director to be
! the number of records returned.
!
! NFILES is set by Director to be the number of files actually held on
! on-line storage or on archive storage, depending on the value of TYPE.
!
! FILENO is not normally used. [ If the top bit of MAXREC is set, FILENO
! is used in the same way as for off-line files, described below ]
!
! The format of the records returned in INFS is
!
! %string(11)NAME, %integer SPARE1, KBYTES,
! %byteinteger ARCH, CODES, CCT, OWNP,
! EEP, USE, CODES2, SSBYTE, SPARE2, PHEAD, DAYNO, GROUP
!
! ( 32 bytes )
! PHEAD is non-zero if the file or group has been permitted itself to a
! user or user group.
! GROUP is non-zero if NAME is the name of a group.
!
! For off-line files, TYPE = 1 or 2, GROUP will normally be be the name
! of a file index eg ERCC99 or ERCC99{UTILS} when all the names in the
! index will be returned. If an actual group name is given eg
!
! ERCC99.PROJ:
!
! then only names of the form
!
! ERCC99.PROJ:name
!
! are returned. MAXREC and NFILES are used in the same way as above.
!
! Filenames are stored in chronological order of archive (or backup) date,
! youngest first. FILENO is set by the caller to specify the "file-number"
! from which names are to be returned, zero representing the most recently
! archived file. Thus the caller can conveniently receive subsets of names
! of a very large number of files.
!
! The format of the records returned in INFS is
!
! %string(11)NAME, %integer KBYTES,
! %string(8)DATE, %string(6)TAPE,
! %halfinteger PREFIX, CHAPTER,
! %byteinteger EEP, PHEAD, SPARE, COUNT
!
! ( 40 bytes )
! To allow the full filenames to be reconstructed, the array INFS, in
! general, contains some records which hold group names. Records refering
! to filenames can be distinguished by the fact that KBYTES > 0. If PREFIX
! is > 0, the name is a member of a group whose name is given in the
! record INFS(PREFIX). The chain can be followed back until a record
! with a zero PREFIX field is found.
!
! Note. MAXREC does not give the number of filenames returned but the
! number of records in INFS.
!
! TAPE and CHAPTER are returned null to unprivileged callers.
EXTERNALINTEGERFNSPEC DFINFO(STRINGNAME FILE INDEX, FILE, INTEGERNAME FSYS, C
STRINGNAME S, INTEGERARRAYNAME I)
! This procedure returns detailed information about the attributes of
! file or group FILE belonging to file index FILE INDEX on disc-pack
! FSYS, in a record written to address ADR.
!
! A caller of the procedure having no permitted access to the file
! receives an error result of 32, as though the file did not exist.
!
! The format of the record returned is:
!
recordformat DFINFOF((integer NKB, RUP, EEP, APF,
USE, ARCH, FSYS, CONSEG, CCT, CODES,
byteinteger SP1, DAYNO, SP2, CODES2,
integer SSBYTE or INTEGERARRAY i(1:12)), string (6)OFFER)
!
! where
! NKB the number of Kbytes (physical file size)
! zero indicates a group name
! RUP the caller's permitted access modes
! EEP the general access permission
! APF 1-4-4 bits, right-justified, giving respectively the Execute,
! Write and Read fields of APF, if the file is connected in
! this VM
! USE the current number of users of the file
! ARCH the value of the archive byte for the file (see procedure
! DFSTATUS)
! FSYS disc-pack number on which the file resides
! CONSEG the segment number at which the file is connected in the
! caller's VM, zero if not connected
! CCT the number of times the file has been connected since this
! field was last zeroed (see procedure DFSTATUS)
! CODES information for privileged processes
! SP1 spare
! DAYNO Day number when file last connected
! SP2 spare
! CODES2 information for internal use
! SSBYTE information for the subsystem's exclusive use
! OFFER the username to which the file has been offered, otherwise
! null
EXTERNALINTEGERFNSPEC DFLAG(INTEGERNAME FLAG, STRINGNAME TXT)
EXTERNALINTEGERFNSPEC DEXECMESS(STRINGNAME USER, INTEGERNAME SACT,LEN,ADDR)
EXTERNALINTEGERFNSPEC DFSTATUS(STRINGNAME FILE INDEX, FILE, INTEGERNAME FSYS, ACT, VALUE)
! This procedure is supplied to enable the attributes of file FILE
! belonging to file index FILE INDEX on disc-pack FSYS to be modified,
! as follows.
!
! Parameter VALUE is for use by the archive/backup program (ACT=13),
! and by the subsystem (ACT=18), otherwise it should be set to zero.
!
! ACT ACTION
!
! 0 HAZARD Remove CHERISHed attribute
!
! 1 CHERISH Make subject to automatic System back-up procedures
! Note: If the file is one of
! SS#DIR, SS#OPT or SS#PROFILE
! then the 'archive-inhibit' bit is also set.
! Similarly, the 'archive-inhibit' bit is
! cleared by HAZARD for these files.
!
! 2 UNARCHIVE Remove the "to-be-archived" attribute
!
! 3 ARCHIVE Mark the file for removal from on-line to archive
! storage.
!
! 4 NOT TEMP Remove the "temporary" attribute.
!
! 5 TEMPFI Mark the file as "temporary", that is, to be
! destroyed when the process belonging to the file
! owner stops (if the file is connected at that
! time), or at system start-up.
!
! 6 VTEMPFI Mark the file as "very temporary", that is, to be
! destroyed when it is disconnected from the owner's
! VM.
!
! 7 NOT PRIVATE May now be written to magnetic tape either for
! back-up or archive. May be called only by
! privileged programs.
!
! 8 PRIVATE Not to be written to magnetic tape either for
! back-up or archive. May be called only by
! privileged programs.
!
! 9 SET CCT Set the connect count for the file to VALUE.
!
! 11 ARCH Operation 1 (PRIVILEGED).
! Set currently-being-backed-up bit (bit 2**1 in
! ARCH byte), unless the file is currently connected
! in write mode, when error result 52 is given.
!
! 12 ARCH Operation 2 (PRIVILEGED).
! Clear currently-being-backed-up bit (2**1) and
! has-been-connected-in-write-mode bit (2**0).
!
! 14 ARCH Operation 4 (PRIVILEGED).
! Clear the UNAVAilable and privacy VIOLATed bits in
! CODES. Used by the back-up and archive programs
! when the file has been read in from magnetic tape.
!
! 15 CLR USE Clear file use-count and WRITE-CONNECTED status
! (PRIVILEGED).
!
! 16 CLR NOARCH Clear archive-inhibit bit in CODES. PRIVILEGED -
! for System
!
! 17 SET NOARCH Set archive-inhibit bit in CODES. Library use
!
! 18 SSBYTE Set SSBYTE to be the bottom 8 bits of VALUE (byte
! for a subsystem's exclusive use).
!
! 19 ARCH Operation 5 (PRIVILEGED).
! Set the WRCONN bit in CODES2. Used to prevent any
! user connecting the file in write mode during
! back-up or archive.
!
! 20 ARCH Operation 6 (PRIVILEGED).
! Clear the WRCONN bit in CODES2. Used when back-up
! is complete.
!
! 21 DAYNO Set DAYNO to bottom 8 bits of VALUE
EXTERNALINTEGERFNSPEC DFSYS(STRINGNAME FILE INDEX, INTEGERNAME FSYS)
EXTERNALINTEGERFNSPEC DFSYSDATA(INTEGERNAME FSYS, INTEGERARRAYNAME DATA)
EXTERNALINTEGERFNSPEC DGETDA(STRINGNAME FILE INDEX, FILE, INTEGERNAME FSYS, INTEGERARRAYNAME I)
! This procedure provides the disc addresses of the sections of file FILE
! belonging to file index FILE INDEX on disc-pack FSYS. Data is written
! from address ADR in the format
!
! (%integer SECTSI, NSECTS, LASTSECT, %integerarray DA(0:255))
!
! where SECTSI is the size (in epages) of the sections (except
! possibly the final section)
!
! NSECTS is the number of sections, and hence the number
! of entries returned in array DA
!
! LASTSECT is the size (in epages) of the final section
!
! In each entry in the DA array, the top byte contains the FSYS number.
EXTERNALINTEGERFNSPEC DMESSAGE(STRINGNAME USER, INTEGERNAME LEN, ACT, INVOC, FSYS, ADR)
EXTERNALINTEGERFNSPEC DNEWGEN(STRINGNAME FILE INDEX, FILE, NEWGEN, INTEGERNAME FSYS)
! This procedure provides a means of introducing an updated version
! (i.e. a new generation) of file FILE belonging to file index FILE INDEX
! even though it may be connected in other users' virtual memories.
!
! If FILE is not connected in any virtual memory, a call on DNEWGEN is
! equivalent to destroying FILE and then renaming NEWGEN to FILE,
! except that the new version of FILE retains the former FILE's access
! permissions.
!
! If FILE is connected in some virtual memory, then the filename
! NEWGEN "disappears", and any subsequent connection of FILE into
! a virtual memory yields the contents of the new generation formerly
! held in NEWGEN.
!
! When the number of users of a former copy of FILE becomes zero
! (i.e. when it is not connected in any virtual memory), that copy is
! destroyed.
EXTERNALINTEGERFNSPEC DPERMISSION(STRINGNAME FILE INDEX, C
USER, DATE, FILE, INTEGERNAME FSYS, TYPE, ADR)
! This procedure allows the caller to set access permissions, or specific
! preventions, for file connection to individual users, groups of users
! or to all users to file FILE belonging to file index FILE INDEX. It
! also allows a caller to determine the modes (if any) in which he may
! access the file.
!
! TYPE determines the service required of the procedure:
!
! TYPE Action
!
! 0 set OWNP (not for files on archive storage)
! 1 set EEP
! 2 put USER into the file list (see "Use of file
! access permissions", below)
! 3 remove USER from file list
! 4 return the file list
! 5 destroy the file list
! 6 put USER into the index list (see "Use of file
! access permissions", below)
! 7 remove USER from the index list
! 8 return the index list
! 9 destroy the index list
! 10 give modes of access available to USER for FILE
! 11 set EEP for the file index as a whole
!
! TYPEs 0 to 9 and 11 are available only to the file owner and to
! privileged processes. For TYPE 10, ADRPRM (see below) should be the
! address of an integer into which the access permission of USER to the
! file is returned. If USER has no access to the file, error result 32
! will be returned from the function, as though the file did not exist.
! If the file is on archive storage, TYPE should be set to 16 plus the
! above values to obtain the equivalent effects.
!
! ADRPRM is either the permission being attached to the file, bit
! values interpreted as follows:
!
! all bits zero prevent access
! 2**0 allow READ access
! 2**1 allow WRITE access not allowed for files
! 2**2 allow EXECUTE access on archive storage
! 2**3 If TYPE = 0, prevent the file from being
! destroyed by e.g. DDESTROY, DDISCONNECT (and
! destroy).
! or, except for type 10, it is the address of an area into which access
! permission information is to be written
!
! %recordformat(%integer BYTES RETURNED, OWNP, EEP, SPARE,
! %record(EF)%array INDIV PRMS(0:15))
!
! and EF is
! %recordformat EF(%string(6)USER, %byteinteger PERMISSION)
!
! where:
!
! BYTES indicates the amount of data returned.
! RETURNED
!
! OWNP is the file owner's own permission to the file, or the
! requesting user's "net" permission if the caller of the
! procedure is not the file owner (see "Use of file access
! permissions", below).
!
! EEP is the general (all users) access permission to the file
! ("everyone else's permission").
!
! UPRM The PERMISSION values in the sub-records are those
! for the corresponding users or groups of users denoted by
! USER. Up to 16 such permissions may be attached to a
! file.
!
! Use of file access permissions
!
! The general scheme for permissions is as follows. With each file
! there are associated:
!
! OWNP the permission of the owner of the file to access it
!
! EEP everyone else's permission to access it (other than users
! whose names are explicitly or implicitly attached to the
! file)
!
! INDIV PRMS a list of up to 16 items describing permissions for
! individual users, e.g. ERCC00, or groups of users, e.g.
! ERCC?? (specifying all usernames of which the first four
! characters are "ERCC")
!
! In addition, a user may attach a similar list of up to 16 items to
! his file index as a whole and an EEP for the file index. These
! permissions apply to any file described in the index along with those
! attached to that particular file.
! In determining the mode or modes in which a particular user may access
! a file, the following rules apply:
!
! 1. If the user is the file owner then OWNP applies.
!
! 2. Otherwise, if the user's name appears explicitly in the list for
! the file, the corresponding permission applies.
!
! 3. Otherwise, if the user's name is a member of a group of users
! represented by a list item for the file, the corresponding
! permission applies.
!
! 4. Otherwise EEP applies if greater than zero.
!
! 5. Otherwise, if the user's name appears explicitly in the list for
! the index, the corresponding permission applies.
!
! 6. Otherwise, if the user's name is a member of a group of users
! represented by a list item for the index, the corresponding
! permission applies.
!
! 7. Otherwise, everybody else's permission to the file index applies.
!
! In the event of a user's name appearing more than once (implicitly)
! within groups specified in a single list, the actual list item to be
! selected to give the permission should be regarded as indeterminate.
EXTERNALINTEGERFNSPEC DPOFF(RECORD (pe)NAME P)
EXTERNALINTEGERFNSPEC DPON3(STRINGNAME USER, RECORD (pe)NAME P, C
INTEGERNAME INVOC, MSGTYPE, OUTNO)
EXTERNALINTEGERFNSPEC DRENAME(STRINGNAME FILE INDEX, OLDNAME, NEWNAME, INTEGERNAME FSYS)
! File OLDNAME belonging to file index FILE INDEX on disc-pack FSYS is
! renamed NEWNAME.
!
! A file may not be renamed while it is connected in any virtual memory.
EXTERNALINTEGERFNSPEC DSFI(STRINGNAME FILE INDEX, INTEGERNAME FSYS, TYPE, C
SET, STRINGNAME S, INTEGERARRAYNAME I)
! This procedure is used to set or read information in file index FILE
! INDEX (or user record in some cases) on disc-pack FSYS. TYPE specifies
! which data item is to be referenced (see list below). SET must be 1
! to write the data item into the index, or 0 to read the item from the
! index. ADR is the address of an area, which must be available in write
! or read mode, to or from which the data item is to be transferred.
!
! TYPE Data item Data type & size
!
! 0 BASEFILE name (the file to be connected
! and entered at process start-up) string(18)
!
! 1 DELIVERY information (to identify string(31)
! slow-device output requested by the
! index owner)
!
! 2 CONTROLFILE name (a file for use by the
! subsystem for retaining control information) string(18)
!
! 3 ADDRTELE address and telephone number of user string(63)
!
! 4 INDEX USE (may not be reset)
! Gives (in successive integers from ADR):
! a) number of files
! b) number of file descriptors currently in use
! c) number of free file descriptors
! d) index size (Kbytes)
! e) Number of section descriptors (SDs)
! f) Number of free section descriptors
! g) Number of permission descriptors (PDs)
! h) Number of free permission descriptors integer(x8)
!
! 5 Foreground and background passwords
! (reading is a privileged operation), a zero
! value means "do not change" integer(x2)
!
! 6 Date last logged-in: (Y-70)<<9 ! (M<<5) ! D and
! date last started (non-interactive) (same)
! (may not be reset) integer(x2)
!
! 7 ACR level at which the process owning this
! index is to run (may be set only by privileged
! processes) integer
!
! 8 Director Version (may be set only by privileged
! processes) integer(x2)
!
! 9 ARCHIVE INDEX USE (may not be reset)
! Gives (in successive integers from ADR):
! a) number of archived files
! b) number of archived Kbytes
! c) number of backed-up files
! d) number of backed-up Kbytes
! e) index size (Kbytes)
! f) number of file descriptors
! g) number of free file descriptors
! h) number of permission descriptors
! i) number of free permission descriptors integer(x9)
!
! 10 Stack size (Kbytes) integer
!
! 11 Limit for total size of all files in disc
! storage (Kbytes) (may be set only by privileged
! processes integer
!
! 12 Maximum file size (Kbytes) (may be set only by
! privileged processes) integer
!
! 13 Current numbers of interactive and batch
! processes, respectively, for the user (may
! not be reset) integer(x2)
!
! 14 Process concurrency limits (may be set only
! by privileged processes). The three words
! denote respectively the maximum number of
! interactive, batch and total processes which
! may be concurrently running for the user.
! (Setting the fields to -1 implies using
! the default values, currently 1, 1 and 1.) integer(x3)
!
! 15 When bit 2**0 is set, TELL messages to the
! index owner are rejected with flag 48. integer
!
! 16 Set Director monitor level (may be set only
! by privileged processes) integer(x2)
!
! 17 Set SIGNAL monitor level (may be set only
! by privileged processes) integer
!
! 18 Initials and surnames of user (may
! be set only by privileged processes) string(31)
!
! 19 Director monitor file string(11)
!
! 20 Thousands of instructions executed, interactive
! and batch modes (may be reset only by
! privileged processes) integer(x2)
!
! 21 Thousands of instructions executed (current
! session only) integer
!
! 22 Thousands of instructions executed in Director
! procedures (current process session only)
! (may not be reset) integer
!
! 23 Page-turns, interactive and batch modes
! (may be reset only by privileged processes) integer(x2)
!
! 24 Page-turns (current process session only) integer
!
! 25 Thousands of bytes output to slow-devices
! (local or remote) (may be reset only by
! privileged processes) integer
!
! 26 Thousands of bytes input from slow-devices
! (local or remote) (may be reset only by
! privileged processes) integer
!
! 27 Milliseconds of OCP time used, interactive
! and batch modes (may be reset only by
! privileged processes) integer(x2)
!
! 28 Milliseconds of OCP time used (current
! session only) integer
!
! 29 Seconds of interactive terminal connect time
! (may be reset only by privileged processes) integer
!
! 30 No. of disc files, total disc Kbytes, no. of
! cherished files, total cherished Kbytes, no.
! of temporary files, total temporary Kbytes
! (cannot be reset) integer(x6)
!
! 31 No. of archive files, total archive Kbytes integer(x2)
!
! 32 Interactive session length in minutes integer
! 0 or 5 <= x <= 240
!
! 33 Funds integer
!
! 34 The FSYS of the Group Holder of the index integer
! owners funds, if he has a GH
!
! 35 Test BASEFILE name string(18)
!
! 36 Batch BASEFILE name string(18)
!
! 37 Group Holder of funds for scarce resources string(6)
!
! 38 Privileges integer
!
! 39 Default LP string(15)
!
! 40 Dates passwords last changed integer(x2)
! (may not be reset)
!
! 41 Password data integer(x8)
!
! 42 Get accounting data integer(x17)
!
! 43 Mail count integer
! (may be reset only by privileged processes)
!
! 44 Supervisor string(6)
!
! 45 Secure record about 512 bytes
!
! 46 Gateway access id string(15)
!
! 47 File index attributes byte
!
! 48 User type byte
EXTERNALINTEGERFNSPEC DTOFF(RECORD (pe)NAME P)
EXTERNALINTEGERFNSPEC DTRANSFER(STRINGNAME FILE INDEX1, FILE INDEX2, FILE1, C
FILE2, INTEGERNAME FSYS1, FSYS2, TYPE)
! This procedure transfers FILE1 belonging to file index FILE INDEX1 on
! FSYS1 to the ownership of file index FILE INDEX2 on FSYS2 under name
! FILE2.
!
! TYPE = 0 'accepts' a file which has been 'offered'. This call
! is non-privileged.
! 1 a privileged call to transfer a file.
! 2 like 1, but, in addition, forces a re-allocation of the
! disc space.
! 3 a privileged call to copy the file.
! 4 as 3 but works even when file connected W (for test purposes)
finish
!*
!*
!*
externalroutinespec dump(integer start, finish, conad)
externalroutinespec i to e(integer ad, l)
externalstringfnspec i to s(integer value)
externalstringfnspec h to s(integer value, places)
externalintegerfnspec s to i(stringname s)
externalroutinespec pt rec(record (pe)name p)
externalroutinespec print log(integer stream,q)
externalroutinespec prompt(string (23) s)
!*
!*
! E X T E R N A L V A R I A B L E S
! - - - - - - - - - - - - - - - - -
extrinsicinteger com36; !ADDRESS OF RESTART REGISTERS
extrinsicinteger oper no; !CURRENT OPER OUTPUT CONSOLE
extrinsicinteger my fsys; !FTRANS FILE SYSTEM
extrinsicinteger my service number; !FTRANS SERVICE NUMBER
extrinsicstring (6) my name; !FTRANS USERNAME
!*
!*
!*
!*
!
!*************************************************************************
!THE MAIN ENTRY POINT TO THE FTRANS EXECUTIVE PROCESS.
!
!
externalroutine control(integer lines,database conad,pointers addr)
!
! MAX Fsys Maximum number of FSYS
! QCONAD Address of basic queue description area.
! LINES Number of file transfer lines available
! LCONAD Address of the LINE descriptor area.
! LNCONAD Address of the 'short' LINE descriptor area.
! FTP STNS Number of external FTP hosts.
! STCONAD Address of the external host table area.
! LINK LIST CONAD Address of the LINK LIST area.
! N O T E here that the control values MAX FTP LINES, FTP Q LINES,
! FTP SERVICE and FTP LIMIT are contained in the first FTP STATION record.
! I N T E G E R S
! - - - - - - - -
integer temp, free list, erase, kicked, stopping, c
mon level, e page size, block size, closing,
FTP check, FTP queue , pt, ptl, ms, msl, picture tick, status header change, ada, refresh line
integer lconad, qconad, stconad, link list conad, FTP stns, control entry, guest entry, address cache addr, hash length
if TARGET # 2900 start
string (63) dsfis
integerarray dsfiia(1:32)
finish
STRING (63) MAIL MC
INTEGER MAIL DIS
!
msl = 0; ptl = 0
!*
!*
! S T R I N G N A M E S
! - - - - - - - - - - -
!*
!*
! I N T E G E R N A M E S
! - - - - - - - - - - - -
!*
!*
! S T R I N G S
! - - - - - - -
string (31) PSS, IPSS
string (63) send message
string (11) system
!
!*
!*
! R E C O R D N A M E S
! - - - - - - - - - - -
! - - - - - - - - - - -
if TARGET = 2900 start
constrecord (comf)name com = x'80000000'+48<<seg shift
finish else start
constrecord (comf)name com = 31 << seg shift
finish
record (name f)name name entry
record (queuef)name queue
record (ftp pointers f)name pointers
!*
!*
! R E C O R D A R R A Y F O R M A T S
! - - - - - - - - - - - - - - - - - -
record (lcf)arrayformat list cells af(1 : list size)
record (linef)arrayformat larf(1 : lines)
record (FTP stationf) arrayformat FTPsf(1: max stations)
record (exp addr f)arrayformat exp addr af(1: max stations)
!*
!*
! R E C O R D A R R A Y N A M E S
! - - - - - - - - - - - - - - - -
record (lcf)arrayname list cells
record (linef)arrayname FTP lines
record (FTP stationf) arrayname FTP stations
record (exp addr f)arrayname expanded addresses
!*
!*
! R E C O R D S
! - - - - - - -
!*
!*
! B Y T E I N T E G E R A R R A Y S
! - - - - - - - - - - - - - - - - -
byteintegerarray kick(1 : lines); !SIGNIFICANCE: 2**0 KICK line INTO ACTION SOMETHING TO DO
!* 2**1 STOP line I.E. SUPPRESS KICKED BIT
!*
!*
! I N T E G E R A R R A Y S
! - - - - - - - - - - - - -
integerarray line addresses ( 1 : lines )
! only used for FTP summary picture so only one such array necessary ( since only one summary held at once )
!*
! R E C O R D A R R A Y S
! - - - - - - - - - - - -
record (opf)array oper(-1 : max oper)
record (fepf)array feps(0 : max fep)
record (f systems f)array f systems(0 : max fsys)
record (FTP tablef)array FTP tables(0:lines)
record (picturef)array pictures ( 1:max pic files)
record (screenf) array screens ( 0:max screen )
!*
!*
! R O U T I N E S A N D F U N C T I O N S S P E C S
! - - - - - - - - - - - - - - - - - - - - - - - - -
routinespec move with overlap(integer length, from, to)
integerfnspec generate pic(integer pic,picture type,id1, refresh, string (15) id2)
routinespec picture manager(record (pe)name p,integer picture type,id1,string (15) id2)
routinespec initialise pictures
routinespec refresh pic(integer pic type, id1, string (15) id2 )
stringfnspec ident to s(integer ident)
routinespec user message(record (pe)name p)
routinespec update descriptors(integer fsys)
routinespec display text(integer oper no, line, col, string (255) s)
routinespec update oper(integer oper no, display type, which display,
which page, switch screen, string (10) specific user)
stringfnspec dt
stringfnspec users delivery(string (6) u, integer fsys)
routinespec opmessage(record (pe)name p)
routinespec switch gear
integerfnspec check filename(string (6) u,string (15) f, integer fsys, allow temp)
routinespec interpret descriptor(integer type ,a,integername l, string (6) user,
integername ident, f)
routinespec interpret command(string (255) s,string (6) user, integer console )
routinespec initialise
routinespec user command(string (255) s,
string (6) u, integername f)
routinespec add to queue(integer ident,delay, all, fixed delay,
integername flag)
routinespec remove from queue(integer ident,
integername flag)
routinespec delete document(integer ident, integername flag)
integerfnspec document addr(integer ident)
integerfnspec password document addr(integer ident)
routinespec connect or create(string (6) u,
string (11) f, integer fs, size, mode, flgs, integername cad)
routinespec output message reply from fep(record (pe)name p)
routinespec FTP input message from fep(record (pe)name p)
routinespec FTP output message to fep(integer fep, record (FTP f)name FTP)
routinespec FTP control(record (pe)name p, integername refresh line)
routinespec requeue FTP document(integer document,delay,all,fixed)
routinespec fire clock tick
routinespec clock ticks
routinespec set document timers(integer addr ptr, time, specific document)
routinespec check FTP(integer line)
routinespec handle close(record (pe)name p)
routinespec close fsys(integer fsys)
routinespec time out(integer remote number)
routinespec fep down(integer fep)
routinespec open fep(record (pe)name p)
routinespec open file system(integer fsys)
routinespec any extra files(integer fsys,special)
stringfnspec errs(integer flag) {used to decide on D call}
!*
!*
!*
!*
!INITIAL ENTRY HERE
if TARGET = 2900 start
*stln_temp; !TO ALLOW NDIAGS TO EXIT FROM CONTROL
finish else start
*st_10,temp
finish
com36 = temp
! temp = change context
print string("FTRANS ".version.snl)
!TELL OPERATOR CONSOLE WE HAVE STARTED
if lines = 0 then c
printstring("CONFIGURATION FAILURE".snl."F/STOP , F/CONFIG only".snl) c
else start
POINTERS == record(pointers addr)
FTP stns = POINTERS_STATIONS
QCONAD = DATABASE CONAD + POINTERS_QUEUE DISPL
LCONAD = DATABASE CONAD + POINTERS_STREAM DISPL
ST CONAD = DATABASE CONAD + POINTERS_STATION DISPL
LINK LIST CONAD = DATABASE CONAD + POINTERS_LINK LIST DISPL
hash length = pointers_hash length
address cache addr = databaseconad + pointers_station addresses displ
expanded addresses == array(database conad + pointers_expanded address displ, exp addr af)
list cells == array(link list conad, list cells af)
FTP lines == array(lconad, larf)
FTP stations == array(stconad,FTPsf)
queue == record(qconad)
guest entry = pointers_guest entry
control entry = pointers_control entry
finish
INITIALISE
!SET UP TABLES AND LISTS
!*
! MAIN LOOP OF THE FTRANS EXECUTIVE
!*
cycle
switch gear; !IF WE EXIT GO ROUND AGAIN
print log(1,jrnl)
!HERE DO THE SAME AS VOLUMS
repeat
!*
!*
routine switch gear
!**********************************************************************
!* *
!* ACCEPTS IN COMMING MESSAGES TO FTRANS AND SWITCHES TO THE *
!* APPROPRIATE ROUTINE. IF ANY ERRORS OCCUR IN A SUBSEQUENTLY CALLED *
!* ROUTINE THE STACK IS COLLAPSED TO THE LEVEL OF THIS ROUTINE AND A *
!* RETURN IS MADE FROM THIS ROUTINE. *
!* *
!**********************************************************************
integer temp, dact
switch sw(0 : 127); ! 1 FOR EACH ACTIVITY
record (pe)p
!*
if TARGET = 2900 start
*stln_temp; !TO ALLOW NDIAGS TO EXIT FROM CONTROL
finish else start
*st_9,temp
finish
com36 = temp
dact = 0; !HOLD LAST ACTIVITY
!*
! MAIN LOOP OF THE FTRANS EXECUTIVE
!*
wait:
! CLOSE DOWN(COM_SECS TO CD) %IF 0 < COM_SECS TO CD <= 900
if stopping = yes start ; !REQUESTED TO STOP?
cycle temp = 1, 1, lines
-> out if FTP lines(temp)_status >= allocated
repeat
cycle temp = 0, 1, max fep
fep down(temp) if feps(temp)_FTP available = yes
!DISABLE COMMS STREAMS
repeat
stop
finish
out:
if kicked # 0 start ; !ANY lineS KICKED INTO ACTION
FTP check = on; !switch FTP check on
cycle temp = kicked, 1, lines
if kick(temp)&3 = 1 start ;!THIS LINE NOT STOPPED AND KICKED
kick(temp) = 0
kicked = temp
if FTP check = on and FTP stations(control entry)_service = open c
and FTP stations(control entry)_max lines > 0 and FTP stations(control entry)_limit > 0 c
and FTP lines(kicked)_status = unallocated then check FTP(kicked)
!the non dedicted FTP lines are 'LOCAL' owned for general FTP
!transactions from the FTP queue as a P station or as
!Q stations for the outside world
continue
finish
repeat
kicked = 0
finish
!SIT HERE WAITING FOR SOMETHING TO DO
if mon level = 1 or mon level = 5 start
select output(1)
printstring(dt."SLEEPING, last activity costs pt/ms: ")
if TARGET # 2900 start
temp = dsfi(my name,my fsys,24,0,dsfis,dsfiia)
pt = dsfiia(1)
temp = dsfi(my name,my fsys,28,0,dsfis,dsfiia)
ms = dsfiia(1)
finish else start
temp = dsfi(my name,my fsys,24,0,addr(pt))
temp = dsfi(my name,my fsys,28,0,addr(ms))
finish
printstring(i to s(pt-ptl)." / ".i to s(ms-msl).snl)
p=0
if TARGET # 2900 then temp = dtoff(p) else dtoff(p)
if p_dest = 0 start
printstring(dt."No Work".snl)
if TARGET # 2900 then temp = dpoff(p) else dpoff(p)
finish
if TARGET # 2900 start
temp = dsfi(my name,my fsys,24,0,dsfis,dsfiia)
ptl = dsfiia(1)
temp = dsfi(my name,my fsys,28,0,dsfis,dsfiia)
msl = dsfiia(1)
finish else start
temp = dsfi(my name,my fsys,24,0,addr(ptl))
temp = dsfi(my name,my fsys,28,0,addr(msl))
finish
print string(dt."POFF ")
pt rec(p)
select output(0); !BACK TO OPER
finish else start
p=0
if TARGET # 2900 then temp = dtoff(p) else dtoff(p)
if p_dest = 0 then start
if TARGET # 2900 then temp = dpoff(p) else dpoff(p)
finish
finish
if dact # p_dest&127 start ; !SAME AS PREVIOUS ACTIVITY?
dact = p_dest&127
! temp = change context
finish
-> sw(dact); !GO DO SOME THING
sw(clock tick): !tick of the clock
! UPDATE OPER( P_P1, OPER(P_P1)_DISPLAY TYPE, OPER(P %C
! _P1)_WHICH DISPLAY, OPER(P_P1)_WHICH PAGE, NO, "")
fire clock tick
clock ticks
!IE WE REQUIRE TICKING TO CONTINUE FOR AT LEAST 1 REMOTE OR FILETRAN WAIT.
-> wait
sw(descriptor update):
!update descriptors(p_p1)
->wait
sw(solicited oper message):
sw(unsolicited oper message):
opmessage(p); -> wait; !OPERATOR MESSAGE
sw(picture maintainance):
picture manager(p,0,0,""); -> wait
sw(open fsys):
open file system(p_p1); -> wait; !NEW FILE SYSTEM ONLINE
sw(user mess): !message from a user
user message(p); -> wait
sw(FTP input mess):
FTP input message from fep(p); -> wait
sw(FTP output reply mess):
output message reply from fep(p); -> wait
sw(FTP input control connect):
sw(FTP input control connect reply):
sw(FTP output control connect reply):
sw(FTP input control enable reply):
sw(FTP output control enable reply):
sw(fep input control connect):
open fep(p); -> wait
sw(close control):
handle close(p)
-> wait
sw(FTP connect):
sw(FTP input connected):
sw(FTP output connected):
sw(FTP input control message):
sw(FTP output control message):
sw(FTP input disconnected):
sw(FTP output disconnected):
sw(FTP p command reply):
sw(FTP p command sent):
sw(FTP data input):
sw(FTP q command reply):
sw(FTP q command sent):
sw(FTP command overflow):
sw(FTP input aborted):
sw(FTP output aborted):
sw(FTP timed out):
sw(FTP confirmation from spooler):
FTP control(p,refresh line)
if refresh line # 0 then refresh pic(FTP status summary display, refresh line, "")
-> wait
sw(spooler reply act):
!This is a response after SPOOLR has processed A log request by DEXECMESS.
!If it fails there is little we can do but record the fact.
if p_p1 # 0 start
select output(1)
printstring(dt."Log transfer, SPOOLR replies with flag of ".itos(p_p1).snl)
select output(0)
finish
-> wait
!* ALL ILLEGAL ACTIVITIES COME HERE
sw(*):
print string("FTRANS BAD DACT "); pt rec(p)
-> wait
!*
! END OF FTRANS EXECUTIVE MAIN LOOP
end ; !OF ROUTINE SWITCH GEAR
!*
!*
!*
!*
routine kick FTP line(integer line)
!**********************************************************************
!* *
!* SETS THE KICKED BIT FOR THE SPECIFIED line AND REMEMBERS THE *
!* LOWEST NUMBERED KICKED line *
!* *
!**********************************************************************
kick(line) = kick(line)!1; !SET KICKED BIT
kicked = line if kicked = 0 or line < kicked
end ; !OF ROUTINE KICK LINE
!*
!*
stringfn i to s s(integer i, l)
!***********************************************************************
!* *
!* TURNS AN INTEGER INTO A STRING OF THE SPECIFIED LENGTH PADDING *
!* WITH LEADING SPACES IF NECESSARY. *
!* *
!***********************************************************************
string (255) s
s = i to s(i)
s = " ".s while length(s) < l
result = s
end ; !OF STRINGFN I TO SS
!*
!*
routine to doc string(record (document descriptorf)name document,
byteintegername field, stringname value)
field = 0 and return if value = ""
field = x'ff' and return if document_string ptr + length(value) > 147
field = document_string ptr
string(addr(document_string space) + document_string ptr) = value
document_string ptr = document_string ptr + length(value) + 1
end
string fn string at(record (FTP station f)name station, integer ptr)
!This fn passes back a string from the string pool in the station
!descriptor record.
STRING (255) S
S = string(addr(station_string space(0)) + ptr)
RESULT = S
end
stringfn doc string(record (document descriptor f)name document,
byteintegername ptr)
if ptr = 0 then result = "" else c
result = string(addr(document_string space) + ptr)
end
stringfn password doc string(record (password document descriptor f)name document,
byteintegername ptr)
if ptr = 0 then result = "" else c
result = string(addr(document_string space) + ptr)
end
!*
stringfn errs(integer flag)
integer i; string (63) error
if TARGET = 2900 then result = derrs(flag) ELSE START
i = dflag(flag,error)
result = error
FINISH
end
!*
!*
string (23) fn dt
!***********************************************************************
!* *
!* RETURNS THE DATE AND TIME IN A FIXED FORMAT *
!* *
!***********************************************************************
result = "DT: ".date." ".time." "
end ; !OF STRINGFN DT
!*
!*
string (15) fn hms(integer secs)
!***********************************************************************
!* *
!* RETURNS THE GIVEN NUMBER OF SECONDS IN THE FORMAT HH.MM.SS *
!* *
!***********************************************************************
integer hrs, mins, scs, i
string (15) s
hrs = secs//3600
i = secs-hrs*3600
mins = i//60
scs = i-mins*60
if hrs > 0 then s = i to s(hrs)."h " else s = ""
s = s.i to s(mins)."m " if s # "" or mins > 0
result = s.i to s(scs)."s"
end ; !OF STRINGFN HMS
!*
!*
integerfn compute priority( c
integer type, resource, resource limit)
resource = resource limit if resource > resource limit
result = prtys(type)+max priority-(max priority* c
resource)//resource limit
end ; !OF INTEGERFN COMPUTE PRIORITY
!*
!*
routine age queue(integer resource used)
integer a, next
resource used = queue_resource limit c
if resource used > queue_resource limit
a = ((max priority*resource used)//queue_resource limit)// c
small weight
next = queue_head
while next # 0 cycle
if list cells(next)_priority > 0 then c
list cells(next)_priority = list cells(next)_priority+a c
else list cells(next)_priority = list cells(next)_priority-a
!IE UPDATE THE QUEUE LINKAGE TABLE'S COPY OF THE PRIORITY FOR THE DOCUMENT.
next = list cells(next)_link
repeat
end ; !OF ROUTINE AGE QUEUE
!*
routine clock ticks
!******************************************************
!* *
!* handle a clock tick for FTP *
!* *
!******************************************************
integer i, next, set kick
record (pe) p
!Transfer control timing is organised as follows:
!Each station has a CONNECT RETRY POINTER. This is incremented
!each time a CONNECT ATTEMPT times out (Not with a CLEAR, and
!hencne not entirley a satisfactory system). The increment drops back
!to 0 to prevent loss of access due to congested other end.
!It dictates the waiting time before the next connect attemp.
!CONNECT RETRY TIME in each station is the actual figure in minutes
!that has to yet elapse before a connection is attempted. This
!is mirrored in the FTP TMIER filed of each document queued for
!that station, but this is only to avoid excessive thrashing when
!we look for a document to service for a line. The FTP TIMER field
!can also have its own meaning when a single document is earmarked for
!a fixed time delay (ie a DEFERRED document on size). in this case
!it is not cleared down when CONNECT RETRY TIME is.
set kick = no
cycle i = 1,1,lines
continue if FTP lines(i)_status <= allocated or c
FTP lines(i)_timer = 0
FTP lines(i)_timer = FTP lines(i)_timer - 1
if FTP lines(i)_timer = 0 start
!we have a time out on an FTP function.
p = 0; p_dest = FTP timed out ! i<<7
FTP control(p,refresh line)
if refresh line # 0 then refresh pic(FTP status summary display, refresh line, "")
finish
repeat
!Now look at the FILETRAN queue for 'wait' timing
cycle i = 1,1,ftp stns
if FTP stations(i)_connect retry time > 0 start
FTP stations(i)_connect retry time = FTP stations(i)_connect retry time - 1
if ftp stations(i)_connect retry time = 0 then set kick = yes
finish
repeat
next = queue_head
while next # 0 cycle
if list cells(next)_FTP timer > 0 start
list cells(next)_FTP timer = list cells(next)_FTP timer - 1
if list cells(next)_FTP timer = 0 start
!a transfer has completed a wait, kick the lines
list cells(next)_FTP flags = list cells(next)_FTP flags&FTP no fixed term delay
!Take of the 'fixed' delaymarker(ie for Deffered transfers)
set kick = yes
finish
finish
next = list cells(next)_link
repeat
if set kick = yes start
cycle i = 1,1,lines
kick FTP line(i)
repeat
finish
return
end ; !of routine clock ticks
!*
routine fire clock tick
!**************************************************
!* *
!* REQUEST A CLOCK TICK *
!* *
!**************************************************
record (pe)p
integer flag
p = 0
p_dest = elapsed int
p_p1 = my service number ! clock tick
p_p2 = default clock tick
flag = dpon3("", p, 0, 0, 6)
end ; !OF ROUTINE FIRE CLOCK TICK.
!*
; !OF ROUTINE POLL FEPS.
!*
!*
routine set document timers(integer addr ptr,time, specific document)
integer next
next = queue_head
while next # 0 cycle
if specific document = 0 or specific document = list cells(next)_document start
if list cells(next)_station ptr = addr ptr and c
list cells(next)_FTP flags&FTP fixed term delay = 0 then c
list cells(next)_FTP timer = time
!only set the timer if the fixed term delay is off.
exit if specific document # 0
finish
!This specific document bit is for GUEST documents. (See ADD TO QUEUE for details)
next = list cells(next)_link
repeat
!Also set the station CONNECT RETRY TIME
FTP stations(addr ptr)_connect retry time = time
return
end ; !of routine set document timers
!*
routine check FTP(integer line)
!*************************************************************
!* *
!* this routine looks at the FILETRAN queue to see if there *
!* is a transfer that can be started and is not under any *
!* restriction by waiting etc. *
!* *
!*************************************************************
integer next, found one, i, j, count, fep, specific document
string (75) caller, called, residue, guest address, s1, s2
record (linef)name FTP line
record (FTP tablef)name FTP table
record (FTP f) FTP
record (document descriptorf)name document
record (FTP stationf)name FTP station
integerfn all numeric(stringname s)
integer i
result = yes if length(s) = 0
cycle i = 1,1,length(s)
result = no unless x'30' <= byteinteger(addr(s)+i) <= x'39'
repeat
result = yes
end
count = 0
!first check to see if we have a P station slot available.
cycle i = 1,1,lines
count = count + 1 if FTP lines(i)_status >= active c
and FTP lines(i)_status # deallocating and FTP lines(i)_station type = P station
repeat
if count >= FTP stations(control entry)_max lines - FTP stations(control entry)_q lines start
select output(1)
printstring(dt."FTP: Max P stations active, waiting.".snl)
select output(0)
FTP check = off
return
finish
!ok to proceed as a potential P station.
FTP line == FTP lines(line)
FTP table == FTP tables(line)
next = queue_head
while next # 0 cycle
if (list cells(next)_size+1023)>>10 <= FTP stations(control entry)_limit and list cells(next)_FTP timer = 0 c
and (list cells(next)_size+1023)>>10 <= FTP stations(list cells(next)_station ptr)_limit c
and FTP stations(list cells(next)_station ptr)_service = open start
!ie the transfer is within the overall transfer limit, has no timer
!set and the station can accept this size of transfer and it's service open.
found one = yes
if list cells(next)_station ptr = guest entry start
document == record(document addr(list cells(next)_document))
guest address = docstring(document,document_guest address)
finish
cycle i = 1,1,lines
if FTP lines(i)_station ptr = list cells(next)_ c
station ptr and (FTP lines(i)_status = connecting c
or FTP lines(i)_status = selected) start
if FTP lines(i)_station ptr = guest entry start
document == record(document addr(FTP lines(i)_document))
called = docstring(document,document_guest address)
if mon level = 8 then c
printstring("GUEST check for ".itos(i).snl.called.snl.guest address.snl)
if called # guest address then -> not same
if mon level = 8 then printstring("No connect".snl)
finish
!we are already trying a connection/allocation to that station, wait.
found one = no
if FTP lines(i)_station ptr = guest entry then j = list cells(next)_document c
else j = 0
set document timers(list cells(next)_station ptr,connect delay,j)
!ie set the delay timer for all transfers queued for this station.
exit
finish
NOT SAME:
repeat
if found one = yes start
!now check that this station is not to its individual simult. transfer
!capacity, if it is set the delay timer on all docs for this station.
!we still have a transfer to attempt
count = 0
cycle i = 1,1,lines
if FTP lines(i)_status >= active and FTP lines(i)_status # deallocating and FTP lines( c
i)_station ptr = list cells(next)_station ptr c
then count = count + 1
repeat
if count >= FTP stations(list cells(next)_station ptr)_max lines start
found one = no
set document timers(list cells(next)_station ptr,station capacity retry time,0)
finish
finish
fep = FTP stations(list cells(next)_station ptr)_fep
if list cells(next)_station ptr = guest entry and document_ c
specific fep # -1 then fep = document_specific fep
if (feps(fep)_FTP available = no or feps(fep)_outgoing calls permitted = no c
or (feps(fep)_comms type = NSI type and c
FTP stations(list cells(next)_station ptr)_address type >= TS type) ) c
or (list cells(next)_station ptr = guest entry c
and document_specific fep = -1) start
fep = -1
if list cells(next)_station ptr = guest entry then specific c
document = list cells(next)_document else specific document = 0
unless list cells(next)_station ptr = guest entry and document_ specific fep # -1 start
cycle i = 0,1,max fep
if feps(i)_FTP available = yes and feps(i)_outgoing calls permitted = yes start
if FTP stations(list cells(next)_station ptr)_address type = TS type start
if feps(i)_comms type >= TS type {TS, X25 or BSP} then fep = i and exit
finish else if feps(i)_comms type = NSI type and list cells(next)_ c
station ptr # guest entry then fep = i and exit
finish
repeat
finish
select output(1)
if fep # -1 then printstring(dt."FTP FEP ". c
itos(fep)." chosen as alternative".snl) and select output(0) else start
printstring(dt."FTP FEP ".i to s(FTP stations(list cells(next)_station ptr)_fep). c
" not available(no alternative).".snl)
select output(0)
found one = no
set document timers(list cells(next)_station ptr,station capacity retry time,specific document)
finish
finish
if found one = yes start
!still have a transfer.
FTP line_station ptr = list cells(next)_station ptr
!mark the document as being served by allocation attempt.
FTP line_bytes transferred = 0
FTP line_timer = FTP selected timeout
FTP line_status = selected
FTP line_document = list cells(next)_document
document == record(document addr(ftp line_document))
FTP line_user = document_user
FTP line_station type = p station
refresh pic(ftp status summary display,line,"")
FTP = 0
if FTP stations(FTP line_station ptr)_address type = TS type then c
FTP_type = 4 else FTP_type = 1; !allocate request
FTP_pair ref = line
FTP station == FTP stations(FTP line_station ptr)
if FTP station_address type = TS type start
caller = spoolFTP
if document_user = "MAILER" then caller = caller.".".spoolmail
if FTP line_station ptr = guest entry then called = docstring( c
document,document_guest address) c
else called = string(address cache addr+FTP station_address(1))
!Now check to see if PSS or IPSS acred required.
if called -> s1.("(PSS)").s2 then called = s1."(".PSS.")".s2 c
else if called -> s1.("(IPSS)").s2 then called = s1."(".IPSS.")".s2
called = called.".".string at(FTP station,FTP station_FTP) if c
FTP line_station ptr # guest entry
if document_user = "MAILER" and FTP line_station ptr # guest entry c
then called = called.".".string at(FTP station,FTP station_mail)
select output(1)
printstring(dt."FTP TS outgoing call on ".called." by ".caller.snl)
select output(0)
byteinteger(addr(FTP_address)) = length(caller) + length(called) + 2
string(addr(FTP_address)+1) = called
string(addr(FTP_address)+2+length(called)) = caller
finish else start
FTP_address = string(address cache addr+FTP stations(FTP line_station ptr)_address(1))
if FTP stations(FTP line_station ptr)_pss entry # 0 then c
FTP_address = FTP_address.".F".itos(FTP stations(FTP line_station ptr)_ c
pss entry)
finish
if TARGET = 2900 then FTP_length = length(FTP_address) + 1 + FTP std mess len
FTP output message to fep(fep,FTP)
return
finish
finish
next = list cells(next)_link
repeat
FTP check = off; !since we found nothing there is no point for any other line.
return
end ; !of routine check FTP.
!*
!*
integerfn sdestroy(string (6) user, string (11) file, c
string (8) date, integer fsys, type)
!********************************************************************
!* *
!* SPECIAL DESTROY FOR FILES THAT MAY BE IN USE *
!* *
!********************************************************************
integer flag
flag = ddestroy(user, file, date, fsys, type)
result = flag unless flag = 40; ! CAN'T HANDLE OTHER FAILURES APART
! FROM 'IN USE'
if TARGET # 2900 then flag = dcreate(user, "##", fsys, 4, 4, ada) c
else flag = dcreate(user, "##", fsys, 4, 4); ! CREATE DUMMY FILE
! ZERO IT TO CLEAR VIOLAT
result = flag if 0 # flag # 16; ! OK IF ALREADY THERE
flag = dnewgen(user, file, "##", fsys)
result = flag unless flag = 0
flag = ddestroy(user, file, date, fsys, type)
result = flag
end
!*
!*
integerfn get block addresses(string (6) user,
string (11) file, integer fsys, address)
!********************************************************************
!* *
!* THIS FUNCTION RETURNS THE NUMBER OF BLOCKS IN A FILE, THE *
!* LENGTH OF EACH BLOCK IN EPAGES AND THE LENGTH OF THE LAST BLOCK *
!* IN EPAGES. ALSO THE DISC ADDRESSES OF EACH BLOCK. THIS FUNCTION *
!* IS SUPPOSED TO WORK FOR SECTION SIZES WHICH ARE MULIPLES OF THE *
!* BLOCK SIZE. *
!* NOTE: ALSO SETS THE GLOBAL VARIABLE "BLOCK SIZE" TO THE NUMBER *
!* OF BYTES IN A BLOCK. *
!* *
!********************************************************************
recordformat sectf(integer sectsi, nsects, last sect,
blk size, integerarray da(1 : 256))
record (sectf)disc sect
record (daf)name daddr
integer flag, mult, in last, inc, i, j, k
!*
if TARGET # 2900 start
daddr == record(address)
flag = dgetda(user, file, fsys, daddr_i)
! printstring("Raw DGETDA : ".htos(daddr_i(0),8)." ".htos(daddr_i(1),8). %c
! snl.htos(daddr_i(2),8)." ".htos(daddr_i(3),8)." ".htos(daddr_i(4),8).snl)
move(12, addr(daddr_i(0)),addr(daddr_sparex))
! printstring("blksi: ".htos(daddr_blksi,8)." nblks: ".htos(daddr_nblks,8). %c
! snl."last blk: ".htos(daddr_last blk,8)." ADDR blk1: ".htos(daddr_da(1),8).snl)
finish else flag = dgetda(user, file, fsys, addr(disc sect))
!GET ADDRESSES OF DISC SECTIONS
if flag = 0 start
if TARGET # 2900 start
block size = daddr_blksi*e page size
result = flag
finish
block size = disc sect_blk size*epage size
!ONLY REALLY NEEDS TO BE SET ONCE
daddr == record(address)
daddr_blk si = disc sect_blk size; !GET BLOCK SIZE IN E PAGES
mult = disc sect_sectsi//disc sect_blk size
!NUMBER OF BLOCKS IN A SECTION
in last = (disc sect_last sect-1)//disc sect_blk size+1
!NUMBER OF BLOCKS IN LAST SECTION
daddr_nblks = (disc sect_nsects-1)*mult+inlast
!TOTAL NUMBER OF BLOCKS
daddr_last blk = disc sect_last sect-(in last-1)* c
disc sect_blk size
!EPAGES IN LAST BLOCK
k = 1
cycle i = 1, 1, disc sect_nsects; !EACH SECTION
inc = 0
cycle j = 1, 1, mult; !EACH BLOCK IN SECTION
daddr_da(k) = disc sect_da(i)+inc; !SET BLOCK DISC ADDRESSES
exit if k = daddr_nblks
k = k+1
inc = inc+disc sect_blk size
repeat
repeat
finish
result = flag
end ; !OF INTEGERFN GET BLOCK ADDRESSES
!*
!*
recordformat cf(integer dest, srce, string (23) s)
routine opmessage(record (cf)name p)
!********************************************************************
!* *
!* THIS ROUTINE ACCEPTS MESSAGES FROM THE LOCAL OPERATOR EITHER *
!* IN RESPONSE TO PROMPTS OR AS UNSOLICITED MESSAGES. *
!* *
!********************************************************************
string (41) s
oper no = (p_srce>>8)&7; !REMEMBER OPER MESSAGE CAME FROM
if p_dest&127 = solicited oper message start
!SOLICITED OPER MESSAGE (I.E.PROMPT UP)
if charno(p_s, length(p_s)) = nl start
!FULL MESSAGE?
length(p_s) = length(p_s)-1;!REMOVE NEWLINE
s = oper(oper no)_command.p_s; !CONCATENATE TO PARTIAL COMMAND ALREADY RECEIVED
oper(oper no)_command = ""
finish else start ; !NOT A FULL MESSAGE SO APPEND
oper(oper no)_command = oper(oper no)_command.p_s
s = ""
finish
finish else s = p_s
if s # "" start ; !IGNORE NULL LINES
select output(1)
print string(dt."FROM OPER".i to s(operno)." ".s.snl)
select output(0)
interpret command(s, "",p_SRCE & X'FFFFFF00' )
prompt(my name.":") if oper(oper no)_prompt on = yes
finish
end ; !OF ROUTINE OPMESSAGE
!*
!*
recordformat pf(integer dest, srce,string (7) user,
integer p3, p4, p5, p6)
routine user message(record (pf)name p)
!********************************************************************
!* *
!* THIS ROUTINE RECEIVES MESSAGES FROM USERS EITHER AS REQUESTS TO *
!* PUT DOCUMENTS IN QUEUES OR AS QUERIES ABOUT DOCUMENTS IN QUEUES *
!* *
!********************************************************************
record (pe)name pp
string (255) s, t
byteintegerarray mess(0:311)
string (7) user, REMOTE user
integer len, flag, ident, dlen, bin doc
bin doc = no
top: ident = 0
len = 311; !MAX SIZE OF MESSAGE PREPARED TO ACCEPT
if TARGET # 2900 then flag = dmessage("",len,0,0,my fsys, c
addr(mess(1))) else flag = dmessage("", len, 0, my fsys, addr(mess(1)))
!GIVE ME NEXT MESSAGE
if flag = 0 start
if len > 255 then mess(0) = 255 else mess(0) = len
if mon level = 1 start
select output(1)
cycle dlen = 0,1,len
printstring(htos(mess(dlen),2))
repeat
newline
select output(0)
finish
s = string(addr(mess(0)))
if s -> t.("BINDOC:").s start
bin doc = yes
!This is a full binary descriptor
dlen = mess(0)-length(s)+1
!ie the start of the binary document in MESS
if len-dlen+1 # 256 start
!the record should have been 256 bytes!
printstring("Bad BIN document length!".snl)
len = 0
finish
s = t."BINDOC:".s
finish
if len > 0 start ; !CHECK THERE WAS A MESSAGE
if s -> t.("**").user.(" ").s c
and s -> t.(": ").s start
!REMOVE INFO NOT REQUIRED
length(s) = length(s)-1 while 0 < length(s) c
and charno(s, length(s)) = nl
!STRIP NEWLINES
length(user) = 6; !REMOVE BELL CHAR FROM USERNAME
select output(1)
if bin doc = no then print string(dt."FROM ".user." ".s.snl) c
else printstring(dt."Document FROM ".user.snl)
select output(0)
if user # p_user start
select output(1)
print string(dt. c
" ABOVE MESSAGE DISCARDED POFFED MESSAGE FROM ". c
p_user.snl)
select output(0)
-> top
finish
if bin doc = yes start
len = 256
interpret descriptor(user call, addr(mess(dlen)), len, user, ident, flag)
finish else start
if s -> ns1.("COMMAND ").s and ns1="" then c
user command(s, user, flag) else flag = bad params
finish
finish else flag = bad params; !START OF MESSAGE INVALID
finish else flag = bad params; !LENGTH INVALID
finish ; !BAD FLAG FROM DIRECTOR
if flag # 0 start
select output(1)
print string(dt."USER MESSAGE REPLY TO ".p_user. c
" FLAG ".i to s(flag).snl)
select output(0)
finish
pp == p
pp_dest = pp_srce
pp_srce = my service number!user mess
pp_p1 = flag
pp_p2 = ident
flag = dpon3("", pp, 0, 0, 6); !REPLY TO USER MESSAGE RECEIVED
end ; !OF ROUTINE USER MESSAGE
!*
!*
!*
routine update descriptors(integer fsys)
!**********************************************************************
!* *
!* THIS ROUTINE UPDATES THE DOC DESCRIPTORS ON THE DEFINED FSYS *
!* (AT LEAST THE FSYS , >= FSYS GIVEN, THAT IS ON LINE) *
!* (ALL IF FSYS=-1). THE VALUE IN QUESTION IS 'PRIORITY' WHICH IS *
!* AGED CONTINUOUSLY VIA THE VALUE HELD ON THE FTRANS SYS DISC *
!* BUT THE 'PERMANENT' COPY ON THE FILE SYSTEM DISC IS ONLY UPDATED *
!* PERIODICALLY ON THE CALL OF THIS ROUTINE TO AVOID EXCESSIVE *
!* PAGING . *
!* *
!**********************************************************************
integer j, n, next, flag
record (document descriptorf)name document
record (pe)p
if fsys = -1 then n = 0 else n = fsys
cycle
!NOW FIND OUT WHICH FSYS(>= FSYS) IS NEXT ON LINE.
cycle j=n, 1, max fsys
exit if f systems(j)_addr#0
!IE THE FSYSTEM IS CONNECTED AND IS HENCE ON LINE.
repeat
n=j+1
exit if j=max fsys and f systems(j)_addr=0
!IE THIS COULD BE THE END OF ON LINE FSYS S.
select output(1)
printstring(dt."UPDATING DESCRIPTORS ON FSYS ".itos(j).snl)
select output(0)
next=queue_head
while next#0 cycle
if list cells(next)_document>>24 = j then start
document==record(document addr(list cells(next)_document))
document_priority=list cells(next)_priority
finish
next=list cells(next)_link
repeat
exit if fsys#-1 or n>max fsys
repeat
if fsys#-1 and n<=max fsys start
!PON OFF MESSAGE TO DO THE NEXT FILE SYSTEM UPDATE
p=0
p_dest=my service number ! descriptor update
p_p1=n
flag=dpon3("", p, 0, 0, 6)
finish
end
!*
integerfn get next descriptor(integer fsys)
!********************************************************************
!* *
!* GETS THE NEXT FREE DOCUMENT DESCRIPTOR FROM THE SPOOL FILE *
!* FREE POINTER CYCLES ROUND FILE LOOKING HOPEFULLY FOR THE OLDEST *
!* FREE DESCRIPTORS SO AS NOT TO OVER WRITE RECENTLY USED ONES TO *
!* PRESERVE A HISTORY OF WHAT HAS GONE ON *
!* *
!********************************************************************
record (fhf)name file header
integer doc, flag
record (document descriptorf)arrayname documents
record (document descriptorf)arrayformat docaf(1 : max documents)
if f systems(fsys)_addr # 0 start ; !CHECK THAT A SPOOL FILE IS THERE
file header == record(f systems(fsys)_addr)
documents == array(f systems(fsys)_addr+file header_start,
docaf)
doc = file header_free hole; !FIND NEXT FREE HOLE
until doc = file header_free hole cycle
!STOP WHEN WE COME ROUND AGAIN
if documents(doc)_state = unused start
!IS DESCRIPTOR UNUSED
file header_free hole = doc+1
file header_free hole = 1 c
if file header_free hole > max documents
!WRAP ROUND
flag = sdestroy(my name,ident to s(fsys<<24!doc),"",fsys,0)
result = fsys<<24!doc
finish
doc = doc+1
doc = 1 if doc > max documents
repeat
select output(1)
print string(dt."NO FREE DOCUMENT DESCRIPTORS FSYS ". c
i to s(fsys).snl)
select output(0)
finish
result = 0
end ; !OF INTEGERFN GET NEXT DESCRIPTOR
!*
!*
routine user command(string (255) s, string (6) user, integername flag)
constinteger commands = 1
conststring (7) array command(1 : commands) = c
"DELETE"
switch com(1 : commands)
integerfnspec check param(string (255) s,
integername ident)
integerfnspec find document(string (6) user,integer ident)
string (255) param1, param2
record (linef)name FTP line
record (document descriptorf)name document
record (pe) p
integer i, ident, fsys, allow
integer ignore delete fail
!
!
!*
fsys = -1
flag = dfsys(user, fsys)
allow = no
if flag = 0 start
if s -> ("*").s start
if TARGET # 2900 start
flag = dsfi(user,fsys,38,0, dsfis, dsfiia)
i = dsfiia(1)
finish else flag = dsfi(user,fsys,38,0,addr(i))
if (i>>10)&1 = 1 then allow = yes
!ie allow the extended version of QUEUE for this user.
finish
if s -> s.(" ").param1 start
param2 = "" unless param1 -> param1.(",").param2
cycle i = 1, 1, commands
-> com(i) if s = command(i)
repeat
finish
flag = command not known
finish
return
!*
!*
com(1): !delete file
if param2 = "" start
flag = check param(param1, ident)
if flag = 0 start ; !VALID DOCUMENT IDENT
document == record(document addr(ident))
if document_user = user start
if document_state = queued start
if document_FTP alias # 0 and document_mode of access &x'8000' # 0 c
then ignore delete fail = yes else ignore delete fail = no
flag = find document(user, ident)
if flag = 0 start ; !FIND DOCUMENT IN QUEUE
remove from queue( ident, flag)
if flag = 0 start
delete document(ident, flag)
flag = 0 if ignore delete fail = yes
flag = FTRANS file create fails c
if flag # 0
finish
finish
finish else start
if document_state = transferring start
cycle i=1,1,lines
FTP line == FTP lines(i)
if FTP line_document = ident start
if FTP line_status > awaiting sft start
!we have found the FTP line on which the doc is active
FTP line_user abort = yes
p = 0
p_dest = i<<7
FTP control(p,refresh line)
if refresh line # 0 then refresh pic(ftp status summary display, c
refresh line, "")
flag = ok
return
finish else flag = not in queue and return
!if it isnt active it must already be aborting
!or being completed so best to reply as above.
finish
repeat
return
finish
flag = not in queue
finish
finish else flag = invalid descriptor
finish
finish else flag = bad params
return
!*
!*
integerfn check param(string (255) s,
integername ident)
integer afsys, i
if length(s) = 6 start
afsys = 0
cycle i = 1, 1, 2
result = invalid descriptor c
unless '0' <= charno(s, i) <= '9'
afsys = afsys*10+charno(s, i)-'0'
repeat
result = invalid descriptor c
unless 0 <= afsys <= max fsys c
and f systems(afsys)_addr # 0
ident = 0
cycle i = 3, 1, 6
result = invalid descriptor c
unless '0' <= charno(s, i) <= '9'
ident = ident*10+charno(s, i)-'0'
repeat
result = invalid descriptor c
unless 1 <= ident <= max documents
ident = afsys<<24!ident
result = 0
finish
result = invalid descriptor
end ; !OF INTEGERFN CHECK PARAM
!*
!*
integerfn find document(string (6) user,integer ident)
integer next, id
next = queue_head; !FIND FIRST DOCUMENT IN Q
while next # 0 cycle ; !SCAN DOWN QUEUE
id = list cells(next)_document; !PICK UP DOCUMENT IDENTIFIER
if id = ident start ; !THE ONE WE ARE LOOKING FOR?
if list cells(next)_user = user c
then result = 0 else result = c
invalid descriptor
!CHECK THE CORRECT USER
finish
next = list cells(next)_link
repeat
result = not in queue
end ; !OF INTEGERFN FIND DOCUMENT
end ; !OF ROUTINE USER COMMAND
!*
!*
integerfn find document(string (15) name, id, string (6) user, integername ident)
!***********************************************************************
!* *
!* ATTEMPTS TO FIND THE SPECIFIED DOCUMENT. ANY OR MANY OF THE PARAMS *
!* MAY NOT BE SPECIFIED. *
!* *
!***********************************************************************
record (document descriptor f)name document
integer next
next = queue_head; !FIND FIRST DOCUMENT IN Q
while next # 0 cycle ; !SCAN DOWN QUEUE
ident = list cells(next)_document
!PICK UP DOCUMENT IDENTIFIER
if user = "" or list cells(next)_user = user start
result = 0 if name = "" and (id = "" or id = ident to s(ident))
if name # "" start
document == record(document addr(ident))
result = 0 if name = docstring(document,document_name) c
and (id = "" or id = ident to s(ident))
finish
finish
next = list cells(next)_link
repeat
result = 1
end ; !OF INTEGERFN FIND DOCUMENT
!*
!*
integerfn check params (string (255) c
param, stringname q, name, user, ident)
!***********************************************************************
!* *
!* *
!***********************************************************************
integer i, id, afsys
q = ""; name = ""; user = ""; ident = ""
if param -> q.(" ").param start ; !Q THE
if 1 <= length(q) <= 15 start ; !RIGHT LT
if param -> user.(" ").name start
result = 0 if length(user) = 6 c
and 1 <= length(name) <= 15
finish
finish else result = 1
finish
if length(param) = 6 start
afsys = 0
cycle i = 1, 1, 2
result = 1 unless '0' <= charno(param, i) <= '9'
afsys = afsys*10+charno(param, i)-'0'
repeat
result = 1 unless 0 <= afsys <= max fsys
id = 0
cycle i = 3, 1, 6
result = 1 unless '0' <= charno(param, i) <= '9'
id = id*10+charno(param, i)-'0'
repeat
result = 1 unless 1 <= id <= max documents
ident = param
result = 0
finish
result = 1
end ; !OF ROUTINE CHECK PARAM
!*
!*
routine interpret command(string (255) command, string (6) user, integer console)
!***********************************************************************
!* *
!* FTRANS COMMAND INTERPRETATION ROUTINE. INTERPRETS MAIN FRAME *
!* OPERATOR COMMANDS AND INTERACTIVE USER *
!* COMMANDS. THE STRING "COMMAND" CONTAINS THE COMMAND AND THE STRING *
!* SOURCE IS THE PERSON WHO SENT THE COMMAND. *
!* *
!***********************************************************************
constinteger command limit = 69
switch swt(1 : command limit)
integer i, j, k, l, line, flag, q no, id, fe, op no
integer command length, link, special
integer flags, next, after
record (document descriptorf)name document
record (pe)p
string (0) zstr
string (15) q, name, ident
string (10) specific user
string (31) param1, param2
string (63) reply, param
string (63) array words(1:15)
routinespec abort line(integer line)
integerfnspec find FTP line(string (255) line)
conststring (15) array comm(1 : command limit) = c
"FEP", "LAST", "NEXT", "SERVICE", "CLOSEFEP", "OPENFEP",
""(6),
"", "START", "STOP", "", "", "ABORT",
""(3), "TIDY", "PRINT", "MON",
"PROMPT", "CONFIG", "", "FEPUP", "FEPDOWN", "LINE",
""(3), "", "Q", "",
"", "DISPLAY", ""(4),
"", "PRIORITY", "", "SETAUTOPOLL", "RUSH", "HOLD",
"RELEASE", "DELETE", ""(4),
""(3), "CONNECTFE", "", "FTDELAY",
"OPENFT","CLOSEFT","FT","FTLINES","FTLIMIT","",
"DUMP","PSS","IPSS"
!The following array of words are param checking flags used as follows:
! x00nnnnnn no checking to be done
! x01nnnnnn do checks
! xnnnnllnn minimum number of params
! xnnnnnnll maximum number of params (FF implies any number)
constintegerarray comm flags(1 : command limit) = c
x'00000000', x'01000000', x'01000000', x'00000000', x'01000202', x'01000202',
x'01000101', x'01000101', x'01000101', x'01000303', x'01000000', x'01000101',
x'01000101', x'01000101', x'01000001', x'01000303', x'01000303', x'01010101',
x'01000102', x'01000202', x'01000101', x'01000101', x'01000001', x'01000101',
x'01000101', x'01000002', x'01000101', x'01000101', x'01000101', x'01110101',
x'01110101', x'01110001', x'01110001', x'01110002', x'01110002', x'01110001',
x'01110001', x'01110102', x'01110000', x'01110001', x'01110001', x'01110101',
x'01110101', x'01010202', x'01010202', x'01010101', x'01010101', x'01010101',
x'01010101', x'01010102', x'01010304', x'01010303', x'01010101', x'01010101',
x'010101FF', x'01100102', x'01100001', x'01000101', x'011100FF', x'01000102',
x'01000001', x'01000001', x'01110002', x'01000102', x'01000102', x'01000102',
x'01000101', x'01000101', x'01000101'
integerfn get scr ( integer wd )
integer i
i = stoi ( words ( wd ))
if 0 <= i < screens per oper then param = "" else param = "SCREEN NO"
result = i
end { of get scr }
integerfn get picture ( integer picture type, id1, string (15) id2 )
! Returns no of file to create picture in. Returns file already in use if id's match, otherwise an empty file. Returns
! oldest file if none found.
integer pic, free, lowest tick
record (picturef) name picture
free = 0
lowest tick = picture tick + 1 { higher than any in the picture records }
cycle pic = 1, 1, max pic files
picture == pictures(pic)
exit if picture_base = 0 { not connected }
if picture_picture type = picture type and picture_id1 = id1 and picture_id2 = id2 then free = pic
if free = 0 and picture_screens=0=picture_count then free = pic { free file }
repeat
if free = 0 start
cycle pic = 1, 1, max pic files
if pictures(pic)_tick < lowest tick and picture_base # 0 then lowest tick = pictures(pic)_tick and free = pic
repeat
finish
result = free
end ; ! get picture
!
!
routine requeue
!***********************************************************************
!* *
!* *
!***********************************************************************
add to queue( id, 0,no,no,flag)
if flag # 0 start
print string("ADD ".ident to s(id)." TO QUEUE ". c
" FAILS ".i to s(flag).snl)
delete document(id, flag)
print string("DELETE DOCUMENT ".ident to s(id). c
" FAILS ".i to s(flag).snl) if flag # 0
finish
end ; !OF ROUTINE REQUEUE
integerfn get document(string (31) param)
!***********************************************************************
!* *
!* *
!***********************************************************************
result = 1 if check params(param, q, name, user, ident) # 0
result = 1 if find document(name, ident, user, id) # 0
remove from queue( id, flag)
if flag = 0 then document == record(document addr(id) c
) else print string("REMOVE ".ident to s(id). c
" FROM QUEUE FAILS ".i to s( c
flag).snl)
result = flag
end ; !OF INTEGERFN GET DOCUMENT
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!GENERAL ROUTINES FOR THE COMMAND SET INTERPRETATION.
integerfn resolve command
integer elements; string (127) word
!
elements = 0
cycle
command -> (" ").command while length(command)>0 and charno(command,1)=' '
exit if command = ""
elements = elements + 1
exit if elements = 16
if command -> word.(" ").command then start
if length(word)>63 then length(word)=63
words(elements) = word
continue
finish
length(command) = 63 if length(command) > 63
words(elements) = command
exit
repeat
result = elements
!
end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!DO THE INITIAL CHECKS AGAINST THE ATRIBUTES WORD
op no = oper no
reply = ""
command length = resolve command
return if command length = 0
link = 0
cycle i = 1, 1, command limit
if words(1) = comm(i) then link = i and exit
repeat
if link = 0 start
reply = "INVALID COMMAND ".words(1)
-> error
finish
flags = comm flags(link)
-> swt(link) if flags >> 24 = 0
!IE DO NOT DO INITIAL CHECKS.
unless (flags<<16)>>24 <= (command length - 1) <= flags&x'FF' start
reply = "NUMBER OF PARAMS ?"
-> error
finish
-> swt(link)
!!!!!!!!!!!!!!!!FTP CONTROL FUNCTIONS!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!**********************************************************
!Open up the system in one go.
!
swt(4):
status header change = yes
cycle i = 2,1,FTP stns
FTP stations(i)_service = open
repeat
FTP stations(control entry)_max lines = 25
FTP stations(control entry)_q lines = 12
FTP stations(control entry)_service = open
FTP stations(control entry)_limit = 1000
cycle i = 1,1,lines
kick(i) = kick(i)&1
kick FTP line(i)
repeat
return
!
!************************************************************
!Open or close FTP service generally or to specific stations.
!
swt(61):
swt(62):
status header change = yes
if link = 61 then j = open else j = closed
if command length = 1 start
!a general open or close on FTP stations(control entry)_service
FTP stations(control entry)_service = j
if j = open then -> kick FTP lines else return
finish
if words(2) = ".ALL" start
!set service latch to all stations.
!Note then general service switch must be on before transactions start.
cycle i = 2,1,FTP stns
FTP stations(i)_service = j
repeat
if FTP stations(control entry)_service = open then -> kick FTP lines else return
finish else start
!we want to mark a specific station service status.
cycle i = 1,1,FTP stns
if string at(FTP stations(i),FTP stations(i)_shortest name) = words(2) start
FTP stations(i)_service = j
if FTP stations(control entry)_service = open then -> kick FTP lines else return
finish
repeat
param = "Station" and -> parameter
finish
!*************************************************************
!Give a general picture of the FTP situation.
swt(63):
status header change = yes
if command length = 1 or ( command length = 2 and words ( 2 ) -> zstr.("#").words ( 2 ) ) start
if command length = 2 start
i = get scr ( 2 )
-> parameter unless param = ""
finish else i = 0
p = 0
p_p2=get picture(FTP status summary display,0,"" )
p_p3 = i
p_p4=console
picture manager ( p,FTP status summary display,0,"" )
finish else start
if command length = 3 start
param = "SCREEN NO" and -> parameter unless words ( 3 ) -> zstr.("#").words ( 3 )
i = get scr ( 3 )
-> parameter unless param = ""
finish else i = 0
j = stoi(words(2))
param = "line" and -> parameter unless 1 <= j <= lines
p=0
p_p2=get picture(FTP line status display,j,"" )
p_p3 = i
p_p4=console
picture manager ( p,FTP line status display,j,"" )
finish
return
return
!********************************************************
!Adjust the transaction go ahead for general or specifics
swt(64):
status header change = yes
if command length = 3 start
if length(words(2)) <= 2 then i = s to i(words(2)) else i = lines + 1
if 0<=i<=lines start
!we are setting the overall total P and Q station transaction control.
j = s to i(words(3))
if 0<=j<=lines start
FTP stations(control entry)_max lines = i
FTP stations(control entry)_q lines = j; !the minimum no. of listeners.
if FTP stations(control entry)_service = open then -> kick FTP lines else return
finish else param = " number of 'slaves'" and -> parameter
finish else start
!else we are setting controls for individual station.
cycle i = 1,1,FTP stns
if string at(FTP stations(i),FTP stations(i)_shortest name) = words(2) start
j = s to i(words(3))
if 0<=j<=lines start
FTP stations(i)_max lines = j
if FTP stations(control entry)_service = open and FTP stations(i)_service = open then c
-> kick FTP lines else return
finish
param = "number of lines" and -> parameter
finish
repeat
param = "station" and -> parameter
finish
finish else start
!we are just setting the general controls via max lines and
!letting listeners(Q stations) default.
i = s to i(words(2))
unless 0<=i<=lines then param = "number of lines" and return
FTP stations(control entry)_max lines = i
if i = 1 then FTP stations(control entry)_q lines = 0 else FTP stations(control entry)_q lines = i//2
if FTP stations(control entry)_service = open then -> kick FTP lines else return
finish
!********************************************************
!Set the transaction size limit generally or specifically
swt(65):
status header change = yes
if command length = 2 start
i = s to i(words(2))
param = "limit" and -> parameter unless 0<=i<=10000
FTP stations(control entry)_limit = i
if FTP stations(control entry)_service = open then -> kick FTP lines else return
finish else start
cycle j = 1,1,FTP stns
if string at(FTP stations(j),FTP stations(j)_shortest name) = words(2) start
i = s to i(words(3))
param = "limit" and -> parameter unless 0<=i<=10000
FTP stations(j)_limit = i
if FTP stations(j)_service = open and FTP stations(control entry)_service = open c
then -> kick FTP lines else return
finish
repeat
param = "station" and -> parameter
finish
kick FTP lines:
cycle i = 1,1,lines
kick FTP line(i)
repeat
return
!***************************************************************
!Enquiry or set the connect fail retry delay array pointer.
swt(60):
cycle j = 1,1,FTP stns
if string at(FTP stations(j),FTP stations(j)_shortest name) = words(2) start
if command length = 2 start
printstring(words(2)." delay is ".i to s(connect retry times( c
FTP stations(j)_connect retry ptr))." m".snl)
printstring(words(2)." connect in ".itos(FTP stations(j)_ c
connect retry time)." m".snl)
return
finish
i = s to i(words(3))
param = "pointer" and -> parameter unless 0<=i<=10
FTP stations(j)_connect retry ptr = i
set document timers(j,connect retry times(i),0)
return
finish
repeat
param = "station" and -> parameter
return
!***********************************************************
!Look at the available FEPs
swt(1):
cycle i = 0,1,max fep
if feps(i)_FTP available = yes start
printstring(itos(i)." ".comms type(feps(i)_comms type))
if feps(i)_outgoing calls permitted = yes then printstring(" <out>")
if feps(i)_incomming calls accepted = yes then printstring(" <in>")
newline
finish
repeat
return
!**************************************
!STOP FTRANS OR STOP SPECIFIED LINES.
swt(15):
if command length = 1 or words(2) = ".ALL" start
if lines = 0 then stop
cycle line = 1, 1, lines
kick(line) = kick(line)!2; !SET STOP BIT
abort line(line) if FTP lines(line)_status >= allocated
repeat
stopping = yes if command length = 1
update descriptors(-1); !IE UPDATE DOCUMENT DESCRIPTORS ON ALL THE FSYS
finish else start
line = find FTP line(words(2))
-> error if line = 0 or FTP lines(line)_status < allocated
abort line(line)
kick(line) = kick(line)!2; !SET STOP BIT
finish
return
!************************************************
!DUMP the system buffers.
swt(67):
if command length = 2 and words(2) -> ("FE").words(2) start
!DUMP the FEP control buffers.
fe = s to i(words(2))
unless 0 <= fe <= max fep then param = "FEP" and -> parameter
j = feps(fe)_ftp out buff con addr
k = feps(fe)_ftp output cursor
l = feps(fe)_ftp out buff length
select output(1)
cycle i = j,1,j+l-1
if i-j = k then printstring(" ** ")
printstring(htos(byteinteger(i),2))
repeat
printstring(snl."OUTPUT CONTROL CURSOR : ".itos(k).snl.snl)
j = feps(fe)_ftp in buff con addr
k = feps(fe)_ftp input cursor
l = feps(fe)_ftp in buff length
cycle i = j,1,j+l-1
if i-j = k then printstring(" ** ")
printstring(htos(byteinteger(i),2))
repeat
printstring(snl."INPUT CONTROL CURSOR : ".itos(k).snl)
select output(0)
printstring("Done".snl)
finish
return
!********************************************
!SET THE FTRANS MONITOR LEVEL.
swt(24):
i = s to i(words(2))
param = "LEVEL" and -> parameter unless 0<=i<=9
monlevel = i
return
!******************************************
!SWITCH THE PROMPT ON OR OFF
swt(25):
reply = "ON OR OFF" and -> error unless words(2) = "ON" c
or words(2) = "OFF"
if words(2) = "ON" then oper(op no)_prompt on = yes c
else oper(op no)_prompt on = no
return
!*******************************************************
!PRINT THE FTRANS LOG TO SPOOLR
swt(23):
print log (1,lp)
return
!CODE FROM VOLUMS HERE
!*****************************
!DISPLAY A SPECIFIED DOCUMENT.
swt(38):
if command length = 3 start
param = "SCREEN NO" and -> parameter unless words ( 3 ) -> zstr.("#").words ( 3 )
K = get scr ( 3 )
-> parameter unless param = ""
finish else k = 0
param = "DOCUMENT"
if length(words(2)) = 6 start
cycle i = 1, 1, 6
-> parameter unless '0' <= charno(words(2), i) <= '9'
repeat
i = (charno(words(2), 1)-'0')*10+charno(words(2), 2)-'0'
j = (charno(words(2), 3)-'0')*1000+(charno(words(2), 4)-'0')*100 c
+(charno(words(2), 5)-'0')*10+charno(words(2), 6)-'0'
-> parameter unless f systems(i)_addr # 0 c
and 1 <= j <= max documents
p = 0
p_p2 = get picture ( individual document display, i << 24 ! j, "" )
p_p3 = K
p_p4 = console
picture manager ( p, individual document display, i << 24 ! j, "" )
return
finish else -> parameter
!******************************************************************
!SETAUTOPOLL Set this document to be a AUTO requeue document for
!the return of output from remote jobmills. Submit a document with
!the command TRANSFER site(,),,job when FT service is closed and
!then give this command on the document before opening service.
!The document then will exist 'forever'
swt(46):
param = "DOCUMENT"
-> parameter if get document(words(2)) # 0
document_auto requeue = yes
requeue
return
!**********************************************************
!RUSH: PUT A JOB AT MAX PRIORITY WITHIN ITS OWN PRIORITY
swt(47):
param = "DOCUMENT"
-> parameter if get document(words(2)) # 0
document_priority = prtys(n priorities)+max priority
document_priority = - document_priority
requeue
return
!***********************
!RELEASE A HELD DOCUMENT
swt(49):
param = "DOCUMENT"
-> parameter if get document(words(2)) # 0
document_priority = -document_priority c
if document_priority < 0
requeue
return
!****************
!HOLD A DOCUMENT.
swt(48):
param = "DOCUMENT"
-> parameter if get document(words(2)) # 0
document_priority = -document_priority c
if document_priority > 0
requeue
return
!*************************************************
!DELETE A DOCUMENT OR THE DOCUMENTS INDICATED BY
!SUBSEQUENT PARAMETERS.
swt(50):
specific user = ""; q no = 0
if words(2) -> words(2).(".ALL") start
!IE DELETE ALL A USER'S DOCS IN THE QUEUE.
specific user = words(2)
param = "USER" and -> parameter if length(specific user) # 6
finish else start
!DELETE A SINGLE DOCUMENT.
param = "DOCUMENT" and -> parameter if get document(words(2)) # 0
delete document(id, flag)
printstring("DELETE ".ident to s(id)." FAILS ".i to s c
(flag).snl) if flag # 0
return
finish
!COMPLETE THE MULTIPLE DELETE.
next = queue_head
while next # 0 cycle
after = list cells(next)_link
if specific user = "" or list cells(next)_user = specific user start
j = list cells(next)_document
remove from queue( j, flag)
delete document(j, flag)
if flag # 0 start
printstring("DELETE ".ident to s(j)." FAILS ".i to s c
(flag).snl)
return unless mon level = 9
finish
finish
next = after
repeat
return
!*************************************************
!CHANGE THE PRIORITY OF A DOCUMENT
swt(44):
i = 0
cycle j = 1, 1, n priorities
if words(3) = priorities(j) start
i = j
exit
finish
repeat
param = "PRIORITY" and -> parameter if i = 0
if get document(words(2)) # 0 then param = "DOCUMENT" and c
-> parameter
cycle k = n priorities, -1, 1
if imod(document_priority) >= prtys(k) start
j = imod(document_priority)-prtys(k)
if document_priority > 0 then k = 0 else k = 1
exit
finish
repeat
document_priority = prtys(i)+j
document_priority = -document_priority if k # 0
requeue
return
!******************************************************
!ABORT ONE OR ALL LINES.
swt(18):
if words(2) = ".ALL" start
cycle line = 1, 1, lines
abort line(line) if FTP lines(line)_status >= allocated
repeat
finish else start
line = find FTP line("FT".words(2))
param = "LINE" and -> parameter if line = 0
reply = "NOT REQUIRED" and -> error if FTP lines(line)_status < allocated
abort line(line)
finish
return
!*********************************************************
!START A LINE (IE REMOVE STOP AND KICK) , OR ALL LINES.
swt(14):
if words(2) = ".ALL" start ; !START ALL LINES
cycle line = 1, 1, lines
kick(line) = kick(line)&1; !REMOVE STOP BIT
kick FTP line(line)
repeat
finish else start
line = find FTP line("FT".words(2))
param = "LINE" and -> parameter if line = 0
kick(line) = kick(line)&1
kick FTP line(line)
finish
return
!********************************************************
!DISPLAY DETAILED PAGE OF QUEUE OR SIMPLE PAGE OF QUEUE
swt(35):
specific user = "" ; i = 0
if command length > 1 start
if command length = 3 start
param = "USER" and -> parameter unless length(words(2)) = 6
specific user = words ( 2 )
param = "SCREEN NO" and -> parameter unless words ( 3 ) -> zstr.("#").words ( 3 )
i = get scr ( 3 )
-> parameter unless param = ""
finish else start
if words ( 2 ) -> zstr.("#").words ( 2 ) start
i = get scr ( 2 )
-> parameter unless param = ""
finish else start
param = "USER" and -> parameter unless length ( words ( 2 )) = 6
specific user = words ( 2 )
finish
finish
finish
p = 0
p_p2 = get picture ( individual queue display, 0, specific user )
p_p3 = i
p_p4 = console
picture manager ( p, individual queue display, 0, specific user )
return
!***************************************************
!SET THE FTRANS CONFIGURATION FILE (SPECIFIED FSYS)
swt(26):
j = s to i(words(2))
param = "FSYS" and -> parameter unless 0<=j<=max fsys
if command length = 3 start
reply = "<USER>.<FILENAME> ?" and -> error unless c
words(3)->param1.(".").param2 and length(param1)=6 c
and 1<=length(param2)<=11
if TARGET # 2900 start
dsfis = words(3)
i = dsfi(my name, j, 2, 1, dsfis, dsfiia)
finish else i = dsfi(my name, j, 2, 1, addr(words(3)))
print string("SET SFI 2 FAILS ".errs(i).snl) if i # 0
finish else start
if TARGET # 2900 start
i = dsfi(my name, j, 2, 0, dsfis, dsfiia)
param = dsfis
finish else i = dsfi(my name, j, 2, 0, addr(param))
if i = 0 then print string("CONFIG ".param.snl) c
else print string("READ SFI 2 FAILS ".errs(i).snl)
finish
return
!***************************************************
!SET the PSS and IPSS info.
swt(68):
swt(69):
if link = 68 then PSS = words(2) else IPSS = words(2)
return
!*************************************************
!DELETE ANY EXTRA FILES HANGING AROUND AS SPECIFIED
swt(22):
if words(2) = "SAFE" then special = yes and words(2) = ".ALL" c
else special = no
if words(2) # ".ALL" start
i = s to i(words(2))
param = "FSYS" and -> parameter unless 0 <= i <= max fsys
any extra files(i,no)
finish else start
cycle i = 0, 1, max fsys
if f systems(i)_addr # 0 then any extra files(i,special)
repeat
finish
return
!*******************************************
!MANUAL REPORT OF A LOST FEP(NORMALLY AUTOMATIC)
swt(29):
if length(words(2)) = 1 start
i = charno(words(2), 1)-'0'
if 0<=i<=max fep and feps(i)_FTP available = yes then fep down(i)
return
finish
param = "FEP"
-> parameter
!
!*********************************************************
!Permit or Withdraw INCOMMING or OUTGOING call access thro a particular FEP
swt(5):
swt(6):
if length(words(2)) = 1 start
i = charno(words(2), 1)-'0'
if 0 <= i <= max fep and FEPs(i)_FTP available = yes start
if words(3) = "IN" start
if link = 5 then FEPs(i)_incomming calls accepted = no else c
FEPs(i)_incomming calls accepted = yes
return
finish else if words(3) = "OUT" start
if link = 5 then FEPs(i)_outgoing calls permitted = no else c
FEPs(i)_outgoing calls permitted = yes
return
finish else reply = "F/CLOSE(OPEN)FEP IN(OUT) n" and -> error
finish else param = "FEP" and -> parameter
finish else param = "FEP" and -> parameter
!************************************************
!CONNECT AN FEP (THAT HAS BEEN RELOADED ?)
swt(58):
swt(28):
if link = 58 then printstring( c
"CONNECTFE kick".snl)
if length(words(2)) = 1 start
i = charno(words(2), 1)-'0'
if 0 <= i <= max fep and feps(i)_FTP available = no start
p = 0
p_dest = i<<8!FTP input control connect
open fep(p)
return
finish
finish
param = "FEP"
-> parameter
parameter:
reply = "INVALID ".param
error:
printstring(reply.snl)
return
!*
routine abort line(integer line)
!***********************************************************************
!* *
!* ABORT THE SPECIFIED STREAM BY CALLING THE APPROPRIATE SERVICE *
!* ROUTINE *
!* *
!***********************************************************************
record (pe)p
p = 0
p_dest = line<<7
FTP control(p,refresh line)
if refresh line # 0 then refresh pic(ftp status summary display, refresh line,"")
return
end ; !OF ROUTINE ABORT line
!*
!*
integerfn find FTP line(string (255) line)
!***********************************************************************
!* *
!* RETURNS THE INDEX INTO THE LINE ARRAY OF THE SPECIFIED LINE *
!* RETURNS ZERO IF THE STREAM IN NOT FOUND *
!* *
!***********************************************************************
integer i
cycle i = 1, 1, lines
result = i if FTP lines(i)_name = line
repeat
reply = "NO SUCH LINE ".line
result = 0
end ; !OF INTEGERFN FIND STREAM
!*
!*
end ; !OF ROUTINE INTERPRET COMMAND
!*
routine move with overlap(integer length, from, to)
! Simple minded move, as opposed to %systemroutine move
if TARGET = 2900 start
*ldtb_x'18000000'
*ldb_length
*lda_from
*cyd_0
*lda_to
*mv_l =dr
finish else move(length,from,to)
end ; ! move with overlap
!
!
!
!
integerfn generate pic(integer pic,picture type,id1 ,refresh, string (15) id2)
integer linead, i, j, full, pic start, line, next
string (3) p
string (41)sline
integername used
switch picsw(1:max pic types)
record (picturef)name picture
if TARGET = 2900 start
constbyteintegerarray blankline(1:41) = 32(40), x'85'
finish else start
constbyteintegerarray blankline (1:40) = 32(40)
finish
conststring (1)dot = "."
conststring (1)sp = " "
record (linef)name FTP line
record (FTP tablef) name FTP table
record (document descriptorf) name document
!
!
stringfn padout ( string (255) s, byteinteger len, side )
! pads s out to len characters with spaces,on left if side = 0, on right otherwise
if length(s) > len then length(s) = len and result = s
if side = 0 start
s = " ".s while length(s) < len
else
s=s." " while length(s) < len
finish
result = s
end ; ! padout
!
routine put line
sline = sline . " " while length(sline) < 40
move with overlap(length(sline),addr(sline)+1,linead)
linead=linead+line len
line=line+1
if line>max pic lines then full=1
end { of put line }
routine build line ( integer i ) { for FTP summary }
string (19) s
FTP line == FTP lines(i)
line addresses ( i ) = linead
s = stream status type(FTP line_status)
if FTP line_status = unallocated or FTP line_station type = P station then s = " ".s else s = "*".s
sline = padout(itos(i),2,1).padout(s,18,1)
unless FTP line_status = disconnecting or FTP line_status = deallocating c
or FTP line_status = unallocated start
if FTP line_station type =p station start
if FTP line_document = 0 then sline = sline." " else sline=sline.FTP line_user
finish else sline=sline.FTP tables(i)_username_value
sline=padout(sline,28,1).padout(itos((FTP line_bytes transferred+1023)>>10),4,0)." "
sline=sline.padout(string at(FTP stations(FTP line_station ptr),FTP stations c
(FTP line_station ptr)_shortest name),7,1) if FTP line_station ptr # 0
finish
put line
end { of build line }
!
if mon level = 6 then c
PRINTSTRING("GenPic P".itos(pic)." TYPE".itos(picture type)." ID1".itos(id1)." ID2".id2.snl)
picture == pictures(pic)
picture_tick = picture tick
pic start = picture_base+32
used==integer(picture_base+24)
if refresh = no start
picture_picture type = picture type
picture_id1 = id1
picture_id2 = id2
move with overlap(line len,addr(blankline(1)),pic start); ! first blank line
move with overlap(used-line len,pic start,pic start+line len)
finish
! right overlap does rest of area
line=1
linead = pic start
full=0
->picsw(picTURE TYPE)
!
!
!
!
picsw(FTP status summary display):
! If id1 = 0, do whole summary, otherwise only update FT line 'id1'
if TARGET # 2900 then sline = "EMAS 370 File Transfer Service ".time C
ELSE sline = "EMAS 2900 File Transfer Service ".time
put line
if status header change = yes start
if FTP stations (control ENTRY)_service = closed then sline = "CLOSED" else sline = "OPEN "
sline = sline." ".padout(itos(FTP stations(control entry)_limit),5,0)."Kb ". c
padout(itos(FTP stations(control entry)_max lines),3,0). c
" Lines, ".padout(itos(FTP stations(control entry)_q lines),3,0). c
" Listening"
put line
status header change = no
finish
if id1 # 0 start
if line addresses ( id1 ) = 0 start { line is not yet displayed }
linead = pic start + used
line = used // line len + 1
if line > max pic lines then full = 1
if full = 0 then build line ( id1 ) else full = 2
finish else start
linead = line addresses ( id1 )
line = ( linead - pic start ) // line len + 1
build line ( id1 ) { no need to check for overflow - this line has been written before }
linead = pic start + used
line = used // line len + 1 { frig for finish }
finish
finish else start { do whole summary }
sline="No STATUS USER nKB STATION"
put line
cycle i=1,1,lines
line addresses ( i ) = 0
if full = 0 then build line ( i ) else full = 2
repeat
finish
-> finish
picsw(FTP line status display):
FTP line == FTP lines(id1)
FTP table == FTP tables(id1)
sline = "File Transfer Details, line ".padout(itos(id1),2,0)." ".time
put line
sline = "Current Status: ".stream status type(FTP line_status)
put line
-> finish if FTP line_status = unallocated
if FTP line_status = selected or FTP line_station type = p station c
then sline = "Acting as MASTER with " else sline = "Acting as SLAVE with "
if FTP line_station ptr > 0 then sline=sline.string at(FTP stations c
(FTP line_station ptr),FTP stations(FTP line_station ptr)_shortest name) c
else sline = sline."?"
put line
sline=""
put line
unless allocated <= FTP line_status < awaiting sft start
sline = "Transfer details for ".ident to s (FTP line_document)
put line
sline = "Local user: "
if FTP line_station type = p station start
if FTP line_document = 0 then sline = sline." " else c
document == record(document addr(FTP line_document))and sline=sline.document_user
finish else sline = sline.FTP table_username_value
put line
sline = "Remote user: "
if FTP line_station type = p station then sline =sline.docstring(document, document_external user ) c
else sline = sline."?"
put line
sline="Local file name: "
if FTP line_station type = p station then sline=sline.docstring(document,document_name) c
else sline=sline.FTP table_filename_value
put line
sline = "Remote file name: "
if FTP line_station type = p station then sline = sline.docstring(document,document_external name) c
else sline = sline."?"
put line
if FTP line_station type = p station start
sline = "Retries left: ".itos(document_FTP retry level)
put line
finish
finish
sline="Time out in ".itos(FTP line_timer)." mins."
put line
-> finish
picsw(individual queue display):
! id1 irrelevant, id2 is specific user if one is specified ( excuse the English )
sline = "File Transfer Queue ".queue_name
if queue_length = queue_max length then sline = sline." Full"
if queue_length = 0 then sline = sline." Empty"
sline = padout ( sline, 32, 1 ).time
put line
if queue_length = 0 then sline = " No" else sline = itoss ( queue_length, 3 )
sline = sline." Entries".itoss ( queue_max length, 4 )." Max".itoss ( queue_maxacr, 3 )." MaxACR"
if queue_length > 0 start
if queue_default time > 0 then sline = sline.padout ( hms ( queue_amount ), 11, 0 ) c
else sline = sline. itoss (( queue_amount + 1023 ) >> 10 , 10 )."K"
finish
put line
if queue_head # 0 start { any documents queued }
sline = "POS IDENT USER NAME PRTY "
if queue_default time <= 0 then sline = sline."SIZE" else sline = sline."TIME"
put line
i = 1
next = queue_head
while next # 0 cycle
if full = 0 start
if id2 = "" or list cells ( next )_user = id2 start
document == record ( document addr ( list cells ( next )_document ))
unless document_start after date and time # 0 and document_start after date and time c
> current packed dt then start
sline = itoss ( i, 3 )." ".ident to s ( list cells ( next )_document )." ". c
document_user." ".doc string ( document, document_name )
length ( sline ) = 29 if length ( sline ) > 29
sline = padout ( sline, 30, 1 )
if document_priority < 0 then sline=sline."HLD" else start
p = ""
cycle j = n priorities, -1, 1
if document_priority >= prtys ( j ) start
p <- priorities ( j )
exit
finish
repeat
sline = sline.p
finish
if document_forms # queue_default forms then sline = sline."F" else start
if document_start after date and time # 0 and document_start after date and time c
> current packed dt then sline = sline."A" else start
if document_order # 0 then sline = sline."0" else sline = sline." "
finish
finish
if document_time > 0 then sline = sline.itoss ( document_time, 5 )."S" c
else sline = sline.itoss (( document_data length + 1023 ) >> 10, 5 )."K"
put line
finish
finish
i = i + 1
next = list cells ( next )_link
finish else full = 2
repeat
finish
-> finish
picsw(individual document display):
! id1 is ident, id2 irrelevant
sline = padout ( "IDENT: ".ident to s ( id1 ), 32, 1 ).time
put line
document == record ( document addr ( id1 ))
sline = "STATE: ".doc state ( document_state )
put line
sline = "ORIGIN: "
if doc string ( document, document_srce ) = "" then sline = sline."USER" else c
sline = sline.doc string ( document, document_srce )
put line
sline = "USER: ".document_user
put line
sline = "NAME: ".doc string ( document, document_name )
put line
sline = "QUEUE: ".document_dest
put line
sline = "DELIVERY: ".doc string ( document, document_delivery )
put line
sline = "RECEIVED: ".unpack date ( document_date and time received )." ".C
unpack time ( document_date and time received )
put line
if document_start after date and time # 0 start
sline = "AFTER: ".unpack date ( document_start after date and time )." ".unpack time ( document_start after date and time )
put line
finish
if document_date and time started # 0 start
sline = "STARTED: ".unpack date ( document_date and time started ). " ".unpack time ( document_date and time started )
put line
finish
if document_date and time deleted # 0 start
sline = "DELETED: ".unpack date ( document_date and time deleted )." ".unpack time ( document_date and time deleted )
put line
finish
sline = "SIZE: ".padout ( itos ( document_data length ), 10, 1 )
sline = sline."START: ".itos ( document_data start ) if document_data start # 0
put line
if document_priority < 0 then sline = "PRIORITY: Held" else start
cycle i = n priorities, -1, 1
if document_priority >= prtys ( i ) then sline = "PRIORITY: ".priorities ( i ) and exit
repeat
finish
put line
if document_FTP alias # 0 start
sline <- "NIFTP-80(B) transfer for ".docstring ( document, document_FTP alias )
put line
finish
sline = "MODE: ".modes ( document_mode )
put line
if document_rerun = no then sline = "RERUN: No" else sline = "RERUN: Yes"
if document_fails # 0 start
sline = padout ( sline, 14, 1 )."FAIL ".itos ( document_fails )
finish
if document_order # 0 start
sline = padout ( sline, 20, 1 )."ORDER: ".itos ( document_order )
finish
put line
!
!
!
finish:
if full=2 start ; ! pic o'flow
line=line-2
linead=linead-(2*line len); ! back off two lines
sline="*********** picture overflow ***********"
put line
finish
used=(line-1)*line len; ! used length
result =ok
end ; ! generate pic
!
!
!
routine picture manager(record (pe)name p,integer picture type,id1,string (15) id2)
!***********************************************************************
!* called to create a picture: *
!* p_srce=0,p_p1=0,p_p2=pic file,p_p3=screen on oper,p_p4=operno *
!* called to refresh a picture: *
!* p_srce=0,p_p1=1,p_p2=pic file *
!* called to service external picture messages: *
!* p_srce#0 *
!* *
!* *
!* the basic sequence to display a picture is: *
!* 1. connect request to cc. reply comes to caller. *
!* 2. enable request to cc. reply comes to caller. *
!* 3. display request to oper routed thru' cc. if successful, *
!* oper's reply 'done' is routed back thru' cc to owner. if *
!* unsuccessful (because oper has disconnected in the meantime) *
!* reply comes from cc to caller. *
!* *
!* while a picture is on screen, we can receive asynchronous messages *
!* direct from oper to owner, either to effect a frame change (when *
!* operator has done pg f/b), or to notify that the picture is now *
!* off screen and need no longer be refreshed. *
!* *
!* the top of screen line confirmed by oper 'done' is not required *
!* to do frame changes since oper itself does the new line *
!* calculation and tells us in frame change request. we do need it *
!* to do display request on a refresh. it is thus recorded here at *
!* the time the display request goes out rather than when the 'done' *
!* is received from oper, which latter is thus redundant and can be *
!* discarded. *
!* *
!* if display requests are issued here while an 'off-screen' is *
!* waiting for us (ie oper has disconnected), these will generate *
!* failures from cc on caller sno. it is impossible for us to see *
!* these until after we have seen and actioned the 'off-screen' from *
!* oper, so these cc failures too can be discarded. *
!* *
!* ie both types of messages poffed from cc (other than connect and *
!* enable replies which are done on sync2) can be discarded. only *
!* those poffed from oper direct (ie frame change and offscreen) need *
!* to be actioned. *
!* *
!* if the caller is an interactive process, we do not do auto refresh *
!* which could be dangerous if the process died. we simply generat:e it *
!* once if need be and point the process at the picture file. *
!* *
!***********************************************************************
record (screenf)name screen
integer pic,scr,operscreen,act,j,bits,oper n
record (picturef)name picture
switch sw(0 : 7)
!
!
!
integerfn process no(integer srce)
srce = srce >> 16
result = srce - com_sync2dest if srce > com_sync2dest
result = srce - com_sync1dest
end
!
!
!
routine opout(string (255)s)
printstring(s . "
")
end
!
!
!
integerfn screeno(integer stream)
! returns the screen number connected on stream
integer i
for i=0,1,max screen cycle
result =i if screens(i)_stream=stream
repeat
result =-1; ! not found
end ; ! screeno
!
!
!
routine off screen(integer screen)
! clears down screen and pic descs, when no longer on screen
record (picturef)name picture
picture == pictures(screens(screen)_picture)
picture_screens = picture_screens & (¬(1<<screen)); ! knock out bit for this screen
screens(screen)=0
end ; ! off screen
!
!
!
routine display request(integer stream,line)
pictures(pic)_tick = picture tick
p=0
p_dest=x'370006'
p_srce=picture act; ! caller=owner
p_p1=stream
p_p6=line
if mon level = 6 start
PRINTSTRING("DisReq P:");pt rec(p);NEWLINE
finish
dpon(p)
end ; ! display request
!
!
!
if mon level = 6 start
printstring("PM called : PTYPE ".itos(picture type)." ID1".itos(id1)." id2 ".id2.snl)
ptrec(p)
finish
picture tick = picture tick + 1
! start by computing an 'act' to simplify subsequent code
act = 0
pic = p_p1 { in which case this is where pic no is }
j = p_srce >> 16
if j = 0 start { internal call to create or refresh }
p_p4=oper dest {! (autooper<<8)} if process no(p_p4)=1 { frig calls from autofile }
pic=p_p2
act = p_p1
act = 2 if act = 0 {create} and p_p4 & x'00ff0000' = oper dest
finish else start
act = 3 {off screen from private process}
act = 4 if j = x'37' { from comms controller }
if j = x'32' start { from oper adaptor }
act = 5 { not recognised }
act = 6 if p_p6 >> 24 = 255 { off screen }
act = 7 if p_p6 >> 24 = 0 { frame change }
finish
finish
if act < 4 start { pic relevant so validate it }
j = 0
if 1 <= pic <= max pic files start
picture == pictures(pic)
j = picture_base
finish
opout("Picture" . itos(pic) . " off") and return if j = 0
if act = 0 or act = 2 start { a create }
if picture_screens=0=picture_count start { not currently in use }
return unless generate pic(pic,picture type,id1,no, id2)=ok
finish
finish
finish
if mon level = 6 then PRINTSTRING("PicMan : sw ".itos(act).snl)
-> sw(act)
sw(0): { create from an interactive process }
p_dest=p_p4!6
p_srce=picture act
p_p1 = pic; ! local pic number
p_p2=uinf_fsys; ! which fsys the picture files are on
! screen in p3
string(addr(p_p4))="PICTURE".itos(pic); ! the file name
if mon level = 6 start
PRINTSTRING("PicMan sw0 dpon : ");ptrec(p)
finish
dpon(p)
picture_count=picture_count+1
return
sw(1): { refresh }
! 'refresh pic' checks that there is at least one screen involved
! before coming here. there may be several as given by bits
! in picture_screens or in picture_count
return unless generate pic(pic,picture type,id1,yes, id2)=ok
! thats all we do for private pics. it would be dangerous to fire pons
! at a process in case it dies. we let it rewrite on clock
bits = picture_screens; ! get the bits
for scr=0,1,max screen cycle
if bits&1#0 start ; ! its on this screen
screen==screens(scr)
display request(screen_stream,screen_top)
finish
bits=bits>>1
repeat
return
sw(2): { create from real oper }
oper n=(p_p4>>8)&x'FF'; ! which one
operscreen=(p_p3<<4) ! oper n; ! device address for connect
scr=oper n*screens per oper+p_p3; ! logical screen
unless 0 <= oper n < screens per oper and 0<=scr<=max screen start
opout("Screen out of bounds !!!!!!!")
return
finish
! first check if that pic is already on that screen
return if screens(scr)_picture=pic
!
p=0 { connect stream }
p_dest=x'370001'; ! cc
p_p1=1; ! output
p_p2=uinf_sync1dest ! picture act; ! owner sno
p_p3=x'8000000'!(operscreen<<16)
if mon level = 6 then PRINTSTRING("PM CONNECT REQ".SNL)
dout(p); ! and wait for reply
if p_p2#0 start
opout("Connect to screen fails.")
return ; ! we haveny changed any descs yet
finish
! so now oper has owner sno.
!
! now check if we already have another picture on this screen.
! we are about to reset the descs to the new pic, so we must
! clear down the old picture now. by the time we see the 'offscreen'
! it will have a stream we no longer have recorded and we will
! not be able to reset the picture desc. the unrecognised
! 'offscreen' will be discarded.
off screen(scr) if screens(scr)_picture#0
! now set up descs
picture_screens=picture_screens!(1<<scr)
screen==screens(scr)
screen_picture=pic
screen_stream=p_p1; ! back from connect
screen_top=0; ! first line first frame
!
p=0 { do enable }
p_dest=x'370002'; ! cc
p_p1=screen_stream
p_p2=picture_p2; ! disc addr
p_p3=picture_p3; ! tags
p_p4=1; ! iso circ
p_p5=32; ! start of pic in section
p_p6=max pic lines * line len; ! length of pic
if mon level = 6 then PRINTSTRING("PM ENABLE REQ".SNL)
dout(p)
if p_p2#0 start ; ! failed
! this can happen if the connected screen has already been
! reconnected and oper has disconnected us. there will be
! an offscreen on its way, but we clear it down now and discard
! the latter when it comes bearing a stream number we dont
! recognise.
off screen(scr)
opout("Enable pic failed"); ! log it for now
return
finish
! all set. display first frame
display request(screen_stream,0)
return
sw(3): { off screen from private viewer }
picture == pictures(p_p1)
if picture_count>0 then picture_count=picture_count-1 c
else opout("PPIC off when not on.")
return
sw(4): { from comms controller }
! either 'done' from oper indirect(srce act=x'c')
! or failed from cc after disconnect(srce act=6)
! discard both of these as detailed above
if p_srce&x'FFFF'=6 start ; ! a cc failure. log it for now
if mon level # 6 then select output(1)
printstring("Display request refused by cc")
select output(0)
finish
return
sw(5): { unrecognised message from oper }
opout("Bad picture message from oper")
return
sw(6): { off screen from oper }
scr = screeno(p_p1)
off screen(scr) if scr>=0
! it might be <0 if we have already cleared this down before or
! after enable above, in which case it is discarded.
return
sw(7): { frame change from oper }
scr=screeno(p_p1); ! get screen no connected to stream
return if scr<0
! we can get frame changes for one we've already cleared down
! at enable above. discard.
screen==screens(scr)
screen_top=p_p6&x'FFFFFF'; ! requested line
pic = screen_picture
display request(screen_stream,screen_top)
end ; ! picture manager
!
!
!
routine initialise pictures
integer flag,i, pic, seg, gap
string (11) file
record (picturef)name picture
recordformat daf((integer sectsi, nsects, last sect, spare,
integerarray da(1:512) or integer sparex, integerarray i(0:514)))
record (daf)da
picture tick = 1
for pic=1,1,max pic files cycle
pictures(pic) = 0
file="PICTURE".itos(pic)
!
if TARGET # 2900 then flag = dcreate(uinf_user, file, uinf_fsys, c
8 << 2, 6, ada) else flag = dcreate(uinf_user, file, uinf_fsys, 8 << 2 {8 pages}, 6 {zero, vtemp})
if flag = 0 or flag = already exists start
seg = 0
gap = 0
if TARGET # 2900 then flag = dconnect(uinf_user,file, c
uinf_fsys,11,seg,gap) else c
flag = dconnect(uinf_user, file, uinf_fsys, 11, 0, seg, gap)
if flag = 0 start
if TARGET = 2900 then flag = dgetda(my name, file, my fsys, addr(da)) c
else start
flag = dgetda(my name, file, my fsys, da_i)
move(12, addr(da_i(0)), addr(da_sparex)) {to preserve common format}
finish
if flag = 0 start
picture == pictures ( pic )
picture_base = seg << seg shift
picture_p2 = da_da(1) { first - and only - section }
picture_p3 = da_lastsect - 1
integer(picture_base) = 32
integer(picture_base + 4) = 32
integer(picture_base + 8) = 8 << 12
integer(picture_base+24)=max pic lines * line len; ! to get all formatted at first use
finish else PRINTSTRING ( "DGETDA for ".FILE." fails : ".errs ( FLAG ).SNL )
finish else PRINTSTRING ( "DCONNECT ".FILE." fails : ".errs ( FLAG ).SNL )
finish else PRINTSTRING ( "DCREATE ".FILE." fails : ".errs ( FLAG ).SNL )
repeat
!
for i=0,1,max screen cycle
screens(i)=0
repeat
end ; ! initialise pictures
!
!
!
routine refresh pic(integer pic type, id1, string (15) id2 )
integer i
record (pe)p
record (picturef)name picture
cycle i = 1, 1, max pic files
picture == pictures ( i )
if picture_picture type = pic type and ( picture_id1 = id1 or pic type = FTP status summary display ) c
and picture_id2 = id2 start
{ id1 is which FT line to update if nonzero and pic type is FTP summary so don't check }
unless picture_screens = 0 = picture_count start
p = 0
p_p1 = 1 { refresh }
p_p2 = i
picture manager(p,pic type,id1,id2)
finish
finish
repeat
end ; ! refresh pic
stringfn ident to s(integer ident)
!***********************************************************************
!* *
!* TURNS A DOCUMENT IDENTIFIER INTO A STRING OF FIXED FORMAT *
!* *
!***********************************************************************
string (2) fsys
string (4) rest
fsys = i to s(ident>>24)
fsys = "0".fsys if length(fsys) = 1
rest = i to s(ident&x'FFFFFF')
rest = "0".rest while length(rest) < 4
result = fsys.rest
end ; !OF STRINGFN IDENT TO S
!*
!*
!*
!*
!***********************************************************
!The hashing routine for handling searches for HOST names.
integer fn hashed(string (63) name)
integer i, pt, n, h
byte integer array x(0:15)
const byte integer array prime(1:7)= 23, 19, 11, 7, 5, 13, 17
pt = (addr(x(7))>>3)<<3
longinteger(pt) = 0
n = addr(name)
byteinteger(pt+i&7) = byteinteger(pt+i&7)!!byteinteger(n+i) for i = 0, 1, length(name)
h = length(name)*29
h = h+prime(i)*byteinteger(pt+i) for i = 1, 1, 7
result = h&hash length
end ; !of hashed
integer fn lookup hasht(string (63) name)
record (name f) name name entry
integer h
h = hashed(name)
if pointers_hasht(h)#-1 start
name entry == record(database conad + pointers_hasht ( h ))
cycle
if name=name entry_name then result = name entry_host entry
exit if name entry_link = -1
name entry == record ( database conad + name entry_link )
repeat
finish
result = 0
end ; !of lookup hasht
integer fn lookup host(string (63) name)
integer i
string (63) rest
{uctranslate or lc?}
i = lookup hasht(name)
if i#0 then result = i
unless name->(this ukac.".").rest start
i = lookup hasht(this ukac.".".name); !prefix uk.ac
if i#0 then result = i
if name->name.(".").rest then result = lookup hasht(name); !for arpa.
finish
result = 0
end ; !of lookup host
!END OF THE HASHING ROUTINES
!*
!*
!*
!*
constbyteinteger file service = x'01'
constbyteinteger mail service = x'02'
routine interpret descriptor(integer call type, address,
integername len, string (6) user,integername ident, flag)
!***********************************************************************
!* *
!* INTERPRETS AND IF VALID ACTS ON THE DOCUMENT DESCRIPTOR AT THE *
!* SPECIFIED ADDRESS. *
!* ON ENTRY: *
!* ADDRESS = ADDRESS OF DESCRIPTOR *
!* LEN = NUMBER OF BYTES IN DESCRIPTOR *
!* USER = NAME OF SENDING PROCESS OR "" IF FROM AN INPUT STREAM *
!* SRCE = NAME OF INPUT STREAM IF USER = "" *
!* IDENT NOT SET *
!* FLAG NOT SET *
!* ON EXIT: *
!* LEN = POSITION OF LAST CHARACTER INTERPRETED IN DESCRIPTOR *
!* IDENT = DOCUMENT IDENTIFIER IF FLAG = 0 *
!* FLAG = RESULT 0 SUCCESSFUL *
!* *
!***********************************************************************
record (document descriptorf)name document
record (password document descriptor f)name password document
record (document descriptorf)temp descr, ndocument
record (fhf)name file header
string (7) c
string (100) field, p, s, s1, s2, guest address
integer i, j, eq found, fsys, char, end, type, resource, seg,gap, station, specific fep
routinespec set and check descriptor(string (7) c,
string (100) p, integername f)
!*
routine to doc string(record (document descriptorf)name document,
byteintegername field, stringname value)
field = 0 and return if value = ""
flag = descriptor full and return if document_string ptr + length(value) > 147
field = document_string ptr
string(addr(document_string space) + document_string ptr) = value
document_string ptr = document_string ptr + length(value) + 1
end
!*
routine to null docstring(record (document descriptor f)name document,
byteinteger field)
integer i,j,k
return if field = 0
k = addr(document_string space) + field
i = byteinteger(k)
return if i = 0
cycle j = k ,1 ,k+i
byteinteger(j) = 0
repeat
!We have written 0s over the string entry.
return
end
!*
routine to password doc string(record (password document descriptorf)name document,
byteintegername field, stringname value)
field = 0 and return if value = ""
flag = descriptor full and return if document_string ptr + length(value) > 127
field = document_string ptr
string(addr(document_string space) + document_string ptr) = value
document_string ptr = document_string ptr + length(value) + 1
end
!*
guest address = ""
temp descr = 0; !SET ALL VALUES TO 0 OR "" OR -1
temp descr_string ptr = 1
temp descr_data start = -1
temp descr_data length = -1
temp descr_time = -1
temp descr_priority = -1
temp descr_output limit = -1
fsys = -1; !INTERNAL CAN BE SET BY USER
!*
if call type = user call start
!We have here a 'trusted' call with a pre constructed document descriptor
!which at the moment can only be a call for an NIFTP-B(80) transfer
ident = 0
move(256, address, addr(ndocument_state))
p = docstring(ndocument,ndocument_FTP alias)
select output(1)
printstring(dt."user ".user." request for ".p.snl)
select output(0)
if p -> s.("[").field.("]").s1 and s=s1="" start
if field -> s.("FEP").s1.(".").s2 and s = "" start
field = s2
specific fep = stoi(s1)
finish else specific fep = -1
guest address = field
p = "GUEST"
station = guest entry
finish else station = lookup host(p)
if station = 0 then flag = 4 and -> fails
fsys = -1
if user = "MAILER" start
!Mailer special case.
if station # guest entry and FTP stations(station)_services c
& mail service = 0 then flag = 4 and -> fails
c = docstring(ndocument,ndocument_name)
unless length(c) = 6 then flag = 6 and ->fails
length(c) = 2
fsys = stoi(c)
finish else start
if station # guest entry and FTP stations(station)_ c
services&file service = 0 then flag = 4 and -> fails
flag = dfsys(user,fsys)
if flag # 0 then flag = 1 and ->fails
!now check that the user has pss priv.(temp until password/name
!for gateway access can be picked up and passed with call)
!FTP Station STATUS list.
!0 General accesss station
!1 PSS accreditation (bit 6) required
!5 Masked (ALIAS) but can be seen in TRANSFERS(.ALL/*) enquiries
!6 MASKED and is invisable even in TRANSFERS(.ALL/*) enquiry.
!7 As 6 but requires ACR 9 for access.
if FTP stations(station)_status = 1 start
!ie status 1 implies accreditation check required(PSS)
!which is priv bit 6 until level 3 addressing available.
!status 2 is test only so include it in checks.
if TARGET # 2900 start
flag = dsfi(user, fsys, 38, 0, dsfis, dsfiia)
j = dsfiia(1)
finish else flag = dsfi(user,fsys,38,0,addr(j))
flag = 8 and ->fails if (j>>6)&1 = 0
finish
finish
ndocument_user = user
ndocument_FTP retry level = 3
ndocument_try emas to emas = yes
ndocument_rerun = yes
ident = get next descriptor(fsys)
if ident = 0 then flag = 2 and ->fails
document == record(document addr(ident))
document = ndocument
document_date and time received = current packed dt
!FRIG for ERCC sites
if p = "2988" or p = "2980" then p = "BUSH" and to docstring( c
document,document_ftp alias,p)
if p = "2972" then p = "EMAS" and to docstring(document,document_ftp alias,p)
!END OF FRIG
if guest address # "" start
to docstring(document,document_guest address,guest address)
to docstring(document,document_FTP alias,p)
if document_FTP alias = x'ff' {full string space!} then flag = 4 and -> fails
document_specific fep = specific fep
finish
if document_priority = -1 then type = queue_default priority c
else type = document_priority
document_priority requested = type
if document_data length = 0 then document_data length = c
FTP stations(station)_limit; !sensible choice in this case.
resource = (document_data length + 1023)>>10
document_priority = compute priority(type, resource, queue_resource limit)
if document_mode of access <= x'0003' or document_mode of access = x'4001' c
or document_mode of access = x'2001' start
!we are to send the file.
flag = dtransfer(user, my name, docstring(document,document_srce), identtos(ident), fsys, fsys, 1)
if flag # 0 start
select output(1)
printstring(dt."DTRANSFER for user request fails ".errs(flag).snl)
select output(0)
flag = 3 and ->fails
finish
seg = 0; gap = 0
if TARGET # 2900 then flag = dconnect(my name, identtos(ident),fsys,r!w,seg,gap) c
else flag = dconnect(my name, identtos(ident), fsys, r!w, 0, seg, gap)
if flag # 0 start
select output(1)
printstring(dt."DCONNECT of DTRANSFERed user request fails ".errs(flag).snl)
select output(0)
flag = 3 and ->fails
finish
file header == record(seg<<seg shift)
document_data length = file header_end-file header_start
document_data start = file header_start
flag = ddisconnect(my name,identtos(ident),fsys,0)
finish else if document_mode of access = x'8002' or document_mode of access = x'C001' start
!we are to fetch the file
document_data length = -1
document_data start = x'20'
finish else flag = 7 and ->fails
password document == record(password document addr(ident))
password document = 0
password document_string ptr = 1
if document_external password # 0 start
field = doc string(document,document_external password)
to null doc string(document,document_external password)
to password doc string(password document,password document_external password,field)
document_external password = set
!we have copied the password to the secure descriptor and blanked out
!the contents in the general descriptor. Marking the filed as set in the
!secure descriptor.
finish
if document_FTP file password # 0 start
field = doc string(document,document_FTP file password)
to null doc string(document,document_FTP file password)
to password doc string(password document,password document_FTP file password,field)
document_FTP file password = set
!we have copied the password to the secure descriptor and blanked out
!the contents in the general descriptor. Marking the filed as set in the
!secure descriptor.
finish
if document_special options # 0 start
field = doc string(document,document_special options)
to null doc string(document,document_special options)
to password doc string(password document,password document_special options,field)
document_special options = set
!we have copied the password to the secure descriptor and blanked out
!the contents in the general descriptor. Marking the filed as set in the
!secure descriptor.
finish
add to queue(ident,FTP stations(station)_connect retry time,no,no,flag)
if flag # 0 then flag = 5 and ->fails
ident = (ident<<8)>>8 and flag = 0; !ie ok.
return
fails:
ident = 0
return
finish
!*
c = ""; p = ""; eq found = no; end = len-1
cycle len = 0, 1, end
char = byte integer(address+len); !GET A CHARACTER
if char = ',' or len = end start
!END OF DESCRIPTOR
p <- p.to string(char) if char # ',' c
and char # nl and length(p) < 100
length(p) = length(p)-1 while length(p) > 1 c
and charno(p, length(p)) = ' '
set and check descriptor(c, p, flag)
return if flag # 0
c = ""; p = ""; eq found = no
finish else start ; !NOT THE END OF A DESCRIPTOR
if char # nl start
if char # '=' start ; !NOT AN EQUALS
if eq found = no start ;!EQUALS NOT FOUND YET
if char # ' ' start ;!IGNORE SPACES IN COMMANDS
c = c.to string(char) if length(c) < 7
finish
finish else start
if char # ' ' or p # "" start
!ONLY IGNORE LEADING SPACES
byteinteger(address+len) = '?' c
if c = "PASS"
p <- p.to string(char) if length(p) < 100
finish
finish
finish else eq found = yes
finish
finish
repeat
!*
return
!*
!*
!*
routine set and check descriptor(string (7) c,
string (100) p, integername flag)
!***********************************************************************
!* *
!* CHECK THE COMMAND AND ITS PARAMETER AND SET THE DESCRIPTOR IF OK *
!* *
!***********************************************************************
constinteger count = 24
conststring (7) array schedule params(1 : count) = c
"USER", "PASS", "DEST", "SRCE", "NAME", "DELIV", "TIME", "PRTY", "COPIES",
"FORMS", "MODE", "ORDER", "START", "LENGTH", "RERUN", "DECKS", "TAPES", "DISCS",
"AFTER", "FSYS", "OUT", "OUTLIM", "OUTNAME", "DAPMINS"
!* THE CONSTANTS BELOW SPECIFY THE RANGE OF VALUES WHICH CAN BE TAKEN
!* BY THE PARAMETERS ABOVE. WHERE-
!* BYTE 0 IF 0 = INTEGER IF 1 = STRING
!* BYTE 1 IF = 1 IGNORE BYTE 3
!* BYTE 2 IF STRING THE MIN LENGTH IF INTEGER THE MIN VALUE
!* BYTE 3 IF STRING THE MAX LENGTH IF INTEGER THE MAX VALUE
constintegerarray schedule param values(1 : count) = c
x'01000606', x'0100011F', x'0100010F', x'0100010F', x'0100010F', x'0100011F',
x'00010100', x'01000305', x'000001FF', x'000000FF', x'01000303', x'000000FF',
x'00010000', x'00010100', x'01000203', x'00000108', x'01000164', x'01000164',
x'0100081F', x'00000063', x'0100010F', x'00010000', x'010001FF', x'00010000'
constintegerarray errors(1 : count) = c
invalid username, invalid password, invalid destination, invalid srce,
invalid name, invalid delivery, invalid time, invalid priority,
invalid copies, invalid forms, invalid mode, invalid order,
invalid start, invalid length, invalid rerun, invalid decks,
invalid tapes or discs, invalid tapes or discs, invalid start after,
invalid fsys, invalid out, invalid outlim, invalid outname, invalid dap mins
integer value, i, min, max, type
flag = 0
cycle i = 1, 1, count
if schedule params(i) = c start
type = schedule param values(i)>>24
min = (schedule param values(i)>>8)&255
if (schedule param values(i)>>16)&255 # 0 c
then max = x'7FFFFFFF' c
else max = scheduleparam values(i)&255
if type = 0 start ; !INTEGER
value = stoi(p)
-> error if value = not assigned
-> error unless min <= value <= max
finish else start
-> error unless min <= length(p) <= max
finish
return
finish
repeat
flag = invalid descriptor
return
error:
flag = errors(i)
return
!NOTE we only do the above cursory check fpr BATCH input over File Transfer.
!The main checking will be done by spooler when the job is in.
end ; !OF ROUTINE SET AND CHECK DESCRPTOR
end ; !OF ROUTINE INTERPRET DESCRIPTOR
!*
!*
integerfn document addr(integer ident)
!***********************************************************************
!* *
!* RETURNS THE ADDRESS OF THE DOCUMENT DESCRIPTOR "IDENT" *
!* RETURNS ZERO IF IDENT IS NOT VALID *
!* *
!***********************************************************************
record (fhf)name file header
integer fsys, doc
fsys = ident>>24; doc = ident&x'FFFFFF'
result = 0 unless f systems(fsys)_addr # 0 c
and 1 <= doc <= max documents
file header == record(f systems(fsys)_addr)
result = f systems(fsys)_addr+file header_start+(doc-1)* c
document entry size
end ; !OF INTEGERFN DOCUMENT ADDR
!*
integerfn password document addr(integer ident)
!***********************************************************************
!* *
!* RETURNS THE ADDRESS OF THE DOCUMENT DESCRIPTOR "IDENT" *
!* RETURNS ZERO IF IDENT IS NOT VALID *
!* *
!***********************************************************************
record (fhf)name file header
integer fsys, doc
fsys = ident>>24; doc = ident&x'FFFFFF'
result = 0 unless f systems(fsys)_password addr # 0 c
and 1 <= doc <= max documents
file header == record(f systems(fsys)_password addr)
result = f systems(fsys)_password addr+file header_start+(doc-1)* c
password document entry size
end ; !OF INTEGERFN PASSword DOCUMENT ADDR
!*
!*
routine add to queue(integer ident, delay, all,fixed delay, integername flag)
!***********************************************************************
!* *
!* ADDS TO THE SPECIFIED QUEUE THE DOCUMENT SPECIFIED. *
!* DOCUMENTS ARE QUEUED BY PRIORITY. *
!* *
!***********************************************************************
record (document descriptorf)name document
string (71) s
integer cell, next, previous, line, amount, i, remove, fsys
integerarray sfi(1:18)
flag = 0
fsys = ident >> 24
if TARGET # 2900 then flag = dsfi(my name,fsys,4,0,dsfis,sfi) c
else flag = dsfi(my NAME, fsys, 4, 0, addr(sfi(1)))
if flag # 0 start
select output(1)
printstring(dt."DSFI for FTRANS on fsys ".itos(fsys)." fails ".errs(flag).snl)
select output(0)
printstring("FTRANS DSFI fails ".errs(flag).snl)
flag = queue full
return
finish
if sfi(3) < 6 or sfi(6) < 1 start
!either less than 6 file descriptors or 1 section descriptor left in that SPOOLR index
select output(1)
printstring(dt."SPOOLR index filling on ".itos(fsys).snl)
select output(0)
flag = queue full
return
finish
document == record(document addr(ident))
if queue_length < queue_max length start
!CHECK OK TO ADD TO QUEUE
cell = free list
if cell # 0 start ; !FREE LIST EMPTY?
free list = list cells(cell)_link
list cells(cell)_document = ident
previous = 0
next = queue_head
while next # 0 and imod(list cells(next)_priority) c
>= imod(document_priority) cycle
!CYCLE TILL END OF QUEUE OR PRIORITY <
previous = next; !REMEMBER ENTRY
next = list cells(previous)_link
repeat
if previous # 0 start ; !NOT ON HEAD OF QUEUE
list cells(cell)_link = list cells(previous)_link
!LINK IN NEW ENTRY
list cells(previous)_link = cell
finish else start ; !ON HEAD OF QUEUE
list cells(cell)_link = queue_head
queue_head = cell
finish
queue_length = queue_length+1
amount = document_data length
list cells(cell)_size=amount
queue_amount = queue_amount+amount
list cells(cell)_priority=document_priority
list cells(cell)_order = document_order
list cells(cell)_user=document_user
list cells(cell)_flags = 0
!we are dealing with general FTP queue
s = docstring(document,document_FTP alias)
i = lookup host(s)
if i = 0 then i = guest entry
list cells(cell)_station ptr = i
if list cells(cell)_station ptr = guest entry and s # "GUEST" then c
printstring(identtos(list cells(cell)_document).": ".s." ?".snl) and remove = yes else remove = no
if delay > 0 start
if all = no or s = "GUEST" start
list cells(cell)_FTP timer = delay
if fixed delay = yes or s = "GUEST" then list cells(cell)_FTP flags = c
list cells(cell)_FTP flags ! FTP fixed term delay
!put on the fixed(ie not to be reset) delay if required.
finish else start
i = queue_head
while i # 0 cycle
if list cells(i)_station ptr = list cells(cell)_station ptr start
list cells(i)_FTP timer = delay
list cells(i)_FTP flags = list cells(i)_FTP flags!FTP fixed term delay c
if fixed delay = yes
finish
i = list cells(i)_link
repeat
FTP stations(list cells(cell)_station ptr)_connect retry time = delay c
unless s = "GUEST"
!Set the Station DELAY for ALL circumstance.
!The GUEST stuff is because we want to treat GUEST in a different way
!since it can have documents queued for many different TS addresses.
!therefore we do not want to reflect one forced delay on one address to another.
finish
finish else list cells(cell)_FTP timer = c
connect retry times(FTP stations(list cells(cell)_station ptr)_ c
connect retry ptr)
document_state = queued
select output(1)
print string(dt.document_dest." ".ident to s(ident). c
" ".document_user.".".docstring(document,document_name)." QUEUED".snl)
select output(0)
cycle line = 1,1,lines
kick FTP line(line)
repeat
finish else start
print string("QUEUE FREE LIST EMPTY".snl)
flag = all queues full
finish
if remove = yes then c
remove from queue(ident,flag)
!This happens if at IPL the document in the FTP queue has an
!address of a station that has gone from the configuration.
finish else flag = queue full
end ; !OF ROUTINE ADD TO QUEUE
!*
!*
routine delete document(integer ident, integername flag)
!***********************************************************************
!* *
!* ROUTINE TO DELETE A DOCUMENT AND ITS DESCRIPTOR. *
!* *
!***********************************************************************
record (document descriptorf)name document
string (11) file
integer fsys
file = ident to s(ident)
fsys = ident>>24
document == record(document addr(ident))
flag = ddestroy(my name, file, "", fsys, 0)
if flag = 0 start
select output(1)
print string(dt.document_dest." ".file." ".document_user. ".".docstring(document,document_name)." DELETED".snl)
select output(0)
finish else start
select output(1)
print string(dt."DESTROY ".my name.".".file. c
" FAILS ".errs(flag).snl)
select output(0)
finish
document_date and time deleted = current packed dt
document_state = unused
end ; !OF ROUTINE DELETE DOCUMENT
!*
!*
routine remove from queue(integer ident,integername flag)
!***********************************************************************
!* *
!* REMOVE THE SPECIFIED DOCUMENT DESCRIPTOR FROM THE QUEUE *
!* *
!***********************************************************************
record (document descriptorf)name document
integer next, previous, amount
flag = 0
next = queue_head
while next # 0 and list cells(next)_document # ident cycle
previous = next
next = list cells(previous)_link
repeat
if next # 0 start
if next = queue_head then queue_head = list cells(next) c
_link else list cells(previous)_link = list cells( c
next)_link
list cells(next)_link = free list
free list = next
document == record(document addr(ident))
amount = document_data length
amount = amount*document_copies if document_copies > 1
queue_length = queue_length-1
queue_amount = queue_amount-amount
select output(1)
print string(dt.document_dest." ".ident to s(ident)." " c
.document_user.".".docstring(document,document_name)." UNQUEUED".snl)
select output(0)
finish else flag = not in queue
end ; !OF ROUTINE REMOVE FROM QUEUE
!*
!*
!*
routine any queued(integer fsys)
!***********************************************************************
!* *
!* SEARCHES THE "SPOOLLIST" ON THE SPECIFIED FILE SYSTEM AND ADDS ANY *
!* QUEUED DOCUMENTS TO THE APPROPRIATE QUEUE. DOCUMENTS WHICH WERE *
!* BEING PROCESSED WHEN THE SYSTEM STOPPED ARE EITHER REQUEUED OR *
!* DELETED DEPENDING ON THE VARIABLE "RERUN". *
!* *
!***********************************************************************
record (document descriptorf)arrayformat ddaf(1 : max documents)
record (document descriptorf)arrayname documents
record (document descriptorf)name document
record (fhf)name file header
string (2) sfsys
integer doc no, flag, ident
sfsys = i to s(fsys)
file header == record(f systems(fsys)_addr)
!MAP HEADER
documents == array(f systems(fsys)_addr+file header_start, ddaf)
!DOCUMENT ADDRS
cycle doc no = 1, 1, max documents
if documents(doc no)_state # unused start
!IS DESCRIPTOR IN USE
document == documents(doc no)
if document_dest = FTP work dest then delete document(ident,flag) and continue
flag = 1; ident = fsys<<24!doc no
if document_state = queued or (document_state = transferring c
and document_rerun = yes) start
!REQUEUE?
add to queue( ident, 0,no,no,flag)
print string("ADD ".ident to s(ident). c
" TO QUEUE ".document_dest." FAILS ". c
i to s(flag).snl) if flag # 0
finish
if flag # 0 start ; !DELETE IT!
select output(1)
print string(dt.document_dest." ".ident to s( c
ident)." ".document_user.".".docstring(document,document_name). c
" DELETED ".doc state(document_state). c
" AT START UP".snl)
select output(0)
delete document(ident, flag) c
if document_state # queued
finish
finish
repeat
end ; !OF ROUTINE ANY QUEUED
!*
!*
routine connect or create(string (6) user,
string (11) file, integer fsys, size, mode, flags,
integername caddr)
!***********************************************************************
!* *
!* CONNECT OR CREATE A FILE. SETTING CADDR WITH THE CONNECT ADDRESS OR*
!* ZERO IF UNSUCCESFUL. *
!* *
!***********************************************************************
record (fhf)name file header
record (finff)file info
integer flag, seg, gap, nkb
string (31) filename
caddr = 0; !SET RETURN CONNECT ADDRESS TO ZERO INITIALLY
nkb = ((size+(e page size-1))&(-e page size))>>10
if TARGET # 2900 then flag = dfinfo(user,file,fsys,file info_offer,file info_i) c
else flag = dfinfo(user, file, fsys, addr(file info))
if flag = 0 start
if nkb # file info_nkb start
flag = dchsize(user, file, fsys, nkb)
if flag # 0 then print string("CHSIZE ".user.".". c
file." FAILS ".errs(flag).snl) c
else print string(user.".".file." SIZE CHANGED ". c
i to s(nkb-file info_nkb)." KBYTES".snl)
finish
finish
seg = 0; !ANY SEGMENT WILL DO
gap = 0; !ANY GAP WILL DO
if TARGET # 2900 then flag = dconnect(user,file,fsys,mode,seg,gap) c
else flag = dconnect(user, file, fsys, mode, 0, seg, gap)
unless flag = ok start ; !SUCCESSFULLY CONNECTED?
filename = user.".".file
unless flag = does not exist start
!NO? THEN DID IT EXIST
print string("CONNECT ".filename." FAILS ".errs(flag). c
snl)
!YES THEN FAILURE MESSAGE
flag = ddestroy(user, file, "", fsys, 0)
!TRY TO DESTROY IT
finish else flag = ok
if flag = ok start ; !SUCCESS OR DOES NOT EXIST
if TARGET # 2900 then flag = dcreate(user, file, fsys, nkb, flags, ada) c
else flag = dcreate(user, file, fsys, nkb, flags)
!CREATE FILE
if flag = ok start ; !CREATED OK?
seg = 0; gap = 0
if TARGET # 2900 then flag = dconnect(user,file,fsys,r!w,seg,gap) c
else flag = dconnect(user, file, fsys, r!w, 0, seg, gap)
if flag = ok start ; !CONNECTED OK?
caddr = seg<<seg shift; !SET CONNECT ADDRESS
file header == record(caddr)
!SET UP A FILE HEADDER
file header_end = file header size
file header_start = file header size
file header_size = (size+e page size-1)&(- c
e page size)
file header_datetime = current packed dt
finish else print string("CONNECT ".filename. c
" FAILS ".errs(flag).snl)
finish else print string("CREATE ".filename. c
" FAILS ".errs(flag).snl)
finish else print string("DESTROY ".filename." FAILS ". c
errs(flag).snl)
finish else caddr = seg<<seg shift; !ALREADY EXISTED SO RETURN CONNECT ADDRESS
end ; !OF ROUTINE CONNECT OR CREATE
!*
!*
routine any extra files(integer fsys,special)
!***********************************************************************
!* *
!* THIS ROUTINE CHECKS TO SEE IF THERE ARE ANY FILES IN FTRANS'S *
!* INDEX WHICH DO NOT CORRESPOND TO A DOCUMENT DESCRIPTOR IN A QUEUE *
!* ANY SUCH FILES FOUND ARE DELETED *
!* THIS ROUTINE MUST ONLY BE CALLED WHEN ALL STREAMS ARE IDLE *
!* *
!***********************************************************************
record (document descriptorf)name document
record (file inff)array temprec(0 : 1)
integer maxrec, filenum, nfiles, flag, i, j, ident, afsys, next
string (11) file
max rec = 1; filenum = 0
if TARGET = 2900 then c
flag = dfilenames(my name, temprec, filenum, maxrec, nfiles,
fsys, 0) else flag = dfilenames(my name, filenum, maxrec, nfiles, c
fsys, 0, temprec)
if flag = 0 start
if nfiles > 0 start
print string("FSYS ".i to s(fsys)." FILES ".i to s( c
nfiles).snl)
max rec = nfiles
begin
record (file inff)array files(0 : max rec)
if TARGET = 2900 then c
flag = dfilenames(my name, files, filenum, max rec, c
nfiles, fsys, 0) else flag = dfilenames(my name, filenum, max rec, c
nfiles, fsys, 0, files)
if flag = 0 start
cycle i = 0, 1, nfiles-1
if charno(files(i)_name, 1) # '#' c
and files(i)_use = 0 start
!ONLY FILES NOT IN USE
file = files(i)_name
if length(file) = 6 start
!DOCUMENT?
afsys = 0
cycle j = 1, 1, 2
-> del unless '0' <= charno(file,
j) <= '9'
afsys = afsys*10+charno(file, j)-'0'
repeat
-> del unless afsys = fsys
ident = 0
cycle j = 3, 1, 6
-> del unless '0' <= charno(file,
j) <= '9'
ident = ident*10+charno(file, j)-'0'
repeat
-> del unless 1 <= ident <= c
max documents
ident = afsys<<24!ident
document == record(document addr( c
ident))
next = queue_head
while next # 0 cycle
!SCAN DOWN QUEUE
-> next if list cells(next)_ c
document = ident
!FOUND IT
next = list cells(next)_link
repeat
if special = no or (document_state = unused and c
document_dest # FTP work dest) start
delete document(ident, flag)
if flag = 0 then print string( c
ident to s(ident)." DELETED".snl) c
else print string("DELETE ". c
ident to s(ident)." FAILS ".i to s c
(flag).snl)
finish
-> next
finish
del:
if special = no start
flag = ddestroy(my name, file, "", fsys, 0)
if flag = 0 then print string(file. c
" DELETED".snl) else print string( c
"DELETE ".file." FAILS ".errs(flag). c
snl)
finish
next:
finish
repeat
finish else print string("FILENAMES ".my name. c
" FSYS ".i to s(fsys)." FAILS ".errs(flag). c
snl)
end
finish else print string("FSYS ".i to s(fsys). c
" NO FILES".snl)
finish else print string("FILENAMES ".my name." FSYS ". c
i to s(fsys)." FAILS ".errs(flag).snl)
end ; !OF ROUTINE ANY EXTRA FILES
!*
!*
routine open file system(integer fsys)
!***********************************************************************
!* *
!* FTRANS MAINTAINS A FILE INDEX ON EACH FILE SYSTEM AND THIS ROUTINE *
!* OPENS THE FILES ON THE SPECIFIED FILE SYSTEM FOR USE, EITHER BY *
!* CONNECTING THEM OR BY CREATING NEW FILES WHERE APPLICABLE. *
!* WHEN A FILE SYSTEM IS OPEN THE APPROPRIATE VARIABLE (ON LINE) IN *
!* IN THE RECORD ARRAY F SYSTEMS IS SET NON ZERO. SIMILARILY WHEN *
!* A FILE IS OPEN FOR USE ITS CONNECT ADDRESS IS PLACED IN THE ARRAY *
!* CONAD. THE ROUTINE CLOSE FILE SYSTEM DOES THE OPPOSITE OF THIS *
!* ROUTINE FOR RECONFIGURATION PURPOSES. *
!* *
!***********************************************************************
record (fhf)name file header, password file header
integer caddr, file size, flag, password caddr, password file size, new list
string (11) file, password file
string (2) sfsys
new list = no
sfsys = i to s(fsys)
if f systems(fsys)_addr = 0 start ; !CHECK IF ALREADY OPEN
file = "FTPLIST".sfsys; password file = "FTPPASS".sfsys
file size = file header size+max documents* c
document entry size
password file size = file header size + max documents*password document entry size
connect or create(my name, file, fsys, file size, r!w!sh, zerod,
caddr)
!CONNECT OR CREATE
f systems(fsys)_addr = caddr; !STORE CONNECT ADDRESS
connect or create(my name, password file, fsys, password file size, c
r!w, zerod, password caddr)
f systems(fsys)_password addr = password caddr
f systems(fsys)_closing = no
unless caddr = 0 start
file header == record(caddr)
if file header_end = file header_start start
!NEW FILE?
new list = yes
file header_end = file size
file header_free hole = 1
print string("NEW FTP LIST FSYS ".sfsys.snl)
flag = dpermission(myname, "DIRECT", "", "", fsys, 6, r)
print string( c
"SET INDEX PERMISSION FOR DIRECT FAILS ".errs( c
flag).snl) if flag # 0
flag = dpermission(myname,"","",file,fsys,1,r)
if flag # 0 then printstring("DPERMISSION for general access fails ". c
i to s(flag).snl)
finish else start
!the next two statements can go when all sites have vsn 31
flag = dpermission(myname,"","",file,fsys,1,r)
if flag # 0 then printstring("DPERMISSION for REMOTE fails ". c
i to s(flag).snl)
any queued(fsys)
finish
finish else print string("NO FTP LIST FSYS ".sfsys.snl)
unless password caddr = 0 start
password file header == record(password caddr)
if password file header_end = password file header_start start
!A new file
password file header_end = password file size
printstring("NEW PASS LIST FSYS ".sfsys.snl)
if new list = no then printstring("DISASTER PASS list on ". c
sfsys.snl."lost. TRANSFERS will fail".snl)
flag = dpermission(my name,"DIRECT","","",fsys,6,r)
printstring("SET INDEX PERMISSION FOR DIRECT fails ".errs(flag).snl) c
if flag # 0
finish
finish else printstring("NO PASS LIST ON FSYS ".sfsys.snl)
finish else print string("ALREADY OPEN FSYS ".sfsys.snl)
end ; !OF ROUTINE OPEN FILE SYSTEM
!*
!*
routine handle close(record (pe)name p)
!******************************************************
!* WARNING OR OCCASION OF A FSYS OR A FEP CLOSING. *
!* OR THE REMOVAL OF A CLOSE. *
!******************************************************
integer i, j
!
if p_p1 = 1 start
!TOTAL OR PARTIAL FSYS CLOSE OR WITHDRAW.
if p_p2 = 0 then j = yes
if p_p2 = 2 then j = no
!0 -> CLOSING, 2 -> WITHDRAW CLOSE.
if p_p3 = -1 start
!FOR ALL FILE SYSTEMS.
cycle i = 0, 1, max fsys
f systems(i)_closing = j
repeat
closing = j
finish else start
!ACTION ON AN INDIVIDUAL FSYS
return if f systems(p_p3)_addr = 0; !NOT AVAILABLE.
close fsys(p_p3) and return if p_p2 = 1; !IE CLOSE NOW
f systems(p_p3)_closing = j
if j = no start
cycle i = 0, 1, max fsys
if f systems(i)_addr # 0 and f systems(i)_closing # no then exit
closing = no if i = max fsys
repeat
finish else closing = yes
finish
finish else start
!FEP CLOSING.
if p_p2 = 2 start
cycle i = 0, 1, max fep
feps(i)_closing = no
repeat
return
finish
return if feps(p_p3)_FTP available = no
!CLOSING A PARTICULAR FEP.
if p_p2 = 0 then feps(p_p3)_closing = yes c
else fep down(p_p3)
return
finish
end
!*
!*
routine close fsys(integer fsys)
!********************************************************
!* THIS ROUTINE CLOSES AN FSYS IN RESPECT TO ALL ACTIVITY*
!*********************************************************
integer line, flag, next, after, i
record (pe)p
string (15) file
printstring("CLOSING FSYS ".i to s(fsys).snl)
update descriptors(fsys)
next = queue_head
while next # 0 cycle
after = list cells(next)_link
if list cells(next)_document>>24 = fsys then c
remove from queue( list cells(next)_document, flag)
next = after
repeat
!NOW CLEAR THE LINES.
cycle line = 1, 1, lines
if FTP lines(line)_status > allocated and FTP lines(line)_document>>24 = fsys start
p = 0
p_dest = line << 7
FTP control(p, refresh line)
if refresh line # 0 then refresh pic(FTP status summary display, refresh line, "")
finish
repeat
f systems(fsys)_addr = 0
f systems(fsys)_closing = no
cycle i = 0, 1, max fsys
exit if f systems(i)_addr # 0 and f systems(fsys)_closing = yes
closing = no if i = max fsys
repeat
file = "FTPLIST".i to s(fsys)
flag = ddisconnect(my name, file, fsys, 0)
if flag # 0 then printstring(" DISCONNECT FTPLIST FAILS ". c
errs(flag).snl)
file = "FTPPASS".i to s(fsys)
flag = ddisconnect(my name, file, fsys, 0)
if flag # 0 then printstring(" DISCONNECT FTPPASS FAILS ". c
errs(flag).snl)
return
end
!*
!*
!*
routine fep down(integer fe)
!**********************************************************************
!* *
!* THIS ROUTINE DEALS WITH CLEARING UP OVER A LOST FEP IN 3 STEPS: *
!* *
!* 1) ANY STREAM THAT WAS CURRENTLY ALLOCATED THRO THE LOST FEP *
!* IS STOPPED AND, IF ACTIVE, ABORTED. *
!* *
!* 2) THE CONTROL STREAMS FOR THE FRONT END ARE DISABLED *
!* *
!**********************************************************************
integer line, i
record (linef)name FTP line
record (pe)p
feps(fe)_FTP available = no
!*
!* STEP 1
!*
cycle line = 1, 1, lines; !ROUND ALL STREAMS
FTP line == FTP lines(line)
if FTP line_status # unallocated start
if FTP line_fep = fe start
interpret command("ABORT ".itos(line),"",0) if FTP line_status > allocated
if FTP line_status = deallocating or FTP line_status = connecting or c
FTP line_status = selected start
FTP line_status = unallocated
refresh pic(ftp status summary display,line,"")
FTP line_in stream status = unallocated
FTP line_out stream status = unallocated
FTP line_document = 0
FTP line_station ptr = 0
finish
finish
finish
repeat
!*
!* STEP 2
!*
feps(fe)_FTP input cursor = 0
feps(fe)_FTP output cursor = 0
p_dest = disable stream
p_srce = fe<<8!FTP output reply mess
p_p1 = feps(fe)_FTP input stream
p_p2 = abort
i = dpon3("", p, 0, 0, 6)
p_dest = disable stream
p_srce = fe<<8!FTP output reply mess
p_p1 = feps(fe)_FTP output stream
p_p2 = abort
i = dpon3("", p, 0, 0, 6)
p_dest = disconnect stream
p_srce = fe<<8!FTP output reply mess
p_p1 = feps(fe)_FTP input stream
i = dpon3("", p, 0, 0, 6)
p_dest = disconnect stream
p_srce = fe<<8!FTP output reply mess
p_p1 = feps(fe)_FTP output stream
i = dpon3("", p, 0, 0, 6)
end ; !OF ROUTINE FEP DOWN
!*
!*
!*
!*
!**********************************************************************
!*********************************************************************
!FTP CONTROL ROUTINES FOLLOW
routine FTP control(record (pe)name p,integername refresh line)
!*****************************************************************
!* *
!* F.T.P. C O N T R O L M A I N M O D U L E *
!* *
!*****************************************************************
record (fhf)name file header
record (linef)name FTP line
record (FTP tablef)name FTP table
record (document descriptorf)name document
integer dact, flag, line, ident, len, command length, command start, buffer offset, seconds
integer data length, data start, reply start, command sent activity, mail ident, rate
integer seg, gap, messages, limit, monitoring, table entry, delay,j, FTP timeout, old len, size
if TARGET = 2900 start
halfinteger transfer status
finish else start
shortinteger transfer status
finish
byteinteger type, subtype
string (128) s, s1, s2, s3, ss
string (11) state, mail state, extra info
string (127) work string
recordformat messf(stringname s)
record (messf) array message(1:16)
switch st(FTP connect : FTP confirmation from spooler )
switch time out(allocated : spooler called)
routinespec connect
routinespec disconnect
routinespec deallocate
routinespec abort FTP
routinespec enable in(integer mode, reply)
routinespec enable out(integer mode, reply, len, start, size, address)
routinespec disable in(integer action, reply)
routinespec disable out(integer action, reply)
routinespec format command(integer addr, offset, integername new len, integer eor)
routinespec interpret tcc(byteintegername type, subtype)
if TARGET # 2900 start
routinespec interpret comm(byteintegername type, shortintegername transfer status)
finish else start
routinespec interpret comm(byteintegername type, halfintegername transfer status)
finish
routinespec send block(integer reply, integername flag)
integerfnspec accept block
routinespec complete file handling(integername flag, stringname report)
routinespec send mail
routinespec generate(byteinteger type, subtype, integername len)
routinespec send to spooler(integer type,ident,confirm)
routinespec mail report(string (255) s, integer displ)
routinespec create FTP work files(integername flag, INTEGER MAIL ONLY)
routinespec input buffer connect
routinespec output buffer connect
routinespec buffer disconnect
routinespec FTP log(string (127) message)
routinespec evaluate negotiation(integer command start, reply start, c
integername reply length, integer limit, byteintegername type)
routinespec delete FTP document(integer ident)
command start = 0; reply start = 0; len = 0
if 2 < mon level < 5 start
select output(1)
printstring(dt."FTP CONTROL(POFF): ")
pt rec(p)
select output(0)
finish
dact = p_dest & 127
FTP timeout = no
line = (p_dest&x'FFFF')>>7
FTP line == FTP lines (line)
table entry = line
FTP table == FTP tables(line)
if dact = 0 start
!we have a locally issued abort.
if ftp line_status = connecting and ftp line_in stream status = connecting c
and ftp line_out stream status = connecting start
!We are in a connecting state on both streams.
!So we try an abort (DEALLOCATE)
FTP line_in stream status = aborting
FTP line_out stream status = aborting
deallocate
!We must watch for a connect reply crossover comming.
FTP line_document = 0
FTP line_station ptr = 0
return
finish
return unless FTP line_in stream status = active
if FTP line_user abort = yes then s = "User " else s = ""
print string(s."Aborting ".FTP line_name.snl)
abort FTP
return
finish
unless line = 0 then refresh line = line
if 2 < mon level < 5 then start
FTP log(" (line ".itos(line).") CURRENT STATUS: ". c
stream status type(FTP line_status)." ACT: ".FTP act(dact))
select output(0)
finish
if receiving data <= FTP line_status <= end of data acknowledge sent c
then start
ident = FTP line_document
document == record(document addr(ident))
finish
if p_p2 # 0 and FTP p command reply <= dact <= FTP data input start
printstring("FTP (".itos(table entry).") Enable buffer fails ". c
i to s(p_p2).snl)
abort FTP
return
finish
-> st(dact)
st(FTP connect):
!----------------------------------------------------------------------
!AN FTP STREAM PAIR IS ALLOCATED, ISSUE THE REQUIRED CONNECT
if FTP stations(control entry)_service = closed start
if FTP line_station type = P station start
FTP line_station ptr = 0
FTP line_document = 0
finish
FTP log(" service closed, not proceeding to connect.")
deallocate
return
finish
if FTP line_station type = P station start
s = "P station"
FTP stations(FTP line_station ptr)_last call = current packed dt
FTP stations(FTP line_station ptr)_connect attempts = FTP stations( c
FTP line_station ptr)_connect attempts + 1
finish else s = "Q station"
s = s." for ".string at(FTP stations(FTP line_station ptr),FTP stations(FTP line_station ptr)_shortest name)
FTP log(" connecting as a ".s)
connect
FTP line_status = connecting
FTP line_user abort = no
FTP line_timer = FTP default timeout
return
st(FTP input connected):
!----------------------------------------------------------------------
!THE INPUT STREAM OF AN FTP PAIR IS CONNECTED.
if FTP line_status = unallocated then FTP log( c
" already unallocated on disconnect reply(fep down / connect attempt aborted?)")
if p_p2 # 0 then start
!THE CONNECTION HAS FAILED.
FTP log(" CONNECT (IN) FAILS ".itos(p_p2).snl)
if FTP line_station type = P station and FTP line_document # 0 start
if FTP stations(FTP line_station ptr)_status # 2 then start
! if # 2 then it is a service station.
j = FTP stations(FTP line_station ptr)_connect retry ptr
if j = 10 then j = 1 else j = j + 1
FTP stations(FTP line_station ptr)_connect retry ptr = j
set document timers(FTP line_station ptr,connect retry times(j),0)
!We must reset the connect retry delay after the failure for the
!documents queued for this station.
finish else start
!we have a test site so if connection fails delete the document.
remove from queue(FTP line_document,flag)
delete FTP document(FTP line_document)
FTP log(" TEST station, document deleted.".snl)
finish
FTP line_document = 0
finish
if FTP line_in stream status = aborting start
!This is a connect abort and the deallocate reply has not yet been recieved.
!It can overtake and in this case we will be in suspended state.
FTP line_in stream status = allocated
FTP log("Connect (IN) fail reply after abort, Deallocate reply to come.".snl)
if FTP line_out stream status = allocated then FTP log("OUT reply ". c
"already recieved.".snl)
return
!We return since the Deallocate was issued to trigger this sequence so
!we await the reply to it now.
finish
if FTP line_in stream status = suspending and FTP line_status = deallocating start
!We have already had the deallocate reply but are hanging around for the
!connect fail reply before freeing the line.
FTP line_in stream status = unallocated
ftp log("Connect IN reply on delayed line reuse(connect abort).".snl)
if FTP line_out stream status = unallocated start
ftp log("Both IN and OUT fail replies recieved.".snl)
FTP line_status = unallocated
kick ftp line(line)
return
finish
return
finish
FTP line_in stream status = allocated
if FTP line_out stream status = active then disconnect
if FTP line_out stream status = allocated then deallocate
return
finish
FTP line_in comms stream = p_p1
FTP line_in stream status = active
if FTP line_out stream status = allocated then disconnect
-> FTP pair connected if FTP line_out stream status = active
return
st(FTP output connected):
!----------------------------------------------------------------------
!THE OUTPUT STREAM OF AN FTP PAIR IS CONNECTED.
if FTP line_status = unallocated then FTP log( c
" already deallocated on connect reply (fep down / connect attempt abort?)")
if p_p2 # 0 then start
!THE CONNECTION HAS FAILED.
FTP log(" CONNECT (OUT) FAILS ".itos(p_p2).snl)
if FTP line_station type = P station and FTP line_document # 0 start
if FTP stations(FTP line_station ptr)_status # 2 then start
!ie = 2 implies service, 2 is test only.
j = FTP stations(FTP line_station ptr)_connect retry ptr
if j = 10 then j = 1 else j = j + 1
FTP stations(FTP line_station ptr)_connect retry ptr = j
set document timers(FTP line_station ptr,connect retry times(j),0)
!We must reset the connect retry delay after the failure for the
!documents queued for this station.
finish else start
!we have a test site so if connection fails delete the document.
remove from queue(FTP line_document,flag)
delete FTP document(FTP line_document)
FTP log(" TEST station, document deleted.".snl)
finish
FTP line_document = 0
finish
if FTP line_out stream status = aborting start
!This is a connect abort and the deallocate reply has not yet been recieved.
!It can overtake and in this case we will be in suspended state.
FTP line_out stream status = allocated
FTP log("Connect (OUT) fail reply after abort, Deallocate reply to come.".snl)
if FTP line_in stream status = allocated then FTP log("IN reply ". c
"already recieved.".snl)
return
!We return since the Deallocate was issued to trigger this sequence so
!we await the reply to it now.
finish
if FTP line_out stream status = suspending and FTP line_status = deallocating start
!We have already had the deallocate reply but are hanging around for the
!connect fail reply before freeing the line.
FTP line_out stream status = unallocated
ftp log("Connect OUT reply on delayed line reuse(connect abort).".snl)
if FTP line_in stream status = unallocated start
ftp log("Both IN and OUT fail replies recieved.".snl)
FTP line_status = unallocated
kick ftp line(line)
return
finish
return
finish
FTP line_out stream status = allocated
if FTP line_in stream status = active then disconnect
if FTP line_in stream status = allocated then deallocate
return
finish
FTP line_out comms stream = p_p1
FTP line_out stream status = active
if FTP line_in stream status = allocated then disconnect
-> FTP pair connected if FTP line_in stream status = active
return
FTP pair connected:
if FTP line_station ptr = 0 start
!Timing problem ?
select output(1)
printstring(dt." ZERO station ptr for line ".itos(line)." on CONNECT OK".snl)
select output(0)
disconnect
return
finish
FTP log(" negotiating")
FTP line_bytes transferred = 0
FTP line_transfer status = viable
FTP line_status = active
FTP line_pre abort status = active
!The pre abort status is always set to 'active' except when
!an ABORT takes place when it is used to remember the status before the abort.
FTP line_offset = 0
FTP line_abort retry count = 0
FTP line_timer = FTP default timeout
FTP line_output transfer pending = no
FTP line_output buffer status = ready
FTP stations(FTP line_station ptr)_connect retry ptr = 0
set document timers(FTP line_station ptr, 0,0)
!Ie if the connection succeeds then no need to have any 'penalty' wait
!before the next connect.
if FTP line_station type = p station start
!WE HAVE AN FTP P STATION CONNECTED.
document == record(document addr(FTP line_document))
create FTP work files(flag,no)
if flag # 0 start
printstring("FTP (".itos(table entry).") work file create fails ".i to s(flag).snl)
FTP stations(control entry)_service = closed
disconnect
return
finish
if document_state # queued start
printstring("User terminates ".FTP line_name.snl)
FTP line_document = 0
FTP stations(FTP line_station ptr)_connect retry ptr = 0
set document timers(FTP line_station ptr,0,0)
FTP line_station ptr = 0
disconnect
return
finish
!This only happens if user deletes the document during the connect phase.
remove from queue(FTP line_document,flag)
if flag # 0 start
FTP log(" Remove ".identtos(FTP line_document)." fails ".itos(flag))
FTP line_document = 0
FTP line_station ptr = 0
disconnect
return
finish
document_state = transferring
FTP line_data transfer start = current packed dt
FTP lines(line)_user = document_user
output buffer connect
generate(FTP sft, 0, len)
buffer disconnect
if document_mode of access > x'8000' then s = "from" else s = "to"
if FTP table_mail = no then c
mail report(document_user.mail mc.snl.snl. c
"To: ".document_user.mail mc.snl. c
"From: TRANSFER [fail]".snl. c
"Subject: ".s." ".string at(FTP stations(FTP line_station ptr),FTP stations c
(FTP line_station ptr)_shortest name)." : ".docstring(document,document_name). c
snl.snl."Transfer of ".identtos(FTP line_document)." ".docstring(document,document_name). c
snl, 0) and FTP table_mail displ = mail dis + length(document_user)*2 c
else mail report(document_user.mail mc.snl.snl. c
"Keywords: " .snl."To:".document_user.mail mc.snl. c
"From:FTPMAN".snl."Comments:FTP".snl."References:".docstring(document, c
document_name).snl.snl, 0) and FTP table_mail displ = mail dis-11
enable out(FTP command, FTP p command sent, len,buffer offset,1, FTP line_out block addr)
enable in(FTP command, FTP command overflow)
FTP line_status = sft sent
return
finish else start
!WE HAVE A CONNECT AS A FTP Q STATION.
create FTP work files(flag,no)
if flag # 0 start
printstring("FTP (".itos(table entry).") work file create fails ".i to s(flag).snl)
FTP stations(control entry)_service = closed
disconnect
return
finish
enable in(FTP command, FTP command overflow)
FTP line_status = awaiting sft
FTP line_data transfer start = current packed dt
return
finish
st(FTP p command reply):
!----------------------------------------------------------------------
!AN INCOMING FTP KICK FROM A Q STATION. WE WILL ALWAYS GET HERE AS A
!OF A HIGH LEVEL CONTROL ON THE INPUT STREAM SINCE AN INCOMING
!COMMAND SHOULD NEVER EXCEED THE BUFFER SIZE.
unless FTP timeout = yes start
!thi may have been entered as a rseult of timeout or abort in
!which case we have no input to read.
command length = p_p5
FTP line_timer = (FTP table_timeout_value+59)//60
input buffer connect
output buffer connect
interpret comm(type, transfer status)
if messages # 0 start
cycle flag = 1,1,messages
mail report("From ".string at(FTP stations(FTP line_station ptr),FTP stations c
(FTP line_station ptr)_shortest name).": ".message(flag)_s.snl,0)
FTP log(" records info: ".message(flag)_s)
repeat
finish
if type = x'FF' then abort FTP and return
!The command structure was corrupted.
finish
!
if FTP line_status = sft sent start
!WE HAVE SENT AN SFT, THIS SHOULD BE OUR REPLY.
if FTP stations(control entry)_limit < FTP stations(FTP line_station ptr)_limit then c
limit = FTP stations(control entry)_limit else limit = FTP stations(FTP line_station ptr)_limit
if 2 < mon level < 5 or mon level = 6 then monitoring = on else monitoring = off
evaluate negotiation( command start, reply start, len, limit, type)
if type = FTP rneg or type = FTP rpos start
FTP stations(FTP line_station ptr)_last response = current packed dt
FTP stations(FTP line_station ptr)_last call = 0
FTP stations(FTP line_station ptr)_connect attempts = 0
finish
if type = FTP rneg start
!OH WELL
document == record(document addr(FTP line_document))
if document_FTP user flags & FTP no mail # 0 then FTP table_mail to send = no
if transfer status # rejected deferred start
if document_auto requeue = yes then ftp log(" ".ident to s(ftp line_document). c
" requeued after RNEG (AUTO REQUEUE)".snl) else start
FTP log(" transfer not viable..Deleting document.")
document_FTP retry level = 0
finish
finish
FTP line_transfer status = transfer status
!the evaluation will have built the STOP.
format command(reply start,0,len,1)
!so format it for FTP
buffer disconnect
enable out(FTP command, FTP p command sent, len,buffer offset,1,
FTP line_out block addr)
enable in(FTP command, FTP command overflow)
FTP line_status = stop sent
return
finish
if type = FTP rpos start
!SO FAR SO GOOD.
!note transfer remains viable.
generate(FTP go, 0, len)
buffer disconnect
enable out(FTP command, FTP p command sent, len,buffer offset,1, FTP line_out block addr)
enable in(FTP table_data control, FTP data input)
FTP line_status = go sent
return
finish
!after SFT SENT no other response is acceptable.
FTP log(" SFT sent invalid response ".itos(type))
buffer disconnect
abort FTP
return
finish
!
if FTP line_status = stop sent start
!WE ARE EXPECTING A STOP ACKNOWLEDGMENT
if type = FTP stopack start
buffer disconnect
document == record(document addr(FTP line_document)) if FTP line_document # 0
!we first check to see if we had SFT->RNEG->STOP->STOPACK
!sequence and if so decide if we can try another SFT (Usually
!this happens if we first tried EMASTOEMAS private code)
if rejected info <= FTP line_transfer status <= rejected attribute start
!indeed it rejected attribute, was it an EMASTOEMAS call, if so
!we could try open working...
document_FTP retry level = 0 if document_auto requeue = no
if FTP table_emas to emas = rejected and document_try emastoemas = yes start
document_try emas to emas = no
FTP log(" reports EMASTOEMAS rejection.")
document_FTP retry level = 3
finish
finish
if transfer status = x'FF' then transfer status = FTP line_transfer status
!We assume that, if no status is sent on the STOPACK, it is agreement.
if FTP line_transfer status = aborted retry possible and c
transfer status = aborted no retry then FTP line_transfer status = transfer status
!ie agree to wishes of Q station on this point.
!otherwise we have either failed completely or succeeded so clear up
if FTP line_transfer status = satisfactory termination and c
transfer status < aborted no retry then start
state = " ok "; mail state = "0"
if transfer status # satisfactory termination start
!We have got a problem message back status x'2001'
state = "fail"
mail state = "1"
finish
if FTP line_document # 0 start
if document_auto requeue = yes start
ftp log(" ".ident to s(FTP line_document)." requeued after success ". c
"(AUTO REQUEUE)".snl)
requeue FTP document(FTP line_document,0,no,no)
finish else delete FTP document(FTP line_document)
finish
if FTP table_mail = yes then mail report(mail state,FTP table_mail displ) c
else mail report(state, FTP table_mail displ); !set keyword for mailer or the OK status.
if FTP line_document # 0 and document_FTP user flags & FTP fail mail # 0 c
then FTP table_mail to send = no
if transfer status # satisfactory termination then mail report( c
date." ".time." Transfer fails, see information from the External System".snl,0) c
else mail report(date." ".time." Transfer successful".snl,0)
seconds = current packed dt
seconds = seconds - ftp line_data transfer start
if ((FTP stations(FTP line_station ptr)_bytes + FTP line_ c
bytes transferred) >>10 ) > 5000 start
select output(1)
printstring(dt."FTP Transfer rate for ".string at(FTP stations(FTP line c
_station ptr),ftp stations(FTP line_station ptr)_shortest name)." has been ")
rate =FTP stations(FTP line_station ptr)_bytes//FTP stations(FTP line_station ptr)_seconds
printstring(itos(rate)." bytes/second")
newline
select output(0)
FTP stations(FTP line_station ptr)_bytes = 0
FTP stations(FTP line_station ptr)_seconds = 0
finish
FTP stations(FTP line_station ptr)_bytes = FTP stations(FTP line_ c
station ptr)_bytes + FTP line_bytes transferred
FTP stations(FTP line_station ptr)_seconds = FTP stations(FTP line_ c
station ptr)_seconds + seconds
if FTP line_activity = sender then s = "to " else s = "from "
if FTP stations(FTP line_station ptr)_status = 1 then ss = " charge" else ss = ""
if transfer status = satisfactory termination then start
FTP log(" P ACCOUNT: ".FTP line_user." transfers ". c
itos((FTP line_bytes transferred+1023)>>10)."k ".s.string at(FTP stations c
(FTP line_station ptr),FTP stations(FTP line_station ptr)_shortest name).ss)
FTP stations(FTP line_station ptr)_P transfers = FTP stations( c
FTP line_station ptr)_P transfers + 1
FTP stations(FTP line_station ptr)_P kb = FTP stations(FTP line_station ptr)_ c
P kb + (FTP line_bytes transferred+1023)>>10
if ftp table_mail = yes then FTP stations(FTP line_station ptr)_ c
P mail = FTP stations(FTP line_station ptr)_P mail + 1
finish
finish else start
unless FTP line_transfer status = rejected deferred start
if document_auto requeue = no start
document_FTP retry level = document_FTP retry level-1 if c
document_FTP retry level > 0
finish
finish
if FTP line_transfer status = aborted no retry and c
document_auto requeue = no then document_FTP retry level = 0
!NOTE that when 'no resumption' is negotiated and I send back a
!'aborted retry possible' then that means retry in new transfer at beginning
if document_FTP retry level = 0 then start
FTP log(" transfer fails, attempts exhausted..Deleting.")
if FTP table_mail = yes then mail report("1",FTP table_mail displ); !set keyword for mailer.
mail report("Transfer fails and has been deleted.".snl,0)
delete FTP document(FTP line_document)
finish else start
if FTP line_transfer status = rejected deferred then delay = deferred delay c
else if document_auto requeue = yes then delay = auto poll delay c
else delay = transfer fail delay
requeue FTP document(FTP line_document,delay,no,yes)
FTP table_mail to send = no
finish
finish
if FTP line_aux document # 0 then delete FTP document( c
FTP line_aux document) and FTP line_aux document = 0
FTP line_document = 0
!here we now have the option to leave the transport service open
!but our implementation will not as yet for the P stations.
if FTP timeout = yes then abort FTP else disconnect
return
finish
!No other response acceptable.
FTP log(" STOP sent invalid response ".itos(type))
buffer disconnect
abort FTP
return
finish
!should never get here, if we do it is a FTRANS, not FTP, fault
FTP log(" P station error, invalid state ".itos(FTP line_status))
buffer disconnect
abort FTP
return
st(FTP p command sent):
!----------------------------------------------------------------------
!A BLOCK HAS BEEN SENT TO A Q STATION.
FTP line_timer = (FTP table_timeout_value+59)//60
FTP line_output buffer status = ready
if FTP line_output transfer pending = yes start
!we have an enable waiting to go.
flag = dpon3("",FTP line_output transfer record,0, 0,6)
FTP line_output buffer status = already enabled
FTP line_output transfer pending = no
FTP log(" pending transfer cleared.")
finish
!
if FTP line_status = sft sent or FTP line_status = stop sent c
or FTP line_status = end of data sent then return
!
if FTP line_status = quit sent start
if aborted no retry <= FTP line_transfer status <= aborted retry possible c
and FTP line_tcc subtype = awaiting data then abort FTP
!If the transfer has timed out (we are receiver) then we have to
!drag the line down when we have sent the quit since we cannot do
!a complete abort of the data input which will screw us up(TS will
!help perhaps with data resets ?)
return
finish
!
if FTP line_status = transmitting data start
send block(FTP p command sent, flag)
if flag # 0 start
!we have a sender error
output buffer connect
FTP line_tcc subtype = S error no resume
generate(FTP es, S error no resume, len)
mail report("Local Transmission failure".snl,0)
buffer disconnect
enable out(FTP data,FTP p command sent,len,buffer offset,1,FTP line_out block addr)
FTP line_status = end of data sent
return
finish
return
finish
!
output buffer connect
!
if FTP line_status = go sent then start
!AS A P STATION WE ARE READY TO RECEIVE OR TRANSMIT DATA.
document == record(document addr(FTP line_document))
if document_FTP user flags & FTP no mail # 0 then FTP table_mail to send = no
if FTP line_activity = sender start
!WE ARE TO TRANSMIT A FILE.
if FTP table_data control # no translation start
!We need a work area for local translation.
s = "LINEWRK".i to s(table entry)
if TARGET # 2900 then flag = dcreate(my name, s, FTP line_document>>24, c
((block size//FTP emas to emas block division)*2)>>10, zerod!tempfi, ada) c
else flag = dcreate(my name,s,FTP line_document>>24,((block size// c
FTP emastoemas block division)*2)>>10, zerod!tempfi)
!We assume the emastoemas blocks to be larger.
flag = 0 if flag = already exists
if flag # 0 start
FTP log(" DCREATE translate work file fails ".errs(flag))
buffer disconnect
abort FTP
return
finish
finish
if FTP table_emastoemas = yes and document_data start # 0 then c
document_data length = document_data length + document_data start
!This is done since we are to send the whole file including header.
FTP line_bytes to go = document_data length
if FTP table_emastoemas = yes then document_data start = 0
!We can safetly do this since if the negotiation is for inter emas
!now then it surely will be next time(should this transfer fail).
FTP line_block = (document_data start+block size)//block size
FTP line_part blocks = 0
FTP line_vrecord length = 0
FTP line_split vrecord length = no
FTP line_vbytes to go = 0
if FTP table_data type_value = x'0002' and FTP table_binary data c
record & x'03' = 3 {UNSTRUCTURED BINARy DATA} start
!It will go as tho it were a single record VARIABLE length record file.
FTP line_Vrecord length = document_data length
FTP line_vbytes to go = document_data length
finish
finish else start
!WE ARE TO RECEIVE A FILE.
if FTP table_file size_set = yes start
if FTP table_file size_value < 64 then size = FTP table_file size_value else c
if FTP table_file size_value <= block size>>10 then size = block size>>10 c
else size = FTP table_file size_value
finish else size = block size>>10
if TARGET # 2900 then flag = dcreate(my name, identtos(FTP line_document), c
FTP line_document>>24, size, 0, ada) else c
flag = dcreate(my name, identtos(FTP line_document), FTP line_document>>24, size, 0)
unless flag = 0 or flag = already exists then start
FTP line_tcc subtype = R error no resume
FTP log(" fails to create recieving file ".itos(flag))
mail report("Local Receiver failure".snl,0)
generate(FTP qr, R error no resume, len)
buffer disconnect
enable out(FTP data,FTP p command sent,len,buffer offset,1,FTP line_out block addr)
enable in(FTP table_data control,FTP data input)
FTP line_status = quit sent
return
finish
document_data length = -1
FTP line_block = 0
FTP line_part blocks = 0
FTP line_bytes to go = 0
FTP line_parity = yes {We assume any parity until otherwise informed by a CS}
FTP line_new FTP data record = yes
!This field is used to indicate that the next block of data is the start of a new
!FTP RECORD and (TEXT-FORMAT x0002 only) has ANSI control char at start.
!Now initialise the fields that will be used if it is BINARY receive
FTP line_records received = 0
FTP line_current vrecord length = 0
FTP line_current vrecord length addr = 0
FTP line_known to have records = 0
finish
FTP line_bytes sent = 0
if FTP line_activity = receiver then FTP line_status = receiving c
data and buffer disconnect and FTP line_timer = (FTP table_timeout_value+59)//60 and return
!OTHERWISE WE ARE READY TO BEGIN TRANSMITTING A FILE
generate(FTP ss, 0, len)
if FTP table_emastoemas = yes then generate(FTP cs,x'C3',len) else c
if FTP table_data type_value = x'0002' then generate(FTP cs,x'01',len) c
else generate(FTP cs, X'C0', len) {This being zero parity IA5}
buffer disconnect
enable out(FTP data, FTP p command sent, len,buffer offset,1, FTP line_out block addr)
FTP line_status = transmitting data
return
finish
!
if FTP line_status = last block sent then start
!WE HAVE ALREADY SENT THE LAST DATA BLOCK.
if FTP table_data control # no translation then flag = ddestroy( c
my name,"LINEWRK".itos(table entry),"",FTP line_document>>24,0)
generate(FTP es, ok, len)
buffer disconnect
enable out(FTP data, FTP p command sent, len,buffer offset,1, FTP line_out block addr)
FTP line_status = end of data sent
FTP line_tcc subtype = ok; !ie ER[OK] sent.
return
finish
!
if FTP line_status= end of data acknowledge sent start
generate(FTP stop, 0, len)
buffer disconnect
enable out(FTP command, FTP p command sent, len,buffer offset,1, FTP line_out block addr)
enable in(FTP command, FTP command overflow)
FTP line_status = stop sent
return
finish
buffer disconnect
FTP log(" P station invalid command sent kick ".itos( c
FTP line_status))
abort FTP
return
st(FTP q command reply):
!----------------------------------------------------------------------
!INCOMMING BLOCK FROM A P STATION
command length = p_p5
FTP line_timer = (FTP table_timeout_value+59)//60
input buffer connect
output buffer connect
interpret comm(type, transfer status)
if messages # 0 start
cycle flag = 1,1,messages
FTP log(" records info: ".message(flag)_s)
repeat
finish
if type = x'FF' then abort FTP and return
!Command structure corrupted.
!
if FTP line_status = awaiting sft start
!WE ARE WAITING FOR THE P STATION TO SEND THE SFT
if type = FTP sft start
!THATS WHAT IT IS.
FTP stations(FTP line_station ptr)_last q response by us = current packed dt
if FTP stations(control entry)_limit < FTP stations(FTP line_station ptr)_limit then c
limit = FTP stations(control entry)_limit else limit = FTP stations(FTP line_station ptr)_limit
old len = len
if 2 < mon level < 5 or mon level = 6 then monitoring = on else monitoring = off
evaluate negotiation( command start, reply start, len, limit, type)
!the evaluation will have built a RPOS or RNEG
if FTP table_mode_value = take job input and type = FTP RPOS start
!This is an incoming job..deal with the job scheduling here and change the
!response to RNEG if necessary.
work string = "DEST=BATCHFROMFTP,USER=".FTP table_username_value.",PASS="
work string = work string.FTP table_username password_value.",NAME="
if FTP table_filename_set = no then workstring = workstring."FTP_JOB" else workstring = work string. c
FTP table_filename_value
if FTP table_special options_set = yes start
s1 = FTP table_special options_value
if s1 -> s3.("PASS=").s2.(",").ss then s1 = s3.ss else c
if s1 -> s3.("PASS=").s2 then s1 = s3
FTP table_special options_value = s1
select output(1)
FTP log(" JOB input params: ".s1)
select output(0)
workstring <- workstring.",".s1
finish
j = length(workstring)
interpret descriptor(job call, addr(workstring)+1,j,"",FTP line_document,flag)
if flag # 0 start
FTP table_stopack message = "Job scheduling rejected."
type = FTP RNEG
FTP line_transfer status = rejected info
len = old len
FTP log("Job transfer rejected (".workstring.").")
generate(type,0,len)
finish else FTP log("JOB transfer accepted.")
finish
format command(reply start,0,len,1); !format it
buffer disconnect
enable out(FTP command, FTP q command sent, len,buffer offset,1, FTP line_out block addr)
enable in(FTP command, FTP command overflow)
if type = FTP rpos then start
FTP line_status = rpos sent
if ftp line_activity # sender and ftp table_mode_value = c
take job output start
ss = "to device "
if ftp table_device type_set = yes start
if ftp table_device type_value -> s1.("@").s then ss = ss.s1 else c
ss = ss.ftp table_device type_value
finish
finish else if ftp line_activity # sender and ftp table_ c
mode_value = take job input start
ss = "of Job "
if ftp table_filename_set = yes then ss = ss." ".ftp table_filename_value
finish else ss = "of ".ftp table_filename_value
if FTP line_activity = sender then s = "to " else s = "from"
mail report(FTP table_username_value.mail mc.snl.snl. c
"To: ".FTP table_username_value.mail mc. c
snl."From: TRANSFER [ ok ]".snl.c
"Subject: ".s." ".string at(FTP stations(FTP line_station ptr) c
,FTP stations(FTP line_station ptr)_shortest name)." : ". c
FTP table_filename_value. c
snl.snl."Externally initiated Transfer ".ss.snl,0)
FTP table_mail displ = mail dis + length(FTP table_username_value)*2
if FTP table_username_value = "FTPMAN" and FTP table_mode_value = take job output c
then FTP table_mail to send = no
finish else start
FTP line_status = rneg sent
FTP line_transfer status = transfer status
finish
return
finish
FTP log(" expected SFT but got a ".itos(type))
buffer disconnect
abort FTP
return
finish
!
if FTP line_status = rneg sent or FTP line_status = awaiting stop start
if type = FTP stop start
if transfer status = x'FF' start
if FTP line_status = awaiting stop start
if FTP line_transfer status = satisfactory termination then c
s = ", x'2000' :success assumed" and transfer status = satisfactory termination c
else s = ", failure, x'3011' assumed" and transfer status = aborted retry possible
finish else s = " after RNEG"
FTP log(" No transfer status on STOP".s)
finish
if FTP line_status = awaiting stop and transfer status # c
FTP line_transfer status then FTP log(" P station disagrees on TRANSFER-STATUS")
FTP line_transfer status = transfer status unless FTP line_transfer status = aborted no retry
!Agree with P unless we know that a retry is of no use.
if transfer status = satisfactory termination start
seconds = current packed dt
seconds = seconds - ftp line_data transfer start
if ((FTP stations(FTP line_station ptr)_bytes + FTP line_ c
bytes transferred) >>10 ) > 2000 start
FTP stations(FTP line_station ptr)_bytes = 0
FTP stations(FTP line_station ptr)_seconds = 0
finish
FTP stations(FTP line_station ptr)_bytes = FTP stations(FTP line_ c
station ptr)_bytes + FTP line_bytes transferred
FTP stations(FTP line_station ptr)_seconds = FTP stations(FTP line_ c
station ptr)_seconds + seconds
mail report(date." ".time." Transfer Successful".snl,0)
if FTP line_activity = sender then s = "to " else s = "from "
if FTP stations(FTP line_station ptr)_status = 1 then ss = " (charge)" else ss = ""
FTP log(" Q ACCOUNT: ".FTP table_username_value." transfers ". c
itos((FTP line_bytes transferred+1023)>>10)."k ".s.string at(FTP stations c
(FTP line_station ptr),FTP stations(FTP line_station ptr)_shortest name).ss)
FTP stations(FTP line_station ptr)_Q transfers = FTP stations( c
FTP line_station ptr)_Q transfers + 1
FTP stations(FTP line_station ptr)_Q kb = FTP stations(FTP line_station ptr)_ c
Q kb + (FTP line_bytes transferred+1023)>>10
if ftp table_mail = yes then FTP stations(FTP line_station ptr)_ c
Q mail = FTP stations(FTP line_station ptr)_Q mail + 1
finish else FTP table_mail to send = no
generate(FTP stopack, 0, len)
buffer disconnect
enable out(FTP command, FTP q command sent, len,buffer offset,1, FTP line_out block addr)
FTP line_status = stopack sent
FTP line_timer = 2
!only have 2 min timeout here.
return
finish
FTP log(" expected STOP but got a ".itos(type))
buffer disconnect
abort FTP
return
finish
!
if FTP line_status = rpos sent start
if type = FTP go start
!we have had a go from the p station so complete the transfer setup.
ident = get next descriptor(FTP table_user fsys)
if ident = 0 then start
FTPlog(FTP line_name." no free descriptors!")
s = "EMAS sys error"
->halt transfer
finish
FTP line_block = 0
FTP line_part blocks = 0
FTP line_bytes sent = 0
FTP line_bytes to go = 0
FTP line_user = FTP table_username_value
if FTP line_activity = sender start
!we are to send the file.
if FTP table_data control # no translation start
!the file needs to be pre processed.
s = "LINEWRK".i to s(table entry)
if TARGET # 2900 then flag = dcreate(my name,s,FTP table_user fsys, (( c
block size//FTP emastoemas block division)*2)>>10,zerod!tempfi,ada) c
else flag = dcreate(my name,s,FTP table_user fsys,((block size// c
FTP emastoemas block division)*2)>>10, zerod!tempfi)
!We assume the emastoemas blocks to be larger.
flag = 0 if flag = already exists
if flag # 0 start
FTP log(" DCREATE translate work file fails ".errs(flag))
buffer disconnect
abort FTP
finish
finish
!otherwise we can send the file as it is
flag = dtransfer(FTP table_username_value,my name,FTP table_filename_value, c
ident to s(ident),FTP table_user fsys,FTP table_user fsys,3)
if flag # 0 start
FTP log(" DTRANSFER ".FTP table_username_value.".". c
FTP table_filename_value." fails ".errs(flag))
s = "User file not FTP available"
-> halt transfer
finish
document == record(document addr(ident))
document = 0
document_priority requested = 3; !std
document_string ptr = 1
document_dest = FTP work dest
FTP line_document = ident
document_user = FTP table_username_value
seg = 0; gap = 0
if TARGET # 2900 then flag = dconnect(my name,ident to s(ident),FTP table_user fsys, c
r!w,seg,gap) else c
flag = dconnect(my name,ident to s(ident),FTP table_user fsys, c
r!w,0,seg,gap)
if flag # 0 start
FTP log(" DCONNECT ".ident tos(ident)." fails ". c
errs(flag))
s = "EMAS sys error"
-> halt transfer
finish
file header == record(seg<<seg shift)
if FTP table_emastoemas = yes then document_data start = 0 else c
document_data start = file header_start
document_data length = file header_end - document_data start
flag = ddisconnect(my name,ident to s(ident),FTP table_user fsys,0)
FTP line_bytes to go = document_data length
FTP line_block = (document_data start+block size)//block size
FTP line_part blocks = 0
FTP line_vrecord length = 0
FTP line_split vrecord length = no
FTP line_vbytes to go = 0
if FTP table_data type_value = x'0002' and FTP table_binary data c
record & x'03' = 3 {UNSTRUCTURED BINARy DATA} start
!It will go as tho it were a single record VARIABLE length record file.
FTP line_Vrecord length = document_data length
FTP line_vbytes to go = document_data length
finish
finish else start
if FTP table_file size_set = yes start
if FTP table_file size_value < 64 then size = FTP table_file size_value else c
if FTP table_file size_value <= block size>>10 then size = block size>>10 c
else size = FTP table_file size_value
finish else size = block size>>10
if TARGET # 2900 then flag = dcreate(my name,ident to s(ident), c
FTP table_user fsys,size,0,ada) else c
flag = dcreate(my name,ident to s(ident),FTP table_user fsys,size,0)
unless flag = 0 or flag = already exists start
FTP log(" DCREATE ".identtos(ident)." fails ".errs(flag))
s = "EMAS sys error"
-> halt transfer
finish
document == record(document addr(ident))
document = 0
document_priority = 1; !the lowest possible
document_string ptr = 1
document_dest = FTP work dest
if FTP table_device type_set = yes then to docstring( c
document,document_name,FTP table_device type_value) else c
to docstring(document,document_name,FTP table_filename_value)
document_user = FTP table_username_value
document_data length = -1
FTP line_new FTP data record = yes
FTP line_document = ident
buffer disconnect
enable in(FTP table_data control, FTP data input)
FTP line_status = receiving data
FTP line_parity = yes {Assume no parity until otherwise informed by a CS}
FTP line_timer = (FTP table_timeout_value+59)//60
!Now initialise the fields that will be used if it is BINARY receive.
FTP line_records received = 0
FTP line_current vrecord length = 0
FTP line_current vrecord length addr = 0
FTP line_known to have records = 0
return
finish
generate(FTP ss, 0, len)
if FTP table_emastoemas = yes then generate(FTP cs,x'C3',len) else c
if FTP table_data type_value = x'0002' then generate(FTP cs,x'01',len) c
else generate(FTP cs, X'C0', len) {being zero parity IA5}
buffer disconnect
enable out(FTP data, FTP q command sent, len,buffer offset,1, FTP line_out block addr)
enable in(FTP table_data control, FTP data input)
FTP line_status = transmitting data
return
finish
if type = FTP stop start
!we have a STOP after sending a RPOS, report on the response.
if 2 < mon level < 5 or mon level = 6 then monitoring = on else monitoring = off
evaluate negotiation(command start, reply start,len,limit,type)
FTP line_transfer status = transfer status
FTP table_mail to send = no
generate(FTP stopack, 0, len)
buffer disconnect
enable out(FTP command, FTP q command sent, len,buffer offset,1, FTP line_out block addr)
FTP line_status = stopack sent
return
finish
FTP log(" gets invalid response to RPOS ".itos(type))
abort FTP
return
finish
!we should never get here.
FTP log(" Q station error, invalid state ". c
i to s(FTP line_status))
buffer disconnect
abort FTP
return
halt transfer:
if FTP line_activity = sender start
FTP line_tcc subtype = S error no resume
mail report("Local Transmission failure".snl,0)
generate(FTP es,S error no resume,len)
buffer disconnect
enable in(FTP table_data control,FTP data input)
enable out(FTP data,FTP q command sent,len,buffer offset,1,FTP line_out block addr)
FTP line_status = end of data sent
return
finish else start
FTP line_tcc subtype = R error no resume
mail report("Local Receiver failure".snl,0)
generate(FTP qr, R error no resume,len)
buffer disconnect
enable out(FTP data,FTP q command sent,len,buffer offset,1,FTP line_out block addr)
enable in(FTP table_data control,FTP data input)
FTP line_status = quit sent
return
finish
st(FTP q command sent):
!----------------------------------------------------------------------
!A BLOCK HAS BEEN SENT TO A P STATION.
FTP line_timer = (FTP table_timeout_value+59)//60
FTP line_output buffer status = ready
if FTP line_output transfer pending = yes start
!we have an enable waiting to go.
flag = dpon3("",FTP line_output transfer record,0, 0,6)
FTP line_output buffer status = already enabled
FTP line_output transfer pending = no
FTP log(" pending transfer cleared.")
finish
!
if FTP line_status = rpos sent or FTP line_status = rneg sent or c
FTP line_status = end of data sent or FTP line_status = awaiting stop then return
!
if FTP line_status = quit sent start
if aborted no retry <= FTP line_transfer status <= aborted retry possible c
and FTP line_tcc subtype = awaiting data then abort FTP
!see p command sent for explanation.
return
finish
!
if FTP line_status = stopack sent start
!we have either failed completely or succeeded so clear up
if FTP line_transfer status = satisfactory termination start
if FTP table_mail to send = yes then send mail
FTP table_mail to send = no
FTP log(" Transaction terminates successfully.")
finish
delete FTP document(FTP line_document) if FTP line_document # 0
FTP line_document = 0
FTP line_status = awaiting sft
enable in(FTP command,FTP command overflow)
!ie we keep the transport service open and time out if no more from
!the P station ( or indeed the P station may close the service and
!we will get a line down)
FTP line_timer = 1; !only keep open for one tick.
FTP log(" negotiating")
FTP line_bytes transferred = 0
FTP line_transfer status = viable
FTP line_pre abort status = awaiting sft
!The pre abort status is always set to 'active' except when
!an ABORT takes place when it is used to remember the status before the abort.
FTP line_offset = 0
FTP line_abort retry count = 0
FTP line_output transfer pending = no
FTP line_output buffer status = ready
FTP log(" records Q station transaction ends. WAITING.")
return
finish
!
if FTP line_status = transmitting data start
send block(FTP q command sent, flag)
if flag # 0 start
!we have a sender error.
output buffer connect
FTP line_tcc subtype = S error no resume
mail report("Local Transmission failure".snl,0)
generate(FTP es, S error no resume, len)
buffer disconnect
enable out(FTP data,FTP q command sent,len,buffer offset,1,FTP line_out block addr)
FTP line_status = end of data sent
return
finish
return
finish
!
if FTP line_status = last block sent start
output buffer connect
if FTP table_data control # no translation then flag = ddestroy( c
my name,"LINEWRK".itos(table entry),"",FTP table_user fsys,0)
generate(FTP es, 0, len)
buffer disconnect
enable out(FTP data, FTP q command sent, len,buffer offset,1, FTP line_out block addr)
FTP line_status = end of data sent
FTP line_tcc subtype = ok
return
finish
!
if FTP line_status = end of data acknowledge sent start
enable in(FTP command,FTP command overflow)
FTP line_status = awaiting stop
return
finish
!Cannot be anything else.
FTP log(" Q station invalid command sent kick ".itos(FTP line_status))
abort FTP
return
st(FTP data input):
!--------------------------------------------------------------------
!WE HAVE DATA TYPE OR TCC IPUT FOR FTP
!
data length = p_p5 + FTP line_offset
FTP line_offset = 0
FTP line_timer = (FTP table_timeout_value+59)//60
input buffer connect
output buffer connect
if FTP line_station type = p station then c
command sent activity = FTP p command sent else c
command sent activity = FTP q command sent
!
if FTP line_status = receiving data or FTP line_status = quit sent start
if FTP line_suspend = yes start
!we have a suspend forced by tcc input
interpret tcc(type, subtype)
if type = FTP es start
!we have ES[nn] from the sender
if subtype = hold start
!we have a hold response from our QR[H]
buffer disconnect
monitor and return
finish
if FTP data error <= subtype < FTP data abort start
FTP line_transfer status = aborted retry possible unless FTP line_transfer c
status = aborted no retry
FTP log(" records ES[E] ".FTP errors(subtype))
mail report("Transmission failure at ".string at(FTP stations(FTP line_station ptr) c
,FTP stations(FTP line_station ptr)_shortest name).snl,0) c
unless FTP line_status = quit sent
if FTP line_status = quit sent and FTP line_tcc subtype > FTP data error c
then FTP line_status = receiving data
!we do this to allow us to drop thro' and send an ER[E]
FTP line_tcc subtype = subtype
finish
if subtype >= FTP data abort start
!we have a sender instigated abort ES[A]
FTP log(" records ES[A] ".FTP errors(subtype))
mail report("Transmission failure at ".string at(FTP stations(FTP line_station ptr) c
,FTP stations(FTP line_station ptr)_shortest name).snl,0)
FTP line_transfer status = aborted retry possible
if FTP line_station type = p station start
generate(FTP stop, 0, len)
buffer disconnect
enable out(FTP command,command sent activity,len,buffer offset,1, c
FTP line_out block addr)
enable in(FTP command,FTP command overflow)
FTP line_status = stop sent
finish else start
buffer disconnect
enable in(FTP command,FTP command overflow)
FTP line_status = awaiting stop
finish
FTP line_suspend = no
return
finish
if subtype = ok start
if FTP line_status = quit sent and FTP line_tcc subtype > c
FTP data error start
!ie we have received a ES[OK] when the last we sent was QR[E]
!so we ditch the input an wait for the ES[E].
buffer disconnect
enable in(FTP table_data control,FTP data input)
FTP line_suspend = no
return
finish
!otherwise the ES[E] drops through to be handled after data check.
finish
finish else start
unless type = FTP ss or type = FTP ms start
!We let MS and SS drop through..any other trap here...We must
!not ES[nn] so what is it ?
if type = FTP CS start
!It is a CODE SELECT
if sub type & x'0F' = x'01' and FTP table_data type_value c
# x'0002' {BINARY} then FTP log(" reports CS BINARY in non BINARY transfer") c
and -> rec quit
if sub type&X'03' = 2 then c
ftp log(" reports CS not IA5 or PRIVATE CODE or BINARY on receive.") c
and -> rec quit
if sub type&X'F0' = X'C0' then ftp log(" reports NO PARITY". c
" set on data receive.") and FTP line_parity = no
finish else start
FTP log(" records protocol error, TCC not ES whilst receiving")
rec quit:
generate(FTP qr, protocol R detected, len)
FTP line_tcc subtype = protocol R detected
buffer disconnect
enable out(FTP data,command sent activity,len,buffer offset,1, c
FTP line_out block addr)
enable in(FTP table_data control,FTP data input)
FTP line_transfer status = aborted retry possible
FTP line_status = quit sent
FTP line_suspend = no
return
finish
finish
FTP line_suspend = no
finish
finish
if data length > 0 and FTP line_transfer status = viable start
!only handle the data if the transfer is still viable.
unless FTP line_status = quit sent and FTP line_tcc subtype > FTP data error start
!should not handle the actual data if we have sent a QR[E]
flag = accept block
if flag # 0 start
!we have detected a receiver error.
FTP line_tcc subtype = flag
mail report("Local Receiver failure".snl,0)
generate(FTP qr, FTP line_tcc subtype, len)
buffer disconnect
enable out(FTP data,command sent activity,len,buffer offset,1,FTP line_out block addr)
enable in(FTP table_data control,FTP data input)
FTP line_status = quit sent
FTP line_suspend = no
return
finish
finish
finish
if FTP line_suspend = yes start
!we have ahd an ES[OK] or an ES[E]
FTP line_suspend = no
if subtype = OK start
!ie we have ES[OK]
complete file handling(flag,s)
if flag = -1 start
!The transfer must invoke spooler so put the line to sleep for reply.
FTP line_timer = 4
return
finish
spooler reply received:
if flag # ok start
!the transfer failed for some reason
FTP log(" cannot complete transfer ".itos(flag))
FTP line_transfer status = aborted no retry
mail report("Local Receiver failure ".errs(flag).snl,0) unless flag = 1
generate(FTP qr, R error no resume, len)
if FTP line_station type = q station and s # "" c
then FTP table_stopack message <- s
FTP line_tcc subtype = R error no resume
FTP line_status = quit sent
finish else start
!the transfer is complete as far as receiver is concerned
FTP line_transfer status = satisfactory termination
FTP line_tcc subtype = ok
generate(FTP er, ok, len)
finish
finish else generate(FTP er, subtype, len)
buffer disconnect
enable out(FTP data,command sent activity,len,buffer offset,1,c
FTP line_out block addr)
if FTP line_status = quit sent then c
enable in(FTP table_data control,FTP data input) else c
FTP line_status = end of data acknowledge sent
return
finish
buffer disconnect
enable in(FTP table_data control,FTP data input)
return
finish
!
if FTP line_status = end of data sent start
!we have sent ES[nn] to the sender
!and sre awaiting response.
if FTP line_suspend = yes start
!there must be a tcc if we have been suspended here.
FTP line_suspend = no
interpret tcc(type, subtype)
if type = FTP er start
!we have a tcc of ER[nn]
if subtype = hold start
if FTP line_tcc subtype # hold start
!we should only have a ER[H] after a hold request.
FTP log(" records ER[H] after ES[nn]")
-> sender invalid command
finish else start
buffer disconnect
monitor and return
finish
finish
if subtype >= FTP data error start
!we have an ER[E] from the receiver.
if FTP line_tcc subtype >= FTP data error start
!this is a response to out generated ES[E]
FTP log(" records ER[E] ".FTP errors(subtype))
FTP line_transfer status = aborted retry possible
finish else start
!we have not sent ES[E] so fail.
FTP log(" records ER[E] after ES[OK]")
-> sender invalid command
finish
finish
if subtype = ok then FTP line_transfer status = satisfactory termination
if FTP line_station type = p station start
generate(FTP stop, 0, len)
buffer disconnect
enable out(FTP command,command sent activity,len,buffer offset,1, c
FTP line_out block addr)
enable in(FTP command,FTP command overflow)
FTP line_status = stop sent
finish else start
buffer disconnect
enable in(FTP command,FTP command overflow)
FTP line_status = awaiting stop
finish
return
finish
if type = FTP qr start
!we have a receiver issued quit QR[nn]
if subtype = hold start
if FTP line_tcc subtype = ok start
!acceptable state.
buffer disconnect
monitor and return
finish else start
! ??
buffer disconnect
monitor and return
finish
finish
if subtype = ok start
!stay as we are.
buffer disconnect
enable in(FTP table_data control,FTP data input)
return
finish
if FTP data error <= subtype < FTP data abort start
!we have a QR[E] from the receiver.
FTP log(" records QR[E] ".FTP errors(subtype))
mail report("Receiver failure at ".string at(FTP stations(FTP line_station ptr) c
,FTP stations(FTP line_station ptr)_shortest name).snl,0)
if FTP line_tcc subtype = ok start
!we have sent ES[OK]
generate(FTP es, subtype, len)
buffer disconnect
if FTP line_output buffer status = already enabled then disable out(abort, FTP output aborted)
enable out(FTP data,command sent activity,len,buffer offset,1, c
FTP line_out block addr)
finish
!if we have sent ES[E] remain as we are.
!but record the new failure subtype.
FTP line_tcc subtype = subtype
buffer disconnect
enable in(FTP table_data control,FTP data input)
return
finish
if subtype >= FTP data abort start
!an abort has arrived from the receiver, QR[A]
!we treat this the same for ES[OK] & ES[E] states.
FTP log(" records QR[A] ".FTP aborts(subtype))
mail report("Receiver failure at ".string at(FTP stations(FTP line_station ptr) c
,FTP stations(FTP line_station ptr)_shortest name).snl,0)
FTP line_transfer status = aborted retry possible
if FTP line_output buffer status = already enabled then c
disable out(abort, FTP output aborted)
!this will cause the current output to be aborted and then
!if we are next to send a STOP (below) it will then be enabled.
if FTP line_station type = p station start
generate(FTP stop, 0, len)
buffer disconnect
enable out(FTP command,command sent activity,len,buffer offset,1, c
FTP line_out block addr)
enable in(FTP command,FTP command overflow)
FTP line_status = stop sent
finish else start
buffer disconnect
enable in(FTP command,FTP command overflow)
FTP line_status = awaiting stop
finish
return
finish
finish
finish
!anything else is in protocol violation.
-> sender invalid command
finish
!
if FTP line_status = transmitting data or FTP line_status = last block sent start
!we are currently sending data.
if FTP line_suspend = yes start
!we must have a tcc input.
FTP line_suspend = no
interpret tcc(type, subtype)
if type = FTP qr start
!we have a quit from the receiver.
if subtype >= FTP data abort start
!abort requested by receiver, QR[A]
FTP log(" records QR[A] ".FTP aborts(subtype))
mail report("Receiver failure at ".string at(FTP stations(FTP line_station ptr) c
,FTP stations(FTP line_station ptr)_shortest name).snl,0)
FTP line_transfer status = aborted retry possible
if FTP line_output buffer status = already enabled then c
disable out(abort, FTP output aborted)
!ie if the output is enabled then abort it and on abort the STOP which
! (may be) generated below is enabled.
if FTP line_station type = p station start
generate(FTP stop, 0, len)
buffer disconnect
enable out(FTP command,command sent activity,len,buffer offset,1, c
FTP line_out block addr)
enable in(FTP command,FTP command overflow)
FTP line_status = stop sent
finish else start
buffer disconnect
enable in(FTP command,FTP command overflow)
FTP line_status = awaiting stop
finish
return
finish
if subtype >= FTP data error start
!error reported by receiving station. QR[E]
FTP log(" records QR[E] ".FTP errors(subtype))
mail report("Receiver failure at ".string at(FTP stations(FTP line_station ptr) c
,FTP stations(FTP line_station ptr)_shortest name).snl,0)
FTP line_tcc subtype = subtype
generate(FTP es, subtype, len)
buffer disconnect
enable out(FTP data,command sent activity,len,buffer offset,1, c
FTP line_out block addr)
enable in(FTP table_data control,FTP data input)
FTP line_status = end of data sent
return
finish
if subtype = hold start
!QR[H]
buffer disconnect
monitor and return
finish
if subtype = ok start
!QR[OK] received, act as per protocol
FTP log(" records QR[OK] ?")
generate(FTP es, ok, len)
FTP line_tcc subtype = ok
buffer disconnect
enable out(FTP data,command sent activity,len,buffer offset,1, c
FTP line_out block addr)
enable in(FTP table_data control,FTP data input)
FTP line_status = end of data sent
return
finish
finish
finish
!any other command is in protocol violation
-> sender invalid command
finish
!Else we are in a bit of trouble, perhaps we have had a race condition
!between an abort and an enable response...What else? An ABORT will be the way
!out even if the race condition is the cause (since the abort will not be
!reissued and the original aborts reply, whatever status, will suffice to close)
FTP log(" invalid state for data input ". c
stream status type(FTP line_status))
buffer disconnect
abort FTP
return
!
sender invalid command:
FTP log(" INVALID COMMAND")
mail report("Receiver failure at ".string at(FTP stations(FTP line_station ptr) c
,FTP stations(FTP line_station ptr)_shortest name).snl,0)
generate(FTP es, protocol S detected, len)
FTP line_tcc subtype = protocol S detected
buffer disconnect
enable out(FTP data,command sent activity,len,buffer offset,1,FTP line_out block addr)
enable in(FTP table_data control,FTP data input)
FTP line_status = end of data sent
return
st(FTP confirmation from spooler):
!---------------------------------------------------------------
!We asked spooler to take a transfered file and do something
!to it. This is the reply.
if p_p2 = no start {No confirmation is required}
if p_p1 # 0 start
!But there was a failure.
select output(1)
printstring(dt."SPOOLR replies ".itos(p_p1)." to FTP (". c
itos(line).") unconfirm call for". FTP type desc(p_p3).snl)
select output(0)
finish else start
select output(1)
printstring(dt."SPOOLR replies success to FTP (". c
itos(line).") unconfirm call for ". FTP type desc(p_p3).snl)
select output(0)
finish
return
finish
select output(1)
printstring(dt."SPOOLR replies with confirmation for FTP (".itos(line).")".snl)
select output(0)
input buffer connect; output buffer connect
if FTP line_station type = p station then command sent activity = c
FTP p command sent else command sent activity = FTP q command sent
flag = 0; s = ""
if p_p3 = FTP mail start
if p_p1 = 1 start {fail}
printstring("No/Full MAIL queue !!".snl)
flag = 1
finish
finish else if p_p3 = FTP job start
if p_p1 # 0 start
if p_p1 = 1 then printstring("No BATCH queue !!".snl)
if p_p1 > 200 start
!The job cannot be queued, submission error.
s = "EMAS2900 Job submission fails ".my errs(p_p1)
FTP log(s)
finish
flag = 1
finish
finish else if p_p3 = FTP output start
if p_p1 # 0 start
if p_p1 = 2 then s = "Will be printed on the MAIN printer : LP" and flag = 0
if p_p1 = 1 then printstring("NO PRINT service !".snl) and flag = 1
if p_p1 > 200 start
s = "Listing output fails ".my errs(P_P1)
flag = 1
finish
finish
finish
-> spooler reply received
st(FTP input control message):
!----------------------------------------------------------------------
!A HIGH LEVEL INPUT CONTROL MESSAGE FROM FEP.
!WILL BE A TCC OR A COMMAND TERMINATION.
if p_p3 = 0 start
!THEN IT IS AN END OF PHASE TRIGGER.
if awaiting sft <= FTP line_status <= rneg sent start
!WE ARE AT COMMAND(NEGOTIATION) PHASE.
if FTP line_station type = p station then c
disable in(suspend, FTP p command reply) else c
disable in(suspend, FTP q command reply)
return
finish
if receiving data <= FTP line_status <= quit sent start
FTP line_suspend = yes
if FTP line_station type = p station then c
disable in(suspend, FTP data input) else c
disable in(suspend, FTP data input)
return
finish
ftp log(" High level control message not expected!")
abort ftp and return
finish else start
!LINE DOWN SITUATION.
if FTP line_status = sft sent start
FTP stations(FTP line_station ptr)_connect retry ptr = 1
set document timers(FTP line_station ptr,1,0)
! ie level 4 reject I think so hold off a bit.
finish
FTP log(" line down. status: ".STREAM STATUS TYPE(FTP LINE_STATUS))
if FTP line_status = stop sent start
FTP log(" STOP sent, STOPACK could be comming(timing problem). Waiting")
FTP line_timer = 1
!Wait for 1 clock tick
return
finish
abort FTP if FTP line_in stream status = active
FTP line_timer = FTP default timeout
return
finish
st(FTP output control message):
!------------------------------------------------------------------
!A HIGH LEVEL CONTROL MESSAGE FROM FEP FOR AN OUTPUT STREAM
if p_p3 # 0 start
if FTP line_status = sft sent start
FTP stations(FTP line_station ptr)_connect retry ptr = 1
set document timers(FTP line_station ptr,1,0)
! ie level 4 reject I think so hold off a bit.
finish
FTP log(" line down .status: ".STREAM STATUS TYPE(FTP LINE_STATUS))
if FTP line_status = stop sent start
FTP log(" STOP sent, STOPACK could follow(Timing problem). Waiting")
FTP line_timer = 1
return
finish
abort FTP if FTP line_out stream status = active
FTP line_timer = FTP default timeout
return
finish
ftp log(" High level control message not expected!")
abort ftp and return
st(FTP command overflow):
!--------------------------------------------------------------
!AN INPUT COMMAND HAS EXCEEDED THE BUFFER ALLOCATED !!
FTP log(" records command overflow, DISASTER")
abort FTP
return
st(FTP input disconnected):
!----------------------------------------------------------------------
!THE FTP INPUT STREAM IS NOW DISCONNECTED.
if p_p2 = 0 start
FTP line_in stream status = allocated
return unless FTP line_out stream status = allocated
-> FTP pair disconnected
finish
!ELSE WE HAVE DISCONNECT FAILURE.
FTP line_in stream status = allocated
select output(1)
printstring("FTP (".itos(table entry).") DISCONNECT (IN) FAILS ".itos(p_p2).snl)
select output(0)
-> FTP pair disconnected if FTP line_out stream status = allocated
return
st(FTP output disconnected):
!----------------------------------------------------------------------
!THE FTP OUTPUT STREAM IS NOW DISCONNECTED.
if p_p2 = 0 start
FTP line_out stream status = allocated
return unless FTP line_in stream status = allocated
-> FTP pair disconnected
finish
!ELSE WE HAVE DISCONNECT FAILURE.
FTP line_out stream status = allocated
select output(1)
printstring("FTP (".itos(table entry).") DISCONNECT (OUT) FAILS ".itos(p_p2).snl)
select output(0)
-> FTP pair disconnected if FTP line_in stream status = allocated
return
FTP pair disconnected:
set document timers(FTP line_station ptr,connect retry times( c
FTP stations(FTP line_station ptr)_connect retry ptr),0) if c
ftp line_station ptr # 0
!ie we can now go ahead with other transactions to this site.
flag = ddestroy(my name,"LINEIN".itos(table entry),"",my fsys,0)
flag = ddestroy(my name,"LINEOUT".itos(table entry),"",my fsys,0)
FTP line_pre abort status = active; !precautionary reset.
deallocate
FTP line_timer = FTP selected timeout
return
st(FTP input aborted):
!----------------------------------------------------------------------
!THE FTP INPUT STREAM IS NOW ABORTED.
if p_p2 # 0 start
FTP log(" IN abort fails, comm stream ".comms stream status(p_p4))
if comm claiming <= p_p4 <= comm enabling start
!ie the comms controller is handling VSI for stream, retry
if FTP line_abort retry count = 50 start
!that is a total of 50 for in and out streams of this line.
printstring("FTP (".itos(table entry).") Hung !".snl)
return
finish
FTP line_abort retry count = FTP line_abort retry count + 1
disable in(abort, FTP input aborted)
return
finish
if comm connected < p_p4 < comm claiming then return
!ie comms conn thinks it is aborting or suspending, wait.
!otherwise it is connected so continue.
finish
FTP line_abort retry count = 0
if FTP line_status = end of data sent or FTP line_status = go sent c
or (FTP line_status = quit sent and FTP line_tcc subtype # awaiting data) c
or FTP line_status = stop sent or FTP line_status = awaiting stop start
!we have had a time out as sender and have sent an abort so we must
!go to command input mode.
!we may also have sent a STOP.
enable in(FTP command,FTP command overflow)
return
finish
if FTP line_status = quit sent and FTP line_tcc subtype = awaiting data start
!we must be receiver aborting input having timed out
!we have not yet enabled the QR[A] as we are safer waiting
!for this abort to occur first.
FTP log(" input aborted for timeout.")
flag = dpon3("",FTP line_output transfer record,0, 0,6)
FTP line_output transfer pending = no
FTP line_output buffer status = already enabled
!after this quit has gone we will drag the connection down.
return
finish
FTP line_in stream status = aborted
return unless FTP line_out stream status = aborted
-> FTP pair aborted
st(FTP output aborted):
!----------------------------------------------------------------------
!THE FTP OUTPUT STREAM IS NOW ABORTED.
if p_p2 # 0 start
FTP log(" OUT abort fails, comm stream ".comms stream status(p_p4))
if comm claiming <= p_p4 <= comm enabling start
!ie the comms controller is handling VSI for stream, retry
if FTP line_abort retry count = 50 start
printstring("FTP (".itos(table entry).") Hung !".snl)
return
finish
FTP line_abort retry count = FTP line_abort retry count + 1
disable out(abort, FTP output aborted)
return
finish
if comm connected < p_p4 < comm claiming then return
!ie comms conn thinks it is aborting or suspending, wait.
!otherwise it is connected so continue.
finish
FTP line_abort retry count = 0
if FTP line_status = stop sent or FTP line_status = awaiting stop start
!we are P or Q station (sender) and have had a QR[A] to
!have got here so enable the output if required.
return if FTP line_status = awaiting stop
flag = dpon3("",FTP line_output transfer record,0, 0,6)
FTP line_output transfer pending = no
FTP line_output buffer status = already enabled
return
finish
if FTP line_status = quit sent or FTP line_status = go sent c
or FTP line_status = end of data sent start
!we have had a time out and need to send the outstanding TCC and
!take the corresponding station action.
!OR we are transmitting and have recieved a QR[e] so we have
!aborted in order to send the ES[e].
flag = dpon3("",FTP line_output transfer record,0, 0,6)
FTP line_output transfer pending = no
FTP line_output buffer status = already enabled
if FTP line_status = end of data sent and r error resume <= c
FTP line_tcc subtype <= r error no resume then return
!IE we have aborted output after a QR[e] and now have sent a ES[e], await reply
if FTP line_station type = p station start
output buffer connect
generate(FTP stop, 0, len)
buffer disconnect
command sent activity = FTP p command sent
enable out(FTP command,command sent activity,len,buffer offset,1, c
FTP line_out block addr)
FTP line_status = stop sent
finish else FTP line_status = awaiting stop
return
finish
FTP line_out stream status = aborted
return unless FTP line_in stream status = aborted
-> FTP pair aborted
FTP pair aborted:
FTP line_status = aborted
disconnect
return
st(FTP timed out):
!---------------------------------------------------------------
!A time out on an FTP function.
if FTP line_station type = p station then c
command sent activity = FTP p command sent else c
command sent activity = FTP q command sent
-> time out(FTP line_status)
time out(*):
printstring("FTP (".itos(table entry).") Unexplained time out ".itos(FTP line_status).snl)
return
time out(spooler called):
printstring("SPOOLER timeout !!".snl)
FTP line_status = receiving data
time out(receiving data):
!this could be a P or Q station
FTP line_transfer status = aborted retry possible
if FTP line_output buffer status = already enabled start
!if this is so then we are really in trouble so lets cut losses.
FTP log("FTP (".itos(table entry).") data input times out and output already enabled!")
abort FTP
return
finish
output buffer connect
FTP line_output buffer status = already enabled
!we do this to prevent the QR[A] going before the input is aborted.
generate(FTP qr, awaiting data, len)
FTP line_tcc subtype = awaiting data
buffer disconnect
enable out(FTP data,command sent activity,len,buffer offset,1,FTP line_out block addr)
FTP line_status = quit sent
!note this will only be sent when this input abort replies.
disable in(abort,FTP input aborted)
FTP log(" data input timed out, abort issued.")
FTP line_timer = (FTP table_timeout_value+59)//60
return
time out(last block sent):
time out(transmitting data):
!the data transmitting is timed out
FTP log(" records data transmission timeout.")
abort FTP
return
time out(selected):
time out(deallocating):
if FTP line_status = deallocating then FTP log(" records time out on deallocate.") c
else FTP log(" records time out on allocate.")
FTP line_status = unallocated
FTP line_station ptr = 0
FTP line_document = 0
kick FTP line(line)
return
time out(connecting):
time out(active):
FTP log(" records time out on connect/active.")
if FTP line_station ptr # 0 start
j = FTP stations(FTP line_station ptr)_connect retry ptr
if j = 10 then j = 1 else j = j + 1
FTP stations(FTP line_station ptr)_connect retry ptr = j
if FTP line_station type = P station then set document timers( c
FTP line_station ptr,connect retry times(j),ftp line_document)
finish
FTP line_document = 0
if FTP line_in stream status = connecting and c
FTP line_out stream status = connecting then start
FTP line_in stream status = aborting
FTP line_out stream status = aborting
-> FTP pair disconnected
finish
disconnect
return
time out(disconnecting):
FTP log(" records time out on disconnect")
!well lets assume its gone !!
FTP line_in stream status = allocated
FTP line_out stream status = allocated
-> FTP pair disconnected
time out(aborting):
FTP log(" records timeout in ABORTING state.")
-> ftp pair aborted
time out(stop sent):
type = FTP stopack
transfer status = x'ff'
FTP timeout = yes
FTP log(" records timeout on STOP sent, STOPACK assumed.")
-> st(FTP p command reply)
time out(awaiting sft):
time out(awaiting stop):
time out(rpos sent):
time out(rneg sent):
time out(sft sent):
FTP log(" records time out on ".stream status type(FTP line_status))
FTP line_transfer status = aborted retry possible
abort FTP
return
time out(end of data sent):
FTP log(" records time out after ES[nn]")
output buffer connect
if FTP line_tcc subtype = ok then FTP line_tcc subtype = ER ok expected c
else FTP line_tcc subtype = ER e expected
generate(FTP es,FTP line_tcc subtype,len)
buffer disconnect
FTP line_pre abort status = FTP line_status
enable out(FTP data,command sent activity,len,buffer offset,1,FTP line_out block addr)
disable in(abort, FTP input aborted)
FTP line_transfer status = aborted retry possible
if FTP line_output transfer pending = yes then c
disable out(abort,FTP output aborted) else start
!if there was a transfer pending then the ES was hung so
!abort else we are ok to issue the stop(p station) now.
if FTP line_station type = p station start
output buffer connect
generate(FTP stop, 0, len)
buffer disconnect
enable out(FTP command,command sent activity,len,buffer offset,1, c
FTP line_out block addr)
FTP line_status = stop sent
finish else FTP line_status = awaiting stop
finish
return
time out(stopack sent):
time out(go sent):
time out(end of data acknowledge sent):
time out(quit sent):
FTP log(" records time out after ".stream status type(FTP line_status))
FTP line_transfer status = aborted retry possible
if FTP line_status = end of data acknowledge sent or FTP line_status = stopack sent or c
(FTP line_status = quit sent and FTP line_tcc subtype >= FTP data abort) c
then abort FTP and return
!ie it is useless to continue.
disable in(abort, FTP input aborted)
output buffer connect
if FTP line_status = go sent then FTP line_tcc subtype = awaiting data
if FTP line_status = quit sent then FTP line_tcc subtype = ES e expected
generate(FTP qr, FTP line_tcc subtype, len)
buffer disconnect
enable out(FTP data,command sent activity,len,buffer offset,1,FTP line_out block addr)
if FTP line_output transfer pending = yes then c
disable out(abort,FTP output aborted) else start
if FTP line_station type = p station then start
output buffer connect
generate(FTP stop, 0, len)
buffer disconnect
enable out(FTP command,command sent activity,len,buffer offset,1, c
FTP line_out block addr)
FTP line_status = stop sent
finish else FTP line_status = awaiting stop
finish
return
!**********************************************************
!ROUTINES FOR FTP CONTROL FOLLOW HERE.
routine send to spooler(integer type, ident, confirm)
!*********************************************************************
!* *
!* Here we are to DEXECMESS a message to spooler to ask it to take *
!* MAIL or a JOB or OUTPUT from a transfer. CONFIRM is set to *
!* indicate that a reply is required. *
!* *
!*********************************************************************
!The message is constructed as follows:
! <DESCRIPTOR>
!where<DESCRIPTOR> is a 256 byte standard
!descriptor.
! DESCRIPTOR_FTRANS ACTION is the action required of spooler.
! DESCRIPTOR_TYPE is the type of document from FTP (JOB/OUTPUT or MAIL)
! DESCRIPTOR_CONFIRM is passed to spooler and reflected back untouched.
! DESCRIPTOR_IDENT is the identity of the FTRANS document to transfer.
!
!In reply FTRANS expects P_P3 to to have the value of DESCRIPTOR_TYPE
! P_P2 to be DESCRIPTOR_CONFIRM
! P_P1 to be the FLAG response to the action.
! If spooler is not FTP available then we abort and CLOSE the service.
record (tran document descriptor f) sp
integer flag
move(256,document addr(ident),addr(sp_state))
sp_header = "BINDOC:"
sp_FTRANS action = 1
sp_transfer ident = ident
sp_type = type
sp_confirm = confirm
sp_tfsys = ident >> 24
flag = dexecmess("SPOOLR",line<<7 ! FTP confirmation from spooler, c
(8 + document entry size), addr(sp))
if flag # 0 start
if flag = 61 start
!There is no spooler.
printstring("SPOOLR DOWN ??".snl)
abort FTP
FTP stations(control entry)_service = closed
finish
select output(1)
printstring(dt."DEXECMESS to SPOOLR fails ".errs(flag).snl)
select output(0)
finish else start
select output(1)
printstring(dt."SPOOLR called for FTP (".itos(line).")".snl)
select output(0)
finish
end ; !of routine send to spooler
routine connect
!*****************************************************
!* *
!* TRY TO CONNECT THE FTP STREAM PAIR
!* *
!*****************************************************
record (pe)p
integer flag
FTP line_in stream status = connecting
p = 0
p_dest = connect stream
p_srce = FTP input connected ! line << 7
p_p1 = 0; !IE INPUT
p_p2 = my service number ! FTP input control message ! line <<7
p_p3 = FTP line_in stream ident
flag = dpon3("", p, 0, 0, 6)
FTP line_out stream status = connecting
p = 0
p_dest = connect stream
p_srce = FTP output connected ! line << 7
p_p1 = 1; !THE OUTPUT STREAM
p_p2 = my service number ! FTP output control message ! line << 7
p_p3 = FTP line_ out stream ident
flag = dpon3("", p, 0, 0, 6)
end ; !OF CONNECT
routine FTP log(string (127) message)
select output(1)
print string(dt."FTP (".itos(table entry).")".message.snl)
select output(0)
end
routine abort FTP
!*************************************************************
!* *
!* Abort an FTP line *
!* *
!*************************************************************
FTP table_mail to send = no unless FTP line_status = awaiting sft c
or (FTP timeout = yes and type = FTP stopack)
!Ie we halt any mail report except when the successful transfer has
!been initiated by us and only the response to a STOP X'2000' is lost.
!Are we right to assume success ?
return unless awaiting sft <= FTP line_status <= end of data acknowledge sent c
or FTP line_status = active
FTP line_pre abort status = FTP line_status if FTP line_pre abort status = active
!Remember the original status when abort occured.
FTP line_status = aborting
FTP line_in stream status = aborting
disable in(abort, FTP input aborted)
FTP line_out stream status = aborting
disable out(abort, FTP output aborted)
end ; !of abort
routine enable in(integer mode, reply)
!*************************************************************
!* *
!* ENABLE AN INPUT FTP STREAM *
!* *
!*************************************************************
record (pe)p
integer flag, division
if mode # FTP command and FTP table_emastoemas = yes then division = c
FTP emastoemas block division else division = FTP block division
p = 0
p_dest = enable stream
p_srce = reply ! line << 7
p_p1 = FTP line_in comms stream
p_p2 = FTP line_in block addr
p_p3 = ((block size//FTP EMASTOEMAS BLOCK division)//epage size)-1
p_p4 = mode
p_p5 = FTP line_offset; !OFFSET
p_p6 = block size//division - p_p5
flag = dpon3("", p, 0, 0, 6)
end ; !OF ENABLE IN.
routine enable out(integer mode, reply, len, start, size, address)
!*************************************************************
!* *
!* ENABLE OUTPUT ON AN FTP STREAM *
!* *
!*************************************************************
record (pe)p
integer flag
p = 0
p_dest = enable stream
p_srce = reply ! line << 7
p_p1 = FTP line_out comms stream
p_p2 = address
p_p3 = size
p_p4 = mode
p_p5 = start
p_p6 = len
if FTP line_output buffer status = ready start
!all is clear to enable the buffer.
FTP line_output transfer record = p
!we remember this because 'output buffer connect' uses p_p5
!of this when the buffer is 'already enabled'
flag = dpon3("", p, 0, 0, 6)
FTP line_output buffer status = already enabled
finish else start
!there is an output already underway.
if FTP line_output transfer pending = yes start
!and there is also one outstanding !!!
FTP log(" output enables out of sync ??")
abort FTP
return
finish
FTP line_output transfer pending = yes
FTP line_output transfer record = p
FTP log(" output transfer pending")
finish
end ; !OF ENABLE OUT
routine disable out(integer action, reply)
!*************************************************************
!* *
!* DISABLE AN FTP OUTPUTSTREAM *
!* *
!*************************************************************
record (pe)p
integer flag
p = 0
p_dest = disable stream
p_srce = reply ! line << 7
p_p1 = FTP line_out comms stream
p_p2 = action
flag = dpon3("", p, 0, 0, 6)
end ; !OF DISABLE OUT
routine disable in(integer action, reply)
!*************************************************************
!* *
!* DISABLE AN FTP INPUT STREAM *
!* *
!*************************************************************
record (pe)p
integer flag
p = 0
p_dest = disable stream
p_srce = reply ! line << 7
p_p1 = FTP line_in comms stream
p_p2 = action
flag = dpon3("", p, 0, 0, 6)
end ; !OF DISABLE IN
routine disconnect
!***************************************************
!* *
!* DISCONNECT ONE OR BOTH STREAM PAIR FOR FTP *
!* *
!***************************************************
record (pe)p
integer flag,i, delay
string (11) name
if FTP line_document # 0 start
!we have had a non controlled termination.
document == record(document addr(FTP line_document))
unless FTP line_station type = p station and FTP line_transfer status # c
satisfactory termination then start
if FTP line_station type = P station start
FTP log(" P station reports SATISFACTORY TERMINATION, but no STOPACK")
if FTP table_mail = yes then mail report("0",FTP table_mail displ) else c
mail report(" ok ",FTP table_mail displ)
if document_FTP user flags & FTP fail mail # 0 then c
FTP table_mail to send = no else mail report(date." ".time." Transfer Successful ".snl,0)
seconds = current packed dt
seconds = seconds - ftp line_data transfer start
if ((FTP stations(FTP line_station ptr)_bytes + FTP line_ c
bytes transferred) >>10 ) > 2000 start
FTP stations(FTP line_station ptr)_bytes = 0
FTP stations(FTP line_station ptr)_seconds = 0
finish
FTP stations(FTP line_station ptr)_bytes = FTP stations(FTP line_ c
station ptr)_bytes + FTP line_bytes transferred
FTP stations(FTP line_station ptr)_seconds = FTP stations(FTP line_ c
station ptr)_seconds + seconds
if document_auto requeue = yes start
FTP log(" ".ident to s(FTP line_document)." requeued after success". c
"(AUTO REQUEUE)".snl)
requeue FTP document(FTP line_document,0,no,no)
finish
if FTP line_activity = sender then s = "to " else s = "from "
if FTP stations(FTP line_station ptr)_status > 0 then ss = " charge" else ss = ""
FTP log(" P ACCOUNT: ".FTP line_user." transfers ". c
itos((FTP line_bytes transferred+1023)>>10)."k ".s.string at(FTP stations(FTP line_station ptr) c
,FTP stations(FTP line_station ptr)_shortest name).ss)
FTP stations(FTP line_station ptr)_P transfers = FTP stations( c
FTP line_station ptr)_P transfers + 1
FTP stations(FTP line_station ptr)_P kb = FTP stations(FTP line_station ptr)_ c
P kb + (FTP line_bytes transferred+1023)>>10
if ftp table_mail = yes then FTP stations(FTP line_station ptr)_ c
P mail = FTP stations(FTP line_station ptr)_P mail + 1
finish else start
s = ""
if FTP line_transfer status = satisfactory termination start
seconds = current packed dt
seconds = seconds - ftp line_data transfer start
if ((FTP stations(FTP line_station ptr)_bytes + FTP line_ c
bytes transferred) >>10 ) > 2000 start
FTP stations(FTP line_station ptr)_bytes = 0
FTP stations(FTP line_station ptr)_seconds = 0
finish
FTP stations(FTP line_station ptr)_bytes = FTP stations(FTP line_ c
station ptr)_bytes + FTP line_bytes transferred
FTP stations(FTP line_station ptr)_seconds = FTP stations(FTP line_ c
station ptr)_seconds + seconds
if FTP line_activity = sender then s = "to " else s = "from "
if FTP stations(FTP line_station ptr)_status = 1 then ss = " (charge)" else ss = ""
FTP log(" Q ACCOUNT: ".FTP line_user." transfers ". c
itos((FTP line_bytes transferred+1023)>>10)."k ".s.string at(FTP stations(FTP line_station ptr) c
,FTP stations(FTP line_station ptr)_shortest name).ss)
FTP stations(FTP line_station ptr)_Q transfers = FTP stations( c
FTP line_station ptr)_Q transfers + 1
FTP stations(FTP line_station ptr)_Q kb = FTP stations(FTP line_station ptr)_ c
Q kb + (FTP line_bytes transferred+1023)>>10
if ftp table_mail = yes then FTP stations(FTP line_station ptr)_ c
Q mail = FTP stations(FTP line_station ptr)_Q mail + 1
s = " but transaction completed."
mail report(date." ".time." Transfer Successful".snl,0)
finish
FTP log(" Q station abnormal termination".s)
finish
delete FTP document(FTP line_document) unless document_auto requeue = yes
finish else start
if receiving data <= FTP line_pre abort status <= end of data acknowledge sent start
!The abort has come in the actual DATA transfer phase.
if document_FTP retry level > 0 and document_auto requeue = no then document_FTP retry level = c
document_FTP retry level - 1
if document_FTP retry level = 0 start
!The attempts are exhausted..delete it.
FTP log(" Transfer fails(aborted), attempts exhausted...Deleting.")
mail report("Transfer fails (in disorder) after repeated attempts.".snl,0)
if FTP table_mail = yes then mail report("1",FTP table_mail displ)
FTP table_mail to send = yes
finish
finish
if document_auto requeue = yes then delay = auto poll delay else c
delay = transfer fail delay
if FTP line_user abort = no and document_FTP retry level > 0 then requeue FTP document( c
FTP line_document,delay,no,no) else delete FTP document( c
FTP line_document)
finish
if FTP line_aux document # 0 then delete FTP document( c
FTP line_aux document) and FTP line_aux document = 0
FTP line_document = 0
FTP line_pre abort status = active
finish
FTP line_user = ""
!do we have a mail message to send to a user as a result of this transfer.
if FTP table_mail to send = yes then send mail c
else flag = ddestroy(my name,"LINEMAIL".itos(table entry),"",my fsys,0)
buffer disconnect
flag = ddestroy(my name,"LINEIN".itos(table entry),"",my fsys,0)
flag = ddestroy(my name,"LINEOUT".itos(table entry),"",my fsys,0)
if FTP line_in stream status = active or c
FTP line_in stream status = aborted start
FTP line_in stream status = disconnecting
p = 0
p_dest = disconnect stream
p_srce = FTP input disconnected ! line << 7
p_p1 = FTP line_in comms stream
flag = dpon3("", p, 0, 0, 6)
FTP line_status = disconnecting
FTP line_timer = FTP default timeout
finish
if FTP line_out stream status = active or c
FTP line_out stream status = aborted start
FTP line_out stream status = disconnecting
p = 0
p_dest = disconnect stream
p_srce = FTP output disconnected ! line << 7
p_p1 = FTP line_out comms stream
flag = dpon3("", p, 0, 0, 6)
FTP line_status = disconnecting
FTP line_timer = FTP default timeout
finish
end ; !OF ROUTINE DISCONNECT
routine deallocate
!************************************************
!* *
!* DEALLOCATE THE STREAM PAIR. *
!* *
!**************************************************
record (FTP f)FTP
if feps(FTP line_fep)_FTP available = no start
!the fep has gone down.
FTP line_status = unallocated
FTP line_in stream status = unallocated
FTP line_out stream status = unallocated
FTP line_station ptr = 0
FTP log(" reports fep down, deallocate assumed.")
return
finish
FTP = 0
FTP_type = 3; !DEALLOCATE.
FTP_pair ref = line
FTP_length = FTP std mess len if TARGET = 2900
FTP_in ident = FTP line_in stream ident & x'FFFF'
FTP_out ident = FTP line_out stream ident & x'FFFF'
FTP output message to fep(FTP line_fep, FTP)
FTP line_status = deallocating
if FTP line_in stream status # aborting start
FTP line_in stream status = deallocating
FTP line_out stream status = deallocating
finish
return
end ; !OF ROUTINE DEALLOCATE.
routine send block(integer reply, integername flag)
!*************************************************************
!* *
!* SEND THE SPECIFED BLOCK OUT ON THE FTP STREAM *
!* *
!*************************************************************
record (daf)daddr
longinteger align
integer FTPr0, FTPr1, oldpos, wp, old wp, cp, l, ln, end
integer start, blk size, len, seg, gap, top, structure, record length, short record, I,j, K,data end
integer block division, max vrecord length
!Note that 1) No Translation mode means take the file as it comes.
!2) EMASTOEMAS means that the file is transmitted with its EMAS header.
!
!Note that non inter EMAS transfers are done in smaller units than others
!governed by the constants 'FTP emastoemas block division' & 'FTP block division'
if FTP table_emastoemas = yes then block division = FTP emastoemas c
block division else block division = FTP block division
FTP line_bytes to go = FTP line_bytes to go - FTP line_bytes sent
unless FTP line_bytes sent = 0 start
if FTP line_part blocks = block division c
then FTP line_block = FTP line_block + 1
finish
if FTP line_part blocks = block division then FTP line_part blocks = 0
flag = get block addresses(my name, ident to s(ident), ident>>24, addr(daddr))
if flag = 0 start
if daddr_nblks = FTP line_block then blk size = daddr_last blk-1 c
else blk size = daddr_blksi-1
if FTP line_block = (document_data start+block size)//block size c
and FTP line_part blocks = 0 then start = document_data start c
else start = (block size//block division)*FTP line_part blocks
if FTP line_part blocks = 0 and start # 0 start
!only happens when transfer commences(after header)
!note that send block assumes that document_data start is not
!greater than one block division. If it is required at any time
!then the routine must be rewritten.
if FTP line_bytes to go + start > block size//block division c
then len = block size//block division - start c
else len = FTP line_bytes to go
finish else start
if FTP line_bytes to go > block size//block division c
then len = block size//block division else len = FTP line_bytes to go
finish
FTP line_bytes sent = len
if FTP line_bytes to go - FTP line_bytes sent = 0 then c
FTP line_status = last block sent
FTP line_part blocks = FTP line_part blocks + 1
FTP log(" send block: ".itos(FTP line_block)." sub block: ". c
itos(FTP line_part blocks). " start: ".itos(start)." len: ".itos(len))
if FTP table_data control # no translation start
!We have to do a pre process on the sub block to be sent
FTP log(" Initiating translation to new length...")
seg = 0; gap = 0
if TARGET # 2900 then flag = dconnect(my name,"LINEWRK".itos(table entry),ident>>24, c
R!W,seg,gap) else flag = dconnect(my name,"LINEWRK".itos(table entry), c
ident>>24,R!W,0,seg,gap)
if flag # 0 start
if flag = already connected then printstring("Warning, FT ". c
itos(table entry)." (wrk) CONNECTED".snl) and flag = 0
if flag # 0 start
FTP log(" Translate Work file connect fails ".errs(flag))
abort FTP
return
finish
finish
wp = seg << seg shift
old wp = wp
end = no
seg = 0; gap = 0
if TARGET # 2900 then flag = dconnect(my name,ident to s(ident), ident>>24, c
R!W,seg,gap) else flag = dconnect(my name, ident to s(ident), c
ident>>24, R!W, 0, seg, gap)
if flag # 0 start
if flag = already connected then printstring("Warning, FT ". c
itos(table entry)." (srce) CONNECTED".snl) and flag = 0
if flag # 0 start
FTP log(" cannot connect original for translate! ".errs(flag))
abort FTP
return
finish
finish
cp = seg << seg shift + start + (block size*(FTP line_block-1))
top = cp + len
!---------------------------------------------
!DATA FORMATING SECTION FOLLOWS
!
if FTP table_data type_value = x'0002' start
structure = FTP table_binary data record & x'03'
record length = (FTP table_binary data record) >> 16
select output(1)
printstring(dt."STRUCTURE ".itos(structure)." RECORDs ".itos(record length).snl)
select output(0)
unless 0 < structure < 4 start
FTP log("**ERROR** Non standard DATA structure. Terminating transfer")
flag = ddisconnect(my name,ident to s(ident),ident>>24,0)
flag = ddisconnect(my name,"LINEWRK".itos(table entry),ident>>24,0)
document_FTP retry level = 1
flag =1
return
finish
!----------------------------------------------------------------------
if structure = 1 {Fixed length records} start
!we are to send FIXED LENGTH RECORD BINARY data. [ on sending we use BIN OFFSET to
!remember if we have already sent n bytes of a data record
!in the previous output enable]
short record = no; data end = no
cycle
!handle a record at a time.
l = top - cp
! l is data left in this block
if l + FTP line_bin offset < record length then short record = yes else c
l = record length - FTP line_bin offset
cycle {each sub record in a record}
if l < 63 start { less than 63 bytes in remainder of record}
move(l, cp, wp+1)
byteinteger(wp) = l
if short record = yes start
FTP line_bin offset = FTP line_bin offset + l
data end = yes
!We are at the end of a block but not a record boundary
!so we must recall where we are in the record for next block
cp = cp + l; wp = wp + l + 1
exit
finish
byteinteger(wp) = byteinteger(wp) ! x'80'
!setting the RECORD bit
cp = cp + l
wp = wp + l + 1
if cp = top then data end = yes
!we are at record end so exit
exit
finish
move(63, cp, wp+1)
byteinteger(wp) = 63
if short record = yes then FTPline_bin offset = FTP line_bin offset + 63
cp = cp + 63
l = l - 63
wp = wp + 64
if cp = top then data end = yes
if l = 0 then byteinteger(wp - 64) = byteinteger(wp - 64) ! x'80' and exit
repeat
exit if data end = yes
FTP line_bin offset = 0 {can reset here because we have had whole record}
repeat
finish else start
!--------------------------------------------------------------------
!We have BINARY UNSTRUCTURED or VARIABLE LENGTH RECORDS.
!The UNSTRUCTURED go in the same way but as one continuous variable
!length record without the EOR at the end.
!We use the halfword in the bottom two bytes for true VRECORD length
!The whole interger is used to represent the inherent UNSTRUCTUED record length.
data end = no
if structure = 3 then max vrecord length = document_data length c
else max vrecord length = record length
cycle
if FTP line_Vbytes to go = 0 and FTP line_split vrecord length = no start
!We are at the start of a record.
abort ftp and return if top-cp = 0
byteinteger(addr(FTP line_vrecord length)+2) = byteinteger(cp)
if top-cp < 2 start
!We do not have a complete record length in this block.
FTP line_split vrecord length = yes
exit
finish
byteinteger(addr(FTP line_vrecord length)+3) = byteinteger(cp+1)
cp = cp + 2
FTP line_vbytes to go = FTP line_vrecord length - 2
exit if top-cp = 0
finish else if FTP line_split vrecord length = yes start
!We have the start of a block with the second byte of the record length.
byteinteger(addr(FTP line_vrecord length)+3) = byteinteger(cp)
cp = cp + 1
FTP line_vbytes to go = FTP line_vrecord length - 2
exit if top-cp = 0
finish
if FTP line_vrecord length > max vrecord length + 2{length} start
FTP log("MAX BINARY RECORD length exceeded")
mail report("BAD (too long) Binary (record) length".snl,0)
flag = ddisconnect(my name,ident to s(ident),ident>>24,0)
flag = ddisconnect(my name,"LINEWRK".itos(table entry),ident>>24,0)
flag = 1; document_FTP retry level = 1; return
finish
l = top - cp
cycle {Now deal with the block record by record}
if FTP line_vbytes to go <= 63 start
!We have the end of this record.
if l < FTP line_vbytes to go start
!But not enough data left to end the record.
move(l,cp,wp+1)
byteinteger(wp) = l
FTP line_vbytes to go = FTP line_vbytes to go - l
wp = wp + l + 1; cp = cp + l
data end = yes
exit
finish
!We have sufficient data.
move(FTP line_vbytes to go,cp,wp+1)
byteinteger(wp) = FTP line_vbytes to go
if FTP table_binary data record & x'03' = 2 then byteinteger(wp) = c
byteinteger(wp) ! x'80' {end of record for VARIABLE length record only}
cp = cp + FTP line_vbytes to go
wp = wp + FTP line_vbytes to go + 1
FTP line_vbytes to go = 0
if top-cp = 0 then data end = yes
exit
finish
!More than a max sub record to go.
if l < 63 start
!But less than one sub record of data in this block.
move(l,cp,wp+1)
byteinteger(wp) = l
FTP line_vbytes to go = FTP line_vbytes to go - l
wp = wp + l + 1; cp = cp + l
data end = yes
exit
finish
move(63,cp,wp+1)
byteinteger(wp) = 63
FTP line_vbytes to go = FTP line_vbytes to go - 63
cp = cp + 63
wp = wp + 64
l = l - 63
repeat
exit if data end = yes
repeat
finish
finish else start
!--------------------------------------------------------------------
!We are dealing with TEXT open working.
{OR PRE OSCOM FEP with free format that we must 'help along' for now}
IF TARGET = 2900 START
FTPr0 = x'58000000'!len
FTPr1 = cp
cycle
old pos = FTPr1
*LDTB_FTPr0
*LDA_FTPr1
*LB_10
*PUT_x'A300'
*JCC_8,<EOA>
*MODD_1
*STD_FTPr0
-> nextnl
EOA: end = yes
FTPr1 = top
nextnl: l = FTPr1 - old pos
if end = no then ln = l-1 else ln = l
cycle
if ln <= 63 start
l = ln
if end = yes start
exit if ln = 0
finish else ln = ln ! x'80'
byteinteger(wp) = ln
if l > 0 then move(l, cp, wp+1)
wp = wp + l + 1; cp = cp + l + ln>>7
exit
finish
byteinteger(wp) = 63
move(63, cp, wp+1)
wp = wp + 64; cp = cp + 63
ln = ln - 63
repeat
exit if end = yes
repeat
FINISH ELSE START
oldpos = cp
cycle i = oldpos, 1, top-1
end = no
{PRE OSCOM FEP} unless FTP table_text format_value = x'0080' start
cycle j = i, 1, top-1
if byteinteger(j) = x'0A' start {NL}
end = yes
k = j
exit
finish
repeat
if end = no start
ln = k-i
i = k
finish else ln = top - i
{PRE OSCOM FEP} finish else start
ln = top - i
i = top - 1
finish
cycle
if ln <= 63 start
l = ln
if end = yes start
exit if ln = 0
finish else ln = ln ! x'80'
byteinteger(wp) = ln
if l > 0 then move(l, cp, wp+1)
wp = wp + l + 1; cp = cp + l + ln>>7
exit
finish
byteinteger(wp) = 63
move(63, cp, wp+1)
wp = wp + 64; cp = cp + 63
ln = ln - 63
repeat
exit if end = yes
repeat
FINISH
finish
!---------------------------------------------
!DATA FORMATTING SECTION ENDS
if mon level = 4 or (mon level = 7 and ftp table_data type_value = x'0002') start
select output(1); printstring(dt."FTP (".itos(table entry).") DATA OUTPUT: ")
cycle j=old wp, 1, wp-1
printstring(htos(byteinteger(j), 2))
repeat
newline; select output(0)
finish
flag = ddisconnect(my name,ident to s(ident),ident>>24,0)
flag = ddisconnect(my name,"LINEWRK".itos(table entry),ident>>24,0)
flag = get block addresses(my name,"LINEWRK".itos(table entry),ident>>24,addr(daddr))
if flag # 0 start
FTP log(" get block addr wrk file fails ".errs(flag))
return
finish
blk size = daddr_last blk - 1
FTP log(" actual bytes sent: ".itos(wp - old wp))
enable out(FTP table_data control,reply,wp-old wp,0,blk size,daddr_da(1))
finish else enable out(FTP table_data control, reply, len, start, blk size,
daddr_da(FTP line_block))
FTP line_bytes transferred = FTP line_bytes transferred + FTP line_bytes sent
finish else start
!we have an error
FTP log(" get block addr fails ".errs(flag))
finish
end ; !OF SEND BLOCK.
integerfn accept block
!***********************************************************************
!* *
!* MOVE DATA FROM AN INPUT BUFFER TO A FILE EXTENDING THE FILE IF *
!* NECESSARY *
!* *
!***********************************************************************
string (11) file
integer seg, gap, size, fsys, i, j, flag, l, wp, cp, end of input, adjust, formatted, header, no format
integer extra space, factor, binary mode, first pass
record (fhf)name file header
if mon level = 4 start
select output(1); printstring(dt."FTP (".itos(table entry).") DATA INPUT: ")
cycle j=0, 1, data length-1
printstring(htos(byteinteger(data start+j), 2))
repeat
newline; select output(0)
finish
seg = 0; gap = 32; !8 MEGA BYTES
if FTP table_data control = translate and FTP table_data type_value = c
x'0002'{BINARY} then factor = 3 else factor = 1 {allow extra space for Vrec lengths}
binary mode = no; !Set only if control mode is TRANSLATE and transfer is BINARY.
no format = no; !only set for text_format x'0800'.
formatted = no; !set to yes only for ANSI TEXT-FORMATTING (x'0002')
file = ident to s(ident)
fsys = ident>>24
if TARGET # 2900 then flag = dconnect(my name,file,fsys,r!w,seg,gap) else c
flag = dconnect(my name, file, fsys, r!w, 0, seg, gap)
if flag = 0 start
file header == record(seg<<seg shift)
if document_data length = -1 start ; !SET UP HEADER
document_data start = file header size
if FTP table_mail = yes then extra space = 80 else extra space = 0
file header_end = document_data start + extra space
file header_start = document_data start + extra space
file header_size = e page size
file header_type = 3; !ISO INPUT (Assume this, change to DATA later if required)
file header_datetime = current packed dt
document_date and time received = file header_datetime
finish
size = file header_size
if file header_end+(data length*factor) > size start ; !EXTEND
size = size + block size
!NOTE that even 'translate' mode input will result in a
!file of less or equal length to the input IF open working is only chioice!
!otherwise we shall have to expand on this extension.
flag = dchsize(my name, file, fsys, size>>10)
if flag # 0 start
print string("FTP (".itos(table entry).") EXTEND ".my name.".".file. c
" FAILS ".errs(flag).snl)
flag = R error no resume
-> error
finish else file header_size = size
finish
if FTP table_data control = translate start
!-------------------------------------------------------------
!NONE DEFAULT. That is the FEP has done no assit and the subrecord
!structure is intact. We have to do 'all our own work'.
FTP log(" Unformatting the complete FTP sub-records")
if FTP table_data type_value = x'0002'{BINARY} then binary mode = yes else start
if FTP table_text format_value = x'0080' then no format = yes
if FTP table_text format_value = x'0002' then formatted = yes
finish
wp = data start; cp = seg<<seg shift + file header_end
end of input = data length + data start
if document_data length = -1 then first pass = yes else first pass = no
cycle
header = byteinteger(wp)
l = header&x'7F'
if header = 0 start
!This could be part of a TCC for which will will get a kick
!from the FEP next. Check this out and if so move down the
!buffer for re enable.
if end of input - wp < 3 start
FTP log(" partial TCC at buffer end!")
move(end of input-wp, wp, data start)
FTP line_offset = end of input - wp
exit
finish else l = 64
finish
if l > 63 start
!data error, incorrect sub record length!
FTP log(" input sub record length > 63, count: ".i to s(wp-data start))
select output(1)
cycle j=0,1,64
printstring(htos(byteinteger(wp+j),2))
repeat
newline
select output(0)
flag = protocol R detected
-> error
finish
if wp + l + 1 > end of input start
!the last sub record is incomplete..leave for next input.
move(end of input - wp, wp, data start)
FTP line_offset = end of input - wp
exit
finish
!---------------------------------------------------------------
if binary mode = no start {It is a TEXT transfer to unscramble}
if formatted = yes and FTP line_new FTP data record = yes c
and l # 0 {l#0 in for VAX SIR DBMS bug} start
!IE it is ANSI text format and this is the start of a new stat record.
j = byteinteger(wp+1)
if j = x'20' then byteinteger(cp) = x'0A' else c
if j = x'2B' then byteinteger(cp) = x'0D' else c
if j = x'31' then byteinteger(cp)= x'0C' else c
if j = x'30' or j = x'2D' then start
byteinteger(cp) = x'0A'
byteinteger(cp+1) = x'0A'
if j = x'2D' then byteinteger(cp+2) = x'0A' and cp = cp + 1
cp = cp + 1
finish else FTP log("Non ANSI control char [space inserted]". c
" (dec: ".itos(j).") in input buffer at displ ". c
itos(wp+1-data start)) and byteinteger(cp) = X'20'
cp = cp + 1
wp = wp + 1
l = l - 1
FTP line_new FTP data record = no
finish
if l > 0 start
if FTP line_parity = yes start
cycle i = 0,1,l-1
byteinteger(wp+1+i) = byteinteger(wp+1+i)&X'7F'
!We must strip off the parity on text.
repeat
finish
move(l, wp+1, cp)
cp = cp + l
finish
if header&x'80' # 0 then start
if formatted = yes then FTP line_new FTP data record = yes else c
if no format = no then byteinteger(cp) = 10 and cp = cp + 1; !ie LF (NL record implication)
finish
finish else start
!-------------------------------------------------------------
!it is a BINARY transfer to unscramble.
if FTP line_current vrecord length addr = 0 start
!First entry of a new binary record
if first pass = yes then extra space = 2 else extra space = 0
!Do this shift of 2 at the start to keep WORD alignment.
FTP line_current vrecord length addr = cp + extra space
cp = cp + 2 + extra space{Leave the two bytes for the record length}
first pass = no
finish
if l > 0 start
!We have some data
move(l, wp+1, cp)
cp = cp + l
FTP line_current vrecord length = FTP line_current vrecord length + l
finish
if header & x'80' # 0 start
!EOR is set on this sub record.
if FTP line_current vrecord length > 65533 start
!EOR shows existance of a record but it is greater than the
!max binary record supported on EMAS. Only possiblity is that
!it is a byte stream and this is the last data and the EOR is
!an abberation on the part of the transmitting entity.
!Lets assume this as we will trap it if there is more data.
if wp + l + 1 < end of input start
!But there is more data!
FTP log(" VRECORD exceeds x'FFFF' in length. Terminated.")
Mail Report("Incomming BINARY data has record in excess ". c
"of 65533 bytes.".snl,0)
flag = rerror no resume
-> error
finish
!OK leave it as discussed.
finish else start
FTP line_current vrecord length = FTP line_current vrecord length +2 {+header}
byteinteger(FTP line_current vrecord length addr) = c
byteinteger(addr(FTP line_current vrecord length)+2)
byteinteger(FTP line_current vrecord length addr + 1) = c
byteinteger(addr(FTP line_current vrecord length)+3)
!IE move in the record length.
i = FTP line_known to have records
FTP line_current vrecord length = FTP line_current v record length - 2
if i>>16 < FTP line_current vrecord length then c
FTP line_known to have records = (FTP line_known to have c
records ! x'ffff0000') & ((FTP line_current vrecord c
length << 16)! x'0000ffff')
if i # 0 and i & x'01' = 0 start
!at the moment all records have been the same length.
if i>>16 # FTP line_current vrecord length then c
FTP line_known to have records = FTP line_known to c
have records ! x'01'
!Bottom bit set means it is variable length.
finish
FTP line_records received = FTP line_records received + 1
FTP line_current vrecord length = 0
FTP line_current vrecord length addr = 0
finish
finish
finish
wp = wp + l + 1
exit unless wp < end of input
repeat
file header_end = cp - seg<<seg shift
finish else start
!-------------------------------------------------------------
!This is DEFAULT. That is either INTER EMAS or free (x'0080') format.
!The sub record stucture has been stripped by the FEP.
if FTP table_emastoemas = yes and document_data length = -1 start
!In this case we want to store the main part of the incomming
!file header untill the whole file has been received and afterwards
!overwrite the temporary file header with it.
adjust = file header size
move(adjust, data start, addr(FTP table_emastoemas header(0)))
finish else adjust = 0
move(data length-adjust, data start+adjust, seg<<seg shift+file header_end)
file header_end = file header_end+data length-adjust
finish
document_data length = file header_end-file header_start
FTP line_bytes transferred = document_data length
flag = ddisconnect(my name, file, fsys, 0)
print string("FTP (".itos(table entry).") DISCONNECT ".my name.".".file." FAILS " c
.errs(flag).snl) and flag = R error no resume and -> Xerror if flag # 0
result = 0
finish
printstring("FTP (".itos(table entry).") CONNECT ".my name.".".file." FAILS ".errs(flag).snl)
flag = R error no resume
-> xerror
error:
i = ddisconnect(my name,file,fsys,0)
print string("FTP (".itos(table entry).") DISCONNECT ".my name.".".file." FAILS ".errs(i).snl) if i # 0
xerror:
FTP log(" receiver error detected.")
result = flag
end ; !OF ACCEPT BLOCK.
routine complete file handling(integername flag, stringname report)
!*************************************************************
!* *
!* COMPLETE THE FILE TRANSFER, WE ARE A RECeiVER. *
!* *
!*************************************************************
integer i, seg, gap
string (15) user, file, my file, newgen file
string (127) tail
flag = 0
report = ""
user = document_user
my file = ident to s(ident)
!
if FTP line_bytes transferred = 0 start
report = "No data has been received."
mail report(report.snl,0)
FTP log(report)
flag = 1
return
finish
seg = 0; gap = 32
if TARGET # 2900 then flag = dconnect(my name, my file, ident>>24, R!W,seg, gap) else c
flag = dconnect(my name, my file, ident>>24, r!w, 0, seg, gap)
if flag # 0 start
report = "Connect SPOOL file for header change fails ".errs(flag)
FTP log(report)
return
finish
file header == record(seg<<seg shift)
size = (file header_end + epage size - 1) & (- epage size)
flag = dchsize(my name, my file, ident>>24, size>>10)
if flag # 0 start
report = "Cannot adjust completed file size ".errs(flag)
FTP log(report)
return
finish else file header_size = size
if FTP table_data type_value = x'0002'{BINARY} start
!We have to amend the header appropriately.
File header_type = 4 {data}
if FTP line_known to have records = 0 start
!Unstructured data file
File header_start = file header_start + 4 {record length offset}
File header_binary record = 3
mail report("This is an unstructured data file.".snl,0)
finish else start
!It has a structure.
File header_start = File header_start + 2 {offset}
File header_records = FTP line_records received
File header_binary record = FTP line_known to have records
File header_binary record = (File header_binary record & x'FFFFFF00') ! X'02' {variable}
mail report("This is a V (Max record: ".itos((File header_binary record)>>16). c
") Data file of ".itos(file header_records)." records.".snl,0)
if FTP line_known to have records & x'03' = 0 then mail report( c
"All the records are the same length.".snl,0)
finish
finish
if FTP table_emastoemas = yes and FTP table_mail = no start
!We have a file that has been transmitted to us with its full header
!and we have stored the start of that header away until this point
!while a temporary header controled the transfer of the data. Now overwrite
!the temp header with the transmitted one.
move(file header size, addr(FTP table_emastoemas header(0)), seg<<seg shift)
finish
if ftp table_mail = no then flag = ddisconnect(my name,my file,ident>>24,0)
if flag # 0 start
report = "Disconnect SPOOL file fails ".errs(flag)
FTP log(report)
return
finish
if FTP table_mail = yes start
!It is a mail message.
FTP table_mail to send = no
if FTP line_station ptr # guest entry then c
tail = string at(FTP stations(FTP line_station ptr),FTP stations(FTP line_station ptr)_shortest name) c
else tail = "[".FTP table_calling address."]"
string(seg<<seg shift + 16) = tail {The way to get the source to MAILER}
flag = ddisconnect(my name,my file,ident>>24,0)
if flag # 0 start
report = "Disconnect SPOOL file fails ".errs(flag)
FTP log(report)
return
finish
document_dest = "MAIL"
document_user = "FTRANS"
buffer disconnect
send to spooler(FTP mail,ident,yes)
flag = -1; !to indicate the sleep for reply required.
return
finish
if FTP table_mode_value = take job input start
!This is JOB input so now add it to the BATCH queue.
buffer disconnect
tail = "DEST=BATCHFROMFTP,USER=".FTP table_username_value.",NAME="
if FTP table_filename_set = no then tail = tail."FTP_JOB" else c
tail = tail.FTP table_filename_value
if FTP table_special options_set = yes then tail <- tail.",".FTP table_special options_value
to docstring(document,document_delivery,tail)
send to spooler(FTP job,ident,yes)
flag = -1
return
finish
if FTP table_mode_value = take job output or FTP table_mode_value = give job output c
or document_FTP user flags&FTP local output # 0 then start
!the tranfsered file is to go to a device.
if (FTP table_mode_value = take job output or (ftp table_mode_value = c
give job output and ftp table_device type_set = yes) ) and c
FTP table_device type_value -> FTP table_device type_value. c
("@").tail then to docstring(document,document_delivery,tail)
!ie the delivery can be included in the device type.
if document_FTP user flags & FTP fail mail # 0 then FTP table_ c
mail to send = no
buffer disconnect
if FTP table_mode_value = take job output or ( ftp table_mode_value = give job output c
and ftp table_device type_set = yes) then document_dest <- FTP table_device type_value c
else document_dest <- docstring(document,document_device type)
send to spooler(FTP output,ident,yes)
flag = -1
return
finish
file = doc string(document, document_name)
if FTP table_mode_value = x'0002' or (FTP line_station type = p station c
and document_FTP user flags & FTP overwrite # 0) then c
newgen file = file and file = "T#TR".my file else newgen file = ""
!we have been asked to replace an existing file
flag = dtransfer(my name, user, my file, file, ident>>24, ident>>24, 1)
if flag # 0 start
report = " TRANSFER ".my file." TO ".user.".".file. c
" FAILS ".errs(flag)
FTP log(report)
finish
if newgen file # "" start
flag = dnewgen(user,newgen file,file,ident>>24)
if flag # 0 start
if flag = 32 start
flag = dtransfer(user,user,file,newgen file,ident>>24,ident>>24,1)
if flag # 0 then report = "TRANSFER of file fails ".errs(flag) c
and FTP log (report) and i = ddestroy(user,file,"",ident>>24,0)
finish else start
report = "NEWGEN of transferred file fails ".errs(flag)
i = ddestroy(user,file,"",ident>>24,0)
FTP log(report)
finish
finish
finish
return
end ; !OF COMPLETE FILE HANDLING.
routine input buffer connect
!***************************************************************
!* *
!* THIS ROUTINE CONNECTS THE INPUT FTP BUFFER . *
!* *
!***************************************************************
integer flag, seg, gap
string (15) file
file = "LINEIN".itos(table entry)
seg = 0; gap = 0
if TARGET # 2900 then flag = dconnect(my name,file,my fsys,R!W,seg,gap) else c
flag = dconnect(my name, file, my fsys, r!w, 0, seg, gap)
monitor and return if flag # 0 and flag # 34
command start = seg <<seg shift
data start = command start
end ; !OF INPUT BUFFER CONNECT.
routine output buffer connect
!*****************************************************************
!* *
!* THIS ROUTINE CONNECTS THE FTP OUTPUT CONTROL BUFFER *
!* *
!*****************************************************************
integer flag, seg, gap
string (15) file
file = "LINEOUT".itos(table entry)
seg = 0; gap = 0
if TARGET # 2900 then flag = dconnect(my name,file,my fsys,R!W,seg,gap) else c
flag = dconnect(my name, file, my fsys, r!w, 0, seg, gap)
monitor and return if flag # 0 and flag # 34
if FTP line_output buffer status = already enabled start
!ie the output buffer is enabled so we want to write the unused
!page of it.
if FTP line_output transfer record_p5 = 0 then c
buffer offset = x'1000' else buffer offset = 0
finish else buffer offset = 0
reply start = seg <<seg shift + buffer offset
return
end ; !OF OUTPUT BUFFER CONNECT
routine buffer disconnect
!**************************************************************
!* *
!* THIS ROUTINE DISCONNECTS THE FTP CONTROL BUFFERS. *
!* *
!**************************************************************
integer flag
if command start # 0 then flag = ddisconnect(my name,
"LINEIN".i to s(table entry), my fsys, 0)
if reply start # 0 then flag = ddisconnect(my name,
"LINEOUT".i to s(table entry), my fsys, 0)
return
end ; !OF BUFFER DISCONNECT
routine delete FTP document(integer ident)
!***********************************************************************
!* *
!* Routine to delete an FTP document and its descriptor *
!* *
!***********************************************************************
record (document descriptorf)name document
string (11) file
integer fsys
file = ident to s(ident)
fsys = ident>>24
document == record(document addr(ident))
flag = ddestroy(my name, file, "", fsys, 0)
if flag = 0 or flag = does not exist start
FTP log(" ".document_dest." ". c
file." ".document_user. c
".".doc string(document,document_name)." DELETED")
finish else FTP log("FTP (".itos(table entry).") DESTROY ".my name.".".file. c
" FAILS ".errs(flag))
document_date and time deleted = current packed dt
document_state = unused
end ; !OF ROUTINE DELETE FTP DOCUMENT
routine mail report(string (255) s, integer displ)
!*****************************************************
!* *
!* This routine adds a line to the MAIL reply area. *
!* *
!*****************************************************
integer seg,gap,flag
string (11) file
seg = 0; gap = 0
file = "LINEMAIL".itos(table entry)
if TARGET # 2900 then flag = dconnect(my name,file,my fsys,R!W,seg,gap) else c
flag = dconnect(my name,file,my fsys,r!w,0,seg,gap)
if flag = 32 start
!Create the MAIL file
create ftp work files(flag,yes)
if flag # 0 start
printstring("MAIL create fails ".errs(flag).snl)
abort FTP
return
finish
seg = 0; gap = 0
if TARGET # 2900 then flag = dconnect(my name,file,my fsys,R!W,seg,gap) else c
flag = dconnect(my name,file,my fsys,r!w,0,seg,gap)
finish
if flag = 0 start
file header == record(seg<<seg shift)
if file header_end + length(s) > file header_size start
FTP log(" MAIL reply area full")
flag = ddisconnect(my name,"LINEMAIL".itos(table entry),my fsys,0)
return
finish
if displ # 0 then move(length(s),addr(s)+1, c
seg<<seg shift+file header_start+displ) else c
move(length(s),addr(s)+1,seg<<seg shift+file header_end) c
and file header_end = file header_end + length(s)
flag = ddisconnect(my name,"LINEMAIL".itos(table entry),my fsys,0)
return
finish
FTP log(" Connect MAIL file fails ".errs(flag))
end
routine create FTP work files(integername flag, integer mail only)
!*************************************************************
!* *
!* CREATE THE FTP INPUT AND OUTPUT BUFFERS *
!* *
!*************************************************************
integer seg,gap
record (daf)daddr
string (11) file
file = "LINEMAIL".itos(table entry)
if TARGET # 2900 then flag = dcreate(my name,file,my fsys,x'1000'>>10, c
zerod!tempfi,ada) else flag = dcreate(my name,file,my fsys,x'1000'>>10,zerod!tempfi)
flag = 0 if flag = already exists
if flag = 0 start
seg=0;gap=0
if TARGET # 2900 then flag = dconnect(my name,file,my fsys,R!W,seg,gap) else c
flag = dconnect(my name,file,my fsys,R!W,0,seg,gap)
file header == record(seg<<seg shift)
file header_start = x'20'
file header_end = file header_start
file header_size = x'1000'
flag = ddisconnect(my name,file,my fsys,0)
return if mail only = yes
file = "LINEIN".i to s(table entry)
if TARGET # 2900 then flag = dcreate(my name,file,my fsys,(block c
size//FTP emastoemas block division)>>10,zerod!tempfi,ada) else c
flag = dcreate(my name, file, my fsys, (block size//FTP emastoemas block division)>>10, ZEROD!tempfi)
!We assume that the EMASTOEMAS mode will have the greatest size.
flag = 0 if flag = already exists
if flag = 0 start
flag = get block addresses(my name, file, my fsys, addr(daddr))
if flag = 0 then FTP line_in block addr = daddr_da(1) else c
printstring("FTP (".itos(table entry).") GET BLOCK ADDR FAILS ".i to s(flag).snl) c
and return
file = "LINEOUT".i to s(table entry)
if TARGET # 2900 then flag = dcreate(my name,file,my fsys, c
x'2000'>>10,zerod!tempfi,ada) else c
flag = dcreate(my name, file, my fsys, x'2000'>>10, ZEROD!tempfi)
flag = 0 if flag = already exists
if flag = 0 start
flag = get block addresses(my name, file, my fsys, addr(daddr))
if flag = 0 then FTP line_out block addr = daddr_da(1) else c
printstring("FTP (".itos(table entry).") GET BLOCK ADDR(O) FAILS ".itos(flag).snl) c
and return
finish else printstring("FTP (".itos(table entry).") DCREATE ".file." FAILS ".itos(flag).snl) c
and return
finish else printstring("FTP (".itos(table entry).") DCREATE ".file." FAILS ".itos(flag).snl) c
and return
finish else printstring("FTP (".itos(table entry).") DCREATE ".file." FAILS ".errs(flag).snl)
end ; !OF CREATE FTP WORK FILES
routine format command(integer addr, offset, integername new len, integer eor)
!*************************************************************
!* *
!* TRANSLATE THE GIVEN BYTES FROM A BYTE STREAM TO *
!* AN FTP FORMATTED STREAM *
!* *
!*************************************************************
integer i, k, wk addr, len
len = new len
monitor and return if offset + len > x'7FF'
!SHOULD NOT BE TRANSLATING MORE THAN 1/2 EPAGE.
wk addr = addr + x'800'; !WORK AREA IS TOP HALF OF PAGE.
move(len, addr+offset, wk addr); !MOVE TO WORK AREA
i = 0; k = 0
cycle
if len - i <= 63 start
!ONE SUB RECORD LEFT.
byteinteger(addr+offset+k) = (len-i) ! eor << 7
!LENGTH OF SUBRECORD AND END OF RECORD MARK IF REQUIRED.
move(len-i, wk addr+i, addr+offset+k+1)
k = k + (len - i + 1)
exit
finish
!MUST HAVE AT LEAST ONE SUB RECORD LEFT
byteinteger(addr+offset+k) = 63; !MAX SUB RECORD LENGTH
move(63, wk addr+i, addr+offset+k+1)
k = k + 64
i = i + 63
repeat
new len = k
if 2 < mon level < 5 start
select output(1); printstring(dt."FTP (".itos(table entry).") COMMAND OUTPUT: ")
cycle i = 0, 1, new len-1
printstring(htos(byteinteger(addr+offset+i), 2))
repeat
newline; select output(0)
finish
return
end ; !OF FORMAT COMMAND.
if TARGET # 2900 start
routine interpret tcc(byteintegername type, subtype)
!*************************************************************
!* *
!* INTERPRET THE THE TCC AT THE END OF THE INPUT BLOCK *
!* AND REDUCE THE INPUT LENGTH BY THE TCC LENGTH *
!* *
!*************************************************************
integer i, tcc len
if FTP table_data control = FTP data then tcc len = 3 else tcc len = 2
if 2 < mon level < 5 start
select output(1)
if tcc len = 3 then printstring(dt."FTP TCC input in FTP DATA mode". c
" requires 3 bytes. Data length is ".itos(data length).snl) else c
printstring(dt."FTP TCC input in FTP DEFAULT mode requires 2 bytes.". c
"Data length is ".itos(data length).snl)
printstring(dt."FTP (".itos(table entry).") TCC INPUT: ")
if data length >= tcc len start
cycle i = data start+data length-tcc len, 1, data start+data length-1
printstring(htos(byteinteger(i), 2))
repeat
finish else printstring("FTP (".itos(table entry).") LENGTH ???")
newline; select output(0)
finish
-> error unless data length >= tcc len
!IE THE INPUT MUST HAVE SPACE FOR A TCC AND END WITH A TCC
data length = data length - tcc len
type = byteinteger (data start+data length+tcc len-2)
subtype = byteinteger(data start+data length+tcc len-1)
return
error:
FTP log(" TCC length ??")
type = x'FF'
return
end ; !OF INTERPRET TCC.
routine interpret comm(byteintegername type,shortintegername transfer status)
!*************************************************************
!* *
!* STRIP OFF FTP FORMAT AND EXTRACT THE COMMAND *
!* *
!*************************************************************
integer i, j, k, l, len, cur pos, p count
string (63) s
if 2 < mon level < 5 start
select output(1)
printstring(dt."FTP (".itos(table entry).") COMMAND INPUT: ")
cycle i = 0, 1, command length-1
printstring(htos(byteinteger(command start + i), 2))
repeat
newline
select output(0)
finish
cur pos = 0
cycle i=0, 1, command length-1
j = byteinteger(command start+i)
if j&x'3F' > 0 start
cycle k = 1, 1, j&x'3F'
byteinteger(command start+cur pos)=byteinteger(command start+i+k)
cur pos = cur pos + 1
repeat
finish
i = i + j&x'3F'
if (j>>7)&1 = 1 start
!END OF RECORD.
if i # command length-1 start
FTP log(" Command format incorrect")
type = x'FF'; !ie force error.
return
finish
exit
finish
repeat
if cur pos <= 1 start
!We do not have a 'minimum' command
FTP log(" Incomplete COMMAND")
type = x'ff' {force error}
return
finish
command length = cur pos
type = byteinteger(command start)
!now get the transfer status if FTP available in the parameters.
transfer status = x'FF'
p count = byteinteger(command start + 1)
messages = 0
cycle i = 1,1,16
message(i)_s == null string
repeat
return if p count = 0
k = command start + 2
cycle i = 1,1,p count
!FIRST get rid of any parity on the string attributes.
if byteinteger(K+1)&X'30' = X'30' start {STRING attribute}
len = byteinteger(K+2)
if len > 0 start
cycle l = 0,1,len-1
byteinteger(K+3+l) = byteinteger(K+3+l)&X'7F' {take off top bit}
repeat
finish
finish
!SECOND Look for state_of_transfer
if byteinteger(k) = x'0F' then start
byteinteger(addr(transfer status)) = byteinteger(k+2)
byteinteger(addr(transfer status)+1) = byteinteger(k+3)
FTP log(" tran status: ".htos(transfer status,4))
finish
unless 0<=byteinteger(k)<=x'80' start
!the attributes are screwed up.
FTP log(" command input attribute list corrupt.")
type = x'FF'
return
finish
if byteinteger(k) = x'71' then start
messages = messages + 1
if messages <= 16 then message(messages)_s == string(k+2)
finish
j = byteinteger(k+1)&x'30'
if j <=x'10' then k=k+2 and continue
if byteinteger(k) = x'70' then s = string(k+2) and FTP log(s)
if j = x'20' then k=k+4 And continue
k=byteinteger(k+2)+k+3
repeat
return
end ; !OF INTERPRET COMM.
finish else start
routine interpret tcc(byteintegername type, subtype)
!*************************************************************
!* *
!* INTERPRET THE THE TCC AT THE END OF THE INPUT BLOCK *
!* AND REDUCE THE INPUT LENGTH BY THE TCC LENGTH *
!* *
!*************************************************************
integer i, tcc len
if FTP table_data control = FTP data then tcc len = 3 else tcc len = 2
if 2 < mon level < 5 start
select output(1)
if tcc len = 3 then printstring(dt."FTP TCC input in FTP DATA mode". c
" requires 3 bytes. Data length is ".itos(data length).snl) else c
printstring(dt."FTP TCC input in FTP DEFAULT mode requires 2 bytes.". c
"Data length is ".itos(data length).snl)
printstring(dt."FTP (".itos(table entry).") TCC INPUT: ")
if data length >= tcc len start
cycle i = data start+data length-tcc len, 1, data start+data length-1
printstring(htos(byteinteger(i), 2))
repeat
finish else printstring("FTP (".itos(table entry).") LENGTH ???")
newline; select output(0)
finish
-> error unless data length >= tcc len
!IE THE INPUT MUST HAVE SPACE FOR A TCC AND END WITH A TCC
data length = data length - tcc len
type = byteinteger (data start+data length+tcc len-2)
subtype = byteinteger(data start+data length+tcc len-1)
return
error:
FTP log(" TCC length ??")
type = x'FF'
return
end ; !OF INTERPRET TCC.
routine interpret comm(byteintegername type,halfintegername transfer status)
!*************************************************************
!* *
!* STRIP OFF FTP FORMAT AND EXTRACT THE COMMAND *
!* *
!*************************************************************
integer i, j, k, l, len, cur pos, p count
string (63) s
if 2 < mon level < 5 start
select output(1)
printstring(dt."FTP (".itos(table entry).") COMMAND INPUT: ")
cycle i = 0, 1, command length-1
printstring(htos(byteinteger(command start + i), 2))
repeat
newline
select output(0)
finish
cur pos = 0
cycle i=0, 1, command length-1
j = byteinteger(command start+i)
if j&x'3F' > 0 start
cycle k = 1, 1, j&x'3F'
byteinteger(command start+cur pos)=byteinteger(command start+i+k)
cur pos = cur pos + 1
repeat
finish
i = i + j&x'3F'
if (j>>7)&1 = 1 start
!END OF RECORD.
if i # command length-1 start
FTP log(" Command format incorrect")
type = x'FF'; !ie force error.
return
finish
exit
finish
repeat
if cur pos <= 1 start
!We do not have a 'minimum' command
FTP log(" Incomplete COMMAND")
type = x'ff' {force error}
return
finish
command length = cur pos
type = byteinteger(command start)
!now get the transfer status if FTP available in the parameters.
transfer status = x'FF'
p count = byteinteger(command start + 1)
messages = 0
cycle i = 1,1,16
message(i)_s == null string
repeat
return if p count = 0
k = command start + 2
cycle i = 1,1,p count
!FIRST get rid of any parity on the string attributes.
if byteinteger(K+1)&X'30' = X'30' start {STRING attribute}
len = byteinteger(K+2)
if len > 0 start
cycle l = 0,1,len-1
byteinteger(K+3+l) = byteinteger(K+3+l)&X'7F' {take off top bit}
repeat
finish
finish
!SECOND Look for state_of_transfer
if byteinteger(k) = x'0F' then start
byteinteger(addr(transfer status)) = byteinteger(k+2)
byteinteger(addr(transfer status)+1) = byteinteger(k+3)
FTP log(" tran status: ".htos(transfer status,4))
finish
unless 0<=byteinteger(k)<=x'80' start
!the attributes are screwed up.
FTP log(" command input attribute list corrupt.")
type = x'FF'
return
finish
if byteinteger(k) = x'71' then start
messages = messages + 1
if messages <= 16 then message(messages)_s == string(k+2)
finish
j = byteinteger(k+1)&x'30'
if j <=x'10' then k=k+2 and continue
if byteinteger(k) = x'70' then s = string(k+2) and FTP log(s)
if j = x'20' then k=k+4 And continue
k=byteinteger(k+2)+k+3
repeat
return
end ; !OF INTERPRET COMM.
FINISH
routine send mail
!****************************************************
!* Send MAIL to the user about the transfer *
!****************************************************
integer mail ident
string (11) name
mail ident = get next descriptor(my fsys)
if mail ident = 0 start
FTP log(" MAIL reply fails, no FTRANS descriptors!")
flag = ddestroy(my name,"LINEMAIL".itos(table entry),"",my fsys,0)
finish else start
flag = drename(my name,"LINEMAIL".itos(table entry),identtos(mail ident),my fsys)
if flag # 0 start
FTP log("MAIL rename fails..document already exists!")
flag = ddestroy(my name,"LINEMAIL".itos(table entry),"",my fsys,0)
finish else start
document==record(document addr(mail ident))
document = 0
document_dest = "MAIL"
document_user = "FTRANS"
name = "FTP reply"
to docstring(document,document_name,name)
document_priority = 1; !really low, it dosent matter with mailer.
!We have to send mail via SPOOLR.
send to spooler(FTP mail, mail ident, no)
finish
finish
end ; !of routine SEND MAIL
routine generate(byteinteger type, subtype, integername len)
!*************************************************************
!* *
!* GENERATE THE REQUIRED FTP COMAND OR TCC *
!* *
!*************************************************************
integer start, i, op, value, param count
switch comm(0:5)
switch tran comm(0:7)
record (password document descriptor f)name password document
if TARGET # 2900 start
routine add(byteinteger id,op,shortinteger bval,string (63) sval)
integer addrs; byteinteger qual
addrs = reply start + len
byteinteger(addrs) = id
byteinteger(addrs+1) = op
if op&x'70' = bits start
byteinteger(addrs+2) = byteinteger(addr(bval))
byteinteger(addrs+3) = byteinteger(addr(bval)+1)
len = len + 4
finish else if op&x'70' = strings start
string(addrs+2) <- sval
len = length(sval)+3+len
finish else len = len + 2
param count = param count + 1
end
routine set bits(record (FTP bits) name bfield, byteinteger id,op, c
shortinteger value,byteinteger set)
add(id,op,value,"")
bfield_set = set
bfield_value = value
bfield_qual = op
end
finish else start
routine add(byteinteger id,op,halfinteger bval,string (63) sval)
integer addrs; byteinteger qual
addrs = reply start + len
byteinteger(addrs) = id
byteinteger(addrs+1) = op
if op&x'70' = bits start
byteinteger(addrs+2) = byteinteger(addr(bval))
byteinteger(addrs+3) = byteinteger(addr(bval)+1)
len = len + 4
finish else if op&x'70' = strings start
string(addrs+2) <- sval
len = length(sval)+3+len
finish else len = len + 2
param count = param count + 1
end
routine set bits(record (FTP bits) name bfield, byteinteger id,op, c
halfinteger value,byteinteger set)
add(id,op,value,"")
bfield_set = set
bfield_value = value
bfield_qual = op
end
finish
routine set string(record (FTP strings) name sfield, byteinteger id,op, c
string (63) value, byteinteger set)
add(id,op,0,value)
sfield_set = set
sfield_value <- value
sfield_qual = op
end
param count = 0
start = reply start
if type <= FTP stopack then -> comm(type) else c
-> tran comm(type&x'0F')
comm(4): !the sft
!NOTE 'SET' in the TABLE entry for a file transfer implies that
!a fixed and non negotiable value is sent on the SFT.
!Otherwise a negotiable entity has been sent and (may) require
!a response.
!First get the PASSWORD(secure) descriptor.
password document == record(password document addr(FTP line_document))
byteinteger(start) = FTP sft
len = 2
FTP table_mail to send = yes
FTP table_data control = FTP data
add(x'71',eq!strings,0,"EMAS 2900 NIFTP-B(80); VSN 4.0")
if document_user = "MAILER" then FTP table_mail = yes
!protocol id
set bits(FTP table_protocol id,x'00',eq!bits,x'0100',yes)
!----------------------------------------------------
!mode of access
set bits(FTP table_mode,x'01',eq!bits,document_mode of access,yes)
if document_mode of access < x'8000' then FTP line_activity = sender c
else FTP line_activity = receiver
!---------------------------------------------------
!data type
op = bits ! eq ; i = yes
if FTP line_activity = receiver start
if document_FTP user flags&FTP binary read only # 0 or document_ c
FTP user flags2&FTP text read only # 0 then document_try emas c
to emas = no
!If the data type is user specified then obey without question.
if document_FTP user flags&FTP binary read only # 0 then c
value = x'0002' {BINARY} c
else if document_FTP user flags2&FTP text read only # 0 then c
value = x'0001' {TEXT} else start
op = bits ! le ! monitor
value = x'0003' {TEXT or BINARY}
i = no
finish
finish else start
Value = X'0001' {ie TEXT for 'true' text and also all other non DATA files}
if document_FTP user flags & FTP binary data # 0 start
!It is a DATA file, only type to go as FTP BINARY out of EMAS.
Value = X'0002'
FTP table_binary data record = document_FTP data record
finish
finish
set bits(FTP table_data type,x'20',op,value,i)
unless document_FTP user flags&FTP binary read only # 0 start {TEXT etc}
!--------------------------------------------------------
!text transfer code.
if document_try emas to emas = yes then start
if document_FTP user flags&(FTP non text or data ! FTP binary data) # 0 then c
set bits(FTP table_text tran code,x'02',EQ!bits,x'0008',yes) else c
set bits(FTP table_text tran code,x'02',LE!monitor!bits,x'0009',no)
finish else if document_FTP user flags&FTP binary data = 0 then c
set bits(FTP table_text tran code,x'02',eq!bits,x'0001',yes)
!--------------------------------------------------------
!text format
if document_FTP user flags & (FTP binary data ! FTP non text or data) = 0 OR C
DOCSTRING(DOCUMENT,DOCUMENT_FTPALIAS) = "FSTORE" {TEMP FRIG} start
!We have a text file so proceed.
if FTP line_activity = sender c
then value = x'0081' else value = x'0083'
if document_ftp user flags & FTP ansi # 0 then c
set bits(FTP table_text format,x'03',eq!bits,x'0002',yes) else c
set bits(FTP table_text format,x'03',le!bits, value,no)
!NOTE HERE we are saying two things
! 1) The user has specified that the (INcomming) file has ANSI control cahars
! 2) The choice is left to the Q station (WE will not expect it to choose
! ANSI for a file it will recieve so let this be a general value)
finish
!--------------------------------------------------------
finish {TEXT etc only}
!-------------------------------------------------------
!BIN word size and BIN format
if document_FTP user flags & FTP binary data # 0 or (FTP line_activity = receiver c
and document_FTP user flags2&FTP text read only = 0) start
!We have a data file (Sender)
set bits(FTP table_binary word size, x'24', eq!bits, x'0008', yes)
finish
!------------------------------------------------------
!max tran record size.
if document_FTP user flags & FTP binary data # 0 and c
(document_FTP data record &x'03') = 4 start
if document_FTP data record&x'03' = 3 {UNSTRUCTURED} then set bits( c
FTP table_max tran rec size,x'05',eq!bits,document_data length,yes) else c
set bits(FTP table_max tran rec size,x'05', eq!bits,document_FTP data record>>16,yes)
finish else c
set bits(FTP table_max tran rec size,x'05',le!bits!monitor,x'ffff',no)
!--------------------------------------------------------
!private code name
if document_try emas to emas = yes then set string(FTP table_private c
code name,x'09',eq!strings,private code,yes)
!-------------------------------------------------------
!now the file details etc.
if document_external user # 0 then c
set string(FTP table_username,x'42',eq!strings,doc string(document,document_external user),yes)
if document_external password = set then c
set string(FTP table_username password,x'44',eq!strings, c
password doc string(password document,password document_external password),yes)
set string(FTP table_filename,x'40',eq!strings,doc string( c
document,document_external name),yes) if document_external name # 0
if document_FTP file password = set then set string(FTP table_file password, c
x'45',eq!strings,password docstring(password document,password document_FTP file password),yes)
!------------------------------------------------------
!Is the job going to or coming to a device.
!Now the code handling auto polling return of output from remote jobmills.
if document_mode of access = give job output and document_auto requeue = yes start
document_device type = 0
document_ftp user flags = document_ftp user flags ! ftp no mail
FTP log(" Auto output poll to ".string at(FTP stations(FTP line_station ptr) c
,ftp stations(ftp line_station ptr)_shortest name).snl)
finish
if document_mode of access = give job output and document_device type = 0 start
!We are dragging job output without knowing where to..ask the other end.
add(x'50',monitor!any!strings,0,"")
add(x'51',monitor!any!strings,0,"")
finish
if document_device type # 0 start
if FTP line_activity = sender start
if doc string(document,document_device type) = "LP" then c
op = monitor!eq!strings else op = eq!strings
set string(FTP table_device type,x'50',op, doc string( c
document,document_device type),yes)
finish else start
FTP table_device type_set = yes
FTP table_device type_value <- docstring(document,document_device type)
finish
finish
!------------------------------------------------------
!The special options field.
if document_special options = set then set string(FTP table_special options, c
x'80',eq!strings,password doc string(password document,password document_special options),yes)
!----------------------------------------------------
!file size
if FTP stations(control entry)_limit < FTP stations(FTP line_station ptr)_limit then limit = c
FTP stations(control entry)_limit else limit = FTP stations(FTP line_station ptr)_limit
if FTP line_activity = sender then I = document_data length
if string at(FTP stations(FTP line_station ptr) c
,FTP stations(FTP line_station ptr)_shortest name) = "UMRCC.GFILE" then c
I = 1 and limit = 1
!THIS HAS TO BE DONE IN THE SHORT TERM TO GET ROUND MANCHESTER'S
!INABILITY TO IMPLEMENT IT'S Q STATION TO THE OW SPEC
if FTP line_activity = sender then set bits(FTP table_file size, c
x'60',eq!bits,( I +1023)>>10,yes) else c
set bits(FTP table_file size,x'60',le!monitor!bits,limit,no)
!----------------------------------------------------
!timeout
set bits(FTP table_timeout,x'0D',eq!bits,x'0258',yes)
byteinteger(start+1) = param count
format command(start, 0, len, 1)
RETURN
comm(3):
!RNEG, This is only generated here when BATCh scheduling parameters given
!with a TAKE_JOB_INPUT transfer are at fault after the transfer itself whas
!been oked by the main negotiation module.
!The STOPACK message is used in this case to hold the info message.
byteinteger(start) = type
byteinteger(start+1) = 2
byteinteger(start+2) = x'0F'
byteinteger(start+3) = x'22'
IF TARGET # 2900 THEN SHORTinteger(start+4) = FTP line_transfer status ELSE C
halfinteger(start+4) = FTP line_transfer status
len = 6
add(x'71',eq!strings,0,FTP table_stopack message)
!the format will be done in thsi case on return to the calling routine.
return
comm(1):
!ie GO
byteinteger(start) = type
byteinteger(start+1)= 0
len = 2
format command(start, 0, len, 1)
return
comm(0):
comm(5):
!ie STOP and STOPACK
byteinteger(start) = type
byteinteger(start + 1) = 1
byteinteger(start + 2) = x'0F'
byteinteger(start + 3) = X'22'
IF TARGET # 2900 THEN SHORTinteger(start+4) = FTP line_transfer status ELSE C
halfinteger(start + 4) = FTP line_transfer status
len = 6
if type = FTP STOPACK and FTP table_stopack message # "" then c
add(x'71',eq!strings,0,FTP table_stopack message) c
and byteinteger(start + 1) = 2
format command(start,0,len,1)
return
tran comm(0):
tran comm(2):
tran comm(3):
tran comm(6):
tran comm(7):
start = start + len; !may have more than one tcc to go out.
byteinteger(start) = 0
byteinteger(start+1) = x'40'!TYPE
byteinteger(start+2) = subtype
len = len + 3
if 2 < mon level < 5 start
select output(1); printstring(dt."FTP (".itos(table entry).") TCC OUTPUT: ")
cycle i=0, 1, 2
printstring(h to s(byteinteger(start+i), 2))
repeat
newline; select output(0)
finish
return
end ; !OF GENERATE.
!*
routine evaluate negotiation(integer command start, reply start, c
integername reply length, integer limit, byteintegername type)
!****************************************************************************
!* *
!* This routine is the general FTP-B(80) negotiation evaluation package. *
!* It handles the following: *
!* 1) A Q station recieving an SFT ,it generates an RPOS or RNEG *
!* 2) A P station recieving a RPOS ,it generates a STOP or accept transfer *
!* 3) A P station recieving a RNEG ,it reports and generates a STOP *
!* 4) A Q station recieving a STOP after sending RPOS, reports only. *
!* *
!****************************************************************************
record (FTP tablef) name FTP wrk
record (finff) finf
record (fhf) name file header
routinespec fill work entry(integer start)
routinespec default table entry
if TARGET # 2900 start
routinespec add(byteinteger id,op, shortinteger bval, string (63) sval)
routinespec reject(byteinteger id,op, shortinteger bval, string (63) sval, c
shortinteger rej code)
routinespec handle rneg
integerfnspec try bits(record (FTP bits)name field, shortinteger value)
integerfnspec try value(record (FTP bits)name field, shortinteger value)
integerfnspec bits set(shortinteger value)
finish else start
routinespec add(byteinteger id,op, halfinteger bval, string (63) sval)
routinespec reject(byteinteger id,op, halfinteger bval, string (63) sval, c
halfinteger rej code)
routinespec handle rneg
integerfnspec try bits(record (FTP bits)name field, halfinteger value)
integerfnspec try value(record (FTP bits)name field, halfinteger value)
integerfnspec bits set(halfinteger value)
finish
integerfnspec validate filename(string (39) file)
integer param count, flag, file type, seg, gap, i, j
string (63) info, S, s1
routine uc tran(stringname string)
integer i,j
if length(string) > 0 start
cycle i = 1,1,length(string)
j = byteinteger(addr(string)+i)
byteinteger(addr(string)+i) = j&95 if 'a'<=j<='z'
repeat
finish
end ; !of routine UC TRAN
param count = 0; reply length = 2
info = ""
FTP wrk == FTP tables(0)
if type = FTP rneg then handle rneg and return else fill work entry(command start)
return if type = FTP STOP
!NOTE Setting The string 'info' before a call of 'add' or 'reject'
!ensures that an extra infromation message(x'71' type) is added to
!the reply. 'info' will return from the called routine set to ""
if FTP line_status = awaiting sft start
type = FTP rpos
default table entry
FTP table_mail = FTP wrk_mail if FTP wrk_mail = yes; !note this in only for NSI.
finish
!ie a Q station so assume we will suceed and put defaults in the table
!protocol identification
if FTP line_status = awaiting sft start
!ie a Q station.
if FTP wrk_protocol id_set = no start
!not given by p !
if FTP wrk_protocol id_qual & monitor # 0 then add(x'00',bits!eq,x'0100',"")
FTP table_protocol id_value = x'0100'
FTP table_protocol id_set = yes
finish else start
if FTP wrk_protocol id_value >> 8 # x'01' start
info = "invalid protocol identification"
reject(x'00',bits!eq,x'0100',"",rejected attribute)
return
finish
FTP table_protocol id = FTP wrk_protocol id
finish
finish
!no action for p station on rpos
!Mode Of Access
if FTP line_status = awaiting sft start
if FTP wrk_mode_value & x'0100' # 0 start
!resume wanted...no way yet
info = "resume not permitted"
reject(x'01',bits!eq,x'feff'&FTP wrk_mode_value,"",rejected attribute)
return
finish
if FTP wrk_mode_set = no start
reject(x'71',strings!eq,0,"no mode of access",rejected attribute)
return
finish
if FTP wrk_mode_value & x'E000' = x'8000' start
!ie Q to P file transfer
if FTP wrk_mode_value <= x'8002' then FTP table_mode = FTP wrk_mode c
else reject(x'01',bits!le,x'8003',"",rejected attribute) and return
if FTP wrk_mode_qual & monitor # 0 then add(x'01',bits!eq,FTP wrk_mode_value,"")
FTP line_activity = sender
finish else if FTP wrk_mode_value & x'E000' = 0 start
!ie it is P to Q file transfer
if FTP table_mail = no start
if FTP wrk_mode_value = X'0005' {MAKE_OR_APPEND} start
!We do not support append, change to MAKE and warn.
FTP wrk_mode_value = X'0001'
add(x'71',eq!strings,0,"APPENDing not supported")
finish
if FTP wrk_mode_value <= x'0003' then FTP table_mode = FTP wrk_mode c
else reject(x'01',bits!eq,x'0003',"",rejected attribute) and return
if FTP wrk_mode_qual & monitor # 0 and FTP wrk_mode_value # x'0003' c
then add(x'01',bits!eq,FTP table_mode_value,"")
finish else FTP table_mode_value = x'0001' and FTP table_mode_set = yes
!IE MAIL gets thro on 'any' file mode.
FTP line_activity = receiver
finish else if FTP wrk_mode_value & x'6000' # 0 start
!P to Q job mode
FTP line_activity = receiver
if FTP wrk_mode_value = x'4001' start
!take job output.
if FTP wrk_device type_set = no and FTP wrk_device type qualifier_set = no start
if FTP wrk_device type_qual&any # 0 or FTP wrk_device type_qual& c
monitor # 0 start
!wants us to choise..use LP
FTP table_device type_value = "LP"
FTP table_device type_set = yes
finish else start
info = "Device required with 'take job output'"
reject(x'50',strings!any,0,"",rejected attribute)
return
finish
finish else start
FTP table_device type_value <- FTP wrk_device type_value. c
FTP wrk_device type qualifier_value
if FTP table_device type_value -> s1.(".").s and s1 = "" then FTP table_device type_value = s
FTP table_device type_set = yes
uc tran(FTP table_device type_value)
finish
FTP table_mode = FTP wrk_mode
finish else start
!It is TAKE_JOB_INPUT..let it thro. The scheduling is checked in the main module.
FTP table_mode = FTP wrk_mode
finish
finish else if FTP wrk_mode_value & x'F000' > x'A000' start
!Q to P job transfer
!again not yet supported.
FTP line_activity = sender
info = "not yet supported"
reject(x'01',bits!le,x'8003',"",rejected attribute)
return
finish else start
info = "non defined mode of access!"
reject(x'01',bits!any,0,"",rejected attribute)
return
finish
finish else start
!P station has rpos...what did we send?
if FTP line_activity = sender and FTP table_mode_value = x'0003' start
!we sent choice.
s = ""
if FTP wrk_mode_set = yes and FTP wrk_mode_value < x'0003' then c
FTP table_mode_value = FTP wrk_mode_value else s = "Possibly "
if FTP table_mode_value = x'0001' then mail report( c
"Transfer will create a new file".snl,0) else mail report(s."Transfer will overwrite an existing file".snl,0)
finish
!this way we know the activity undertaken at the q station.
finish
!Now verify the file attributes.
if FTP line_status = awaiting sft start
!Q station
if FTP table_mail = no start
!don't do this checking for MAIL transactions.
if FTP wrk_username_set = no start
if FTP table_mode_value = x'4001' then FTP table_username_value = c
"FTPMAN" and FTP table_username_set = yes and -> get fsys
!else there should be a username.
info = "no username given"
reject(x'42',any!strings,0,"",rejected attribute)
return
finish else start
FTP table_username = FTP wrk_username
uc tran(FTP table_username_value)
get fsys:
FTP table_user fsys = -1
flag = dfsys(FTP table_username_value,FTP table_user fsys)
if flag # 0 start
info = "user not known"
reject(x'42',ne!strings,0,FTP table_username_value,rejected attribute)
return
finish
FTP line_user = ftp table_username_value {for picture update efficiency}
finish
unless FTP table_mode_value = x'4001' start
if FTP wrk_file password_set = yes then add(x'71',eq!strings, c
0,"File password not required.")
if FTP wrk_username password_set = no start
info = "no username password given"
reject(x'44',strings!any,0,"",rejected attribute)
return
finish else start
FTP table_username password = FTP wrk_username password
flag = d check bpass(FTP table_username_value,FTP table_username password_value, c
FTP table_user fsys)
if flag # 0 start
info = "invalid username password"
reject(x'44',ne!strings,0,FTP table_username password_value,rejected attribute)
return
finish
finish
finish
finish else start
FTP table_username_value = "MAILER"
FTP table_user fsys = my fsys
FTP line_user = "MAILER"
finish
if FTP wrk_filename_set = no start
unless FTP table_mode_value = x'4001' or FTP table_mode_value = x'2001' c
or (FTP wrk_device type_set = c
yes and FTP table_mode_value = x'0001') or FTP table_mail = yes start
!we need a file name if it is not for a device or MAIL.
info = "No filename given"
reject(x'40',strings!any,0,"",rejected attribute)
return
finish
finish else start
FTP table_filename = FTP wrk_filename
if FTP table_mail = yes then flag = 1 else start
uc tran(FTP table_filename_value)
unless validate filename(FTP table_filename_value) = ok start
!They have given a bad filename.
info = FTP table_filename_value." is not a valid EMAS filename."
reject(X'40',strings!ne,0,FTP table_filename_value,rejected info)
return
finish
if TARGET # 2900 then flag = dfinfo(FTP table_username_value,FTP table_ c
filename_value,FTP table_user fsys,finf_offer,finf_i) else c
flag = dfinfo(FTP table_username_value,FTP table_filename_value,FTP table_user fsys,addr(finf))
finish
if FTP line_activity = sender start
!we are to send the file
if flag # 0 start
!the file isn't there!
info = FTP table_username_value.".".FTP table_filename_value." not found."
reject(x'40',ne!strings,0,FTP table_filename_value,rejected attribute)
return
finish
finish else start
!we are to receive the file
if FTP table_mode_value = x'0003' start
if flag = 0 then FTP table_mode_value = x'0002' else c
FTP table_mode_value = x'0001'
add(x'01',eq!bits,FTP table_mode_value,"")
finish else if (FTP table_mode_value = x'0001' and flag = 0) c
or (FTP table_mode_value = x'0002' and flag # 0) start
if FTP table_mode_value = x'0001' then info = "File already exists" c
else info = "File does not already exist"
reject(x'01',ne!bits,FTP table_mode_value,"",rejected attribute)
return
finish
finish
finish
finish
!The Data Type for the transaction.
if FTP line_status = awaiting sft start
if FTP wrk_data type_set = no start
!then we will assume the default of text.
FTP wrk_data type_value = x'0001'
FTP wrk_data type_qual = eq!bits
FTP wrk_data type_set = yes
FTP log("No data type on P sft, default assumed.")
!we set wrk not table and fall through to the file type test.
finish
!not default but specifically defined or drop through from default assumption.
if FTP line_activity = sender start
seg = 0; gap = 0
flag = dpermission(FTP table_username_value,myname,"",ftp table_filename_value, c
FTP table_user fsys,2,r)
if flag = 0 start
if TARGET # 2900 then flag = dconnect(FTP table_username_value, c
FTP table_filename_value,FTP table_user fsys,R,seg,gap) else c
flag = dconnect(FTP table_username_value,FTP table_filename_value, c
FTP table_user fsys,R,0,seg,gap)
finish
if flag # 0 start
reject(x'71',eq!strings,0,"file not available, try later",rejected deferred)
return
finish
flag = dpermission(FTP table_username_value,myname,"",ftp table_filename_value, c
FTP table_user fsys,3,r)
file header == record(seg<<seg shift)
file type = file header_type
unless try bits(FTP wrk_text tran code,x'0008') = yes and c
FTP wrk_private code name_value = private code start
if file type = iso text start
flag = ddisconnect(FTP table_username_value,FTP table_filename_value,FTP table_user fsys,0)
if try bits(FTP wrk_data type,x'0001') = yes start
!we can select text.
FTP table_data type_set = yes
if FTP wrk_data type_qual & monitor # 0 then add(x'20',eq!bits,x'0001',"")
finish else if try bits(FTP wrk_data type,x'0002') = yes start
!we are required to transmit text as binary
info = "Text as binary not yet available."
reject(x'20',eq!bits,x'0001',"",rejected attribute)
return
finish else start
!any other reject.
reject(x'20',eq!bits,x'0001',"",rejected attribute)
return
finish
finish else start
if file type = 4{DATA} start
!We have a DATA file send as BINARY.
if try bits(FTP wrk_data type,x'0002') = yes start
!OK they will accept a binary transfer
FTP table_data type_value = x'0002'
FTP table_data type_set = yes
FTP table_binary data record = file header_binary record
if FTP wrk_data type_qual & monitor # 0 or FTP wrk_data type_qual c
& op mask # eq then add(x'20',eq!bits,x'0002',"")
flag = ddisconnect(FTP table_username_value,FTP table_filename_value,FTP table_user fsys,0)
finish else start
info = "File is binary and Binary transfers not supported by you."
reject(x'20',eq!bits,x'0002',"",rejected attribute)
return
finish
finish else start
reject(x'71',eq!strings,0,"File is not TEXT or BINARY data",rejected info)
flag = ddisconnect(FTP table_username_value,FTP table_filename_value,FTP table_user fsys,0)
return
finish
finish
finish else flag = ddisconnect(FTP table_username_value,c
FTP table_filename_value,FTP table_user fsys,0)
finish else start
!we are to receive.
unless try bits(FTP wrk_text tran code,x'0008') = yes and c
FTP wrk_private code name_value = private code start
if try bits(FTP wrk_data type,x'0001') = yes start
!text,as yet, only option..chose it
if FTP wrk_data type_qual&monitor # 0 then add(x'20',eq!bits,x'0001',"")
FTP table_data type_set = yes
finish else if try bits(FTP wrk_data type,x'0002') = Yes start
FTP table_data type_value = x'0002'
FTP table_data type_set = yes
FTP table_data control = translate{ie no assist form the FEP in sub rec handling}
if FTP wrk_data type_qual & monitor # 0 then add(x'20', c
eq!bits,x'0002',"")
finish else start
reject(x'71',eq!strings,0,"Mixed data not supported",rejected attribute)
return
finish
finish
finish
finish else start
!P station has got an RPOS
unless try bits(FTP wrk_text tran code, x'0008') = yes start
!If inter emas has been accepted then don't bother with data type
if FTP table_data type_set = yes start
!we must be the sender and know the data type.
if FTP wrk_data type_set = yes and FTP table_data type_value c
# FTP wrk_data type_value start
!The Q has sent RPOS with differing data type. !
info = "DATA-TYPE response unacceptable"
mail report("Negotiation failure (".info.")".snl,0)
handle RNEG
FTP log("Q responds with wrong DATA-TYPE on RPOS")
FTP table_emastoemas = rejected
transfer status = rejected info
return
finish
finish else start
!We sent a choice(as reciever) so Q must respond
if FTP wrk_data type_set = yes start
!We have a response from Q on this
if FTP wrk_data type_value = x'0001'{TEXT} start
FTP table_data type = FTP wrk_data type
finish else if FTP wrk_data type_value = x'0002'{BINARY} start
FTP table_data type = FTP wrk_data type
FTP table_data control = translate{no FEP assists on sub records}
finish
finish else start
!EH?
FTP log(" no DATA_TYPE response from Q !")
info = "NO response by your Q on DATA_TYPE monitor. Protocol error"
FTP table_emastoemas = rejected
transfer status = rejected info
return
finish
finish
finish
finish
! The Text Transfer Code.
if FTP line_status = awaiting sft start
if FTP wrk_text tran code_set = no and FTP table_data type_value = x'0001'{text} start
!must assume default.
FTP table_text tran code_set = yes
if FTP wrk_text tran code_qual&monitor # 0 then add(x'02',eq!bits,x'0001',"")
finish else start
if try bits(FTP wrk_text tran code,x'0008') = yes start
!we have a private code, is it emas-emas?
unless FTP wrk_private code name_value = private code start
info = "unknown private code name"
finish else start
FTP table_text tran code_value = x'0008'
FTP table_text tran code_set = yes
FTP table_private code name_set = yes
FTP table_private code name_value = FTP wrk_private code name_value
FTP table_emas to emas = yes
FTP table_data control = no translation
add(x'09',eq!strings,0,FTP table_private code name_value)
add(x'02',eq!bits,x'0008',"")
!Reflect the code type.
finish
finish
if FTP table_private code name_set = no and FTP table_data type_value = x'0001'{TEXT} start
!we have not accepted a private code, look at the options
if try bits(FTP wrk_text tran code,x'0001') = yes start
!we will accept IA5 text transfer.
FTP table_text tran code_value = x'0001'
FTP table_text tran code_set = yes
finish else start
!no other possible text code.
reject(x'02',ne!bits,x'0004',"",rejected attribute)
return
finish
finish
if FTP table_data type_value = x'0001'{TEXT} and (FTP wrk_text tran code_qual&op mask # eq or c
FTP wrk_text tran code_qual&monitor # 0) then add(x'02',eq!bits, c
FTP table_text tran code_value,"")
finish
finish else start
!P station has RPOS.
if FTP table_text tran code_qual&monitor # 0 or c
FTP table_text tran code_qual&op mask # eq or c
(FTP table_text tran code_value = x'0008' and ((FTP wrk_text tran code_value c
= x'0008' and FTP wrk_text tran code_ qual&op mask = eq) or c
(FTP wrk_private code name_qual&op mask = eq and FTP wrk_private code c
name_value = private code))) start
!NOTE that the rule of INTER-EMAS is that the Q will on the RPOS
!always send back text transfer code of EQ x'0008'
!
!We sent choice or monitor or private code only.
!or implied inter emas in DATA only transaction.
if FTP table_text tran code_qual&op mask # eq and c
FTP wrk_text tran code_qual&op mask # eq start
if FTP table_data type_value = x'0002' then -> skip ttc
!We do this since if it is BINARY the TTC does not matter(except EMAS private code)
FTP log("Q fails to respond on RPOS to text tran code mon/choice.")
FTP table_emas to emas = rejected
transfer status = rejected info
info = "No text tran code response on RPOS"
mail report("Negotiation Failure".snl,0)
handle rneg
return
finish
FTP table_text tran code = FTP wrk_text tran code unless FTP table_text tran code_set = yes
if FTP table_text tran code_value = x'0008' start
!The private code has been selected.
FTP log("----inter EMAS new style----")
FTP table_emastoemas = yes
FTP table_data control = no translation
finish
finish
skip ttc:
finish
!Text Formatting
if FTP table_data type_value = x'0001'{TEXT} start
!HERE NOTE that we accept the following at release 3 level
! x'0001' OSI required level
! x'0002' ANSI control for INcomming transfer ONLY
! x'0080' FREE format..let the file thro as it is presented.
if FTP table_emas to emas = no and FTP table_data type_value # X'0002' start
!ie not EMAS intercommunication or Binary only transaction.
if FTP line_status = awaiting sft start
!Q station.
if FTP wrk_text format_set = no start
!assume the default.
FTP log("Assuming Default Text Format")
FTP table_text format_set = yes
if FTP wrk_text format_qual&monitor # 0 then add(x'03',eq!bits,x'0001',"")
finish else if FTP wrk_text format_qual&op mask = eq start
!at the moment we are aiming at open working and 'free' format(x'0080')
!and ANSI (x'0002')(INcomming transfers only)
unless FTP wrk_text format_value & x'0081' # 0 or c
(FTP wrk_text format_value & x'0083' # 0 and FTP line_activity = receiver) start
reject(x'03',bits!le,x'0081',"",rejected attribute)
return
finish
FTP table_text format = FTP wrk_text format
finish else start
!we are given a choice.
if try bits(FTP wrk_text format,x'0001') = yes then c
FTP table_text format_value = x'0001' else if c
(try bits(FTP wrk_text format,x'0002') = yes and FTP line_activity = receiver) then c
FTP table_text format_value = x'0002' else if c
try bits(FTP wrk_text format,x'0080') = yes then c
FTP table_text format_value = x'0080' else start
!no other initially permitted
info = "other text transfers under development"
reject(x'03',bits!le,x'0083',"",rejected attribute)
return
finish
FTP table_text format_set = yes
finish
if FTP wrk_text format_qual&monitor # 0 or FTP wrk_text format_qual&op mask # eq then c
add(x'03',eq!bits,FTP table_text format_value,"")
if FTP table_text format_value = x'0080' and FTP line_activity = sender c
and {PRE OSCOM FEP only} TARGET = 2900 then FTP table_data control = no translation
finish else start
!WE are a P station and sent a choice.
if FTP table_text format_set = no start
!we have sent a choice and requested monitor.
if FTP wrk_text format_qual&op mask # eq start
!we have no response.
FTP log("No text format monitor response(qual # eq)")
transfer status = rejected info
info = "No text format response on RPOS"
mail report("Negotiation Failure".snl,0)
handle rneg
return
finish
unless (FTP wrk_text format_value & x'0081' # 0 or ( c
FTP wrk_text format_value & x'0083' # 0 and FTP line_activity = receiver)) c
and bits set(FTP wrk_text format_value) = 1 start
FTP log("Q has not taken an acceptable text format choice")
transfer status = rejected info
info = "Unaccepted text format choice"
mail report("Negotiation Failure".snl,0)
handle rneg
return
finish
FTP table_text format = FTP wrk_text format
finish else if FTP wrk_text format_set = yes start
!we already had a value in mind but Q knows better.
if FTP wrk_text format_qual&op mask = eq and FTP wrk_text format_ c
value & x'0081' # 0 and bits set(FTP wrk_text format_value) = 1 start
FTP log("Q changes text format OK")
FTP table_text format = FTP wrk_text format
finish else start
FTP log("Q screws text format negotiation")
transfer status = rejected attribute
info = "Text format negotiation screwed"
mail report("Negotiation Failure".snl,0)
handle rneg
return
finish
finish
if FTP table_text format_value = x'0080' and FTP line_activity = sender c
and {PRE OSCOM FEP only} TARGET = 2900 then FTP table_data control = no translation
finish
finish
finish
!Device type.
if FTP line_status = awaiting sft start
if FTP wrk_device type_qual & monitor # 0 then start
if FTP table_mode_value = x'4001' then add(x'50',eq!strings,0, c
FTP table_device type_value)
finish
!only need to reply to a monitor for a device.
finish else start
if ftp table_mode_value = give job output start
!This is a special case where job output is being dragged back and the
!RPOS may include a device type from the run job JCL.
if ftp wrk_device type_set = yes start
ftp table_device type_value = ftp wrk_device type_value
if ftp wrk_device type qualifier_set = yes then ftp table_device type_ c
value = ftp table_device type_value.ftp wrk_device type qualifier_value
ftp table_device type_set = yes
finish
finish else start
if FTP wrk_device type_set = yes and FTP table_device type_set = yes start
!sent a possible device and got one back.
if FTP wrk_device type_value # FTP table_device type_value c
and type # FTP rneg start
mail report("External system chooses device: ". c
FTP wrk_device type_value.snl,0)
FTP table_device type = FTP wrk_device type
finish
finish
finish
finish
!max transfer record size
if FTP line_status = awaiting sft start
!we will accept any value defaulting to infinity(x'ffff')
if FTP wrk_max tran rec size_set = yes then c
FTP table_max tran rec size = FTP wrk_max tran rec size else c
FTP table _max tran rec size_set = yes
if FTP wrk_max tran rec size_qual&monitor # 0 then c
add(x'05',bits!eq,FTP table_max tran rec size_value,"")
finish else start
if FTP line_activity = sender and FTP table_emastoemas = no and c
FTP table_data type_value = x'0002' and FTP wrk_max tran rec size_set = yes c
and FTP wrk_max tran rec size_value < FTP table_max tran rec size_value start
!We have a DATA file that cannot be transmitted RECORDS PRESERVED because
!Q will not accept the MAX-TRAN-REC-SIZE.
FTP log("Q cannot handle large enough RECORDS")
info = "DATA file has too large records for your Q."
mail report("DATA records too large for External Station to handle".snl,0)
transfer status = rejected info
handle rneg
return
finish else if FTP wrk_max tran rec size_set = yes then c
FTP table_max tran rec size = FTP wrk_max tran rec size
finish
!Transmission Limit
if FTP line_status = awaiting sft start
if FTP wrk_tran limit_set = yes start
!The P station has set a value on tran limit
if FTP line_activity = sender and FTP wrk_tran limit_value < x'FFFF' start
!It is only meaningful if we are sending and infinity not assumed.
if finf_nkb+1 > FTP wrk_tran limit_value start
info = "File requested larger than your TRANSMISSION-LIMIT"
reject(X'06',eq!bits,finf_nkb+1,"",rejected info)
return
finish else FTP table_tran limit = FTP wrk_tran limit
finish
finish
if FTP wrk_tran limit_qual&monitor # 0 then add(X'06',eq!bits,x'FFFF',"")
finish else start
if FTP wrk_tran limit_set = yes start
if FTP line_activity = sender and FTP wrk_tran limit_value < x'ffff' start
if FTP table_file size_value > FTP wrk_tran limit_value start
info = "EMAS file in excess of your TRANSMISSION-LIMIT"
mail report("Transfer is too large and is rejected.".snl,0)
handle rneg
return
finish
FTP table_tran limit = FTP wrk_tran limit
finish
finish
finish
!Now look at the file size
!LET X25 mail in without FILE-SIZE at the moment
if FTP table_mail = yes and FTP wrk_file size_set = no then c
FTP wrk_file size_set = yes and FTP wrk_file size_value = 1
if FTP wrk_file size_set = yes and FTP wrk_file size_value = 0 then c
FTP wrk_file size_value = 1
if FTP line_status = awaiting sft start
!we are the Q station
if FTP line_activity = sender start
FTP table_file size_value = finf_nkb
add(x'60',eq!bits,finf_nkb,"")
finish else start
if FTP wrk_file size_set = no start
info = "No File size given, large transfer assumed ."
FTP wrk_file size_set = yes
FTP wrk_file size_value = 100
! reject(x'60',any!bits,0,"",rejected attribute)
! %return
finish
FTP table_file size = FTP wrk_file size
finish
if FTP table_file size_value > limit then start
reject(x'71',strings!eq,0,"File too large, try later",rejected deferred)
return
finish
finish else start
if FTP line_activity = receiver start
!we are P station receiver
!and we expect to be given a size.
if FTP wrk_file size_set = no start
FTP log("No file size from Q, 100k assumed.")
FTP wrk_file size_value = 100
FTP wrk_file size_set = yes
finish
FTP table_file size = FTP wrk_file size
if FTP table_file size_value > limit start
FTP log("We shall exceed our own transfer limit!!!")
!need to set document timer here!
transfer status = rejected deferred
info = "Try Later, Transfer too large for now"
handle rneg
return
finish
finish
finish
!BINARY_WORD_SIZE
if FTP table_data type_value = x'0002' start
!It is a binary transfer
if FTP line_status = awaiting sft start
if FTP wrk_binary word size_set = no start
!We therefore assume the default.
add(x'24',eq!bits,x'0008',"")
finish else start
unless try value(FTP wrk_binary word size, x'0008') = yes start
!We only support BINARY_WORD_SIZE of 8
info = "Only BINARY_WORD_SIZE 8 supported"
reject(x'24',eq!bits,x'0008',"",rejected attribute)
return
finish
if FTP wrk_binary word size_qual&monitor # 0 or FTP wrk_binary word c
size_qual&op mask # eq then add(x'24',eq!bits,x'0008',"")
finish
finish else start
!We have RPOS
if FTP wrk_binary word size_set = yes and FTP wrk_binary word size_value # c
FTP table_binary word size_value start
info = "BINARY_WORD_SIZE of 8 only supported."
FTP log("Q cannot support BINARY_WORD_SIZE of 8")
mail report("Cannot agree on Binary transfer, negotiation fails.".snl,0)
transfer status = rejected info
handle rneg
return
finish
finish
!BINARY_FORMAT
{Does not matter since word size of 8 is only one supported.}
finish
!Now clear up the remaining attributes
if FTP line_status = awaiting sft start
!Initial restart mark.
if FTP wrk_restart mark_qual&monitor # 0 then add(x'0B',eq!bits,0,"")
!only need to reply to monitor
!Timeout
if FTP wrk_timeout_qual&monitor # 0 then add(x'0D',eq!bits,x'0258',""); !ie 10 mins
!again only reply to monitor
!Facilities
!Q station only accepts default at the moment.
if FTP wrk_facilities_qual&monitor # 0 or FTP wrk_facilities_set = yes c
then add(x'0E',eq!bits,0,"")
FTP table_facilities_set = yes
finish
!OK.. We now clear up
if FTP line_status = awaiting sft start
flag = reply length
byteinteger(reply start) = FTP RPOS
byteinteger(reply start + 1) = param count
FTP log("RPOS sent.")
fill work entry(reply start)
!ie report on the RPOS
finish
return
routine fill work entry(integer start)
!This routine is entered to report on the contents of an incomming or
!an outgoing command (determined by the 'start' address) and in the
!case of an incomming command sets up the work table to be processed
!with respect to the negotiation of the transfer.
integerfnspec noffset
if TARGET # 2900 start
shortintegerfnspec hi(integer from)
finish else start
halfintegerfnspec hi(integer from)
finish
record (FTP bits) name bfield
record (FTP strings) name sfield
record (FTP bits) tran status
switch att0,att2,att4,att5,att7 (0:15)
integer offset, count, i ,pstart, attribute, qualifier
offset = 2; count = byteinteger(start + 1)
FTP wrk = 0
FTP log("Evaluating ".type descr(type)) if start = command start
if count = 0 start
!no parameters given , could be ok for RPOS but not SFT
if FTP line_status = awaiting sft and start # reply start then c
add(x'71',eq!strings,0,"No attributes on SFT!")
FTP log("No attributes with command")
return
finish
cycle i = 1,1,count
!look at each attribute
pstart = start + offset
attribute = byteinteger(pstart)
qualifier = byteinteger(pstart + 1)
if attribute < x'10' then -> att0(attribute)
if x'20' <= attribute <x'30' then -> att2(attribute - x'20')
if x'40' <= attribute < x'50' then -> att4(attribute - x'40')
if x'50' <= attribute < x'52' then -> att5(attribute - x'50')
if attribute = x'60' then -> att6
if x'70'<= attribute < x'72' then -> att7(attribute - x'70')
if attribute = x'80' then -> att8
FTP log("attribute not valid: ".h to s(attribute,2))
offset = noffset
continue
integerfn noffset
if qualifier&form mask = strings then result = byteinteger(pstart+2)+3+offset c
else if qualifier&form mask = bits then result = offset + 4 else result = offset + 2
end
routine set string
sfield_qual = qualifier
unless qualifier&op mask = any then start
sfield_set = yes
sfield_value <- string(pstart + 2)
finish
offset = noffset
if monitoring = on then FTP log("Attribute ".htos(attribute,2)." / ".qual descr((qualifier>>4)&x'03'). c
" / ".op descr(qualifier&op mask).mon descr((qualifier&monitor)>>7)." / ".sfield_value)
return
end
routine reject message(string (63) mess)
if type = FTP rneg and start # reply start then c
mail report(mess.snl,0)
end
routine set bits
bfield_qual = qualifier
unless qualifier&op mask = any then start
bfield_set = yes
bfield_value = hi(pstart)
finish
offset = noffset
if monitoring = on then FTP log("Attribute ".htos(attribute,2)." / ".qual descr((qualifier>>4)&x'03'). c
" / ".op descr(qualifier&op mask).mon descr((qualifier&monitor)>>7)." / ".htos(bfield_value,4))
return
end
if TARGET # 2900 start
shortintegerfn hi(integer from)
shortinteger i
byteinteger(addr(i)) = byteinteger(from+2)
byteinteger(addr(i)+1) = byteinteger(from+3)
result = i
end
finish else start
halfintegerfn hi(integer from)
halfinteger i
byteinteger(addr(i)) = byteinteger(from+2)
byteinteger(addr(i)+1) = byteinteger(from+3)
result = i
end
finish
att0 (0):
bfield == FTP wrk_protocol id
set bits
continue
att0(1):
bfield == FTP wrk_mode
set bits; continue
att0(2):
bfield == FTP wrk_text tran code
set bits; continue
att0(3):
bfield == FTP wrk_text format
set bits; continue
att0(4):
bfield == FTP wrk_binary format
set bits; continue
att0(5):
bfield == FTP wrk_max tran rec size
set bits; continue
att0(6):
bfield == FTP wrk_tran limit
set bits; continue
att0(9):
sfield == FTP wrk_private code name
set string; continue
att0(11):
bfield == FTP wrk_restart mark
set bits; continue
att0(13):
bfield == FTP wrk_timeout
set bits; continue
att0(14):
bfield == FTP wrk_facilities
set bits; continue
att0(15):
!transfer status.
bfield == tran status
set bits
continue
att0(*):
att2(*):
att4(*):
att5(*):
if monitoring = on then FTP log("Attribute not handled : ".htos(attribute,2))
add(attribute,any!attribute unknown,0,"") if type # FTP rneg and start # reply start
offset = noffset
continue
att2(0):
bfield == FTP wrk_data type
reject message("Invalid file type".snl)
set bits; continue
att2(4):
bfield == FTP wrk_binary word size
set bits; continue
att4(0):
sfield == FTP wrk_filename
reject message("External file name is rejected".snl)
set string
continue
att4(2):
sfield == FTP wrk_username
reject message("External user name is rejected.".snl)
set string; continue
att4(4):
sfield == FTP wrk_username password
reject message("External user pass is rejected.".snl)
set string; continue
att4(5):
sfield == FTP wrk_file password
reject message("External file pass is rejected.".snl)
set string
continue
att5(0):
sfield == FTP wrk_device type
reject message("External output device name is rejected.".snl)
set string
continue
att5(1):
sfield == FTP wrk_device type qualifier
reject message("Device type".snl)
set string
continue
att6:
bfield == FTP wrk_file size
set bits; continue
att7(0):
offset = noffset
continue
att7(1):
!info msgs handled in main module already.
offset = noffset
continue
att8:
if (qualifier>>4)&x'03' # 3 then add(x'80',eq!strings,0,"STRING value only") c
and offset = noffset else sfield == FTP table_special options and set string
continue
repeat
end
routine default table entry
FTP table_stopack message = ""
FTP table_mail to send = yes
FTP table_data control = translate; !that is mode x'40'
FTP table_data type_value = x'0001'; !ie text only
FTP table_text tran code_value = x'0001'; !ie IA5 text
FTP table_text format_value = x'0001'; !ie EOR implies NL
if TARGET = 2900 then FTP table_max tran rec size_value = X'FFFF' C
else FTP table_max tran rec size_value = -1
FTP table_timeout_value = x'0258'
FTP table_binary word size_value = x'0008'
end
if TARGET # 2900 start
routine add(byteinteger id,op,shortinteger bval,string (63) sval)
integer addrs
string (63) s
addrs = reply start + reply length
byteinteger(addrs) = id
byteinteger(addrs+1) = op
if op&form mask = bits start
byteinteger(addrs+2) = byteinteger(addr(bval))
byteinteger(addrs+3) = byteinteger(addr(bval)+1)
reply length = reply length + 4
finish else if op&form mask = strings start
string(addrs+2) = sval
reply length = length(sval)+3+reply length
if id = x'71' then FTP log("info msg out: ".sval)
finish else reply length = reply length + 2
param count = param count + 1
if info # "" start
s = info
info = ""
add(x'71',eq!strings,0,s)
finish
end
routine reject(byteinteger id,op,shortinteger bval,string (63) sval, shortinteger rej code)
!this routine adds the transfer status to the attribute reply field
!and generates a RNEG for this Q station to send.
type = FTP RNEG
add(id,op,bval,sval)
add(x'0F',x'22',rej code,"")
transfer status = rej code
byteinteger(reply start) = type
byteinteger(reply start+1)= param count
FTP log("RNEG sent.")
fill work entry(reply start)
end
routine handle rneg
!this routine will report on a received RNEG(as P station) or will
!generate a STOP if a received RPOS is unacceptable.
if type = FTP RNEG start
!we have received an RNEG from Q, report on it
unless rejected info <= transfer status <= rejected deferred then start
FTP log("bad transfer status :".itos(transfer status))
transfer status = rejected attribute
finish
unless transfer status = rejected deferred then mail report("Transfer rejected".snl,0)
fill work entry(command start)
finish else type = FTP RNEG
add(x'0F',x'22',transfer status,"")
byteinteger(reply start) = FTP STOP
byteinteger(reply start+1) = param count
FTP log("STOP sent.")
fill work entry(reply start)
end
integerfn try bits(record (FTP bits)name field, shortinteger value)
byteinteger op
op = field_qual & op mask
if op = eq and field_value = value then result = yes
if op = ne and field_value # value then result = yes
if op = le and field_value&value = value then result = yes
if op = ge and field_value&value = field_value then result = yes
if op = any then result = yes
result = no
end
integerfn try value(record (FTP bits)name field, shortinteger value)
byteinteger op
op = field_qual & op mask
if op = eq and field_value = value then result = yes
if op = ne and field_value # value then result = yes
if op = le and value <= field_value then result = yes
if op = ge and value >= field_value then result = yes
if op = any then result = yes
result = no
end
integerfn bits set(shortinteger value)
integer count, i
count = 0
cycle i = 0,1,7
if (value>>i)&1 = 1 then count = count + 1
repeat
result = count
end
finish else start
routine add(byteinteger id,op,halfinteger bval,string (63) sval)
integer addrs
string (63) s
addrs = reply start + reply length
byteinteger(addrs) = id
byteinteger(addrs+1) = op
if op&form mask = bits start
byteinteger(addrs+2) = byteinteger(addr(bval))
byteinteger(addrs+3) = byteinteger(addr(bval)+1)
reply length = reply length + 4
finish else if op&form mask = strings start
string(addrs+2) = sval
reply length = length(sval)+3+reply length
if id = x'71' then FTP log("info msg out: ".sval)
finish else reply length = reply length + 2
param count = param count + 1
if info # "" start
s = info
info = ""
add(x'71',eq!strings,0,s)
finish
end
routine reject(byteinteger id,op,halfinteger bval,string (63) sval, halfinteger rej code)
!this routine adds the transfer status to the attribute reply field
!and generates a RNEG for this Q station to send.
type = FTP RNEG
add(id,op,bval,sval)
add(x'0F',x'22',rej code,"")
transfer status = rej code
byteinteger(reply start) = type
byteinteger(reply start+1)= param count
FTP log("RNEG sent.")
fill work entry(reply start)
end
routine handle rneg
!this routine will report on a received RNEG(as P station) or will
!generate a STOP if a received RPOS is unacceptable.
if type = FTP RNEG start
!we have received an RNEG from Q, report on it
unless rejected info <= transfer status <= rejected deferred then start
FTP log("bad transfer status :".itos(transfer status))
transfer status = rejected attribute
finish
unless transfer status = rejected deferred then mail report("Transfer rejected".snl,0)
fill work entry(command start)
finish else type = FTP RNEG
add(x'0F',x'22',transfer status,"")
byteinteger(reply start) = FTP STOP
byteinteger(reply start+1) = param count
FTP log("STOP sent.")
fill work entry(reply start)
end
integerfn try bits(record (FTP bits)name field, halfinteger value)
byteinteger op
op = field_qual & op mask
if op = eq and field_value = value then result = yes
if op = ne and field_value # value then result = yes
if op = le and field_value&value = value then result = yes
if op = ge and field_value&value = field_value then result = yes
if op = any then result = yes
result = no
end
integerfn try value(record (FTP bits)name field, halfinteger value)
byteinteger op
op = field_qual & op mask
if op = eq and field_value = value then result = yes
if op = ne and field_value # value then result = yes
if op = le and value <= field_value then result = yes
if op = ge and value >= field_value then result = yes
if op = any then result = yes
result = no
end
integerfn bits set(halfinteger value)
integer count, i
count = 0
cycle i = 0,1,7
if (value>>i)&1 = 1 then count = count + 1
repeat
result = count
end
finish
integerfn validate filename(string (39) file)
unless 1<= length(file) <=11 then result = 1
cycle i = 1,1,length(file)
j = byteinteger(addr(file)+i)
result = 1 unless (i>1 and '0' <= j <= '9') or 'A' <= j&95 <= 'Z' c
or ( i>1 and j = '#' )
repeat
result = ok
end
end ; !of routine evaluate negotiation
end ; !of routine FTP CONTROL
routine requeue FTP document(integer document,delay,all,fixed)
!********************************************************
!* *
!* this routine will put an FTP document back on the *
!* queue with a time delay if required and on all docs *
!* for the same FTP station if required. *
!* *
!********************************************************
integer flag
if fsystems(document>>24)_addr= 0 start
select output(1)
printstring(dt."FTP (?) fsys off line, ".identtos(document)." requeue not done".snl)
select output(0)
return
finish
add to queue(document,delay,all,fixed,flag)
if flag # 0 start
printstring("FTP (?) ADD ".identtos(document)." TO QUEUE ". c
" fails ".itos(flag).snl)
delete document(document, flag)
if flag # 0 then printstring("FTP (?) DELETE DOCUMENT ".identtos(document). c
" fails ".itos(flag).snl)
finish
end ; !of routine requeue FTP document
routine FTP input message from fep(record (pe)name p)
!*************************************************************
!* *
!* THIS ROUTINE HANDLES THE CONTROL BUFFER MAINTAINED WITH *
!* THE FRONT ENDS FOR FTP CONTROL PROCEDURES. *
!*************************************************************
integer fe, cursor, newcursor, line, j, i, address,
buffer length, monitor,count,flag, pss entry, slen, addrs, mess control byte displ
integerarray address component (1:15)
string (31) base, pss, work string
string (127) caller, called, residue, address string, extra string
record (FTP tablef)name FTP table
record (FTP f)FTP
record (FTP stationf)name FTP station
record (linef)name FTP line
switch sw(1 : 4)
!*
routine monitor input(integer start, finish, addr)
integer i
cycle i=start, 1, finish
print string(i to s(byteinteger(addr+i))." ")
repeat
newline
end ; !OF ROUTINE MONITOR INPUT
!*
routine get(integer add, len)
integer i
cycle i = 0, 1, len-1; !GET LEN BYTES FROM CIRCULAR BUFFER
byteinteger(add+i) = byteinteger(address+cursor)
if TARGET # 2900 and i = 1 then mess control byte displ = cursor
cursor = cursor+1
cursor = cursor-buffer length c
if cursor >= buffer length
repeat
end ; !OF ROUTINE GET
integerfn all numeric(stringname s)
integer i
result = yes if length(s) = 0
cycle i = 1,1,length(s)
result = no unless x'30' <= byteinteger(addr(s)+i) <= x'39'
repeat
result = yes
end
!*
if mon level = 1 or 2 < mon level < 5 then monitor = yes c
else monitor = no
if 2 < mon level < 5 then start
select output(1)
printstring(dt."FTP INPUT(POFF): ")
pt rec(p)
select output(0)
finish
fe = (p_dest>>8)&255; !GET FEP
if feps(fe)_FTP available = no start
select output(1)
printstring(dt."MESSAGE FROM 'DOWN' FEP ".i to s(fe).snl)
select output(0)
return
finish
if p_p3 = x'01590000' start ; !FEP DOWN!
fep down(fe) if feps(fe)_FTP available = yes
return
finish
address = feps(fe)_FTP in buff con addr
cursor = feps(fe)_FTP input cursor
buffer length = feps(fe)_FTP in buff length
new cursor = p_p2
if monitor = yes start
select output(1)
printstring(dt."OWN FTP CURSOR: ".itos(cursor)." FE".itos(fe). c
" FTP CURSOR: ".itos(new cursor).snl)
select output(0)
finish
while cursor # new cursor cycle
if TARGET # 2900 start
get(addr(FTP), FTP std mess len + 1)
if FTP_control # 0 start
!WE have had a shot of this one, dump it and carry on.
select output(1)
printstring(dt."DISCARDING problem message from FE".itos(fe). c
"(will try for next(if any) message.".snl)
monitor input(0,FTP std mess len,addr(FTP))
select output(0)
if cursor # new cursor start
get(addr(FTP), FTP std mess len + 1)
if FTP_control # 0 start
!We really are screwed. Should never happen.
printstring("FE".itos(fe)." FTP control buffer".snl."Screwed ! Ring JH".snl)
exit
finish
finish else exit
finish
byteinteger(address+mess control byte displ) = 1 {set the control bit}
finish else start
get(addr(FTP), FTP std mess len + 1)
get(addr(FTP)+FTP std mess len + 1, FTP_length - FTP std mess len) c
if FTP_length > FTP std mess len
finish
if monitor = yes then start
select output(1)
printstring(dt."FTP INPUT MESSAGE FROM FE".itos(fe)." ")
if TARGET # 2900 then monitor input(0, FTP std mess len, addr(ftp)) c
else monitor input(0, FTP_length, addr(FTP))
select output(0)
finish
-> sw(FTP_type)
!*
sw(1):
sw(4):
!-------------------------------------------------------------
!AN ALLOCATE REQUEST OR REPLY FROM A FTRANS GENERATED
!ALLOCATION REQUEST.( 1 is NSI, 4 is TS (X25 or BSP) )
if FTP_pair ref = 0 then start
!THIS IS AN INITIAL CALL FROM THE FRONT END SO THE FTP
!CALL IS BEING GENERATED EXTERNALY.
if FTP stations(control entry)_service = closed or c
FEPs(FE)_incomming calls accepted = no start
!NO FTP SERVICE OFFERED IN THIS SESSION
select output(1)
printstring(dt."NO FTP SERVICE FTP AVAILABLE, call rejected".snl)
select output(0)
-> reply2
finish
if TARGET = 2900 then i = FTP_length-FTP std mess len else c
i = length(FTP_address)
if i > 0 start
!THERE MUST BE A STATION ADDRESS ATTACHED.
count = 0; line = 0
cycle i = 1,1,lines
if FTP lines(i)_status > unallocated and FTP lines(i)_status # c
deallocating then count = count + 1 else start
line = i if line = 0 and kick(i)&2 = 0; !ie not stopped.
finish
repeat
if line = 0 or count >= FTP stations(control entry)_max lines start
!no FTP lines FTP available for incoming call
select output(1)
printstring(dt."incomming FTP call rejected, no lines.".snl)
select output(0)
-> reply2
finish
FTP line == FTP lines(line)
FTP line_station ptr = 0
if FTP_type = 1 start ; !ie an NSI call.
if FTP_address -> base.("F").pss then pss entry = stoi(pss) else c
pss entry = 0
cycle i = 1,1,FTP stns
if (pss entry # 0 and FTP stations(i)_pss entry = pss entry) or c
(pss entry = 0 and string(address cache addr+ c
FTP stations(i)_address(1)) = FTP_address) start
!we recognise the station calling.
FTP line_station ptr = i
exit
finish
repeat
finish else start
!it is an TS allocation request.
called <- string(addr(FTP_address)+1)
caller <- string(addr(FTP_address)+2+length(called))
!We now have a long string adddres, handle this and rebuild a new address
!string where all components are separated by '.' and are of length 14.
!(at least 14, the CUDF will perhaps be corrupted but this does not matter)
extra string = caller
addrs= addr(extra string)
slen = length(extra string)
count = 1
select output(1)
printstring(dt."FTP TS call from ".caller.snl)
select output(0)
address component(count) = addrs
cycle i = 1,1,slen
j = byteinteger(addrs+i)
if x'2D' < j < x'30' or j = x'2B' or i = slen start
!We have a separator or the end of the string.
if i = slen then i = i + 1
byteinteger(address component(count)) = (addrs-1) + i - address component(count)
exit if i > slen
count = count + 1
address component(count) = addrs + i
finish
repeat
residue = ""
cycle i = 1,1,count
address string = string(address component(i))
if i # 1 then residue = residue."."
if all numeric(address string) = no then residue = residue.address string else start
if length(address string) >= 14 then residue = residue.address string else c
if length(address string) = 12 then residue = residue.address string."00" c
else if length(address string) < 12 start
address string = address string."00"
address string = "0".address string while length(address string) # 14
residue = residue.address string
finish
finish
repeat
select output(1)
printstring(dt."FTP TS call converted to ".residue.snl)
select output(0)
!Now we have a caller string like a.b.c.d... where all numeric elements of the
!address proper are of style xxxxxxxxxxxxss. Try a match.
address string = ""
!Now look at the address for a refined location address.
cycle i = 1,1,FTP stns
continue if expanded addresses(i)_address type = BASE type {not Directories}
cycle j = 1,1,4
if expanded addresses(i)_ptr(j) = no address then exit
address string = string(address cache addr + expanded addresses(i)_ptr(j))
work string = ""
if residue -> work string.(address string).residue start
FTP line_station ptr = i
if work string # "" start
select output(1)
printstring(dt."FTP TS unknown data before address ".work string.snl)
select output(0)
finish
exit
finish
repeat
exit if FTP line_station ptr # 0
repeat
!Here would could and sometime shall check the residuals from the calling
!station to see if it agrees with what we think it should be.
finish
if FTP line_station ptr = 0 then FTP line_station ptr = guest entry
if FTP stations(FTP line_station ptr)_service = closed start
select output(1)
printstring(dt."No ".string at(FTP stations(FTP line_station ptr) c
,FTP stations(FTP line_station ptr)_shortest name)." FTP service".snl)
select output(0)
FTP line_station ptr = 0
-> reply2
finish else if FTP line_station ptr = guest entry start
if FTP_type = 1 then caller = FTP_address
select output(1)
printstring(dt."FTP call from ".caller." unrecognised, GUESTed.".snl)
select output(0)
finish
count = 0
cycle i = 1,1,lines
if FTP lines(i)_status > unallocated and FTP lines(i)_station ptr c
= FTP line_station ptr then count = count + 1
repeat
if count >= FTP stations(FTP line_station ptr)_max lines + 1 start
!'+1' since we will allow 1 q station over station capacity to
!prevent possible P station line hogging with respect to a particular station
if FTP line_station ptr = guest entry then base = "GUEST" else c
base = string at(FTP stations(FTP line_station ptr) c
,FTP stations(FTP line_station ptr)_name)
FTP line_station ptr = 0
select output(1)
printstring(dt."FTP call from ".base." rejected, station capacity.".snl)
select output(0)
-> reply2
finish
FTP table == FTP tables(line)
FTP table = 0
if FTP line_station ptr = guest entry then FTP table_calling address = caller
if FTP_type = 4 start
select output(1)
printstring(dt."FTP TS called field : ".called.snl)
select output(0)
unless called -> (spoolFTP).called or called -> ("X").called start
select output(1)
printstring(dt."FTP TS 'called' field wrong ".called.snl)
select output(0)
FTP line_station ptr = 0
-> reply2
finish
if called # "" start
if called -> address string.(spoolmail) and length(address string) = 1 start
select output(1)
printstring(dt."FTP TS MAIL call accepted".snl)
select output(0)
FTP table_mail = yes
finish else start
select output(1)
printstring(dt."FTP TS (MAIL ?) call rejected. ".called." FILE only assumed.".snl)
select output(0)
! FTP line_station ptr = 0
! -> reply2
finish
finish
finish
FTP line_status = allocated
!WE HAVE CHOSEN THIS LINE FOR FTP SERVICE TO AN EXTERNAL CALL.
FTP line_station type = q station
FTP line_in stream ident = 14<<24!fe<<16!FTP_in ident
FTP line_out stream ident = 14<<24!fe<<16!FTP_out ident
FTP line_in stream status = allocated
FTP line_out stream status = allocated
FTP line_fep = fe
FTP line_bytes transferred = 0
FTP_pair ref = line
FTP_length = FTP std mess len if TARGET = 2900
FTP_type = 2
!NO NEED TO REFLECT THE ADDRESS.
FTP output message to fep(fe, FTP)
p = 0
p_dest = line<<7 ! FTP connect
FTP control(p,refresh line)
refresh pic(ftp status summary display,FTP_pair ref,"")
-> check
finish else start
select output(1)
printstring(dt."NO STATION ADDR ON INCOMING FTP CALL".snl)
select output(0)
-> reply2
finish
finish else start
!WE HAVE AN FEP REPLY TO A FTRANS INITIATED FTP CALL.
!THIS REPLY CONTAINS ALLOCATION DETAILS FOR THE FTP STREAM PAIR.
if FTP_in ident = 0 or FTP_out ident = 0 start
!A FAILURE FROM FEP
select output(1)
printstring(dt."FEP REJECTS FTP OUTWARD CALL: ". itos( c
FTP_in ident)." ".itos(FTP_out ident)." LINE: ".itos( c
FTP_pair ref).snl)
select output(0)
FTP line == FTP lines(FTP_pair ref)
remove from queue(FTP line_document,flag)
requeue FTP document(FTP line_document,allocate fail delay,yes,no)
FTP line_status = unallocated
FTP line_document = 0
FTP line_station ptr = 0
-> check
finish
FTP line == FTP lines(FTP_pair ref)
FTP tables(FTP_pair ref) = 0
if FTP line_status # selected start
!FTRANS REALLY IS SCREWED WITH ITS FTP IF IT GETS HERE!!
printstring("FTP SCREWED UP!!".snl)
FTP stations(control entry)_service = closed
->check
finish
FTP line_status = allocated
FTP line_in stream ident = 14<<24!fe<<16!FTP_in ident
FTP line_out stream ident = 14<<24!fe<<16!FTP_out ident
FTP line_in stream status = allocated
FTP line_out stream status = allocated
FTP line_fep = fe
p = 0
p_dest = FTP_pair ref<<7!FTP connect
FTP control(p,refresh line)
refresh pic(ftp status summary display,FTP_pair ref,"")
-> check
finish
sw(3):
!------------------------------------------------------
!REPLY TO DEALLOCATE REQUEST ON STREAM PAIR.
if FTP_pair ref = 0 start
!SHOULD NOT HAPPEN.
select output(1)
printstring(dt."ZERO PAIR REF DEALLOCATE REPLY!!".snl)
select output(0)
->check
finish
FTP line == FTP lines(FTP_pair ref)
if FTP line_status = deallocating start
select output(1)
printstring(dt."FTP (".itos(FTP_pair ref).") TS diagnostics dec: ". c
itos((FTP_in ident)>>8&X'FF')." ".itos(FTP_in ident&X'FF').snl)
select output(0)
if FTP line_in stream status = aborting or FTP line_out stream c
status = aborting start
select output(1)
printstring(dt."Deallocate reply before connect abort reply, suspending.".snl)
select output(0)
FTP line_in stream status = suspending
FTP line_out stream status = suspending
FTP line_user = ""
FTP line_station ptr = 0
-> check
finish
FTP line_status = unallocated
refresh pic(ftp status summary display,FTP_pair ref,"")
FTP line_in stream status = unallocated
FTP line_out stream status = unallocated
FTP line_user = ""
FTP line_station ptr = 0
finish else start
select output(1)
printstring(dt."DEALLOCATE REPLY NOT EXPECTED : ".FTP line_name.snl)
select output(0)
finish
kick FTP line(FTP_pair ref)
-> check
!*
reply2:
FTP_type = 2
reply:
FTP output message to fep(fe, FTP)
check:
repeat
feps(fe)_FTP input cursor = new cursor
end
!*
routine FTP output message to fep(integer fe, record (FTP f)name FTP)
!*************************************************************
!* SEND A MESSAGE OUT ON THE FTRANS - FEP FTP CONTROL BUFFER *
!*************************************************************
record (pe)p
integer cursor, buff len, flag, i, add, mess length
!*
routine put(integer address, len)
integer i
cycle i = 0, 1, len
byteinteger(add+cursor) = byteinteger(address+i)
cursor = cursor+1
cursor = cursor-buff len if cursor >= buff len
repeat
end ; !OF ROUTINE PUT
!*
!*
if feps(fe)_FTP available = yes start
cursor = feps(fe)_FTP output cursor
add = feps(fe)_FTP out buff con addr
buff len = feps(fe)_FTP out buff length
if TARGET = 2900 then mess length = FTP_length else mess length = c
FTP std mess len
put(addr(FTP), mess length)
if mon level = 1 or mon level= 3 start
select output(1)
print string(dt."FTP OUTPUT MESSAGE TO FE".i to s(fe)." ")
cycle i = 0, 1, mess length
print string(i to s(byteinteger(addr(FTP)+i)). c
" ")
repeat
newline
select output(0)
finish
p = 0
p_dest = stream control message
p_srce = fe<<8!FTP output reply mess
p_p1 = feps(fe)_FTP output stream
p_p2 = cursor
if feps(fe)_FTP suspend on output = yes then flag = dpon3("",p,0, 0,7) c
and feps(fe)_FTP suspend on output = no else flag = dpon3("", p, 0, 0, 6)
feps(fe)_FTP output cursor = cursor
finish else start
select output(1)
printstring(dt."FTP FEP ".itos(fe)." down, output message discarded.".snl)
select output(0)
finish
end ; !OF ROUTINE OUTPUT MESSAGE TO FEP
!*
!END OF FTP CONTROL ROUTINES
!**********************************************************************
!*********************************************************************
!*
!*
!*
routine output message reply from fep(record (pe)name p)
integer fe
if p_srce = stream control message start
!It is a reply to a PON&CONTINUE for output on a cyclic buffer.
!We want to see if we have wrapped round and if so we will
!only PON&SUSPEND until the FE has caught up.
fe = (P_dest&x'FF00')>>8
if p_dest&x'FF' = FTP output reply mess and feps(fe)_FTP output cursor < c
p_p5 then feps(fe)_FTP suspend on output = yes
if feps(fe)_FTP suspend on output = yes c
then select output(1) and printstring(dt."Output Buffer Suspend set".snl) c
and select output(0)
finish else start
select output(1)
print string(dt."FTP OUTPUT CONTROL MESSAGE ")
pt rec(p)
select output(0)
finish
end ; !OF ROUTINE OUTPUT MESSAGE REPLY FROM FEP
!*
!*
routine open fep(record (pe)name p)
integer dact, which fe, flag
switch FTP act(FTP input control connect : FTP output control enable reply)
dact = p_dest&127
which fe = (p_dest>>8)&255
unless dact < FTP input control connect then -> FTP act(dact)
!*
!DUMMY act(fep input control connect): !connect input control stream
!*
FTP act(FTP input control connect): !connect FTP input control stream
p = 0
p_dest = connect stream
p_srce = which fe<<8!FTP input control connect reply
p_p1 = feps(which fe)_FTP input stream
p_p2 = my service number!which fe<<8!FTP input mess
!INPUT HIGH LEVEL CONTROL MESSAGES TO THIS ACTIVITY
p_p3 = 14<<24!which fe<<16!FTP in control stream
flag = dpon3("", p, 0, 0, 6)
return
!*
!*
FTP act(FTP input control connect reply): !FTP input stream connect reply
if p_p2 = 0 start
feps(which fe)_FTP input stream = p_p1; !STORE COMMS STREAM ALLOCATED
if (p_p6>>24) = 3 and STRING(ADDR(P_p6)) = "X25" then c
printstring("FE".itos(which fe)." is TS X25".snl) c
and feps(which fe)_comms type = TS type else if c
((p_p6>>24) = 3 and string(addr(p_p6)) = "BSP") then c
printstring("FE".itos(which fe)." is TS BSP".snl) and c
feps(which fe)_comms type = TS type else printstring( c
"FE".itos(which fe)." is NSI".snl) c
and feps(which fe)_comms type = NSI type
p = 0
p_dest = connect stream
p_srce = which fe<<8!FTP output control connect reply
p_p1 = feps(which fe)_FTP output stream
p_p2 = my service number!which fe<<8!FTP output reply mess
!OUTPUT HIGH LEVEL CONTROL MESSAGES TO THIS ACTIVITY
p_p3 = 14<<24!which fe<<16!FTP out control stream
flag = dpon3("", p, 0, 0, 6)
finish
return
!*
!*
FTP act(FTP output control connect reply): !FTP output stream connect reply
if p_p2 = 0 start
feps(which fe)_FTP output stream = p_p1
p_dest = enable stream
p_srce = which fe<<8!FTP input control enable reply
p_p1 = feps(which fe)_FTPinput stream
p_p2 = feps(which fe)_FTP in buff disc addr
p_p3 = feps(which fe)_FTP in buff disc blk lim
p_p4 = 2<<4!1; !BINARY CIRCULAR
p_p5 = feps(which fe)_FTP in buff offset
p_p6 = feps(which fe)_FTP in buff length
flag = dpon3("", p, 0, 0, 6)
finish else print string("CONNECT FTP OUT line FE".i to s( c
which fe)." FAILS ".i to s(p_p2).snl)
return
!*
!*
FTP act(FTP input control enable reply): !enable FTP input stream reply
if p_p2 = 0 start
p_dest = enable stream
p_srce = which fe<<8!FTP output control enable reply
p_p1 = feps(which fe)_FTP output stream
p_p2 = feps(which fe)_FTP out buff disc addr
p_p3 = feps(which fe)_FTP out buff disc blk lim
p_p4 = 2<<4!1; !BINARY CIRCULAR
p_p5 = feps(which fe)_FTP out buff offset
p_p6 = feps(which fe)_FTP out buff length
flag = dpon3("", p, 0, 0, 6)
finish else print string("ENABLE FTP IN line FE".i to s( c
which fe)." FAILS ".i to s(p_p2).snl)
return
!*
!*
FTP act(FTP output control enable reply):
if p_p2 = 0 start
feps(which fe)_FTP available = yes
printstring("FE".itos(which fe)." FTP CONNECTED".snl)
feps(which fe)_incomming calls accepted = yes
feps(which fe)_outgoing calls permitted = yes
finish else c
printstring("ENABLE FTP OUT line FE".itos(which fe). c
" FAILS ".itos(p_p2).snl)
return
end ; !OF ROUTINE OPEN FEP
!*
!*
routine initialise
!**********************************************************************
!* *
!* SETS UP GLOBAL VARIABLES, TABLES AND LISTS *
!* AND CONNECTS FILES USED BY FTRANS ON THE ON-LINE FILE SYSTEMS. *
!* *
!**********************************************************************
record (pe)p
record (daf) FTP in disc addr, FTP out disc addr
integer i, j, k, FTP in buff addr, FTP out buff addr
integerarray a(0 : max fsys); !USED TO STORE FSYS NOS SUPLIED BY DIRECTOR
!*
system = "EMAS AMDAHL"
if TARGET = 2900 then MAIL MC = "@29".ocptype(com_ocptype) and c
mail dis = 33 else mail mc = "@AMDAHL" and mail dis = 35
if TARGET = 2900 then e page size = com_e page size<<10 c
else e page size = 4096{NOt really 'e' page for non 2900}; !EXTENDED PAGE SIZE IN BYTES
kicked = 0; !INITIALLY NO STREAMS KICKED
mon level = no; !INITIALLY NO MONITORING
stopping = no; !INITIALLY NOT STOPPING
IPSS = ""; PSS = ""
send message = ""
fire clock tick
status header change = no; !Just says whether the next update of the status report should do the header
if lines > 0 start
cycle i = 1,1,lines
FTP lines(i)_status = unallocated
kick(i) = 2; !INITIALLY ALL STREAMS STOPPED
repeat
finish
cycle i = 0, 1, max oper
oper(i)_prompt on = no; !INITIALLY NO OPER PROMPTS
oper(i)_update rate = default oper update rate
oper(i)_display type = all queues
oper(i)_which display = 0
oper(i)_which page = 0
oper(i)_command = ""
oper(i)_specific user=""
repeat
!*
closing = no
RETURN if lines = 0
cycle i = 0, 1, max fsys
f systems(i)_addr = 0; !MARK ALL FILES AS NOT CONNECTED
f systems(i)_password addr = 0
f systems(i)_closing = no
repeat
!*
cycle i = 1, 1, list size-1; !SET UP FREE LIST OF POINTERS TO DOCUMENT DESCRIPTORS
list cells(i)_link = i+1
repeat
list cells(list size)_link = 0; !END OF LIST
free list = 1; !HEAD OF LIST
!*
!*
if TARGET = 2900 then get av fsys(j, a) c
else i = d av fsys(j, a); !GET LIST OF AVAILABLE F SYSTEMS
!*
i = 0
cycle i = j-1,-1,0
open file system(a(i)); !OPEN CURRENTLY ON LINE FILE SYSTEMS
! k = change context
repeat
!*************************************************
! FEP INITIALISATION FOR FTP FOLLOWS.
i = -1
connect or create(my name, "FTPINBUFF", my fsys, (max fep+1)* c
fep io buff size, r!w, zerod, FTP in buff addr)
connect or create(my name, "FTPOUTBUFF", my fsys, (max fep+1)* c
fepio buff size, r!w, zerod, FTP out buff addr)
if FTP in buff addr # 0 and FTP out buff addr # 0 start
i = get block addresses(my name, "FTPINBUFF", my fsys,
addr(FTP in disc addr))
if i = 0 start
i = get block addresses(my name, "FTPOUTBUFF", my fsys,
addr(FTP out disc addr))
if i = 0 start
cycle i = 0, 1, max fep
feps(i)_FTP available = no
feps(i)_closing = no
feps(i)_comms type = unknown type
j = (fep io buff size*i)//block size+1
feps(i)_FTP input stream = 0;!STREAM TYPE
feps(i)_FTP output stream = 1; !DITTO
j = (fep io buff size*i)//block size+1
feps(i)_FTP in buff disc addr = FTP in disc addr_da(j)
feps(i)_FTP out buff disc addr = FTP out disc addr_da( c
j)
if j = FTP in disc addr_nblks c
then feps(i)_FTP in buff disc blk lim = c
FTP in disc addr_last blk-1 c
else feps(i)_FTP in buff disc blk lim = c
FTP in disc addr_blksi-1
if j = FTP out disc addr_nblks c
then feps(i)_FTP out buff disc blk lim = c
FTP out disc addr_last blk-1 c
else feps(i)_FTP out buff disc blk lim = c
FTP out disc addr_blksi-1
feps(i)_FTPin buff con addr = FTP in buff addr+ c
fep io buff size*i
feps(i)_FTP out buff con addr = FTP out buff addr+ c
fep io buff size*i
feps(i)_FTP in buff offset = fep io buff size*i- c
block size*(j-1)
feps(i)_FTP out buff offset = fep io buff size*i- c
block size*(j-1)
feps(i)_FTP in buff length = fep io buff size
feps(i)_FTP out buff length = fep io buff size
feps(i)_FTP input cursor = 0
feps(i)_FTP output cursor = 0
feps(i)_FTP suspend on output = no
p = 0
p_dest = i<<8!fep input control connect
open fep(p)
repeat
i = 0
finish else printstring("GETDA FTPOUTBUFF FAILS". c
errs(i).snl)
finish else printstring("GETDA FTPINBUFF FAILS". c
errs(i).snl)
finish
if i # 0 start
FTP in buff addr = 0
FTP out buff addr = 0
finish
initialise pictures
!*
end ; !OF ROUTINE INITIALISE
!*
!*
end
endoffile