(FILECREATED "19-Dec-84 15:17:39" {ERIS}<LISPCORE>SOURCES>DPUPFTP.;18 56963
changes to: (FNS \FTP.RECOGNIZEFILE \FTP.PACKFILENAME \FTP.GENERATEFILES \FTP.DELETEFILE
\FTP.OPENFILE.FROM.PLIST \FTP.HANDLE.NO)
previous date: " 7-Oct-84 20:42:17" {ERIS}<LISPCORE>SOURCES>DPUPFTP.;16)
(* Copyright (c) 1983, 1984 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT DPUPFTPCOMS)
(RPAQQ DPUPFTPCOMS [(FNS \FTPINIT \FTP.OPENFILE \FTP.OPENFILE.FROM.PLIST \FTP.GETFILEPTR
\FTP.SETFILEPTR \FTP.GETFILENAME \FTP.RECOGNIZEFILE \FTP.DIRECTORYNAMEP
\FTP.CLOSEFILE \FTP.EOFP \FTP.RENAMEFILE \FTP.DELETEFILE \FTP.GENERATEFILES
\FTP.NEXTFILE \FTP.FILEINFOFN \FTP.GETFILEINFO \FTP.GETFILEINFO.FROM.PROPS)
(FNS \FTP.OPEN.CONNECTION \FTP.SENDVERSION \FTP.WHENCLOSED \GETFTPCONNECTION
\RELEASE.FTPCONNECTION \FTP.ERRORHANDLER \FTP.FIX.BROKEN.INPUT \FTP.CLEANUP
\FTP.ASSURE.CLEANUP)
(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)
(FNS FTPDEBUG FTPPRINTMARK FTPPRINTCODE FTPGETMARK FTPPUTMARK FTPPUTCODE FTPGETCODE
FLUSH.FTPCONNECTIONS)
(ADDVARS (\FTPCONNECTIONS))
(INITVARS (FTPDEBUGLOG)
(FTPDEBUGFLG)
(\FTPAVAILABLE)
(\FTP.IDLE.TIMEOUT 120000))
(DECLARE: EVAL@COMPILE DONTCOPY (VARS FTPMARKTYPES)
(CONSTANTS \FTP.VERSION)
(CONSTANTS * FTPNOCODES)
(MACROS MARK# .EOC. .FTPDEBUGLOG.)
(RECORDS FTPCONNECTION FTPSTREAM FTPFILEGENSTATE)
(GLOBALVARS FTPDEBUGFLG \FTPCONNECTIONS \FTPAVAILABLE \FTP.IDLE.TIMEOUT \BSPFDEV
\FTPFDEV)
(FILES (LOADCOMP)
BSP))
(DECLARE: DONTEVAL@LOAD DOCOPY (P (\FTPINIT])
(DEFINEQ
(\FTPINIT
[LAMBDA NIL (* bvm: "28-Aug-84 21:39")
(COND
((type? FDEV \BSPFDEV)
(SETQ \FTPFDEV (NCREATE (QUOTE FDEV)
\BSPFDEV))
(with FDEV \FTPFDEV (SETQ DEVICENAME (QUOTE DPUPFTP))
(SETQ OPENFILE (FUNCTION \FTP.OPENFILE))
(SETQ CLOSEFILE (FUNCTION \FTP.CLOSEFILE))
(SETQ DIRECTORYNAMEP (FUNCTION \FTP.DIRECTORYNAMEP))
(SETQ GETFILENAME (FUNCTION \FTP.GETFILENAME))
(SETQ GETFILEINFO (FUNCTION \FTP.GETFILEINFO))
(SETQ GETFILEPTR (FUNCTION \FTP.GETFILEPTR))
(SETQ SETFILEPTR (FUNCTION \FTP.SETFILEPTR))
(SETQ RENAMEFILE (FUNCTION \FTP.RENAMEFILE))
(SETQ DELETEFILE (FUNCTION \FTP.DELETEFILE))
(SETQ GENERATEFILES (FUNCTION \FTP.GENERATEFILES))
(SETQ EOFP (FUNCTION \FTP.EOFP)))
(SETQ \FTPAVAILABLE T])
(\FTP.OPENFILE
[LAMBDA (FILENAME ACCESS RECOG OTHERINFO) (* bvm: "26-Sep-84 14:44")
(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 (SELECTQ (SETQ TYPE (CADR PAIR))
((TEXT BINARY)
T)
(NIL)
(LISPERROR "ILLEGAL ARG" PAIR)))
(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]
[COND
((NULL TYPE)
(push DESIREDPLIST (LIST (QUOTE 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: "19-Dec-84 14:58")
(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))
(replace BSPFILEPTR of INS with 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)
(replace BSPFILEPTR of OUTS with 0)
(replace EOLCONVENTION of OUTS with (\FTP.EOL.FROM.PLIST DESIREDPLIST))
(replace DEVICE of OUTS with \FTPFDEV)
(RETURN OUTS))
(T (GO NEWCONNECTION]
NIL])
(\FTP.GETFILEPTR
[LAMBDA (STREAM) (* bvm: " 2-NOV-83 14:31")
(IPLUS (fetch BSPFILEPTR of STREAM)
(COND
((fetch CPPTR of STREAM)
(fetch COFFSET of STREAM))
(T 0])
(\FTP.SETFILEPTR
[LAMBDA (STREAM INDX) (* bvm: " 1-NOV-83 17:47")
(PROG (SKIPBYTES)
(RETURN (COND
((AND (fetch BSPOUTPUTSTREAM of STREAM)
(IGEQ (SETQ SKIPBYTES (IDIFFERENCE INDX (\FTP.GETFILEPTR STREAM)))
0)) (* Can only move file pointer on input, and then only
forward)
(\BSP.SKIPBYTES STREAM SKIPBYTES))
(T (\IS.NOT.RANDACCESSP STREAM])
(\FTP.GETFILENAME
[LAMBDA (NAME RECOG DEV) (* bvm: "20-SEP-83 16:48")
(\FTP.RECOGNIZEFILE NAME DEV])
(\FTP.RECOGNIZEFILE
[LAMBDA (NAME DEV OPTION) (* bvm: "19-Dec-84 15:17")
(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]
[(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) (* bvm: "28-Aug-84 21:37")
(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 (fetch BSPINPUTSTREAM
of (fetch BSPSOC of 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.EOFP
[LAMBDA (STREAM) (* bvm: "28-Aug-84 21:38")
(* * If using BSP connection for a file, want to be specifically at MARK)
(AND (BSPEOFP STREAM)
(fetch MARKPENDING of STREAM])
(\FTP.RENAMEFILE
[LAMBDA (OLDFILE NEWFILE) (* bvm: "27-OCT-83 14:42")
(RESETLST (PROG (CONNECTION HOST OLDNAME INS OUTS OLDPLIST NEWPLIST)
(OR (SETQ HOST (\FTP.UNPACKFILENAME OLDFILE))
(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) (* bvm: "19-Dec-84 14:53")
(RESETLST (PROG (CONNECTION HOST REMOTENAME INS OUTS REMOTEPLIST DESIREDPLIST RESULT)
(OR (SETQ HOST (\FTP.UNPACKFILENAME FILENAME))
(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])
)
(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.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-OCT-83 19:17")
(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
(fetch BSPSOC of INSTREAM))
(ETHERHOSTNAME (fetch FRNPORT
of OUTSTREAM)
T])
(\FTP.FIX.BROKEN.INPUT
[LAMBDA (INSTREAM) (* bvm: "28-Aug-84 22:50")
(* 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))
(replace BSPFILEPTR of INSTREAM with 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])
)
(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: " 3-NOV-83 22:21")
(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 inchars ITEM
do (SELCHARQ (COND
(ISPASSWORD (SETQ CH (\DECRYPT.PWD.CHAR CH)))
(T CH))
((%( %) ')
(BOUT STREAM (CHARCODE ')))
NIL)
(BOUT STREAM CH))
(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) (* bvm: "27-SEP-83 17:52")
(PROG [(DIRECTORY (CADR (ASSOC (QUOTE DIRECTORY)
PLIST]
(RETURN (PACK* (QUOTE {)
(fetch FTPHOST of CONNECTION)
"}"
(COND
(DIRECTORY (CONCAT (QUOTE <)
DIRECTORY
(QUOTE >)))
(T ""])
(\FTP.UNPACKFILENAME
[LAMBDA (FILENAME) (* lmm " 7-Oct-84 20:41")
(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 (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])
)
(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])
(FLUSH.FTPCONNECTIONS
[LAMBDA NIL (* bvm: "14-JUN-83 12:35")
(while \FTPCONNECTIONS do (CLOSEBSPSTREAM (fetch FTPIN of (CAR \FTPCONNECTIONS))
11610Q])
)
(ADDTOVAR \FTPCONNECTIONS )
(RPAQ? FTPDEBUGLOG )
(RPAQ? FTPDEBUGFLG )
(RPAQ? \FTPAVAILABLE )
(RPAQ? \FTP.IDLE.TIMEOUT 120000)
(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)))
)
[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)
)
(FILESLOAD (LOADCOMP)
BSP)
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(\FTPINIT)
)
(PUTPROPS DPUPFTP COPYRIGHT ("Xerox Corporation" 1983 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1796 31405 (\FTPINIT 1806 . 2664) (\FTP.OPENFILE 2666 . 4722) (\FTP.OPENFILE.FROM.PLIST
4724 . 7952) (\FTP.GETFILEPTR 7954 . 8219) (\FTP.SETFILEPTR 8221 . 8708) (\FTP.GETFILENAME 8710 .
8862) (\FTP.RECOGNIZEFILE 8864 . 11575) (\FTP.DIRECTORYNAMEP 11577 . 11758) (\FTP.CLOSEFILE 11760 .
14425) (\FTP.EOFP 14427 . 14691) (\FTP.RENAMEFILE 14693 . 16158) (\FTP.DELETEFILE 16160 . 19052) (
\FTP.GENERATEFILES 19054 . 27743) (\FTP.NEXTFILE 27745 . 29883) (\FTP.FILEINFOFN 29885 . 30091) (
\FTP.GETFILEINFO 30093 . 30408) (\FTP.GETFILEINFO.FROM.PROPS 30410 . 31403)) (31406 40126 (
\FTP.OPEN.CONNECTION 31416 . 32382) (\FTP.SENDVERSION 32384 . 32939) (\FTP.WHENCLOSED 32941 . 33388) (
\GETFTPCONNECTION 33390 . 34536) (\RELEASE.FTPCONNECTION 34538 . 34709) (\FTP.ERRORHANDLER 34711 .
36789) (\FTP.FIX.BROKEN.INPUT 36791 . 38498) (\FTP.CLEANUP 38500 . 39875) (\FTP.ASSURE.CLEANUP 39877
. 40124)) (40127 51207 (\FTP.HANDLE.NO 40137 . 43899) (\FTP.DIRECTORYNAMEONLY 43901 . 44153) (
\FTP.EOL.FROM.PLIST 44155 . 44500) (\FTP.MAKEPLIST 44502 . 44967) (\FTP.PRINTPLIST 44969 . 45734) (
\FTP.PACKFILENAME 45736 . 48010) (\FTP.PACK.DIRECTORYNAMEP 48012 . 48388) (\FTP.UNPACKFILENAME 48390
. 49565) (\FTP.ADD.USERINFO 49567 . 49875) (\FTP.FLUSH.TO.EOC 49877 . 50410) (\FTP.FLUSH.TO.MARK
50412 . 50718) (\FTPERROR 50720 . 51205)) (51208 53460 (FTPDEBUG 51218 . 51764) (FTPPRINTMARK 51766 .
52088) (FTPPRINTCODE 52090 . 52457) (FTPGETMARK 52459 . 52744) (FTPPUTMARK 52746 . 52901) (FTPPUTCODE
52903 . 53060) (FTPGETCODE 53062 . 53218) (FLUSH.FTPCONNECTIONS 53220 . 53458)))))
STOP