(FILECREATED "30-Sep-86 14:18:21" {ERIS}<LISPCORE>SOURCES>DPUPFTP.;32 87100
changes to: (FNS \FTPINIT)
previous date: "23-Sep-86 13:38:14" {ERIS}<LISPCORE>SOURCES>DPUPFTP.;31)
(* Copyright (c) 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT DPUPFTPCOMS)
(RPAQQ DPUPFTPCOMS
((* ;;; "Implementation of the PUP FTP device")
(COMS (FNS \FTPINIT \FTPEVENTFN \FTP.OPENFILE \FTP.OPENFILE.FROM.PLIST \FTP.GETFILENAME
\FTP.RECOGNIZEFILE \FTP.DIRECTORYNAMEP \FTP.CLOSEFILE \FTP.UNREGISTER
\FTP.RENAMEFILE \FTP.DELETEFILE \FTP.GENERATEFILES \FTP.NEXTFILE \FTP.FILEINFOFN
\FTP.GETFILEINFO \FTP.GETFILEINFO.FROM.PROPS)
(INITVARS (\FTPAVAILABLE)
(\FTP.IDLE.TIMEOUT 120000)))
(COMS (* ;; "internal")
(FNS \FTP.OPEN.CONNECTION FTP.BREAKCONNECTION \FTP.SENDVERSION \FTP.WHENCLOSED
\GETFTPCONNECTION \RELEASE.FTPCONNECTION \FTP.ERRORHANDLER \FTP.FIX.BROKEN.INPUT
\FTP.CLEANUP \FTP.ASSURE.CLEANUP)
(ADDVARS (\FTPCONNECTIONS))
(FNS \FTP.HANDLE.NO \FTP.DIRECTORYNAMEONLY \FTP.EOL.FROM.PLIST \FTP.MAKEPLIST
\FTP.PRINTPLIST \FTP.PACKFILENAME \FTP.PACK.DIRECTORYNAMEP \FTP.UNPACKFILENAME
\FTP.ADD.USERINFO \FTP.FLUSH.TO.EOC \FTP.FLUSH.TO.MARK \FTPERROR))
(COMS (* ;; "for debugging")
(FNS FTPDEBUG FTPPRINTMARK FTPPRINTCODE FTPGETMARK FTPPUTMARK FTPPUTCODE FTPGETCODE)
(INITVARS (FTPDEBUGLOG)
(FTPDEBUGFLG)))
(DECLARE: EVAL@COMPILE DONTCOPY (VARS FTPMARKTYPES)
(CONSTANTS \FTP.VERSION)
(CONSTANTS * FTPNOCODES)
(MACROS MARK# .EOC. .FTPDEBUGLOG.)
(PROP INFO MARK#)
(RECORDS FTPCONNECTION FTPSTREAM FTPFILEGENSTATE)
(GLOBALVARS FTPDEBUGFLG \FTPCONNECTIONS \FTPAVAILABLE \FTP.IDLE.TIMEOUT \BSPFDEV
\FTPFDEV))
(DECLARE: DONTEVAL@LOAD DOCOPY (P (\FTPINIT)))))
(* ;;; "Implementation of the PUP FTP device")
(DEFINEQ
(\FTPINIT
(LAMBDA NIL (* hdj "30-Sep-86 14:13")
(COND
((type? FDEV \BSPFDEV)
(SETQ \FTPFDEV (NCREATE (QUOTE FDEV)
\BSPFDEV)) (* ; "Specialize the BSP device")
(with FDEV \FTPFDEV DEVICENAME ← (QUOTE DPUPFTP)
OPENFILE ← (FUNCTION \FTP.OPENFILE)
CLOSEFILE ← (FUNCTION \FTP.CLOSEFILE)
DIRECTORYNAMEP ← (FUNCTION \FTP.DIRECTORYNAMEP)
GETFILENAME ← (FUNCTION \FTP.GETFILENAME)
GETFILEINFO ← (FUNCTION \FTP.GETFILEINFO)
RENAMEFILE ← (FUNCTION \FTP.RENAMEFILE)
DELETEFILE ← (FUNCTION \FTP.DELETEFILE)
GENERATEFILES ← (FUNCTION \FTP.GENERATEFILES)
EVENTFN ← (FUNCTION \FTPEVENTFN)
OPENP ← (FUNCTION \GENERIC.OPENP)
REGISTERFILE ← (FUNCTION \ADD-OPEN-STREAM)
UNREGISTERFILE ← (FUNCTION \GENERIC-UNREGISTER-STREAM))
(SETQ \FTPAVAILABLE T)))))
(\FTPEVENTFN
[LAMBDA (DEV EVENT) (* bvm: "28-Apr-85 14:32")
(SELECTQ EVENT
(BEFORELOGOUT (FTP.BREAKCONNECTION T))
((BEFORESYSOUT BEFOREMAKESYS BEFORESAVEVM)
(FTP.BREAKCONNECTION T T))
NIL)
(\BSPEVENTFN DEV EVENT])
(\FTP.OPENFILE
[LAMBDA (FILENAME ACCESS RECOG OTHERINFO) (* bvm: "15-Jan-85 21:15")
(RESETLST
(PROG (HOST DESIREDPLIST TYPE BYTESIZE EOLCONVENTION)
(COND
((SELECTQ ACCESS
(INPUT (EQ RECOG (QUOTE NEW)))
(OUTPUT (EQ RECOG (QUOTE OLD)))
T)
(LISPERROR "FILE WON'T OPEN" FILENAME)))
(OR (SETQ HOST (\FTP.UNPACKFILENAME FILENAME))
(RETURN))
(SETQ DESIREDPLIST (CDR HOST))
(SETQ HOST (CAR HOST))
(SELECTQ ACCESS
(OUTPUT [for PAIR in OTHERINFO when (LISTP PAIR)
do (COND
((SELECTQ (CAR PAIR)
((TYPE FILETYPE)
[SELECTQ (SETQ TYPE (CADR PAIR))
(TEXT T)
(NIL)
(PROGN (* All unrecognized types are BINARY)
(SETQ TYPE (QUOTE BINARY]
NIL)
(BYTESIZE (SETQ BYTESIZE (OR (FIXP (CADR PAIR))
(LISPERROR "ILLEGAL ARG" PAIR)))
NIL)
((EOL EOLCONVENTION)
(SETQ EOLCONVENTION (CADR PAIR))
NIL)
(CREATIONDATE (push DESIREDPLIST (LIST (QUOTE CREATION-DATE)
(CADR PAIR)))
NIL)
(LENGTH [push DESIREDPLIST (LIST (QUOTE SIZE)
(OR (FIXP (CADR PAIR))
(LISPERROR "ILLEGAL ARG"
PAIR]
NIL)
(SEQUENTIAL NIL)
T)
(push DESIREDPLIST PAIR]
[push DESIREDPLIST (LIST (QUOTE TYPE)
(OR TYPE (SETQ TYPE DEFAULTFILETYPE]
(SELECTQ TYPE
(TEXT [push DESIREDPLIST (LIST (QUOTE END-OF-LINE-CONVENTION)
(OR EOLCONVENTION (QUOTE CR])
(BINARY (push DESIREDPLIST (LIST (QUOTE BYTE-SIZE)
(OR BYTESIZE 8))))
NIL))
NIL)
(RETURN (\FTP.OPENFILE.FROM.PLIST HOST DESIREDPLIST ACCESS])
(\FTP.OPENFILE.FROM.PLIST
[LAMBDA (HOST DESIREDPLIST ACCESS) (* bvm: "28-Apr-85 14:14")
(PROG (CONNECTION INS OUTS REMOTEPLIST FULLNAME)
NEWCONNECTION
(OR (SETQ CONNECTION (\GETFTPCONNECTION HOST T))
(RETURN))
(SETQ INS (fetch FTPIN of CONNECTION))
(SETQ OUTS (fetch FTPOUT of CONNECTION))
RETRY
(FTPPUTMARK OUTS (SELECTQ ACCESS
(INPUT (MARK# RETRIEVE))
(OUTPUT (MARK# NEW-STORE))
NIL))
(\FTP.PRINTPLIST OUTS DESIREDPLIST)
(.EOC. OUTS)
(SELECTC (FTPGETMARK INS)
((MARK# NO)
(COND
[(\FTP.HANDLE.NO CONNECTION DESIREDPLIST)
(COND
((BSPOPENP INS (QUOTE INPUT))
(GO RETRY))
(T (GO NEWCONNECTION]
(T (\RELEASE.FTPCONNECTION CONNECTION)
(RETURN))))
((MARK# HERE-IS-PLIST)
(SETQ REMOTEPLIST (READPLIST INS))
[SETQ FULLNAME (\FTP.PACKFILENAME HOST REMOTEPLIST NIL (CADR (ASSOC (QUOTE DEVICE)
DESIREDPLIST]
(OR (EQ (FTPGETMARK INS)
(MARK# EOC))
(RETURN (\FTPERROR CONNECTION))))
((MARK# BROKEN)
(GO NEWCONNECTION))
(RETURN (\FTPERROR CONNECTION)))
(SELECTQ ACCESS
(INPUT (FTPPUTMARK OUTS (MARK# YES))
(FTPPUTCODE OUTS 0)
(.EOC. OUTS)
(SELECTC (FTPGETMARK INS)
((MARK# NO)
[COND
((\FTP.HANDLE.NO CONNECTION DESIREDPLIST NIL NIL T)
(CLOSEBSPSTREAM INS 2000) (* Can't recover from in the middle
like this, so just flush and start
over)
(GO NEWCONNECTION))
(T (\RELEASE.FTPCONNECTION CONNECTION)
(RETURN (LISPERROR "FILE WON'T OPEN" FULLNAME])
((MARK# HERE-IS-FILE)
(replace FULLFILENAME of INS with FULLNAME)
(replace FTPFILEPROPS of INS with REMOTEPLIST)
(replace ACCESS of INS with (QUOTE INPUT))
(replace EOLCONVENTION of INS with (\FTP.EOL.FROM.PLIST REMOTEPLIST))
(\BSP.DECLARE.FILEPTR INS 0) (* For GETFILEPTR)
(replace DEVICE of INS with \FTPFDEV)
(RETURN INS))
((MARK# BROKEN)
(GO NEWCONNECTION))
(RETURN (\FTPERROR CONNECTION))))
(OUTPUT (COND
((BSPOPENP OUTS (QUOTE OUTPUT))
(FTPPUTMARK OUTS (MARK# HERE-IS-FILE))
(replace FULLFILENAME of OUTS with FULLNAME)
(replace FTPFILEPROPS of OUTS with REMOTEPLIST)
(\BSP.DECLARE.FILEPTR OUTS 0)
(replace EOLCONVENTION of OUTS with (\FTP.EOL.FROM.PLIST DESIREDPLIST))
(replace DEVICE of OUTS with \FTPFDEV)
(RETURN OUTS))
(T (GO NEWCONNECTION))))
NIL])
(\FTP.GETFILENAME
[LAMBDA (NAME RECOG DEV) (* lmm " 6-Jan-85 17:36")
(SELECTQ RECOG
(OLD (\FTP.RECOGNIZEFILE NAME DEV))
(OLD/NEW (OR (\FTP.RECOGNIZEFILE NAME DEV)
(\GENERIC.OUTFILEP NAME DEV)))
(NEW (\GENERIC.OUTFILEP NAME DEV))
(SHOULDNT])
(\FTP.RECOGNIZEFILE
[LAMBDA (NAME DEV OPTION) (* lmm "25-Mar-85 14:34")
(RESETLST (PROG (CONNECTION HOST INS OUTS REMOTEPLIST DESIREDPLIST RESULT CODE)
(OR (SETQ HOST (\FTP.UNPACKFILENAME NAME))
(RETURN))
(SETQ DESIREDPLIST (CDR HOST))
(SETQ HOST (CAR HOST))
(SELECTQ OPTION
(DIRECTORYNAMEP
(RPLACA (CDR (ASSOC (QUOTE NAME-BODY)
DESIREDPLIST))
"QXZYQJ")
(push DESIREDPLIST (LIST (QUOTE DESIRED-PROPERTY)
(QUOTE DIRECTORY))
(LIST (QUOTE DESIRED-PROPERTY)
(QUOTE DEVICE))))
((NIL NAME)
(for PROP in (QUOTE (DIRECTORY NAME-BODY VERSION))
do (push DESIREDPLIST (LIST (QUOTE DESIRED-PROPERTY)
PROP))))
NIL)
NEWCONNECTION
(OR (SETQ CONNECTION (\GETFTPCONNECTION HOST T))
(RETURN))
(SETQ INS (fetch FTPIN of CONNECTION))
(SETQ OUTS (fetch FTPOUT of CONNECTION))
RETRY
(FTPPUTMARK OUTS (MARK# ENUMERATE))
(\FTP.PRINTPLIST OUTS DESIREDPLIST)
(.EOC. OUTS)
(SELECTC (FTPGETMARK INS)
((MARK# NO)
[SELECTC (SETQ CODE (FTPGETCODE INS T))
(\NO.ILLEGAL.DIRECTORY
(\FTP.FLUSH.TO.EOC INS (.FTPDEBUGLOG.)))
(\NO.FILE.NOT.FOUND
(\FTP.FLUSH.TO.EOC INS (.FTPDEBUGLOG.))
[COND
((EQ OPTION (QUOTE DIRECTORYNAMEP))
(* Directory exists)
(SETQ RESULT (\FTP.PACK.DIRECTORYNAMEP CONNECTION
DESIREDPLIST])
(COND
((\FTP.HANDLE.NO CONNECTION DESIREDPLIST NIL CODE NIL T)
(COND
((BSPOPENP INS (QUOTE INPUT))
(GO RETRY))
(T (GO NEWCONNECTION])
((MARK# HERE-IS-PLIST)
(SETQ REMOTEPLIST (READPLIST INS))
[SETQ RESULT (SELECTQ OPTION
(PROPS REMOTEPLIST)
(DIRECTORYNAMEP
(\FTP.PACK.DIRECTORYNAMEP CONNECTION REMOTEPLIST))
(\FTP.PACKFILENAME HOST REMOTEPLIST NIL
(CADR (ASSOC (QUOTE DEVICE)
DESIREDPLIST]
[COND
((OR (NOT (\EOFP INS))
(NEQ (FTPGETMARK INS)
(MARK# EOC)))
(RETURN (\FTPERROR CONNECTION])
((MARK# BROKEN)
(GO NEWCONNECTION))
(RETURN (\FTPERROR CONNECTION)))
(\RELEASE.FTPCONNECTION CONNECTION)
(RETURN RESULT])
(\FTP.DIRECTORYNAMEP
[LAMBDA (HOST/DIR DEV) (* bvm: "27-SEP-83 17:59")
(\FTP.RECOGNIZEFILE HOST/DIR DEV (QUOTE DIRECTORYNAMEP])
(\FTP.CLOSEFILE
(LAMBDA (STREAM) (* hdj "23-Sep-86 13:31")
(PROG ((ACCESS (fetch ACCESS of STREAM))
(CONN (find C in \FTPCONNECTIONS suchthat (OR (EQ (fetch FTPIN of C)
STREAM)
(EQ (fetch FTPOUT of C)
STREAM))))
(FILENAME (fetch FULLFILENAME of STREAM))
INS SUCCESS)
(replace FTPFILEPROPS of STREAM with NIL)
(SELECTQ ACCESS
(INPUT (COND
((NOT (BSPOPENP STREAM ACCESS)) (* ; "connection went away")
NIL)
((OR (\EOFP STREAM)
(PROGN (\BSP.FLUSHINPUT STREAM)
(AND (BSPOPENP STREAM ACCESS)
(\EOFP STREAM))))
(* ;; "Hack. We are at the end of the file, or the remainder of the file has been sent, so we can terminate the RETRIEVE cleanly")
(SETQ SUCCESS (SELECTC (FTPGETMARK STREAM)
((MARK# YES) (* ; "File sent ok")
(FTPGETCODE STREAM)
(\FTP.FLUSH.TO.EOC STREAM (.FTPDEBUGLOG.)))
((MARK# NO)
(FTPGETCODE STREAM T)
(PROG1 (\FTP.FLUSH.TO.EOC STREAM (\GETSTREAM
PROMPTWINDOW
(QUOTE OUTPUT)))
(ERROR
"CLOSEF: Remote file not successfully retrieved"
)))
NIL)))))
(OUTPUT (OR (SELECTC (COND
((SETQ INS (BSPINPUTSTREAM STREAM))
(FTPPUTMARK STREAM (MARK# YES))
(FTPPUTCODE STREAM 0)
(.EOC. STREAM)
(FTPGETMARK INS)))
((MARK# YES)
(FTPGETCODE INS)
(SETQ SUCCESS (\FTP.FLUSH.TO.EOC INS (.FTPDEBUGLOG.))))
((MARK# NO)
(SELECTC (PROG1 (FTPGETCODE INS T)
(SETQ SUCCESS (\FTP.FLUSH.TO.EOC
INS
(\GETSTREAM PROMPTWINDOW
(QUOTE OUTPUT)))))
(\NO.STORAGE.FULL
(LISPERROR "FILE SYSTEM RESOURCES EXCEEDED" FILENAME))
NIL))
NIL)
(ERROR "CLOSEF: Remote file not successfully stored" FILENAME)))
NIL)
(COND
(SUCCESS (* ; "Stream still in good protocol state")
(replace DEVICE of STREAM with \BSPFDEV)
(* ; "Make it back into a plain BSP stream")
(\RELEASE.FTPCONNECTION CONN))
(CONN (CLOSEBSPSTREAM (fetch FTPIN of CONN)
1000)))
(RETURN FILENAME))))
(\FTP.UNREGISTER
(LAMBDA (DEVICE STREAM) (* hdj "23-Sep-86 13:35")
(\GENERIC-UNREGISTER-STREAM (if (FMEMB STREAM (\DEVICE-OPEN-STREAMS DEVICE))
then DEVICE
else (\GETDEVICEFROMNAME FILENAME))
STREAM)))
(\FTP.RENAMEFILE
[LAMBDA (OLD-DEVICE OLDFILE NEW-DEVICE NEWFILE) (* hdj "23-Jun-86 16:57")
(RESETLST (COND
((NEQ OLD-DEVICE NEW-DEVICE)
(\GENERIC.RENAMEFILE OLD-DEVICE OLDFILE NEW-DEVICE NEWFILE))
(T (PROG (CONNECTION HOST OLDNAME INS OUTS OLDPLIST NEWPLIST)
(OR (SETQ HOST (\FTP.UNPACKFILENAME OLDFILE))
(FDEVOP (QUOTE OPENP)
OLD-DEVICE
(FULLNAME OLDFILE)
NIL OLD-DEVICE)
(RETURN))
(SETQ OLDPLIST (CDR HOST))
(SETQ HOST (CAR HOST))
(OR (SETQ NEWPLIST (\FTP.UNPACKFILENAME NEWFILE))
(RETURN))
[COND
((NEQ (CAR NEWPLIST)
HOST)
(RETURN))
(T (SETQ NEWPLIST (CDR NEWPLIST]
(CLEAR.LEAF.CACHE HOST) (* In case Leaf has this file open for
input)
NEWCONNECTION
(OR (SETQ CONNECTION (\GETFTPCONNECTION HOST T))
(RETURN))
(SETQ INS (fetch FTPIN of CONNECTION))
(SETQ OUTS (fetch FTPOUT of CONNECTION))
RETRY
(FTPPUTMARK OUTS (MARK# RENAME))
(\FTP.PRINTPLIST OUTS OLDPLIST)
(\FTP.PRINTPLIST OUTS NEWPLIST)
(.EOC. OUTS)
(RETURN (PROG1 (SELECTC (FTPGETMARK INS)
((MARK# NO)
[COND
((\FTP.HANDLE.NO CONNECTION OLDPLIST)
(COND
((BSPOPENP INS (QUOTE INPUT))
(GO RETRY))
(T (GO NEWCONNECTION])
((MARK# YES)
(FTPGETCODE INS)
(AND (\FTP.FLUSH.TO.EOC INS (.FTPDEBUGLOG.))
NEWFILE))
((MARK# BROKEN)
(GO NEWCONNECTION))
(\FTPERROR CONNECTION))
(\RELEASE.FTPCONNECTION CONNECTION])
(\FTP.DELETEFILE
[LAMBDA (FILENAME) (* hdj "23-Jun-86 15:34")
(RESETLST (PROG (CONNECTION HOST REMOTENAME INS OUTS REMOTEPLIST DESIREDPLIST RESULT)
(OR (SETQ HOST (\FTP.UNPACKFILENAME FILENAME))
(LET* ((NAME (FULLNAME FILENAME))
(DEVICE (\GETDEVICEFROMNAME NAME)))
(FDEVOP (QUOTE OPENP)
DEVICE NAME NIL DEVICE))
(RETURN))
(SETQ DESIREDPLIST (CDR HOST))
(SETQ HOST (CAR HOST))
[COND
((AND (NULL (ASSOC (QUOTE VERSION)
DESIREDPLIST))
(EQ (GETHOSTINFO HOST (QUOTE OSTYPE))
(QUOTE VMS))) (* Ugh bletch, VMS defaults version to
newest, have to explicitly ask for
oldest)
(push DESIREDPLIST (LIST (QUOTE VERSION)
"-0"]
(for PROP in (QUOTE (DIRECTORY NAME-BODY VERSION))
do (push DESIREDPLIST (LIST (QUOTE DESIRED-PROPERTY)
PROP)))
(CLEAR.LEAF.CACHE HOST) (* In case Leaf has this file open for
input)
NEWCONNECTION
(OR (SETQ CONNECTION (\GETFTPCONNECTION HOST T))
(RETURN))
(SETQ INS (fetch FTPIN of CONNECTION))
(SETQ OUTS (fetch FTPOUT of CONNECTION))
RETRY
(FTPPUTMARK OUTS (MARK# DELETE))
(\FTP.PRINTPLIST OUTS DESIREDPLIST)
(.EOC. OUTS)
(SELECTC (FTPGETMARK INS)
((MARK# NO)
(COND
[(\FTP.HANDLE.NO CONNECTION DESIREDPLIST)
(COND
((BSPOPENP INS (QUOTE INPUT))
(GO RETRY))
(T (GO NEWCONNECTION]
(T (\RELEASE.FTPCONNECTION CONNECTION)
(RETURN))))
((MARK# HERE-IS-PLIST)
NIL)
((MARK# BROKEN)
(GO NEWCONNECTION))
(RETURN (\FTPERROR CONNECTION)))
NEXTPLIST
(SETQ REMOTEPLIST (READPLIST INS))
(OR (EQ (FTPGETMARK INS)
(MARK# EOC))
(\FTPERROR CONNECTION))
(FTPPUTMARK OUTS (MARK# YES))
(FTPPUTCODE OUTS 0)
(.EOC. OUTS)
(SELECTC (FTPGETMARK INS)
((MARK# NO)
(COND
((\FTP.HANDLE.NO CONNECTION DESIREDPLIST NIL NIL T)
(CLOSEBSPSTREAM INS 2000)
(GO NEWCONNECTION))))
((MARK# YES)
(FTPGETCODE INS)
(\FTP.FLUSH.TO.MARK INS)
[push RESULT (\FTP.PACKFILENAME HOST REMOTEPLIST NIL
(CADR (ASSOC (QUOTE DEVICE)
DESIREDPLIST])
(RETURN (\FTPERROR CONNECTION)))
(SELECTC (FTPGETMARK INS)
((MARK# HERE-IS-PLIST)
(GO NEXTPLIST))
((MARK# EOC)
(\RELEASE.FTPCONNECTION CONNECTION)
[RETURN (COND
((CDR RESULT)
(REVERSE RESULT))
(T (CAR RESULT])
(RETURN (\FTPERROR CONNECTION])
(\FTP.GENERATEFILES
[LAMBDA (DEVICE PATTERN DESIREDPROPS OPTIONS) (* bvm: "19-Dec-84 14:59")
(PROG [(RESULT (RESETLST (PROG (CONNECTION HOST REMOTENAME INS OUTS DESIREDPLIST CODE VERSION
EXTENSION DEVICE WANTDEVICE NAME DIRECTORY NAMEBODY OSTYPE
INFO FILTERNEEDED)
(for TAIL on (UNPACKFILENAME.STRING PATTERN)
by (CDDR TAIL)
do (SELECTQ (CAR TAIL)
(HOST [SETQ HOST (\CANONICAL.HOSTNAME
(MKATOM (CADR TAIL])
(DIRECTORY (SETQ DIRECTORY (CADR TAIL)))
(NAME (SETQ NAME (CADR TAIL)))
(EXTENSION (SETQ EXTENSION (OR (CADR TAIL)
"")))
(VERSION [SETQ VERSION (AND (IGREATERP
(NCHARS (CADR TAIL))
0)
(MKATOM (CADR TAIL])
(DEVICE (SETQ WANTDEVICE (SETQ DEVICE (CADR TAIL))))
(RETURN)))
(SETQ OSTYPE (GETHOSTINFO HOST (QUOTE OSTYPE)))
(SELECTQ OSTYPE
(TENEX [COND
((AND (STRPOS (QUOTE *)
NAME)
(IGREATERP (NCHARS NAME)
1))
(SETQ FILTERNEEDED (SETQ NAME (QUOTE *]
[COND
(EXTENSION (SELECTQ (NCHARS EXTENSION)
(0
(* Maxc enumerates "name.*" even when
given just "name.")
(SETQ FILTERNEEDED T))
(1
(* Extension * no problem))
(COND
((STRPOS (QUOTE *)
EXTENSION)
(SETQ FILTERNEEDED (SETQ
EXTENSION
(QUOTE *]
[OR VERSION (COND
((EQ OSTYPE (QUOTE TENEX))
(SETQ VERSION 0])
(TOPS20 (* Can handle all *'s)
(OR VERSION (SETQ VERSION 0))
(OR WANTDEVICE (SETQ WANTDEVICE T)))
(VMS (* Can handle all *'s))
((NIL IFS UNIX)
(COND
(EXTENSION
(SELECTQ (NCHARS EXTENSION)
(1 [COND
((EQ (CHCON1 EXTENSION)
(CHARCODE *))
(* If enumerating FOO.* need to ask
for FOO* or else we will miss
extensionless FOO)
(SETQ EXTENSION NIL)
(COND
((NEQ (NTHCHARCODE NAME -1)
(CHARCODE *))
(SETQ FILTERNEEDED
(SETQ NAME (CONCAT NAME (QUOTE *])
(0 (* Explicit null extension.
IFS enumerates FOO. okay, but FOO*.
would also enumerate files with
non-null extensions)
(SETQ EXTENSION NIL)
(SETQ FILTERNEEDED (STRPOS (QUOTE *)
NAME)))
NIL)))
[COND
[(EQ OSTYPE (QUOTE UNIX))
(* Coerce directory name to lowercase,
get rid of trailing /)
[COND
((EQ (NTHCHARCODE DIRECTORY -1)
(CHARCODE /))
(SETQ DIRECTORY (SUBSTRING DIRECTORY 1 -2]
[COND
((NEQ (NTHCHARCODE DIRECTORY 1)
(CHARCODE /))
(SETQ DIRECTORY (CONCAT (QUOTE /)
DIRECTORY]
(COND
((U-CASEP DIRECTORY)
(SETQ DIRECTORY (L-CASE DIRECTORY]
(T (OR VERSION (SETQ VERSION (QUOTE H])
NIL)
(SETQ DESIREDPLIST
(for PROP
in (NCONC (for PROP in DESIREDPROPS
collect (SELECTQ PROP
(BYTESIZE (QUOTE BYTE-SIZE))
(LENGTH (QUOTE SIZE))
((CREATIONDATE ICREATIONDATE)
(QUOTE CREATION-DATE))
((WRITEDATE IWRITEDATE)
(QUOTE WRITE-DATE))
((READDATE IREADDATE)
(QUOTE READ-DATE))
(EOLCONVENTION
(QUOTE END-OF-LINE-CONVENTION))
PROP))
(QUOTE (DIRECTORY NAME-BODY VERSION)))
collect (LIST (QUOTE DESIRED-PROPERTY)
PROP)))
[COND
([AND VERSION (OR (NEQ VERSION (QUOTE *))
(EQ OSTYPE (QUOTE VMS]
(push DESIREDPLIST (LIST (QUOTE VERSION)
VERSION]
[SETQ NAMEBODY (COND
((NULL EXTENSION)
NAME)
(T (CONCAT NAME "." EXTENSION]
[COND
((EQ OSTYPE (QUOTE UNIX))
[COND
((AND NIL (U-CASEP NAMEBODY))
(* Would like to help out by coercing
name to lowercase, but the leaf server
really does write uppercase filenames!)
(SETQ NAMEBODY (L-CASE NAMEBODY]
(COND
((NEQ (NTHCHARCODE NAMEBODY -1)
(CHARCODE *))(* Unix FTP server does not understand
versions, so make sure that whatever
pattern we give ends in *)
(SETQ FILTERNEEDED (SETQ NAMEBODY (CONCAT NAMEBODY
(QUOTE *]
(push DESIREDPLIST (LIST (QUOTE NAME-BODY)
NAMEBODY))
[COND
(DIRECTORY (push DESIREDPLIST (LIST (QUOTE DIRECTORY)
DIRECTORY]
[COND
(WANTDEVICE (push DESIREDPLIST (LIST (QUOTE DESIRED-PROPERTY)
(QUOTE DEVICE)))
(COND
(DEVICE (push DESIREDPLIST (LIST (QUOTE DEVICE)
DEVICE]
(push DESIREDPLIST [LIST (QUOTE USER-NAME)
(CAR (SETQ INFO (\INTERNAL/GETPASSWORD
HOST]
(LIST (QUOTE USER-PASSWORD)
(CDR INFO)))
NEWCONNECTION
(OR (SETQ CONNECTION (\GETFTPCONNECTION HOST T))
(GO NOFILES))
(SETQ INS (fetch FTPIN of CONNECTION))
(SETQ OUTS (fetch FTPOUT of CONNECTION))
RETRY
(FTPPUTMARK OUTS (MARK# ENUMERATE))
(\FTP.PRINTPLIST OUTS DESIREDPLIST)
(.EOC. OUTS)
(SELECTC (FTPGETMARK INS)
((MARK# NO)
(COND
[(\FTP.HANDLE.NO CONNECTION DESIREDPLIST NIL CODE NIL
T)
(COND
((BSPOPENP INS (QUOTE INPUT))
(GO RETRY))
(T (GO NEWCONNECTION]
(T (\RELEASE.FTPCONNECTION CONNECTION))))
((MARK# HERE-IS-PLIST)
(replace FTPBUSY of CONNECTION with (SETUPTIMER
\FTP.IDLE.TIMEOUT
))
(* This guy gets a timer because the
generator could be aborted out of our
control. Blech)
[RETURN (create FILEGENOBJ
NEXTFILEFN ←(FUNCTION \FTP.NEXTFILE)
FILEINFOFN ←(FUNCTION \FTP.FILEINFOFN)
GENFILESTATE ←(create FTPFILEGENSTATE
FTPGENCONNECTION ←
CONNECTION
FTPDEVICEWANTED ←
WANTDEVICE
FTPGENPLIST ← NIL
FTPNAMEFILTER ←(AND
FILTERNEEDED
(
DIRECTORY.MATCH.SETUP
PATTERN
])
((MARK# BROKEN)
(GO NEWCONNECTION))
(\FTPERROR CONNECTION))
NOFILES
(RETURN (create FILEGENOBJ
NEXTFILEFN ←(FUNCTION NILL]
[COND
((AND RESULT (fetch GENFILESTATE of RESULT)) (* Have a generator, so need to assure
generator will terminate)
(COND
[(EQMEMB (QUOTE RESETLST)
OPTIONS)
(RESETSAVE NIL (LIST [FUNCTION (LAMBDA (CONNECTION)
(AND RESETSTATE (CLOSEBSPSTREAM (fetch FTPIN
of CONNECTION)
0]
(fetch FTPGENCONNECTION of (fetch GENFILESTATE of RESULT]
(T (\FTP.ASSURE.CLEANUP]
(RETURN RESULT])
(\FTP.NEXTFILE
[LAMBDA (GENSTATE NAMEONLY) (* bvm: "13-Jul-84 16:44")
(DECLARE (SPECVARS FTPCONNECTION)) (* Seen by \FTP.CLEANUP)
(PROG ((FTPCONNECTION (fetch FTPGENCONNECTION of GENSTATE))
(FILTER (fetch FTPNAMEFILTER of GENSTATE))
INS NAMEBODY NAME EXT N PLIST)
(COND
((NULL FTPCONNECTION)
(RETURN (ERROR "End of file Enumerator" GENSTATE)))
((NOT (SETQ INS (fetch FTPIN of FTPCONNECTION)))
(GO BROKEN)))
LP (SETUPTIMER \FTP.IDLE.TIMEOUT (fetch FTPBUSY of FTPCONNECTION))
[COND
((\EOFP INS) (* NEW-ENUMERATE sends plists one
after another with no intervening
HERE-IS-PLIST; check here for
oldstyle, or for end of command)
(SELECTC (FTPGETMARK INS)
((MARK# EOC)
(\RELEASE.FTPCONNECTION FTPCONNECTION)
(replace FTPGENCONNECTION of GENSTATE with NIL)
(RETURN NIL))
((MARK# HERE-IS-PLIST)
(* Old style))
((MARK# BROKEN)
(GO BROKEN))
(RETURN (\FTPERROR FTPCONNECTION]
(COND
([AND (NULL (SETQ PLIST (READPLIST INS)))
(NOT (BSPOPENP INS (QUOTE INPUT]
(GO BROKEN)))
[SETQ NAME (COND
(NAMEONLY (OR (CADR (ASSOC (QUOTE NAME-BODY)
PLIST))
""))
(T (\FTP.PACKFILENAME (fetch FTPHOST of FTPCONNECTION)
PLIST T (fetch FTPDEVICEWANTED of GENSTATE]
(COND
((AND FILTER (NOT (DIRECTORY.MATCH FILTER NAME)))
(GO LP)))
(replace FTPGENPLIST of GENSTATE with PLIST)
(SETUPTIMER \FTP.IDLE.TIMEOUT (fetch FTPBUSY of FTPCONNECTION))
[RETURN (OR NAME (AND FTPDEBUGFLG (HELP "Uninterpretable filename returned by ENUMERATE"
PLIST]
BROKEN
(ERROR "File server broke connection before directory enumeration finished. RETURN() to terminate enumeration."
(fetch FTPHOST of FTPCONNECTION))
(RETURN NIL])
(\FTP.FILEINFOFN
[LAMBDA (GENSTATE ATTRIBUTE) (* bvm: "26-Apr-84 15:22")
(\FTP.GETFILEINFO.FROM.PROPS (fetch FTPGENPLIST of GENSTATE)
ATTRIBUTE])
(\FTP.GETFILEINFO
[LAMBDA (STREAM ATTRIBUTE DEV) (* bvm: "27-SEP-83 17:53")
(\FTP.GETFILEINFO.FROM.PROPS [COND
((type? STREAM STREAM)
(fetch FTPFILEPROPS of STREAM))
(T (\FTP.RECOGNIZEFILE STREAM DEV (QUOTE PROPS]
ATTRIBUTE])
(\FTP.GETFILEINFO.FROM.PROPS
[LAMBDA (PROPS ATTRIBUTE) (* bvm: " 5-May-84 16:31")
(PROG (TMP)
(RETURN (SELECTQ ATTRIBUTE
(CREATIONDATE (CADR (ASSOC (QUOTE CREATION-DATE)
PROPS)))
(WRITEDATE (CADR (ASSOC (QUOTE WRITE-DATE)
PROPS)))
(READDATE (CADR (ASSOC (QUOTE READ-DATE)
PROPS)))
(ICREATIONDATE
(IDATE (CADR (ASSOC (QUOTE CREATION-DATE)
PROPS))))
(IWRITEDATE (IDATE (CADR (ASSOC (QUOTE WRITE-DATE)
PROPS))))
(IREADDATE (IDATE (CADR (ASSOC (QUOTE READ-DATE)
PROPS))))
(LENGTH (MKATOM (CADR (ASSOC (QUOTE SIZE)
PROPS))))
(SIZE (AND (SETQ TMP (CADR (ASSOC (QUOTE SIZE)
PROPS)))
(FIXP (SETQ TMP (MKATOM TMP)))
(FOLDHI TMP BYTESPERPAGE)))
(TYPE [MKATOM (U-CASE (CADR (ASSOC ATTRIBUTE PROPS])
(BYTESIZE (MKATOM (CADR (ASSOC (QUOTE BYTE-SIZE)
PROPS))))
(CADR (ASSOC ATTRIBUTE PROPS])
)
(RPAQ? \FTPAVAILABLE )
(RPAQ? \FTP.IDLE.TIMEOUT 120000)
(* ;; "internal")
(DEFINEQ
(\FTP.OPEN.CONNECTION
[LAMBDA (HOST ECHOSTREAM) (* bvm: " 1-NOV-83 15:40")
(PROG ((PORT (BESTPUPADDRESS HOST PROMPTWINDOW))
INSTREAM)
(OR PORT (RETURN))
(SETQ INSTREAM (OPENBSPSTREAM [CONS (CAR PORT)
(COND
((ZEROP (CDR PORT))
\PUPSOCKET.FTP)
(T (CDR PORT]
NIL
(FUNCTION \FTP.ERRORHANDLER)
NIL NIL (FUNCTION \FTP.WHENCLOSED)
"Can't open FTP connection"))
(RETURN (COND
(INSTREAM (SETQ INSTREAM (create FTPCONNECTION
FTPIN ← INSTREAM
FTPOUT ←(BSPOUTPUTSTREAM INSTREAM)
FTPHOST ←[\CANONICAL.HOSTNAME
(COND
((LITATOM HOST)
HOST)
(T (ETHERHOSTNAME PORT]
FTPBUSY ← T))
(COND
((\FTP.SENDVERSION INSTREAM ECHOSTREAM)
(push \FTPCONNECTIONS INSTREAM)
INSTREAM)
(T (CLOSEBSPSTREAM (fetch FTPIN of INSTREAM])
(FTP.BREAKCONNECTION
[LAMBDA (HOST IDLEONLY) (* bvm: "28-Apr-85 14:51")
(LET (HOSTS)
(for STREAM in [for CONN in \FTPCONNECTIONS collect (pushnew HOSTS (fetch FTPHOST
of CONN))
(fetch FTPIN of CONN)
when (AND (OR (EQ HOST T)
(EQ HOST (fetch FTPHOST of CONN)))
(OR (NULL IDLEONLY)
(NULL (fetch FTPBUSY of CONN] do (CLOSEBSPSTREAM STREAM 5000
))
HOSTS])
(\FTP.SENDVERSION
[LAMBDA (CONNECTION ECHOSTREAM) (* bvm: " 3-JUN-83 23:58")
(PROG ((INS (fetch FTPIN of CONNECTION))
(OUTS (fetch FTPOUT of CONNECTION)))
(FTPPUTMARK OUTS (MARK# VERSION))
(BOUT OUTS \FTP.VERSION)
(PRIN3 "Interlisp-D Ftp user" OUTS)
(.EOC. OUTS)
(RETURN (SELECTC (FTPGETMARK INS)
((MARK# VERSION)
(COND
((EQ (BIN INS)
\FTP.VERSION)
(\FTP.FLUSH.TO.EOC INS ECHOSTREAM))))
NIL])
(\FTP.WHENCLOSED
[LAMBDA (INSTREAM) (* bvm: "15-SEP-83 23:06")
(PROG [(CONN (find C in \FTPCONNECTIONS suchthat (EQ (fetch FTPIN of C)
INSTREAM]
(COND
(CONN (SETQ \FTPCONNECTIONS (DREMOVE CONN \FTPCONNECTIONS))
(AND FTPDEBUGFLG (printout FTPDEBUGLOG T "{FTP Connection with "
(fetch FTPHOST of CONN)
" closed}" T])
(\GETFTPCONNECTION
[LAMBDA (HOST UNWINDSAVE) (* bvm: "11-Jul-84 15:32")
(PROG ([H (\CANONICAL.HOSTNAME (COND
((LITATOM HOST)
HOST)
(T (ETHERHOSTNAME HOST]
CONNECTION)
(RETURN (COND
([SETQ CONNECTION (OR (for CONN in \FTPCONNECTIONS
when (AND (EQ (fetch FTPHOST of CONN)
H)
(NOT (fetch FTPBUSY of CONN))
(BSPOPENP (fetch FTPIN of CONN)
(QUOTE OUTPUT)))
do (replace FTPBUSY of CONN with T)
(replace ACCESS of (fetch FTPIN of CONN)
with (QUOTE INPUT))
(* Because \CLOSEFILE clobbered this
field)
(replace ACCESS of (fetch FTPOUT of CONN)
with (QUOTE OUTPUT))
(RETURN CONN))
(\FTP.OPEN.CONNECTION HOST (.FTPDEBUGLOG.]
[COND
(UNWINDSAVE (RESETSAVE (PROGN (fetch FTPIN of CONNECTION))
(QUOTE (AND RESETSTATE (CLOSEBSPSTREAM OLDVALUE 0]
CONNECTION])
(\RELEASE.FTPCONNECTION
[LAMBDA (CONN) (* bvm: "18-MAY-83 10:53")
(replace FTPBUSY of CONN with NIL])
(\FTP.ERRORHANDLER
[LAMBDA (INSTREAM ERRCODE) (* bvm: "28-Apr-85 14:01")
(PROG (OUTSTREAM TMP)
(RETURN (SELECTQ ERRCODE
(MARK.ENCOUNTERED
(COND
((fetch FTPOPENP of INSTREAM) (* If reading a file, this is EOF)
(STREAMOP (QUOTE ENDOFSTREAMOP)
INSTREAM INSTREAM))
(T -1)))
(BAD.STATE.FOR.BOUT
(COND
((AND (SETQ OUTSTREAM (BSPOUTPUTSTREAM INSTREAM))
(fetch FTPOPENP of OUTSTREAM))
(* Writing a file, and partner timed
out. Hard to recover from this)
(ERROR "File server has broken connection" (fetch FULLFILENAME
of OUTSTREAM)))
(T (* Just protocol stuff.
Let it go by, and catch the error on
the next input)
(* (replace BOUTFN of OUTSTREAM with
(FUNCTION NILL)))
NIL)))
(BAD.STATE.FOR.BIN
(COND
((fetch FTPOPENP of INSTREAM) (* Could recover by reopening file)
(\FTP.FIX.BROKEN.INPUT INSTREAM))
((SETQ TMP (STKPOS (QUOTE READPLIST)))
(* Reading a plist, can't just barf in
the middle)
(RETFROM TMP NIL T))
(T (* Act like end of file)
-1)))
(BAD.GETMARK (COND
((BSPOPENP INSTREAM (QUOTE INPUT))
(MARK# NOTAMARK))
(T (MARK# BROKEN))))
(ERROR ERRCODE (AND INSTREAM (OR (fetch FULLFILENAME of INSTREAM)
(AND (SETQ OUTSTREAM (BSPOUTPUTSTREAM INSTREAM
))
(fetch FULLFILENAME of OUTSTREAM))
(AND (SETQ OUTSTREAM (BSPFRNADDRESS INSTREAM))
(ETHERHOSTNAME OUTSTREAM T])
(\FTP.FIX.BROKEN.INPUT
[LAMBDA (INSTREAM) (* bvm: "28-Apr-85 14:15")
(* Called when remote server breaks
connection in midstream.
Try to reopen and set fileptr to the
right place)
(PROG ((FULLNAME (fetch FULLFILENAME of INSTREAM))
(PROPS (fetch FTPFILEPROPS of INSTREAM))
(POS (GETFILEPTR INSTREAM))
NEWSTREAM)
(printout PROMPTWINDOW T "File server broke connection while reading " FULLNAME " at byte "
.P2 POS (QUOTE ...))
(COND
((SETQ NEWSTREAM (\FTP.OPENFILE.FROM.PLIST
(FILENAMEFIELD FULLNAME (QUOTE HOST))
[\FTP.ADD.USERINFO (for PAIR in PROPS collect PAIR
when (FMEMB (CAR PAIR)
(QUOTE (NAME-BODY VERSION DIRECTORY
DEVICE SERVER-FILENAME
]
(QUOTE INPUT)))
(\SMASHBSPSTREAM NEWSTREAM INSTREAM) (* Smash new stream into old, so we
are now using INSTREAM again)
(for CONN in \FTPCONNECTIONS when (EQ (fetch FTPIN of CONN)
NEWSTREAM)
do (replace FTPIN of CONN with INSTREAM)
(replace FTPOUT of CONN with (BSPOUTPUTSTREAM INSTREAM))
(RETURN))
(\BSP.DECLARE.FILEPTR INSTREAM 0)
(printout PROMPTWINDOW T "Reopening file and restoring fileptr...")
(SETFILEPTR INSTREAM POS)
(printout PROMPTWINDOW "done.")
(RETURN T))
(T (ERROR "File server broke connection; unable to reestablish" FULLNAME])
(\FTP.CLEANUP
[LAMBDA NIL (* bvm: "19-AUG-83 16:19")
(* Process that sits watching to see
if an FTP connection has been idle too
long)
(DECLARE (SPECVARS CONNS FAIL))
(PROG ((TIMER (SETUPTIMER 0))
(INTERVAL (LRSH \FTP.IDLE.TIMEOUT 1))
CONNS)
SLEEP
(SETUPTIMER INTERVAL TIMER)
(do (BLOCK NIL TIMER) until (TIMEREXPIRED? TIMER))
LP1 (COND
((NULL (SETQ CONNS \FTPCONNECTIONS))
(RETURN)))
LP2 (COND
([AND (FIXP (fetch FTPBUSY of (CAR CONNS)))
(TIMEREXPIRED? (fetch FTPBUSY of (CAR CONNS)))
(NOT (PROG (FAIL)
[MAP.PROCESSES (FUNCTION (LAMBDA (PROC)
(COND
((EQ (PROCESS.EVALV PROC (QUOTE
FTPCONNECTION
))
(CAR CONNS))
(SETQ FAIL T]
(RETURN FAIL]
(* Timer expired AND there is nobody actively using this connection.
Latter is important in case the remote server was just slow to answer.
Ideal solution would be to see if anyone has a pointer to the generator, but
that takes gc changes)
(CLOSEBSPSTREAM (fetch FTPIN of (CAR CONNS)))
(GO LP1)))
(COND
((SETQ CONNS (CDR CONNS))
(GO LP2)))
(GO SLEEP])
(\FTP.ASSURE.CLEANUP
[LAMBDA NIL (* bvm: "19-AUG-83 16:12")
(OR (FIND.PROCESS (QUOTE \FTP.CLEANUP))
(ADD.PROCESS (QUOTE (\FTP.CLEANUP))
(QUOTE RESTARTABLE)
(QUOTE NO])
)
(ADDTOVAR \FTPCONNECTIONS )
(DEFINEQ
(\FTP.HANDLE.NO
[LAMBDA (CONNECTION BADPLIST ECHOSTREAM CODE LEAVEMARK NOERRORFLG)
(* bvm: "19-Dec-84 14:55")
(PROG ((INSTREAM (fetch FTPIN of CONNECTION))
(HOST (fetch FTPHOST of CONNECTION))
[FLUSHER (COND
(LEAVEMARK (FUNCTION \FTP.FLUSH.TO.MARK))
(T (FUNCTION \FTP.FLUSH.TO.EOC]
INFO CPASS CNAME)
(SELECTC (OR CODE (SETQ CODE (FTPGETCODE INSTREAM T)))
(\NO.FILE.NOT.FOUND
(APPLY* FLUSHER INSTREAM (OR ECHOSTREAM (.FTPDEBUGLOG.)))
(RETURN))
((LIST \NO.BAD.TRANSFER.PARMS \NO.BAD.EOLCONVENTION)
(COND
((AND (SETQ INFO (ASSOC (QUOTE END-OF-LINE-CONVENTION)
BADPLIST))
(NEQ (CADR INFO)
(QUOTE CR)))
(RPLACA (CDR INFO)
(QUOTE CR)) (* Fall back on EOL = CR, which
everyone must support)
(APPLY* FLUSHER INSTREAM (OR ECHOSTREAM (.FTPDEBUGLOG.)))
(RETURN T))))
((LIST \NO.ILLEGAL.CONNECTNAME \NO.FILE.PROTECTED)
(COND
((NULL (ASSOC (QUOTE CONNECT-NAME)
BADPLIST))
[NCONC1 BADPLIST (LIST (QUOTE CONNECT-NAME)
(\FTP.DIRECTORYNAMEONLY (CADR (ASSOC (QUOTE DIRECTORY)
BADPLIST]
(APPLY* FLUSHER INSTREAM (OR ECHOSTREAM (.FTPDEBUGLOG.)))
(RETURN T))))
NIL)
GENERAL.FAILURE
(printout [OR ECHOSTREAM (SETQ ECHOSTREAM (GETSTREAM PROMPTWINDOW (QUOTE OUTPUT]
T HOST ": ")
(COND
((APPLY* FLUSHER INSTREAM ECHOSTREAM)
(SELECTC CODE
((LIST \NO.ILLEGAL.USERNAME \NO.ILLEGAL.USERPASSWORD)
(* User Password errors)
(RETURN (COND
((SETQ INFO (\INTERNAL/GETPASSWORD HOST T NIL NIL))
(for PAIR in BADPLIST
do (SELECTQ (CAR PAIR)
(USER-NAME (FRPLACA (CDR PAIR)
(CAR INFO)))
(USER-PASSWORD
(FRPLACA (CDR PAIR)
(CDR INFO)))
NIL))
T))))
((LIST \NO.ILLEGAL.CONNECTNAME \NO.ILLEGAL.CONNECTPASSWORD)
(* Connect Password errors)
(RETURN (COND
((SETQ INFO (\INTERNAL/GETPASSWORD HOST
(AND (SETQ CPASS (ASSOC (QUOTE CONNECT-PASSWORD)
BADPLIST))
T)
(CADR (SETQ CNAME (ASSOC (QUOTE CONNECT-NAME)
BADPLIST)))
NIL))
[COND
(CNAME (FRPLACA (CDR CNAME)
(CAR INFO]
[COND
(CPASS (FRPLACA (CDR CPASS)
(CDR INFO)))
(T (NCONC1 BADPLIST (LIST (QUOTE CONNECT-PASSWORD)
(CDR INFO]
T))))
(\NO.ILLEGAL.NAME.ERRORS
(OR NOERRORFLG (LISPERROR "BAD FILE NAME" (\FTP.PACKFILENAME HOST BADPLIST NIL
T))))
(\NO.STORAGE.FULL
(OR NOERRORFLG (LISPERROR "FILE SYSTEM RESOURCES EXCEEDED"
(\FTP.PACKFILENAME HOST BADPLIST NIL T))))
((LIST \NO.FILE.PROTECTED \NO.FILE.BUSY)
(GO WONT.OPEN))
(GO WONT.OPEN)))
(T (\FTPERROR CONNECTION)))
(RETURN)
WONT.OPEN
(OR NOERRORFLG (LISPERROR "FILE WON'T OPEN" (\FTP.PACKFILENAME HOST BADPLIST NIL T])
(\FTP.DIRECTORYNAMEONLY
[LAMBDA (DIRNAME) (* bvm: "16-AUG-83 18:35")
(PROG ((N (STRPOS (QUOTE >)
DIRNAME)))
(RETURN (COND
(N (SUBATOM DIRNAME 1 (SUB1 N)))
(T DIRNAME])
(\FTP.EOL.FROM.PLIST
[LAMBDA (PLIST) (* bvm: "21-NOV-83 15:33")
(for PAIR in PLIST when (EQ (CAR PAIR)
(QUOTE END-OF-LINE-CONVENTION))
do (RETURN (SELECTQ (CADR PAIR)
(LF LF.EOLC)
(CRLF CRLF.EOLC)
CR.EOLC)) finally (RETURN CR.EOLC])
(\FTP.MAKEPLIST
[LAMBDA (FILENAME HOST DESIREDPROPS) (* bvm: " 4-JUN-83 21:35")
(PROG ((INFO (\INTERNAL/GETPASSWORD HOST)))
(RETURN (CONS (LIST (QUOTE USER-NAME)
(CAR INFO))
(CONS (LIST (QUOTE USER-PASSWORD)
(CDR INFO))
(CONS (LIST (QUOTE SERVER-FILENAME)
FILENAME)
(for PROP inside DESIREDPROPS collect (LIST (QUOTE
DESIRED-PROPERTY
)
PROP])
(\FTP.PRINTPLIST
[LAMBDA (STREAM PLIST) (* bvm: "24-Apr-86 19:20")
(BOUT STREAM (CHARCODE %())
(for PAIR in PLIST do (for ITEM in PAIR bind (BEFORE ←(CHARCODE %())
ISPASSWORD
do (BOUT STREAM BEFORE)
(SETQ BEFORE (CHARCODE SPACE))
[for CH inpname ITEM do (SELCHARQ (COND
(ISPASSWORD (SETQ CH
(\DECRYPT.PWD.CHAR
CH)))
(T CH))
((%( %) ')
(BOUT STREAM (CHARCODE ')))
NIL)
(BOUT STREAM (COND
((ILEQ CH \MAXTHINCHAR)
CH)
(T
(* Illegal, try something hopeless)
(CHARCODE #↑A]
(SELECTQ ITEM
((USER-PASSWORD CONNECT-PASSWORD)
(SETQ ISPASSWORD T))
NIL))
(BOUT STREAM (CHARCODE %))))
(BOUT STREAM (CHARCODE %)))
(COND
(FTPDEBUGFLG (PRIN2 PLIST FTPDEBUGLOG)))
STREAM])
(\FTP.PACKFILENAME
[LAMBDA (HOST PLIST PRESERVECASE DEVICEWANTED) (* bvm: "19-Dec-84 15:16")
(PROG (NAMEBODY VERSION SERVERNAME DEVICE DIR FIELDS NAME I)
(for PAIR in PLIST do (SELECTQ (CAR PAIR)
(DIRECTORY (COND
((SETQ DIR (CADR PAIR))
(SELCHARQ (CHCON1 DIR)
(%[ [COND
((EQ (NTHCHARCODE DIR -1)
(CHARCODE %]))
(* patch around buggy VMS server)
(SETQ DIR (SUBSTRING DIR 2 -2])
(/ (* UNIX returns a /, although
Interlisp always uses complete
directory names)
(SETQ DIR (SUBSTRING DIR 2 -1)))
NIL))))
(DEVICE [COND
(DEVICEWANTED (SETQ DEVICE (CADR PAIR])
(NAME-BODY (SETQ NAMEBODY (CADR PAIR)))
(VERSION (SETQ VERSION (CADR PAIR)))
(SERVER-FILENAME
(SETQ SERVERNAME (CADR PAIR)))
NIL))
[SETQ NAME (COND
[NAMEBODY [COND
(VERSION (SETQ FIELDS (LIST (QUOTE ;)
VERSION]
[COND
((NOT (STRPOS (QUOTE %.)
NAMEBODY))
(push FIELDS (QUOTE %.]
(push FIELDS NAMEBODY)
[COND
(DIR (push FIELDS (QUOTE <)
DIR
(QUOTE >]
(COND
(DEVICE [COND
((AND (NEQ DEVICEWANTED T)
(NOT (STREQUAL DEVICE DEVICEWANTED))
SERVERNAME
(SETQ I (STRPOS ":" SERVERNAME)))
(* Ugh, VMS puts a different device in
the DEVICE field than in
SERVER-FILENAME field)
(SETQ DEVICE (SUBSTRING SERVERNAME 1 (SUB1 I]
(push FIELDS DEVICE (QUOTE :]
(SERVERNAME (SETQ FIELDS (LIST SERVERNAME)))
(T (RETURN]
(push FIELDS (QUOTE {)
HOST
(QUOTE }))
(SETQ NAME (CONCATLIST FIELDS))
(RETURN (COND
(PRESERVECASE NAME)
(T (MKATOM (U-CASE NAME])
(\FTP.PACK.DIRECTORYNAMEP
[LAMBDA (CONNECTION PLIST) (* lmm "25-Mar-85 14:38")
(PROG [(DIRECTORY (CADR (ASSOC (QUOTE DIRECTORY)
PLIST)))
(DEVICE (CADR (ASSOC (QUOTE DEVICE)
PLIST]
(RETURN (PACKFILENAME.STRING (QUOTE HOST)
(fetch FTPHOST of CONNECTION)
(QUOTE DEVICE)
DEVICE
(QUOTE DIRECTORY)
DIRECTORY])
(\FTP.UNPACKFILENAME
[LAMBDA (FILENAME) (* bvm: "20-Oct-85 15:37")
(PROG ((FIELDS (UNPACKFILENAME.STRING FILENAME))
PLIST HOST DEVICE DIR NAME EXT INFO)
(for TAIL on FIELDS by (CDDR TAIL) do (SELECTQ (CAR TAIL)
(HOST (SETQ HOST (MKATOM (CADR TAIL))))
(DIRECTORY (SETQ DIR (CADR TAIL)))
(DEVICE (SETQ DEVICE (CADR TAIL)))
(NAME (SETQ NAME (CADR TAIL)))
(EXTENSION (SETQ EXT (CADR TAIL)))
(VERSION (push PLIST (LIST (QUOTE VERSION)
(CADR TAIL))))
NIL))
(RETURN (COND
(HOST [push PLIST (LIST (QUOTE NAME-BODY)
(COND
((AND EXT (IGREATERP (NCHARS EXT)
0))
(CONCAT NAME (QUOTE %.)
EXT))
(T NAME]
[COND
(DIR [COND
((EQ (GETHOSTINFO HOST (QUOTE OSTYPE))
(QUOTE UNIX)) (* Coerce directory name to lowercase,
get rid of trailing /)
[COND
((EQ (NTHCHARCODE DIR -1)
(CHARCODE /))
(SETQ DIR (SUBSTRING DIR 1 -2]
[COND
((NEQ (NTHCHARCODE DIR 1)
(CHARCODE /))
(SETQ DIR (CONCAT (QUOTE /)
DIR]
(COND
((U-CASEP DIR)
(SETQ DIR (L-CASE DIR]
(push PLIST (LIST (QUOTE DIRECTORY)
DIR]
[COND
(DEVICE (push PLIST (LIST (QUOTE DEVICE)
DEVICE]
(CONS HOST (\FTP.ADD.USERINFO PLIST HOST])
(\FTP.ADD.USERINFO
[LAMBDA (PLIST HOST) (* bvm: "27-OCT-83 15:50")
(PROG ((INFO (\INTERNAL/GETPASSWORD HOST)))
(push PLIST (LIST (QUOTE USER-NAME)
(CAR INFO))
(LIST (QUOTE USER-PASSWORD)
(CDR INFO)))
(RETURN PLIST])
(\FTP.FLUSH.TO.EOC
[LAMBDA (INSTREAM ECHOSTREAM) (* bvm: "13-JUN-83 15:36")
(* Eat bytes from the input side of CONNECTION up to next mark, copying bytes
to ECHOSTREAM if given, and return T if the mark is EOC)
(PROG ([STREAM (AND ECHOSTREAM (GETSTREAM ECHOSTREAM (QUOTE OUTPUT]
CH)
(while (NEQ (SETQ CH (BIN INSTREAM))
-1) do (AND STREAM (\OUTCHAR STREAM CH)))
(RETURN (EQ (FTPGETMARK INSTREAM)
(MARK# EOC])
(\FTP.FLUSH.TO.MARK
[LAMBDA (INSTREAM ECHOSTREAM) (* bvm: " 7-JUL-83 12:08")
(bind CH [STREAM ←(AND ECHOSTREAM (GETSTREAM ECHOSTREAM (QUOTE OUTPUT]
while (NEQ (SETQ CH (BIN INSTREAM))
-1) do (AND STREAM (\OUTCHAR STREAM CH)))
T])
(\FTPERROR
[LAMBDA (CONNECTION ERRMSG ERRARG) (* bvm: "11-Jul-84 15:33")
(COND
(FTPDEBUGFLG (printout FTPDEBUGLOG T "{FTP Protocol violation, aborted}" T)
(HELP)))
(CLOSEBSPSTREAM (COND
((type? STREAM CONNECTION)
CONNECTION)
(T (fetch FTPIN of CONNECTION)))
1000)
(COND
(ERRMSG (ERROR (COND
((EQ ERRMSG T)
"FTP Protocol violation")
(T ERRMSG))
ERRARG])
)
(* ;; "for debugging")
(DEFINEQ
(FTPDEBUG
[LAMBDA (FLG REGION) (* bvm: "27-OCT-83 14:57")
(SETQ FTPDEBUGLOG (CREATEW REGION "FTP Debug info"))
[WINDOWPROP FTPDEBUGLOG (QUOTE CLOSEFN)
(FUNCTION (LAMBDA (WINDOW)
(AND (EQ (WINDOWPROP WINDOW (QUOTE DSP))
FTPDEBUGLOG)
(SETQ FTPDEBUGLOG (SETQ FTPDEBUGFLG NIL]
(SETQ FTPDEBUGLOG (WINDOWPROP FTPDEBUGLOG (QUOTE DSP)))
(DSPFONT (FONTCREATE (QUOTE GACHA)
8)
FTPDEBUGLOG)
(DSPSCROLL T FTPDEBUGLOG)
(SETQ FTPDEBUGFLG T)
FTPDEBUGLOG])
(FTPPRINTMARK
[LAMBDA (MARK) (* bvm: "25-Aug-84 21:58")
[COND
(FTPDEBUGFLG (printout FTPDEBUGLOG "[" (OR (CADR (FASSOC MARK (LISTP FTPMARKTYPES)))
MARK)
"]")
(COND
((EQ MARK (MARK# EOC))
(TERPRI FTPDEBUGLOG]
MARK])
(FTPPRINTCODE
[LAMBDA (CODE NOCODEP) (* bvm: "20-AUG-83 00:12")
(COND
(FTPDEBUGFLG (PRIN1 (QUOTE {)
FTPDEBUGLOG)
(COND
(NOCODEP (PRINTCONSTANT CODE FTPNOCODES FTPDEBUGLOG "\NO."))
(T (PRINTNUM (QUOTE (FIX 1))
CODE FTPDEBUGLOG)))
(PRIN1 (QUOTE })
FTPDEBUGLOG)))
CODE])
(FTPGETMARK
[LAMBDA (STREAM) (* bvm: " 4-JUN-83 21:51")
(bind MARK while (EQ (SETQ MARK (FTPPRINTMARK (BSPGETMARK STREAM)))
(MARK# COMMENT)) do (\FTP.FLUSH.TO.MARK STREAM) finally (RETURN MARK])
(FTPPUTMARK
[LAMBDA (STREAM MARK) (* bvm: "12-MAY-83 10:24")
(BSPPUTMARK STREAM (FTPPRINTMARK MARK])
(FTPPUTCODE
[LAMBDA (STREAM CODE NOCODEP) (* bvm: "20-AUG-83 00:12")
(BOUT STREAM (FTPPRINTCODE CODE NOCODEP])
(FTPGETCODE
[LAMBDA (STREAM NOCODEP) (* bvm: "20-AUG-83 00:17")
(FTPPRINTCODE (BIN STREAM)
NOCODEP])
)
(RPAQ? FTPDEBUGLOG )
(RPAQ? FTPDEBUGFLG )
(DECLARE: EVAL@COMPILE DONTCOPY
(RPAQQ FTPMARKTYPES ((1 RETRIEVE)
(2 STORE)
(3 YES)
(4 NO)
(5 HERE-IS-FILE)
(6 EOC)
(7 COMMENT)
(8 VERSION)
(9 NEW-STORE)
(10 ENUMERATE)
(11 HERE-IS-PLIST)
(12 NEW-ENUMERATE)
(14 DELETE)
(15 RENAME)
(16 STORE-MAIL)
(17 RETRIEVE-MAIL)
(18 FLUSH-MAILBOX)
(19 MAILBOX-EXCEPTION)
(253 NOTAMARK)
(254 BROKEN)))
(DECLARE: EVAL@COMPILE
(RPAQQ \FTP.VERSION 1)
(CONSTANTS \FTP.VERSION)
)
(RPAQQ FTPNOCODES ((\NO.UNIMPLEMENTED 1)
(\NO.PROTOCOL.ERROR 3)
(\NO.BAD.PLIST 8)
(\NO.ILLEGAL.DIRECTORY 10)
(\NO.ILLEGAL.NAME.ERRORS (QUOTE (9 10 11 12 25)))
(\NO.BAD.EOLCONVENTION 15)
(\NO.ILLEGAL.USERNAME 16)
(\NO.ILLEGAL.USERPASSWORD 17)
(\NO.ILLEGAL.CONNECTNAME 19)
(\NO.ILLEGAL.CONNECTPASSWORD 20)
(\NO.FILE.NOT.FOUND 64)
(\NO.FILE.PROTECTED 65)
(\NO.BAD.TRANSFER.PARMS 66)
(\NO.DISK.ERROR 67)
(\NO.STORAGE.FULL 68)
(\NO.FILE.BUSY 73)
(\NO.RENAME.DESTINATION.EXISTS 74)))
(DECLARE: EVAL@COMPILE
(RPAQQ \NO.UNIMPLEMENTED 1)
(RPAQQ \NO.PROTOCOL.ERROR 3)
(RPAQQ \NO.BAD.PLIST 8)
(RPAQQ \NO.ILLEGAL.DIRECTORY 10)
(RPAQQ \NO.ILLEGAL.NAME.ERRORS (9 10 11 12 25))
(RPAQQ \NO.BAD.EOLCONVENTION 15)
(RPAQQ \NO.ILLEGAL.USERNAME 16)
(RPAQQ \NO.ILLEGAL.USERPASSWORD 17)
(RPAQQ \NO.ILLEGAL.CONNECTNAME 19)
(RPAQQ \NO.ILLEGAL.CONNECTPASSWORD 20)
(RPAQQ \NO.FILE.NOT.FOUND 64)
(RPAQQ \NO.FILE.PROTECTED 65)
(RPAQQ \NO.BAD.TRANSFER.PARMS 66)
(RPAQQ \NO.DISK.ERROR 67)
(RPAQQ \NO.STORAGE.FULL 68)
(RPAQQ \NO.FILE.BUSY 73)
(RPAQQ \NO.RENAME.DESTINATION.EXISTS 74)
(CONSTANTS (\NO.UNIMPLEMENTED 1)
(\NO.PROTOCOL.ERROR 3)
(\NO.BAD.PLIST 8)
(\NO.ILLEGAL.DIRECTORY 10)
(\NO.ILLEGAL.NAME.ERRORS (QUOTE (9 10 11 12 25)))
(\NO.BAD.EOLCONVENTION 15)
(\NO.ILLEGAL.USERNAME 16)
(\NO.ILLEGAL.USERPASSWORD 17)
(\NO.ILLEGAL.CONNECTNAME 19)
(\NO.ILLEGAL.CONNECTPASSWORD 20)
(\NO.FILE.NOT.FOUND 64)
(\NO.FILE.PROTECTED 65)
(\NO.BAD.TRANSFER.PARMS 66)
(\NO.DISK.ERROR 67)
(\NO.STORAGE.FULL 68)
(\NO.FILE.BUSY 73)
(\NO.RENAME.DESTINATION.EXISTS 74))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS MARK# MACRO (X (OR (CAR (find M in FTPMARKTYPES suchthat (EQ (CADR M)
(CAR X))))
(HELP "Unknown mark type" (CAR X)))))
(PUTPROPS .EOC. MACRO ((STREAM)
(FTPPUTMARK STREAM (MARK# EOC))))
(PUTPROPS .FTPDEBUGLOG. MACRO (NIL (AND FTPDEBUGFLG FTPDEBUGLOG)))
)
(PUTPROPS MARK# INFO NOEVAL)
[DECLARE: EVAL@COMPILE
(RECORD FTPCONNECTION (FTPIN FTPOUT FTPHOST FTPBUSY FTPCURRENTFILE))
(ACCESSFNS FTPSTREAM ((FTPFILEPROPS (fetch F5 of DATUM)
(replace F5 of DATUM with NEWVALUE)))
(SYNONYM FTPFILEPROPS (FTPOPENP)))
(RECORD FTPFILEGENSTATE (FTPGENCONNECTION FTPGENPLIST FTPDEVICEWANTED FTPNAMEFILTER))
]
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS FTPDEBUGFLG \FTPCONNECTIONS \FTPAVAILABLE \FTP.IDLE.TIMEOUT \BSPFDEV \FTPFDEV)
)
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(\FTPINIT)
)
(PUTPROPS DPUPFTP COPYRIGHT ("Xerox Corporation" 1983 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2179 48968 (\FTPINIT 2189 . 3251) (\FTPEVENTFN 3253 . 3573) (\FTP.OPENFILE 3575 . 6709)
(\FTP.OPENFILE.FROM.PLIST 6711 . 10728) (\FTP.GETFILENAME 10730 . 11083) (\FTP.RECOGNIZEFILE 11085 .
15145) (\FTP.DIRECTORYNAMEP 15147 . 15332) (\FTP.CLOSEFILE 15334 . 19478) (\FTP.UNREGISTER 19480 .
19827) (\FTP.RENAMEFILE 19829 . 22832) (\FTP.DELETEFILE 22834 . 27351) (\FTP.GENERATEFILES 27353 .
43947) (\FTP.NEXTFILE 43949 . 46705) (\FTP.FILEINFOFN 46707 . 46923) (\FTP.GETFILEINFO 46925 . 47336)
(\FTP.GETFILEINFO.FROM.PROPS 47338 . 48966)) (49061 62910 (\FTP.OPEN.CONNECTION 49071 . 50850) (
FTP.BREAKCONNECTION 50852 . 51699) (\FTP.SENDVERSION 51701 . 52395) (\FTP.WHENCLOSED 52397 . 52982) (
\GETFTPCONNECTION 52984 . 54904) (\RELEASE.FTPCONNECTION 54906 . 55081) (\FTP.ERRORHANDLER 55083 .
58221) (\FTP.FIX.BROKEN.INPUT 58223 . 60575) (\FTP.CLEANUP 60577 . 62636) (\FTP.ASSURE.CLEANUP 62638
. 62908)) (62944 80706 (\FTP.HANDLE.NO 62954 . 68079) (\FTP.DIRECTORYNAMEONLY 68081 . 68380) (
\FTP.EOL.FROM.PLIST 68382 . 68800) (\FTP.MAKEPLIST 68802 . 69657) (\FTP.PRINTPLIST 69659 . 71652) (
\FTP.PACKFILENAME 71654 . 75309) (\FTP.PACK.DIRECTORYNAMEP 75311 . 75885) (\FTP.UNPACKFILENAME 75887
. 78814) (\FTP.ADD.USERINFO 78816 . 79177) (\FTP.FLUSH.TO.EOC 79179 . 79762) (\FTP.FLUSH.TO.MARK
79764 . 80081) (\FTPERROR 80083 . 80704)) (80738 83079 (FTPDEBUG 80748 . 81393) (FTPPRINTMARK 81395 .
81808) (FTPPRINTCODE 81810 . 82279) (FTPGETMARK 82281 . 82584) (FTPPUTMARK 82586 . 82745) (FTPPUTCODE
82747 . 82908) (FTPGETCODE 82910 . 83077)))))
STOP