(FILECREATED "19-Dec-84 15:25:13" {ERIS}<LISPNEW>PATCHES>FTPPATCH.;1 24032
changes to: (VARS FTPPATCHCOMS))
(* Copyright (c) 1984 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT FTPPATCHCOMS)
(RPAQQ FTPPATCHCOMS ((FNS \FTP.GENERATEFILES \FTP.DELETEFILE \FTP.OPENFILE.FROM.PLIST
\FTP.RECOGNIZEFILE \FTP.HANDLE.NO \FTP.PACKFILENAME)))
(DEFINEQ
(\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.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.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.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.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.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])
)
(PUTPROPS FTPPATCH COPYRIGHT ("Xerox Corporation" 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (375 23953 (\FTP.GENERATEFILES 385 . 9074) (\FTP.DELETEFILE 9076 . 11968) (
\FTP.OPENFILE.FROM.PLIST 11970 . 15198) (\FTP.RECOGNIZEFILE 15200 . 17911) (\FTP.HANDLE.NO 17913 .
21675) (\FTP.PACKFILENAME 21677 . 23951)))))
STOP