Google
 

Trailing-Edge - PDP-10 Archives - -
There are no other files named in the archive.
(FILECREATED "30-JAN-82 23:28:24" <LISPUSERS>FTP.;29 12973  

     changes to:  ARPAFTP CLOSEARPAFTP FINDFILEINLINE

     previous date: "19-DEC-80 00:35:31" <LISPUSERS>FTP.;28)


(* Copyright (c) 1982 by Xerox Corporation)

(PRETTYCOMPRINT FTPCOMS)

(RPAQQ FTPCOMS [(* enable access of files across network)
		(FNS CHECKREMOTEFILE CHANGEFILENAME FTPHELP)
		(FNS ARPAFTP FINDFILEINLINE ARPACMD CLOSEARPAFTP CMDREAD CMDREADCODE GETLINE 
		     DISCARDLINE)
		(P (MOVD? (QUOTE ARPAFTP)
			  (QUOTE FTP)))
		(* key off BAD FILE NAME error to detect attempt to access files with "{" in them. 
		   Curly brackets used instead of square because typing square brackets into lisp as 
		   part of atoms is a pain)
		(ALISTS (ERRORTYPELST 42))
		(VARS (FTPDEBUGFLG))
		(* GETFILENAME is in lisp-coded MSG)
		(ADVICE GETFILENAME)
		(ADDVARS (REMOTEINFOLST))
		(FILES NET PASSWORDS)
		(BLOCKS (NIL CHECKREMOTEFILE CHANGEFILENAME FTPHELP (LOCALVARS . T))
			(ARPAFTPBLOCK (ENTRIES ARPAFTP CLOSEARPAFTP)
				      ARPAFTP FINDFILEINLINE ARPACMD CLOSEARPAFTP CMDREAD CMDREADCODE 
				      GETLINE DISCARDLINE (SPECVARS INC OUTC FILE HOST)
				      (NOLINKFNS . T)
				      (GLOBALVARS FTPDEBUGFLG MACSCRATCHSTRING)))
		(DECLARE: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
						       NET))
		(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
										      (NLAML)
										      (LAMA FTPHELP])



(* enable access of files across network)

(DEFINEQ

(CHECKREMOTEFILE
  [LAMBDA (FILE)                   (* lmm "18-DEC-80 19:59")
    (RESETVARS (HELPFLAG (DIRFIELDS DIRFIELDS))
	       (RETURN
		 (PROG (POS REMOTEFILE MODE RFLG TEM BYTESIZE HOST REMOTENAME COPYFLG)
		   LP  (COND
			 ((AND
			     (LITATOM FILE)
			     (EQ (NTHCHAR FILE 1)
				 (QUOTE {))
			     (SETQ POS (STRPOS "}" FILE 2))
			     (SELECTQ
			       (STKNAME ERRORPOS)
			       (INFILE (SETQ MODE (QUOTE INPUT)))
			       ((OUTFILE DRIBBLE)
				 (SETQ MODE (QUOTE OUTPUT)))
			       [OPENFILE (SETQ RFLG T)
					 (SETQ BYTESIZE (STKARG 4 ERRORPOS))
					 (FMEMB (SETQ MODE (STKARG 2 ERRORPOS))
						(QUOTE (INPUT OUTPUT]
			       [OPENF (SETQ RFLG T)
				      (COND
					((FIXP (SETQ TEM (STKARG 2 ERRORPOS)))
					  (SETQ BYTESIZE (LRSH TEM 30))
					  (SETQ MODE (COND
					      ((IEQP 32768 (LOGAND TEM 1073741823))
						(QUOTE OUTPUT))
					      ((IEQP 65536 (LOGAND TEM 1073741823))
						(QUOTE INPUT]
			       [DIRECTORY
				 [SETQ DIRFIELDS
				   (PROG ((I 0))
				         (RETURN
					   (for X_COMMANDS by (CDR X) while X
					      join
					       (SELECTQ (CAR X)
							(P (PROG1 (LIST (LIST (QUOTE NAME-BODY)
									      I 0)
									";"
									(QUOTE (VERSION 0 T)))
								  (add I 20)))
							(COND
							  ((SETQ TEM (FASSOC (CAR X)
									     REMOTEINFOLST))
							    (LIST (LIST (CADR TEM)
									(PROG1 I (add I (CADDR TEM)))
									1)))
							  (T (printout T 
								"Remote directory specification "
								       (CAR X)
								       " ignored." T)
							     NIL]
				 (SETQ RFLG (SETQ MODE (QUOTE DIRECTORY]
			       NIL))
			   [SETQ HOST (MKATOM (SUBSTRING FILE 2 (COND
							   ((EQ (NTHCHAR FILE (SUB1 POS))
								(QUOTE :))
							     (SETQ COPYFLG T)
							     (IDIFFERENCE POS 2))
							   (T (SUB1 POS)))
							 (CONSTANT (CONCAT]
			   (OR [SETQ REMOTEFILE (SUBSTRING FILE (ADD1 POS)
							   -1
							   (CONSTANT (CONCAT]
			       (AND (EQ MODE (QUOTE DIRECTORY))
				    (SETQQ REMOTEFILE *.*)))
			   (COND
			     (COPYFLG 
                                   (* copy to local file)

          (* * NOT IMPLEMENTED YET * *)


				      ))
			   (COND
			     [(NLSETQ (SETQ REMOTEFILE (FTP HOST REMOTEFILE MODE NIL NIL NIL BYTESIZE)
					))
			       (COND
				 (RFLG (RETFROM ERRORPOS REMOTEFILE T))
				 (T (RETURN REMOTEFILE]
			     (T (SETQ ERRORMESS (ERRORN))
				(COND
				  ((EQ (CAR ERRORMESS)
				       42)
				    (ERROR!])

(CHANGEFILENAME
  (LAMBDA (F1 F2 OUTFLG)                (* lmm "26-MAY-78 03:41")

          (* Kludge of the week -
	  I don't think you want to know what this does)


    (ASSEMBLE NIL
	      (CQ F1)
	      (CQ2 OUTFLG)
	      (CAME 2 , KNIL)
	      (JRST OU)
	      (FASTCALL IFSET)
	      (JRST GOT)
	  OU  (MOVEI 2 , 0 (1))
	      (FASTCALL OFSET)
	  GOT (CQ F2)
	      (HRRM 1 , FILEA (FX)))    (* for WHENCLOSE)
    (SETPROPLIST F2 (GETPROPLIST F1))
    (SETPROPLIST F1)
    F2))

(FTPHELP
  (LAMBDA ARG                                               (* lmm "16-OCT-78 02:56")
    (ERROR (OR ARG FILE)
	   " unrecognized response from remote FTP server")))
)
(DEFINEQ

(ARPAFTP
  [LAMBDA (HOST FILE ACCESS USER PWD ACCT BYTESIZE)
                                   (* lmm "30-JAN-82 23:14")
    (RESETLST
      (PROG [INC OUTC FIL FORM TMP P1 LINE (CONNECTION (MAKENEWCONNECTION HOST (QUOTE NET)
									  (QUOTE FTP]
	    (DECLARE (SPECVARS INC OUTC))
	    (RESETSAVE NIL (SETQ FORM (LIST (FUNCTION CLOSECONNECTION)
					    CONNECTION)))
	    (SETQ INC (CAR CONNECTION))
	    (SETQ OUTC (CADR CONNECTION))
	    (ARPACMD NIL NIL 300)
	    (SELECTQ (ARPACMD "USER" [OR USER (PROGN (SETQ TMP (LOGIN (MKATOM HOST)
								      (QUOTE QUIET)
								      NIL))
						     (SETQ PWD (CDR TMP))
						     (SETQ USER (CAR TMP]
			      (QUOTE (330 230)))
		     (230 NIL)
		     (330 (SELECTQ (ARPACMD "PASS" (OR PWD (USERNAME))
					    (QUOTE (230 331)))
				   (230 NIL)
				   (331 (ARPACMD "ACCT" (OR ACCT 1)
						 230))
				   (FTPHELP)))
		     NIL)
	    [AND ACCT (ARPACMD "ACCT" ACCT (QUOTE (230 200]
	    (SELECTQ BYTESIZE
		     ((8 7 NIL)    (* assume text)
		       (SETQ BYTESIZE))
		     [(36 32)
		       (ARPACMD "BYTE" (MKSTRING BYTESIZE)
				(QUOTE (200 331)))
		       (ARPACMD "TYPE" (QUOTE I)
				(QUOTE (200 331]
		     (ERROR BYTESIZE "ILLEGAL BYTE SIZE"))
	    (SELECTQ ACCESS
		     (DELETE (ARPACMD "DELE" FILE NIL NIL 254)
			     (RETURN (OR (FINDFILEINLINE "file " (GETLINE INC))
					 FILE)))
		     (ARPACMD (SELECTQ ACCESS
				       (OUTPUT "STOR")
				       (INPUT "RETR")
				       (LIST "NLST")
				       (DIRECTORY "LIST")
				       (DELETE "DELE")
				       (ERRORX (LIST 27 ACCESS)))
			      FILE NIL NIL 255))
	    (OR (EQ (RATOM INC)
		    (QUOTE SOCK))
		(FTPHELP))
	    (SETQ FIL (ARPAOPENF 6 HOST (RATOM INC)
				 (SELECTQ ACCESS
					  ((LIST DIRECTORY)
					    (QUOTE INPUT))
					  ACCESS)
				 (OR BYTESIZE 8)))
	    (DISCARDLINE INC)
	    (PUTPROP FIL (QUOTE CONNECTION)
		     (CADR FORM))
	    (WHENCLOSE FIL (QUOTE AFTER)
		       (FUNCTION CLOSEARPAFTP))
	    (ARPACMD NIL NIL NIL NIL 250)
	    (SETQ LINE (GETLINE INC))
	    (RETURN
	      (PROG1 (SELECTQ
		       ACCESS
		       (DIRECTORY (COPYBYTES FIL)
				  (CLOSEF FIL)
				  NIL)
		       (LIST (while [NLSETQ (SETQ TMP
					      (READ FIL (DEFERREDCONSTANT
						      (PROG [(R (COPYREADTABLE (QUOTE ORIG]
							    (SETBRK NIL NIL R)
							    (SETSYNTAX (QUOTE %%)
								       (QUOTE OTHER)
								       R)
							    (SETSEPR (QUOTE (13 10 31))
								     NIL R)
							    (RETURN R]
				collect (LIST TMP)))
		       [INPUT (CHANGEFILENAME FIL (PACK* (QUOTE {)
							 HOST
							 (QUOTE })
							 (OR (FINDFILEINLINE (QUOTE (" retrieve of "
										      "Here comes "))
									     LINE)
							     FILE]
		       (OUTPUT (PUTPROP FIL (QUOTE OUTPUT)
					T)
			       (CHANGEFILENAME FIL
					       (PACK* (QUOTE {)
						      HOST
						      (QUOTE })
						      (COND
							[(SETQ P1
							    (STRPOS "Store of " LINE NIL NIL NIL T))
							  (SUBSTRING LINE P1
								     (SUB1 (OR (STRPOS ";P" LINE P1)
									       (STRPOS " " LINE P1)
									       0]
							(T FILE)))
					       T))
		       (SHOULDNT))
		     (FRPLACA FORM (FUNCTION NILL])

(FINDFILEINLINE
  [LAMBDA (STRS LINE)              (* lmm "16-OCT-78 02:49")
    (for STR inside STRS bind P1 when (SETQ P1 (STRPOS STR LINE NIL NIL NIL T))
       do [SETQ LINE (SUBSTRING LINE P1 (SUB1 (OR (STRPOS " " LINE P1)
						  0]
	  (COND
	    ((EQ (NTHCHAR LINE -1)
		 (QUOTE %.))
	      (GLC LINE)))
	  (RETURN (MKATOM LINE])

(ARPACMD
  (LAMBDA (CMD ARG WANT DISCARD WANTARG)                    (* lmm "16-OCT-78 02:57")
    (PROG NIL
          (COND
	    (CMD (COND
		   (FTPDEBUGFLG (PRIN3 CMD FTPDEBUGFLG)
				(PRIN3 " " FTPDEBUGFLG)
				(PRIN3 ARG FTPDEBUGFLG)))
		 (PRIN3 CMD OUTC)
		 (PRIN3 " " OUTC)
		 (PRIN3 ARG OUTC)
		 (TERPRI OUTC)
		 (JS MTOPR (OPNJFN OUTC)
		     21Q)                                   (* flush)
		 (COND
		   (FTPDEBUGFLG (TERPRI FTPDEBUGFLG)))))
      LP  (COND
	    (FTPDEBUGFLG (PRIN3 "< " FTPDEBUGFLG)))
          (SETQ CMD (CMDREADCODE INC))
          (COND
	    ((EQMEMB CMD WANTARG)
	      (AND (EQ (CMDREAD INC)
		       (QUOTE -))
		   (FTPHELP))
	      (RETURN CMD)))
          (COND
	    ((EQ (CMDREAD INC)
		 (QUOTE -))
	      (do (DISCARDLINE INC) repeatuntil (EQ (CMDREADCODE INC)
						    CMD))))
          (COND
	    ((EQMEMB CMD WANT)
	      (DISCARDLINE INC)
	      (RETURN CMD))
	    ((EQMEMB CMD DISCARD)
	      (DISCARDLINE INC)
	      (GO LP)))
          (SELECTQ (AND (FIXP CMD)
			(IQUOTIENT CMD 100))
		   ((2 3)
		     (FTPHELP CMD))
		   ((4 5)
		     (ERROR (GETLINE INC T)))
		   NIL)
          (DISCARDLINE INC)
          (GO LP))))

(CLOSEARPAFTP
  [LAMBDA (X)                      (* lmm "24-SEP-78 02:41")
    (PROG ((CONN (GETP X (QUOTE CONNECTION)))
	   INC OUTC)
          (COND
	    (CONN [COND
		    ((AND (GETP X (QUOTE OUTPUT))
			  (CHECKCONNECTION CONN))
		      (SETQ INC (CAR CONN))
		      (SETQ OUTC (CADR CONN))
		      (ARPACMD "BYE" "" (QUOTE (231 232))
			       (QUOTE (257 252]
		  (CLOSECONNECTION CONN)
		  (REMPROPLIST X (QUOTE (OUTPUT CONNECTION])

(CMDREAD
  (LAMBDA (IN)                                              (* lmm "31-MAY-78 00:47")
    ((LAMBDA (CH)
	(COND
	  (FTPDEBUGFLG (PRIN3 CH FTPDEBUGFLG)))
	CH)
      (READC IN))))

(CMDREADCODE
  (LAMBDA (IN)                                              (* lmm "31-MAY-78 00:45")
    (PACK* (CMDREAD IN)
	   (CMDREAD IN)
	   (CMDREAD IN))))

(GETLINE
  (LAMBDA (IN FLG)                                          (* lmm "31-MAY-78 00:46")
    (bind CH for POS from 1 while (NEQ (SETQ CH (CMDREAD IN))
				       (QUOTE %
))
       do (RPLSTRING MACSCRATCHSTRING POS CH) finally (SETQ CH (SUBSTRING MACSCRATCHSTRING 1
									  (SUB1 POS)
									  (CONSTANT (CONCAT))))
						      (RETURN (COND
								(FLG (CONCAT CH))
								(T CH))))))

(DISCARDLINE
  (LAMBDA (IN)                                              (* lmm "31-MAY-78 00:45")
    (until (EQ (CMDREAD IN)
	       (QUOTE %
)))))
)
(MOVD? (QUOTE ARPAFTP)
       (QUOTE FTP))



(* key off BAD FILE NAME error to detect attempt to access files with "{" in them. Curly 
brackets used instead of square because typing square brackets into lisp as part of atoms is a 
pain)


(ADDTOVAR ERRORTYPELST (42 (CHECKREMOTEFILE (CADR ERRORMESS))))

(RPAQQ FTPDEBUGFLG NIL)



(* GETFILENAME is in lisp-coded MSG)


(PUTPROPS GETFILENAME READVICE [NIL (BEFORE NIL
					    (COND
					      ((EQ (PEEKC T)
						   (QUOTE {))
					       (RETURN (PROG ((NM (READ T)))
							     (RETURN (COND
								       ((FILENAMEFIELD NM
										       (QUOTE DEVICE))
									NM)
								       (T (PACKFILENAME (QUOTE BODY)
											NM
											(QUOTE NAME)
											NAME
											(QUOTE 
											EXTENSION)
											EXT
											(QUOTE 
											DIRECTORY)
											USERNAME])

(ADDTOVAR REMOTEINFOLST )
(FILESLOAD NET PASSWORDS)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: NIL CHECKREMOTEFILE CHANGEFILENAME FTPHELP (LOCALVARS . T))
(BLOCK: ARPAFTPBLOCK (ENTRIES ARPAFTP CLOSEARPAFTP)
	ARPAFTP FINDFILEINLINE ARPACMD CLOSEARPAFTP CMDREAD CMDREADCODE GETLINE DISCARDLINE
	(SPECVARS INC OUTC FILE HOST)
	(NOLINKFNS . T)
	(GLOBALVARS FTPDEBUGFLG MACSCRATCHSTRING))
]
(DECLARE: EVAL@COMPILE DONTCOPY 
(FILESLOAD (LOADCOMP)
	   NET)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA )

(ADDTOVAR NLAML )

(ADDTOVAR LAMA FTPHELP)
)
(DECLARE: DONTCOPY (PUTPROPS FTP COPYRIGHT ("Xerox Corporation" 1982)))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (1514 4824 (CHECKREMOTEFILE 1526 . 4102) (CHANGEFILENAME 4106 . 4632) (FTPHELP 4636 . 
4821)) (4826 11340 (ARPAFTP 4838 . 8182) (FINDFILEINLINE 8186 . 8559) (ARPACMD 8563 . 9841) (
CLOSEARPAFTP 9845 . 10309) (CMDREAD 10313 . 10516) (CMDREADCODE 10520 . 10707) (GETLINE 10711 . 11160)
 (DISCARDLINE 11164 . 11337)))))
STOP