;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:10; Patch-File:T -*- ;;; Patch file for CDI version 1.15 ;;; Reason: ;;; Still more tape system patches. ;;; Written 10-Jul-86 14:49:05 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.13, microcode 1564, CDI Beta III. ; From file S2: >Lambda-3>TAPE>user.lisp.93 at 10-Jul-86 14:49:27 #10R TAPE#: #!:CL (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE"))) (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; USER  " (defun get-new-tape-name () (string-upcase (prompt-and-read :string-trim "~&Please input a name for the tape >> "))) )) ; From file S2: >Lambda-3>TAPE>user.lisp.93 at 10-Jul-86 14:49:29 #10R TAPE#: #!:CL (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE"))) (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; USER  " (defun prompt-for-tape-info (host logp) (do-forever (let* ((name (do ((val (get-new-tape-name) (get-new-tape-name))) ((y-or-n-p "~&Is ~S correct for the tape name? " val) val))) (log-file-default (fs:parse-pathname (format nil "~A:~A.backup-log#1" host name) host))) (when logp (do ((log-file (prompt-and-read `(:pathname :defaults ,log-file-default) "~&Backup log pathname (default \"~A\") >> " log-file-default) (prompt-and-read `(:pathname :defaults ,log-file-default) "~&Backup log pathname (default \"~A\") >> " log-file-default))) ((and (y-or-n-p "Is ~S correct for the log file pathname?" log-file) (if (condition-case () (probef log-file) (fs:directory-not-found (format t "~&Creating directory for ~A" log-file) (fs:create-directory log-file) nil)) (not (format t "~&Log file already exists! Starting again...")) (return-from prompt-for-tape-info (values name log-file))))))) (return-from prompt-for-tape-info name)))) )) ; From file S2: >Lambda-3>TAPE>user.lisp.93 at 10-Jul-86 14:49:31 #10R TAPE#: #!:CL (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE"))) (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; USER  " (defun backup-files (file-list host &key (set-backup-bits t) (compare t) (tape-info-function 'prompt-for-tape-info) (device-spec *selected-device*) (format-spec *selected-format*)) "This backs up the files in FILE-LIST to tape. Each element in the list must be a file truename (no wildcards) or a file property list. The files backed up will be compared and/or have their backup bits set as specified by the arguments. TAPE-INFO-FUNCTION takes no arguments and should return two values for each tape mounted: the tape name and the pathname for the log. It is called for each tape in the dump." (using-device (device device-spec) (using-format (format format-spec) (with-device-locked device (format t "~&Backing-up ~D files: ~:D total bytes" (length file-list) (let ((num 0)) (dolist (f file-list num) (incf num (* (get f :length-in-bytes) (/ (file-byte-size f) 8)))))) (do ((time (time:get-universal-time)) (files-to-backup file-list) failed-files) ((null files-to-backup) (when failed-files (format t "~&*** ~D files failed during access ***~%" (length failed-files))) (format t "~&~%*** Backup Finished ***~%") failed-files) (multiple-value-bind (tape-name log-file) (funcall (or tape-info-function 'prompt-for-tape-info) host t) (do* ((files files-to-backup (cdr files)) (file (car files) (car files)) bad-files files-to-log new-tape) ((or (null file) new-tape) (if (not new-tape) (format t "~&Last file written to tape.~%") (format t "~&End of tape encountered writing \"~A\". ~%~ Fixing last file on tape - " (car (send new-tape :file-plist))) (typecase new-tape (end-of-tape-writing-file (send format :beginning-of-file device) (send format :finish-tape device)) (end-of-tape-writing-header)) (format t "done.~%")) (send format :finish-tape device) (when compare (format t "~&Rewinding to compare ... ") (send format :rewind device) (format t "done.~2%Comparing files:~%") (do* ((vl (compare-files :format-spec format :device-spec device) (cdr vl)) (val (car vl) (car vl)) (count 0 (add1 count))) ((null vl)) (when (errorp val) (push val bad-files) (delq (nth count files-to-log) files-to-log))) (if (null bad-files) (format t "~&All files compared were equal.") (format t "~&*** Not all files were equal (bad files follow) ***") ;; +++ compare returns condition objects (at least in the case of "file not found" +++ (dolist (condition bad-files) (format t "~&~10@t~A~%" (send condition :source-file))) (format t "~&Make a note of these files and dump them again.~%") (y-or-n-p "Continue? "))) (setq files-to-backup files) (format t "~&Logging files - ") (log-files files-to-log host log-file `(:tape ,tape-name) (type-of format) user-id time) (format t "done.~%") (when (and set-backup-bits files-to-log) (format t "~&Setting backup bits ... ") (set-backup-bits files-to-log) (format t "done.~%")) (when files-to-backup (prompt-for-new-tape format device)) t) (condition-case (condition) (send format :write-file device file :end-of-tape-action :error) ((end-of-tape-writing-header end-of-tape-writing-file) (setq new-tape condition)) (fs:file-operation-failure (format t "~&*** Failed writing file: \"~s\". ***" (car file)) (push (cons (car file) condition) failed-files)) (:no-error (push file files-to-log)))))))))) )) ; From file S2: >Lambda-3>TAPE>lmfl-format.lisp.200 at 10-Jul-86 14:49:57 #10R TAPE#: #!:CL (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE"))) (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; LMFL-FORMAT  " (defmethod (lmfl-format :write-file) (device file &key (end-of-tape-action :continue) silent) (check-device device) (check-type file (or string pathname list)) (check-type end-of-tape-action (member :continue :error :return)) (let ((pathname (if (consp file) (fs:parse-pathname (car file)) (fs:parse-pathname file))) (properties (if (consp file) (cdr file)))) (with-open-file (instream pathname :direction :input :characters (or (getf properties :characters) :default)) (unless properties (setq properties (send instream :plist))) (block write-file (unless silent (format t "~&Writing file: ~a" pathname)) (Setq current-plist nil) (let ((props (check-plist-validity (or properties (send instream :plist)))) (byte-factor (/ (file-byte-size instream) 8)) (chunk-size (floor (send device :optimal-chunk-size record-size) record-size)) (truename (send instream :truename)) number-of-records last-record-fill) ;; +++ kludge to indicate byte size actually used to write the file to tape +++ ;; +++ problem occurs on unknown file types -- confusion about byte size +++ (nconc props (list :byte-size (file-byte-size instream))) (condition-case (condition) (send self :write-file-header device truename props) (physical-end-of-tape (ecase end-of-tape-action (:error (signal 'end-of-tape-writing-header :file-plist (cons nil props) :device device)) (:continue (setq tape-modified nil) (Get-Next-Tape "Physical end of tape. Continue on next tape. Unloading..." self device) (send self :write-file-header device truename props)) (:return (return-from write-file (make-condition 'end-of-tape-writing-header :file-plist (cons nil props) :device device)))))) (using-resource (buffer si:dma-buffer (* chunk-size (/ record-size *bytes-per-page*))) (multiple-value-bind (a b) (floor (* (send instream :length) byte-factor) record-size) (setq number-of-records (if (zerop b) a (add1 a)) last-record-fill (/ (if (zerop b) record-size b) byte-factor))) (do* ((record-count 0) (rs (/ record-size byte-factor)) (records-this-pass (min (- number-of-records record-count) chunk-size) (min (- number-of-records record-count) chunk-size)) (last-bunch (<= (- number-of-records record-count) chunk-size) (<= (- number-of-records record-count) chunk-size)) (buffer-array (ecase byte-factor (1 (si:dma-buffer-8b buffer)) (2 (si:dma-buffer-16b buffer))))) ((= record-count number-of-records) (condition-case (condition) (send device :write-filemark) (physical-end-of-tape)) t) (send instream :string-in nil buffer-array 0 (if (not last-bunch) (* records-this-pass rs) ;; stupid format lossage (array-initialize buffer-array 0 (+ (* (sub1 records-this-pass) rs) last-record-fill) (* records-this-pass rs)) (+ (* (sub1 records-this-pass) rs) last-record-fill))) (condition-case (condition) (send device :write-array buffer-array records-this-pass record-size) (physical-end-of-tape (ecase end-of-tape-action ((:error :return) (let ((cond (make-condition 'end-of-tape-writing-file :file-plist (cons nil props) :device device :bytes-transferred (* (+ record-count (send condition :data-transferred)) rs)))) (case end-of-tape-action (:return (return-from write-file cond)) (:error (signal cond))))) (:continue (setq tape-modified nil) (Get-Next-Tape "Physical end of tape encountered. Continue on next tape. Unloading..." self device) (let ((records-written (send condition :data-transferred))) (send self :write-file-header device (fs:parse-pathname "lm:continuation.file#0") (let ((bytes-left (- (or (send-if-handles instream :length-in-bytes) (send instream :length)) (* (+ record-count records-written) rs)))) (list :byte-size (file-byte-size props) :length-in-bytes bytes-left :length-in-blocks (ceiling (* bytes-left byte-factor) *bytes-per-page*) :continuation-properties props))) (using-resource (temp-buffer si:dma-buffer (* (- records-this-pass records-written) (/ rs *bytes-per-page*))) (copy-array-portion buffer-array (* records-written rs) (* records-this-pass record-size) (case byte-factor (1 (si:dma-buffer-8b temp-buffer)) (2 (si:dma-buffer-16b temp-buffer))) 0 (* (- records-this-pass records-written) rs)) (send device :write-array (si:dma-buffer-8b temp-buffer) (- records-this-pass records-written) record-size)) (incf record-count records-this-pass))))) (:no-error (incf record-count records-this-pass))))))))) ) ;;; Need to do a better job than this. (properties may be in a different order, etc.) )) ; From file S2: >Lambda-3>TAPE>lmfl-format.lisp.200 at 10-Jul-86 14:49:58 #10R TAPE#: #!:CL (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE"))) (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; LMFL-FORMAT  " (defmethod (lmfl-format :compare-file) (device &key transform silent (error-action :return)) (check-device device) (let* ((pl (send self :read-file-header device)) (max-chunk (send device :optimal-chunk-size record-size)) (pathname (if transform (process-transform transform pl) (car pl))) (length-in-bytes (or (get pl :length-in-bytes) (get pl :length) (get pl :size) ; for partitions (ferror nil "length in bytes is NIL!"))) (byte-factor (/ (file-byte-size pl) 8)) number-of-chunks last-chunk-size) (setq current-plist nil) (if (get pl :partition) (send self :compare-partition device pl silent) (if (not (condition-case (cond) (probef pathname) (fs:directory-not-found))) (let ((cond (make-condition 'compare-source-not-found :source-file pathname))) (send self :space-to-end-of-this-file device pl 0) (case error-action (:return (unless silent (format t "~&File \"~a\" not found for comparison" pathname)) cond) (:error (signal-condition cond)))) (block really-compare (multiple-value-bind (a b) (floor (* length-in-bytes byte-factor) max-chunk) (setq number-of-chunks (if (zerop b) a (add1 a)) last-chunk-size (if (zerop b) max-chunk b)) (with-open-file (f pathname :direction :input :characters :default) (using-resource (fbuffer si:dma-buffer (/ max-chunk *bytes-per-page*)) (using-resource (tbuffer si:dma-buffer (/ max-chunk *bytes-per-page*)) (unless silent (format t "~&Comparing \"~a\" ... " pathname)) (unless (and (= length-in-bytes (or (get f :length-in-bytes) (get f :length) (ferror nil "file's length in bytes is NIL!"))) (= (file-byte-size pl) (file-byte-size f)) (= (get pl :creation-date) (get f :creation-date)) (eq (get pl :characters) (get f :characters))) (let ((cond (make-condition 'compare-source-changed :source-plist (cons (send f :truename) (plist f)) :file-plist pl))) (unless silent (format t "[*** Not Compared ***]")) (send self :space-to-end-of-this-file device pl 0) (case error-action (:return (return-from really-compare cond)) (:error (signal-condition cond))))) (when (zerop length-in-bytes) (Setq current-plist nil) (condition-case (condition) (send device :space 1) ((filemark-encountered physical-end-of-tape))) (format t "[Zero Length]") (return-from really-compare pl)) (do* ((count 0 (add1 count)) (records-compared 0) (bytes-this-time ;note these are 8-bit bytes (if (= count (sub1 number-of-chunks)) last-chunk-size max-chunk) (if (= count (sub1 number-of-chunks)) last-chunk-size max-chunk)) (farray (case byte-factor (1 (si:dma-buffer-8b fbuffer)) (2 (si:dma-buffer-16b fbuffer)))) (fstring (si:dma-buffer-string fbuffer)) (tstring (si:dma-buffer-string tbuffer)) unequalp) ((or (= count number-of-chunks) unequalp) (if unequalp (let ((cond (make-condition 'compare-error :source-file (send f :truename) :file-plist pl))) (unless silent (format t "[*** Unequal ***]")) (ecase error-action (:return (send self :space-to-end-of-this-file device pl records-compared) cond) (:error (signal-condition cond)))) (unless silent (format t "[Equal]")) (Setq current-plist nil) (condition-case (condition) (send device :space 1) ((filemark-encountered physical-end-of-tape))) pl)) (send f :string-in nil farray 0 (/ bytes-this-time byte-factor)) (Setq current-plist nil) (condition-case (condition) (send device :read-array tstring (ceiling bytes-this-time record-size) record-size) (physical-end-of-tape (let* ((records-read (send condition :data-transferred)) (bytes-left (- bytes-this-time (* records-read record-size)))) (send self :find-continuation-tape device pl) (if (string-not-equal fstring tstring :end1 (- bytes-this-time bytes-left) :end2 (- bytes-this-time bytes-left)) (setq unequalp t records-compared (+ records-compared records-read)) (send device :read-array tstring (ceiling bytes-left record-size) record-size) (unless (string-equal fstring tstring :Start1 (- bytes-this-time bytes-left) :end1 bytes-this-time :end2 bytes-left) (setq unequalp t)) (incf records-compared (ceiling bytes-this-time record-size))))) (:no-error (unless (string-equal fstring tstring :start1 0 :end1 bytes-this-time :Start2 0 :end2 bytes-this-time) (setq unequalp t records-compared (ceiling bytes-this-time record-size))))))))))))))) )) ; From file S2: >Lambda-3>TAPE>user.lisp.93 at 10-Jul-86 14:50:00 #10R TAPE#: #!:CL (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE"))) (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; USER  " (defun select-format-from-tape (&optional (device-spec *selected-device*)) "This checks the tape and sets *selected-format* to an appropriate format object if the format for the tape is handled and can be determined." (using-device (device device-spec) (with-device-locked device (rewind :device-spec device-spec) (if (when *selected-format* (send *selected-format* :tape-is-your-format-p device)) (type-of *selected-format*) (block find-format (dolist (cons *tape-format-alist* (signal 'unknown-format :device-type (type-of device) :unit (send device :unit) :header-string (using-resource (buf si:dma-buffer 64) (send device :rewind) (prog1 (substring (si:dma-buffer-string buf) 0 (send device :read-array (si:dma-buffer-string buf) 1 (* 64 1024.))) (send device :rewind))))) (using-format (format (cdr cons)) (rewind :device-spec device-spec) (when (send format :tape-is-your-format-p device) (rewind :device-spec device-spec) (setq *selected-format* (make-instance (cdr cons))) (return-from find-format (cdr cons)))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Lisp level FileSystem backup interface ;;; ;;; )) ; From file S2: >Lambda-3>TAPE>tape.lisp.162 at 10-Jul-86 14:50:02 #10R TAPE#: #!:CL (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE"))) (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; TAPE  " (defun check-plist-validity (plist &optional (error-action *error-action-on-imperfect-tape-plists*)) ;; sometime in the system 99 beta release the filesystem and/or the magtape ;; code conspired to put bogus plists on the tape which would cause the filesystem ;; to barf when you tried to restore the tape. The magtape code has since been ;; corrected to never output bogus plists but we must make sure never the less. (let ((newplist (loop for x in plist collect (if (and (symbolp x) (not (memq x '(t nil)))) (intern (string x) pkg-keyword-package) x)))) (unless (equal newplist plist) (format *error-output* "~&Property list ~S was converted to have all KEYWORD symbols.~%" plist) (setq plist newplist))) (do ((*print-base* 10.) (new-plist) (l plist) (key)(value)(type)) ((null l) new-plist) (setq key (pop l) value (pop l)) (cond ((and (setq type (getf tape-file-property-type-plist key)) (not (typep value type))) (select error-action (:warn (cond ((and (not (eq (getf l key plist) plist)) (typep (getf l key) type)) ;; this seems to be the only case in fact. (format *error-output* "~&Key ~S had bogus value ~S was and duplicated~%" key value)) ('else (format *error-output* "~&Key ~S with bogus value ~S is being ignored~%" key value)))) (t (ferror nil "Key ~S with bogus value ~S" key value)))) ((eq (getf new-plist key plist) plist) (setf (getf new-plist key) value)) ('else (select error-action (:warn (format *error-output* "~&Duplicate key ~S with value ~S being ignored" key value)) (t (ferror nil "~&Duplicate key ~S with value ~S" key value))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Random helpful code ;;; ;;; ))