(FILECREATED " 9-Jan-85 12:27:06" {ERIS}<LISPNEW>PATCHES>TOPS20FTPPATCH.;1 9062
changes to: (VARS TOPS20FTPPATCHCOMS)
(FNS \FTP.GENERATEFILES))
(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT TOPS20FTPPATCHCOMS)
(RPAQQ TOPS20FTPPATCHCOMS ((FNS \FTP.GENERATEFILES)))
(DEFINEQ
(\FTP.GENERATEFILES
[LAMBDA (DEVICE PATTERN DESIREDPROPS OPTIONS) (* bvm: " 9-Jan-85 12:26")
(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)))
(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])
)
(PUTPROPS TOPS20FTPPATCH COPYRIGHT ("Xerox Corporation" 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (330 8977 (\FTP.GENERATEFILES 340 . 8975)))))
STOP