;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*- ;;; Patch file for CDI version 1.22 ;;; Reason: ;;; Check VERBOSE flag before printing Byte Size info on copy file. ;;; Written 22-Jul-86 13:07:34 by Gibson at site CDI Dallas ;;; while running on EXPLORER-1 from band 1 ;;; with System 110.232, Lambda-Diag 7.17, Experimental Local-File 68.7, FILE-Server 18.4, Unix-Interface 9.1, ZMail 65.14, Object Lisp 3.4, Tape 6.39, Site Data Editor 3.3, Tiger 24.0, KERMIT 31.3, Gateway 4.15, TCP-Kernel 39.7, TCP-User 62.7, TCP-Server 45.5, MEDIUM-RESOLUTION-COLOR 3.4, MICRO-COMPILATION-TOOLS 3.2, System Revision Level 3.93, Experimental Window-Maker 2.0, Experimental CDI 1.21, microcode 1564, CDI Beta III. ; From file S2: >Lambda-3>TAPE>copy.lisp.160 at 22-Jul-86 13:07:35 #8R FILE-SYSTEM#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM"))) (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; COPY  " (DEFUN FS-COPY-FILE (FROM TO &REST OPTIONS &KEY &OPTIONAL OVERWRITE (VERBOSE T) DELETE AFTER DIRECTORY-LIST DEFAULT-BYTE-SIZE OUTPUT-DIRECTORY-LIST (CREATE-DIRECTORY T) &ALLOW-OTHER-KEYS &AUX TRUE-BYTE-SIZE KNOWN-BYTE-SIZE TRUE-CHARACTERS TRUENAME OUTNAME OUTNAME-UNCERTAIN TYPE QFASLP INSTREAM OUTSTREAM (ABORT-FLAG ':ABORT) FROM-IS-STREAM-P TO-DEFAULTS-FROM-STREAM AUTHOR TEM) (*CATCH 'COPY-FILE (UNWIND-PROTECT (PROG () (COND ((STRINGP FROM)) ((TYPEP FROM 'PATHNAME)) ((SI:IO-STREAM-P FROM) (SETQ FROM-IS-STREAM-P T) (SETQ INSTREAM FROM))) ;; If possible, get the byte size from the directory info. (COND (DIRECTORY-LIST (IF (NULL FROM-IS-STREAM-P) (SETQ TRUENAME FROM)) (SETF (VALUES OUTNAME OUTNAME-UNCERTAIN TO-DEFAULTS-FROM-STREAM) (DETERMINE-COPY-DESTINATION TO TRUENAME NIL INSTREAM)) ;; Punt now if :AFTER specification is not met. (AND AFTER ( (GET (LOCF DIRECTORY-LIST) ':CREATION-DATE) AFTER) (RETURN ':AFTER)) ;; Verbosify after calling DETERMINE-COPY-DESTINATION. (IF VERBOSE (FORMAT T "~%~A~23T ~A~50T" (IF FROM-IS-STREAM-P "" TRUENAME) OUTNAME)) ;; If we are sure we know the destination name, ;; and we have an output directory list, check now ;; in case we don't need to copy. (OR TO-DEFAULTS-FROM-STREAM OUTNAME-UNCERTAIN (AND OUTPUT-DIRECTORY-LIST (LET ((DESTEX (COPY-DESTINATION-EXISTS-P OVERWRITE OUTPUT-DIRECTORY-LIST OUTNAME TRUENAME VERBOSE (OR (GET (LOCF DIRECTORY-LIST) ':CREATION-DATE) (FUNCALL INSTREAM ':CREATION-DATE))))) (AND DESTEX (RETURN DESTEX))))) (LET ((CHRLOC (LOCF (GET (LOCF DIRECTORY-LIST) ':CHARACTERS)))) (AND CHRLOC (SETQ TRUE-CHARACTERS (CDR CHRLOC)))) ;; Take :DIRECTORY-LIST information with a grain of salt... ;; Note that we are assuming here that the files are used for LISPMs... (LET ((POSSIBLE-BYTE-SIZE (GET (LOCF DIRECTORY-LIST) ':BYTE-SIZE))) (AND POSSIBLE-BYTE-SIZE (COND ((EQ POSSIBLE-BYTE-SIZE 7.) (SETQ TRUE-BYTE-SIZE 8.)) ((NEQ POSSIBLE-BYTE-SIZE 36.) (SETQ TRUE-BYTE-SIZE POSSIBLE-BYTE-SIZE))))))) ;; Next try opening the file. (COND ((NULL FROM-IS-STREAM-P) (SETQ INSTREAM (OPEN FROM ':CHARACTERS (OR TRUE-CHARACTERS ':DEFAULT) ':BYTE-SIZE (OR TRUE-BYTE-SIZE ':DEFAULT) ':ERROR NIL)) (COND ((ERRORP INSTREAM) (AND VERBOSE (FORMAT T"~%~A~50T~A" FROM INSTREAM)) (RETURN INSTREAM))))) ;; Punt now if :AFTER specification is not met. (AND AFTER ( (OR (GET (LOCF DIRECTORY-LIST) ':CREATION-DATE) (FUNCALL INSTREAM ':CREATION-DATE) (FERROR NIL "Bletch!!")) AFTER) (RETURN ':AFTER)) (IF (NULL FROM-IS-STREAM-P) (SETQ TRUENAME (FUNCALL INSTREAM :send-if-handles :TRUENAME))) (SETQ QFASLP (FUNCALL INSTREAM ':QFASLP)) ;; Now determine the destination if not done already. (IF (OR (NULL OUTNAME) OUTNAME-UNCERTAIN) (PROGN (MULTIPLE-VALUE (OUTNAME TEM TO-DEFAULTS-FROM-STREAM) (DETERMINE-COPY-DESTINATION TO TRUENAME QFASLP INSTREAM)) (AND VERBOSE (FORMAT T "~%~A~23T ~A~50T" TRUENAME OUTNAME)))) ;; Does the output file already exist? Is its date the same? ;; Check now if we didn't check before. (AND (NULL TO-DEFAULTS-FROM-STREAM) (OR OUTNAME-UNCERTAIN (NOT OUTPUT-DIRECTORY-LIST)) (LET ((DESTEX (COPY-DESTINATION-EXISTS-P OVERWRITE OUTPUT-DIRECTORY-LIST OUTNAME TRUENAME VERBOSE (OR (GET (LOCF DIRECTORY-LIST) ':CREATION-DATE) (FUNCALL INSTREAM ':CREATION-DATE))))) (when DESTEX (setq abort-flag nil) ;don't close in abort mode. (RETURN DESTEX)))) ;; If we knew the byte size before opening the stream, remember that fact. (SETQ KNOWN-BYTE-SIZE TRUE-BYTE-SIZE) (SETQ TYPE (IF (null truename) (FUNCALL INSTREAM ':TYPE) (FUNCALL TRUENAME ':TYPE))) (OR TRUE-BYTE-SIZE ;; If stream knows its proper byte size, believe it. QFILE streams don't. (AND (SETQ TRUE-BYTE-SIZE (FUNCALL INSTREAM ':SEND-IF-HANDLES ':BYTE-SIZE)) ;; If it knows that, it also did :characters :default properly. (PROGN (SETQ TRUE-CHARACTERS (FUNCALL INSTREAM ':CHARACTERS)) T)) ;; Otherwise guess. (SETQ TRUE-BYTE-SIZE (COND ((or QFASLP (MEMBER TYPE BINARY-FILE-TYPES) (string-search "QFASL" type)) ;temporary kludgery, because QFASLP is ALWAYS nil. ; I will fix it later. This function should eventualy ; get thrown away. -dg 16.) ((MEMBER TYPE PDP10-FILE-TYPES) 9) ((FILE-EXTRACT-ATTRIBUTE-LIST INSTREAM) 8) ((OR (MEMQ TYPE '(NIL :UNSPECIFIC)) (MEMBER TYPE CHARACTER-FILE-TYPES)) 8) (DEFAULT-BYTE-SIZE) ((Y-OR-N-P (FORMAT NIL "~%Is ~A a CHARACTER File? " TRUENAME)) 8) (T 16.)))) (OR TRUE-CHARACTERS (SETQ TRUE-CHARACTERS (= TRUE-BYTE-SIZE 8))) (When verbose (FORMAT T "~%Byte size ~D, Characters ~S" TRUE-BYTE-SIZE TRUE-CHARACTERS)) ;; If stream is open in wrong byte size or with wrong :characters, reopen it. (OR FROM-IS-STREAM-P (AND (OR KNOWN-BYTE-SIZE (= TRUE-BYTE-SIZE (OR (FUNCALL INSTREAM ':SEND-IF-HANDLES ':BYTE-SIZE) (IF (FUNCALL INSTREAM ':CHARACTERS) 8 16.)))) (EQ TRUE-CHARACTERS (FUNCALL INSTREAM ':CHARACTERS))) (PROGN (PRINC " -- Must reopen stream" *ERROR-OUTPUT*) (CLOSE INSTREAM) (SETQ INSTREAM (OPEN TRUENAME ':ERROR NIL ':BYTE-SIZE TRUE-BYTE-SIZE ':CHARACTERS (= TRUE-BYTE-SIZE 8))) (COND ((ERRORP INSTREAM) (AND VERBOSE (FORMAT T "~%~A~50T~A" FROM INSTREAM)) (RETURN INSTREAM))))) (SETQ AUTHOR (OR (GET (LOCF DIRECTORY-LIST) :AUTHOR) (FUNCALL INSTREAM :GET :AUTHOR) (IF (NULL FROM-IS-STREAM-P) (DETERMINE-FILE-AUTHOR (FUNCALL INSTREAM :TRUENAME))) "Unknown")) OPEN-OUTPUT ;; Do It. (COND ((ERRORP (SETQ OUTSTREAM (COND (TO-DEFAULTS-FROM-STREAM (LEXPR-FUNCALL OUTNAME ':OPEN OUTNAME ':DIRECTION ':OUTPUT ':ERROR NIL ':CHARACTERS TRUE-CHARACTERS ':BYTE-SIZE TRUE-BYTE-SIZE ':DEFAULTS-FROM-STREAM INSTREAM ':AUTHOR AUTHOR (cond ((memq ':record-size options) `(:record-size ,(get (locf options) ':record-size))) (t nil)))) (T (OPEN OUTNAME (COND ((EQ TRUE-BYTE-SIZE 8.) '(:WRITE :NOERROR)) ((EQ TRUE-BYTE-SIZE 16.) '(:WRITE :FIXNUM :NOERROR)) (T `(:WRITE :NOERROR :BYTE-SIZE ,TRUE-BYTE-SIZE))) ))))) (AND CREATE-DIRECTORY (NOT (ERRORP (CREATE-DIRECTORY OUTNAME ':ERROR NIL))) (GO OPEN-OUTPUT)) (AND VERBOSE (FUNCALL OUTSTREAM ':REPORT STANDARD-OUTPUT)) (RETURN OUTSTREAM))) ;; This now hacks arbitrary property stuff... (IF TO-DEFAULTS-FROM-STREAM NIL (FUNCALL OUTSTREAM ':CHANGE-PROPERTIES NIL ':AUTHOR AUTHOR ':CREATION-DATE (FUNCALL INSTREAM ':GET ':CREATION-DATE)) (LOOP WITH other-properties = (or directory-list (copylist (funcall instream ':property-list))) AS remove-properties = (funcall outstream ':property-list) THEN (cddr remove-properties) WHILE (and remove-properties other-properties) DO (remprop (locf other-properties) (car remove-properties)) FINALLY (dolist (p '(:directory :name :version :type)) (remprop (locf other-properties) p)) FINALLY (cond (other-properties (lexpr-funcall outstream ':CHANGE-PROPERTIES NIL other-properties))))) (STREAM-COPY-UNTIL-EOF INSTREAM OUTSTREAM NIL) (SETQ ABORT-FLAG NIL)) (OR (NULL OUTSTREAM) (ERRORP OUTSTREAM) (FUNCALL OUTSTREAM ':CLOSE ABORT-FLAG)) (OR (NULL INSTREAM) (ERRORP INSTREAM) (PROGN (AND (NOT ABORT-FLAG) DELETE (FUNCALL INSTREAM ':SEND-IF-HANDLES ':DELETE NIL)) (FUNCALL INSTREAM ':CLOSE ABORT-FLAG)))))) ))