;;; -*- Mode:Lisp; Readtable:CL; Package:USER; Base:10; Patch-File:T -*- ;;; Patch file for CDI version 1.14 ;;; Reason: ;;; More patches to tape system, including patches from LMI Cambridge. ;;; Written 10-Jul-86 14:01:35 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>lmfl-format.lisp.199 at 10-Jul-86 14:01:42 #10R TAPE#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE"))) (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; LMFL-FORMAT  " (defmethod (lmfl-format :restore-partition) (plist device silent) (check-plist plist) (check-device device) (let ((size (get plist :size)) (comment (or (get plist :comment) (get plist :name)))) (multiple-value-bind (host unit start ignore ignore name) (When (yes-or-no-p "Restore Partition ~s? " comment) (partition-searcher (format nil "for writing partition ~a" comment) size :confirm-write t :default-unit tframe:*default-disk-unit*)) ;; +++ (unwind-protect (if (null host) (progn (format t "~&*** User Aborted restoring partition: ~s ***" comment) (send self :space-to-end-of-this-file device plist 0)) (si:update-partition-comment name "Incomplete Copy" unit) (do ((first-block start) (blocks size) finished?) (finished?) (Setq current-plist nil) (condition-case (condition) (send device :read-to-disk unit first-block blocks record-size :silent silent) (physical-end-of-tape (Get-Next-Tape "Partition continued on another tape. Unloading..." self device) (Let ((dt (send condition :data-transferred))) (incf first-block dt) (decf blocks dt))) (:no-error (si:update-partition-comment name (or (get plist :comment) "??? from tape") unit) (condition-case (condition) (send device :search-filemark 1 :high) (physical-end-of-tape)) (setq finished? t))))) (when unit (si:dispose-of-unit unit)))))) )) ; From file S2: >Lambda-3>TAPE>lmfl-format.lisp.199 at 10-Jul-86 14:01:46 #10R TAPE#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE"))) (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; LMFL-FORMAT  " (defmethod (lmfl-format :write-file-header) (device truename attribute-list) (check-device device) (check-type truename pathname) (check-attribute-list attribute-list) (let* ((*print-base* 10.) (plist (nconc (unless (getf attribute-list :partition) (list :device (pathname-device truename) :directory (pathname-directory truename) :name (pathname-name truename) :type (pathname-type truename) :version (pathname-version truename))) attribute-list)) (string (format nil "LMFL~S" plist))) (using-resource (header-block si:dma-buffer (/ record-size *bytes-per-page*)) (copy-array-contents string (si:dma-buffer-string header-block)) (Setq current-plist nil) (setq tape-modified t) (send device :write-block header-block record-size)))) )) ; From file S2: >Lambda-3>TAPE>lmfl-format.lisp.199 at 10-Jul-86 14:01:48 #10R TAPE#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE"))) (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; LMFL-FORMAT  " (defmethod (lmfl-format :write-partition) (partition-name device unit-arg &key silent end start) (check-type partition-name string) (check-type start (or null (integer 0))) (check-type end (or (integer 0) (member t nil))) (check-device device) (check-type unit-arg (or (integer 0) string closure)) (si:with-decoded-disk-unit (unit unit-arg "for reading partition") (multiple-value-bind (beg length nil name) (si:find-disk-partition partition-name nil unit) (unless beg (ferror 'no-such-partition :host (unit-host unit) :disk-unit (unit-number unit) :partition partition-name)) (setq start (or start beg) end (cond ((null end) (+ (or (si:measured-from-part-size unit name beg length) length) start)) ((integerp end) (+ start end)) (t (+ beg length)))) (unless (and (< start end) (>= start beg) (<= end (+ beg length))) (ferror nil "Partition start or end specifications out of bounds.")) (Setq current-plist nil) (using-resource (buffer si:dma-buffer (/ record-size *bytes-per-page*)) (let ((*print-base* 10.) (plist (list :partition t :name name :size (- end start) :comment (si:partition-comment name unit) :byte-size 16. :host (send (unit-host unit) :name) :host-unit (unit-number unit) :creation-date (time:get-universal-time)))) (copy-array-contents (format nil "LMFL~s" plist) (si:dma-buffer-string buffer)) (setq tape-modified t) (with-device-locked device (send device :write-block buffer record-size))) (do ((addr start) (blocks-to-write (* (ceiling (- end start) 4.) 4))) ((zerop blocks-to-write)) (with-device-locked device (condition-case (condition) (send device :write-from-disk unit addr blocks-to-write record-size :silent silent) (physical-end-of-tape (setq tape-modified nil) (Get-Next-Tape "End of tape during partition. Unloading tape..." self device) (Let ((data-transferred (send condition :data-transferred))) (Incf addr data-transferred) (Decf blocks-to-write data-transferred))) (:no-error (setq blocks-to-write 0) (condition-case () (send device :write-filemark) (physical-end-of-tape)))))))))) )) ; From file S2: >Lambda-3>TAPE>lmfl-format.lisp.199 at 10-Jul-86 14:01:50 #10R TAPE#: (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.199 at 10-Jul-86 14:01:52 #10R TAPE#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE"))) (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; LMFL-FORMAT  " (defmethod (lmfl-format :compare-partition) (device plist silent) (check-device device) (check-plist plist) (let ((part-disk-unit (get plist :host-unit)) (part-host (or (si:parse-host (get plist :host) t) si:local-host)) (plist-name (get (Car plist) :name))) (multiple-value-bind (host unit start length ignore name) (partition-searcher (format nil "for comparing ~s" (get plist :comment)) (get plist :size) :default-partition (when (stringp plist-name) plist-name) :default-unit (if (eq (si:parse-host part-host) si:local-host) part-disk-unit (format nil "~A ~D" part-host part-disk-unit)) :default-comment (get plist :comment)) (if (null host) (progn (format t "~&*** User aborted comparison of partition: ~a ***" (or (get plist :comment) (get plist :name))) (send self :space-to-end-of-this-file device plist 0)) (do ((first start) (blocks (or (si:measured-from-part-size unit name start length) length)) Result finished?) (finished? result) (condition-case (condition) (setq result (send device :compare-to-disk unit first blocks record-size :silent silent)) (physical-end-of-tape (Get-Next-Tape "Partition continued on another tape. Unloading this tape..." self device) (Let ((data-transferred (send condition :data-transferred))) (incf first data-transferred) (decf blocks data-transferred))) (:no-error (setq finished? t) (if result (condition-case () (send device :space 1) ((physical-end-of-tape filemark-encountered) (signal 'logical-end-of-tape :device-object device))) (do (finished?) (finished?) (condition-case (condition) (send device :search-filemark 1 :high) (physical-end-of-tape (prompt-for-new-tape self device)) (:no-error (setq finished? t)))))))))))) )) ; From file S2: >Lambda-3>TAPE>TFRAME-COMS.LISP.41 at 10-Jul-86 14:01:57 #10R TFRAME#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TFRAME"))) (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; tframe-coms lisp " (define-command REWIND/UNLOAD (control tape-info dump backup retrieve) "Rewind the storage device. {M: Unload}" :left (with-status ("Rewinding tape...") (tape:rewind)) :middle (with-status ("Unloading tape...") (tape:unload)) :documentation "~ This command rewinds the tape to load point if the left mouse button is used. If the middle button is used, then the tape is unloaded. If the tape is unloaded, all subsequent operations will get an error until another tape is loaded.") )) ; From file S2: >Lambda-3>TAPE>TFRAME-COMS.LISP.41 at 10-Jul-86 14:02:01 #10R TFRAME#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TFRAME"))) (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; tframe-coms lisp " (define-command BACKWARD-FILES (control) "Space backwards N files. L: use global numeric arg {M: Enter from Keyboard}" :left (with-status ("Spacing Backward ~D Files ..." *global-numeric-arg*) (condition-case () (send tape:*selected-format* :previous-file tape:*selected-device* *global-numeric-arg*) (tape:physical-beginning-of-tape (format *standard-output* "~&At beginning of tape.")))) :middle (let ((number (prompt-and-read :number "~&Number of file to space backward by >> "))) (if (typep number '(integer 1)) (with-status ("Spacing Backward ~D Files ..." number) (condition-case () (send tape:*selected-format* :previous-file tape:*selected-device* number) (tape:physical-beginning-of-tape (format *standard-output* "~&At beginning of tape.")))) (tv:beep) (format t "~&~%Number must be and integer greater than 1!~%"))) :documentation "~ This moves the tape backward by files. If the left mouse button is used, then the \"global numeric argument\" determined the number of files to space over. If the middle button is used, the number of files must be specified by the user.") )) ; From file S2: >Lambda-3>TAPE>TFRAME-COMS.LISP.41 at 10-Jul-86 14:02:07 #10R TFRAME#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TFRAME"))) (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; tframe-coms lisp " (Defun Space-Forward-Files (format device n) (with-status ("Spacing Forward ~d Files ..." n) (Send format :next-file device n))) )) ; From file S2: >Lambda-3>TAPE>TFRAME-COMS.LISP.41 at 10-Jul-86 14:02:07 #10R TFRAME#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TFRAME"))) (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; tframe-coms lisp " (define-command FORWARD-FILES (control) "Space forward N files. L: use global numeric argument {M: Enter from Keyboard}" :left (Space-Forward-Files tape:*selected-format* tape:*selected-device* *global-numeric-arg*) :middle (let ((number (prompt-and-read :number "~&Number of file to space forward by >> "))) (if (typep number '(integer 1)) (Space-Forward-Files tape:*selected-format* tape:*selected-device* number) (tv:beep) (format t "~&~%Number must be an integer greater than 1!~%"))) :documentation "~ This moves the tape forward by files. If the left mouse button is used, then the \"global numeric argument\" determined the number of files to space over. If the middle button is used, the number of files must be specified by the user.") )) ; From file S2: >Lambda-3>TAPE>TFRAME-COMS.LISP.41 at 10-Jul-86 14:02:10 #10R TFRAME#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TFRAME"))) (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; tframe-coms lisp " (define-command device-status (control) "Return status of the selected tape device." :left (tape:device-status) :documentation "~ Returns a list of keywords which describe the status of the selected tape device. Keywords are intuitively named and their presence implies boolean truth of the condition.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Tape info ;;; )) ; From file S2: >Lambda-3>TAPE>TFRAME-COMS.LISP.41 at 10-Jul-86 14:02:13 #10R TFRAME#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TFRAME"))) (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; tframe-coms lisp " (define-option *verify-files* (DUMP BACKUP RETRIEVE) "Verify files" t (:boolean) "~ This determines whether files should be verified after they are dumped or retrieved. If files are being dumped, then all of the files are written, then verified. If a partition is being written and it is longer than one tape, then each tape will be verified before the next one is written. This eliminates the waste of time writing subsequent reels if one reel has a compare error.") )) ; From file S2: >Lambda-3>TAPE>TFRAME-COMS.LISP.41 at 10-Jul-86 14:02:14 #10R TFRAME#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TFRAME"))) (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; tframe-coms lisp " (Defun Sum-File-Lengths (files) (Let ((total 0)) (DoList (file files) (Incf total (* (or (get file :length-in-bytes) (get file :length)) (/ (tape:file-byte-size file) 8)))) total) ) )) ; From file S2: >Lambda-3>TAPE>TFRAME-COMS.LISP.41 at 10-Jul-86 14:02:14 #10R TFRAME#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TFRAME"))) (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; tframe-coms lisp " (Defun Dump-Files (format device pathname subdirectories?) (Let ((files (With-Status ("Listing Files to Dump") (tape:full-directory-list pathname :inferiors subdirectories? :stream nil)))) (DoList (file files) (with-status ("Writing File: \"~a\"" (car file)) (send format :write-file device (car file) :end-of-tape-action *end-of-tape-action* :silent t))) (format t "~&Dumped ~:D files (~:D bytes).~%" (length files) (sum-file-lengths files))) ) )) ; From file S2: >Lambda-3>TAPE>TFRAME-COMS.LISP.41 at 10-Jul-86 14:02:16 #10R TFRAME#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TFRAME"))) (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; tframe-coms lisp " (define-command WRITE-FILES (dump) "Write files to tape using the global pathname arg" :left (Dump-Files tape:*selected-format* tape:*selected-device* *global-pathname-arg* *write-subdirectories*) ;;; (let ((files (with-status ("Listing Files to Dump") ;;; (tape:full-directory-list *global-pathname-arg* ;;; :inferiors *write-subdirectories* ;;; :stream nil)))) ;;; (dolist (file files (format *standard-output* ;;; "~&Dumped ~:D files (~:D bytes).~%" ;;; (length files) ;;; (lexpr-funcall ;;; '+ ;;; (mapcar #'(lambda (file) ;;; (* (or (get file :length-in-bytes) ;;; (get file :length)) ;;; (/ (tape:file-byte-size file) 8))) ;;; files)))) ;;; (with-status ("Writing File: \"~A\"" (car file)) ;;; (send tape:*selected-format* :write-file ;;; tape:*selected-device* (car file) ;;; :end-of-tape-action *end-of-tape-action* ;;; :silent t)))) :documentation "~ This command writes files to tape according to a specified \(optionally wilcarded) pathname. The pathname is determined from the \"global pathname argument\". Various options will affect the action of this command as documented.") )) ; From file S2: >Lambda-3>TAPE>TFRAME-COMS.LISP.41 at 10-Jul-86 14:02:18 #10R TFRAME#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TFRAME"))) (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; tframe-coms lisp " (define-command RESTORE-FILES (retrieve) "L: Restore all files from tape {M: Restore N files}" :left (condition-case () (do-forever (when *file-match* (send tape:*selected-format* :find-file tape:*selected-device* *file-match*)) (send tape:*selected-format* :restore-file tape:*selected-device* :transform *transform* :query *query* :overwrite *overwrite* :create-directory *create-directory*)) (tape:logical-end-of-tape (format t "~&*** End of Tape ***~%"))) :middle (condition-case () (dotimes (c *global-numeric-arg*) (when *file-match* (send tape:*selected-format* :find-file tape:*selected-device* *file-match*)) (send tape:*selected-format* :restore-file tape:*selected-device* :transform *transform* :query *query* :overwrite *overwrite* :create-directory *create-directory* :silent *silent*)) (tape:logical-end-of-tape (format t "~&*** End of Tape ***~%"))) :documentation "~ Restore some files (and/or partitions) from the tape. If the left mouse button is used, then files are restored until the logical-end-of-tape is reached. If the middle button is used, the \"global numeric argument\" determines how many files to restore. Other options will affect this command as documented.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Backup logs mode ;;; )) ; From file S2: >Lambda-3>TAPE>TFRAME-COMS.LISP.41 at 10-Jul-86 14:02:24 #10R TFRAME#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TFRAME"))) (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; tframe-coms lisp " (defun document-tframe-to-file (pathname format) (with-open-file (f pathname :direction :output) (ecase format (:text (format f "-*- Mode: Text; Base: 10; Package: TFrame -*-~%") (dolist (mode *mode-types*) (format f "~C~%---[TFrame Mode: ~A]---~2%" #\page mode) (if (null (get mode :options)) (format f "No options defined.~2%") (format f "Options are defined as follows:~2%") (dolist (option (get mode :options)) (format f "~A (~S)~%~10T~~?~~2%" (tframe-option-name option) (tframe-option-print-name option) (tframe-option-documentation option)))) (if (null (get mode :commands)) (format f "No commands defined.~2%") (format f "Commands are defined as follows:~2%") (dolist (command (get mode :commands)) (format f "~A~%~10T~~?~~2%" (tframe-command-name command) (tframe-command-documentation command))))) (format f "*** End of Tframe Documentation ***~%")) (:botex (format f "@comment -*- Mode: Text; Base: 10; Package: TFrame -*-~%") (format f botex-format-preamble) (format f "@subheading Global TFrame options:~2%") (dolist (option *global-options*) (format f "@defvar ~A~%~?~%@end defvar~2%" (string-downcase (tframe-option-name option)) (tframe-option-documentation option))) (dolist (mode *mode-types*) (format f "@subheading The ~A command mode~2%" mode) (if (null (get mode :options)) (format f "No options defined.~2%") (format f "Options are defined as follows:~2%") (dolist (option (get mode :options)) (format f "@defvar ~A~%~?~%@end defvar~2%" (string-downcase (tframe-option-name option)) (tframe-option-documentation option)))) (if (null (get mode :commands)) (format f "No commands defined.~2%") (format f "Commands are defined as follows:~2%") (dolist (command (get mode :commands)) (format f "@b[~A]~2%~?~2%" (tframe-command-name command) (tframe-command-documentation command))))) (format f "@comment *** end of TFrame documentation ***~%@end(document)~%"))))) )) ; From file S2: >Lambda-3>TAPE>TFRAME-COMS.LISP.41 at 10-Jul-86 14:02:26 #10R TFRAME#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TFRAME"))) (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; tframe-coms lisp " (define-command install-distribution-tape (retrieve) "Install an LMI distribution tape." :left (tape:install-distribution-tape) :documentation "~ Install an LMI distribution tape. This is provided for automatic installation of software release and update tapes.") )) ; From file S2: >Lambda-3>TAPE>backup.lisp.26 at 10-Jul-86 14:02:29 #10R TAPE#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE"))) (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; BACKUP  " (defun load-backup-log (type log-number) (let ((pathname (determine-backup-log-source type log-number)) *dump-info-list* *dump-files-list* (*read-base* 10.)) (load pathname 'tape) (when (= 1 (get *dump-info-list* :log-version)) (dolist (file *dump-files-list*) (setf (nth 1 file) (intern (format nil "~s" (nth 1 file)) *pathname-component-package*)) (setf (nth 2 file) (intern (format nil "~s" (nth 2 file)) *pathname-component-package*)) (setf (nth 7 file) (intern (format nil "~S" (nth 7 file)) *pathname-component-package*)))) (put-log type log-number (make-backup-log :version log-number :type type :dump-info-list *dump-info-list* :dump-files-list *dump-files-list*)))) )) ; From file S2: >Lambda-3>TAPE>backup.lisp.26 at 10-Jul-86 14:02:31 #10R TAPE#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE"))) (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; BACKUP  " (defun log-files (file-list host log-file place format user universal-time) (check-type file-list cons) (check-type host si:host) (check-type log-file (or string pathname)) (check-type place cons) (check-type format symbol) (check-type user string) (check-type universal-time (or integer bignum)) (let ((*print-base* 10.)) (with-open-file (f log-file :direction :output :characters t :byte-size 8) (format f ";;; -*- Mode: Lisp; Package: tape; Base:10; Readtable:CL -*-~%~ ;;;~%;;; Backup log for \"~S\" (format:~A) on host: ~A.~%~ ;;; Dumped by ~A on ~\date\.~%;;;~2%" place format host user universal-time) (print `(setq *dump-info-list* '(,place :host ,(send host :string-for-printing) :log-file ,(send (send f :truename):string-for-printing) :tape-format ,format :user ,user :time ,universal-time :log-version ,*backup-log-format-version*)) f) (format f "~&~2%;;; The format for the files is:~%~ ;;; ( ~%~ ;;; )~%;;;~2%(setq *dump-files-list*~%'(") (dolist (file file-list) (format f "(~s ~s ~s ~d ~s ~d ~d ~s)~%" (send (car file) :directory) (intern (send (car file) :name) *pathname-component-package*) (intern (send (car file) :type) *pathname-component-package*) (send (car file) :version) (get file :characters) (get file :creation-date) (file-byte-size file) (intern (get file :author) *pathname-component-package*))) (format f "))~2%;;; End of tape log.~%")) (setq *backup-info-consistent* nil))) )) ; From file S2: >Lambda-3>TAPE>tape.lisp.161 at 10-Jul-86 14:02:44 #10R TAPE#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE"))) (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; TAPE  " (defun prompt-for-rewind-with-state () (tv:beep) (do (return-value) (return-value return-value) (setq return-value (select (character (prompt-and-read :character "~&Tape has been altered, but the end of tape had not been properly marked.~%~ Action? (~C, ~C, ~C or ~C) >> " #\end #\resume #\call #\help)) ((#\resume) :resume) ((#\end) :save-state) ((#\call) :enter-debugger) ((#\help) (format *query-io* "~&~C~7T- Rewind or unload anyway.~%~ ~C~7T- Save state then rewind or unload.~%~ ~C~7T- Enter the debugger.~2%" #\resume #\end #\call)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Device locking ;;; ;;; )) ; From file S2: >Lambda-3>TAPE>tape.lisp.161 at 10-Jul-86 14:02:46 #10R TAPE#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE"))) (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; TAPE  " (defun process-filter-keywords (filter-keywords file-plist) "Filter keywords should be an alist of the form ( . ...). If each value matches the value of the corresponding value in plist, T is returned, otherwise NIL. This is useful for filtering for files that have a certain property value. (i.e. '(:BACKED-UP NIL))" (do* ((win? t) (l filter-keywords (cddr l)) (key (car l) (car l)) (value (cadr l) (cadr l)) (thing (when l (if (memq key '(:device :directory :name :type :version)) (send (car file-plist) key) (get file-plist key))) (when l (if (memq key '(:device :directory :name :type :version)) (send (car file-plist) key) (get file-plist key))))) ((or (not win?) (null l)) win?) (unless (or (equal value thing) (and (stringp value) (stringp thing) (si:string-matchp value thing))) (setq win? nil)))) )) ; From file S2: >Lambda-3>TAPE>user.lisp.92 at 10-Jul-86 14:02:48 #10R TAPE#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE"))) (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; USER  " (defun next-file (&key (number-of-files 1) (device-spec *selected-device*) (format-spec *selected-format*)) "Move forward NUMBER-OF-FILES files from the current file." (using-format (format format-spec) (using-device (device device-spec) (with-device-locked device (send format :next-file device number-of-files))))) )) ; From file S2: >Lambda-3>TAPE>user.lisp.92 at 10-Jul-86 14:02:50 #10R TAPE#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE"))) (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; USER  " (defun restore-files (&key (device-spec *selected-device*) (format-spec *selected-format*) transform match number-of-files query (create-directory :always) (overwrite :never) silent) "Restores files (and/or partitions) from the tape to disk. TRANSFORM if present determines where each file is restored. If it is a string or a pathname it is parsed with respect to the local host and merged with the file properties of each file on tape to determine the pathname to restore to. It can also be a function of one argument, the file property list, which must return a pathname. NUMBER-OF-FILES determines how many files to restore (all files on tape if not specified). MATCH is used to find a specific files on the tape to restore. If it is a pathname (or string) each file property list is parsed into a pathname and used as the argument to the :PATHNAME-MATCH message sent to the match pathname. MATCH can also be a function of one argument, a file property list, which should return non-NIL if the file should be restored. QUERY if non-NIL, then the user will be asked whether to restore each file. CREATE-DIRECTORY determines whether to create a directory for a file to be restored if it does not already exist. Valid values are :ALWAYS, :NEVER or :ERROR. If :NEVER is specified, the file is automatically skipped. OVERWRITE specifies what to do when a file already exists. :NEVER means to skip the file, :ALWAYS means to overwrite it automatically, :QUERY means to ask the user what to do, and :ERROR means to signal an error. SILENT if this is NIL, the action taken for each file on tape will be printed to *standard-output*." (check-type query (member t nil)) (check-type create-directory (member :always :query :never :error)) (check-type number-of-files (or null (integer 1))) (check-type overwrite (member :always :query :never)) (using-device (device device-spec) (using-format (format format-spec) (with-device-locked device (condition-case () (do ((count 0 (add1 count))) ((and number-of-files (= count number-of-files))) (when match (send format :find-file device match)) (send format :restore-file device :transform transform :query query :create-directory create-directory :overwrite overwrite :silent silent)) (logical-end-of-tape (unless silent (format *standard-output* "~&** End of Tape **~%")))))))) )) ; From file S2: >Lambda-3>TAPE>user.lisp.92 at 10-Jul-86 14:02:51 #10R TAPE#: (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) ***") (dolist (plist bad-files) (format t "~&~10@t~A~%" (car plist))) (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>user.lisp.92 at 10-Jul-86 14:02:53 #10R TAPE#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE"))) (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; USER  " (defun view-tape (&key (device-spec *selected-device*) (output-to *standard-output*) ignore-padding) "This prints the raw contents of the tape (in 8-bit bytes) to OUTPUT-TO. Filemarks on the tape are denoted as \"{*** FILEMARK ***}\". This is particularly useful for examining an unknown tape format." (using-device (device device-spec) (using-resource (block si:dma-buffer 32) (with-device-locked device (do-forever (let ((rsize (condition-case () (send device :read-block block (* 32 1024)) (filemark-encountered :filemark))) (string (si:dma-buffer-string block))) (cond ((eq rsize :filemark) (return-from view-tape nil)) (output-to (send output-to :string-out string 0 (or (when ignore-padding (string-search-char #\center-dot string) rsize))))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Automated Distribution Tape Installation ;;; )) ; From file S2: >Lambda-3>TAPE>user.lisp.92 at 10-Jul-86 14:02:56 #10R TAPE#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE"))) (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; USER  " (defmacro distribution-installation-forms (&rest body) `(progn . ,body)) )) ; From file S2: >Lambda-3>TAPE>user.lisp.92 at 10-Jul-86 14:02:57 #10R TAPE#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE"))) (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; USER  " (defun install-distribution-tape (&key (device-spec *selected-device*) (format-spec *selected-format*) &aux distribution-form) (using-device (device device-spec) (using-format (format format-spec) (with-open-stream (tape-stream (send format :open-file device)) (when (string-equal (send tape-stream :type) "distribution") (format t "~&Reading distribution header") (let* ((*package* (pkg-find-package 'TAPE)) (*read-base* 10.) (*readtable* si:common-lisp-readtable)) (setq distribution-form (catch-error (read tape-stream)))))) (cond ((neq (car-safe distribution-form) 'distribution-installation-forms) (format t "~&The mounted tape is not a distribution tape.")) ('else (format t "~&Running the product specific distribution procedure.") (eval distribution-form)))))) )) ; From file S2: >Lambda-3>TAPE>TFRAME-WINDOW.LISP.28 at 10-Jul-86 14:03:02 #10R TFRAME#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TFRAME"))) (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; tframe-window lisp " (defmethod (menu-mode-pane :set-mode) (mode) (send self :setup-items) (let ((mode-item (assoc mode (send self ':item-list)))) (and current-mode (send self :remove-highlighted-item current-mode)) (send self :add-highlighted-item mode-item) (setq current-mode mode-item) (send *menu* :update-item-list (mapcar #'(lambda (str) (list (tframe-command-name str) :value (tframe-command-name str) :documentation (tframe-command-mouse-documentation str))) (get mode :commands))) (send *vars* :set-variables (mapcar #'(lambda (option) `(,(tframe-option-name option) ,(tframe-option-print-name option) :documentation "Click Left or Right to change this value. {M: View documentation}" ,(tframe-option-type option) ,@(tframe-option-type-args option))) (append (get mode :options) *global-options*))))) )) ; From file S2: >Lambda-3>TAPE>INITIALIZATIONS.LISP.2 at 10-Jul-86 14:03:36 #10R TAPE#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TAPE"))) (COMPILER::PATCH-SOURCE-FILE "SYS: TAPE; INITIALIZATIONS  " (add-initialization "Determine available devices" `(progn (setq *available-devices* nil) (dolist (list *tape-device-alist*) (when (funcall (third list)) (push (second list) *available-devices*)))) `(:now) 'si:tape-warm-initialization-list) (add-initialization "Select default device and format" `(progn (setq *selected-device* (cond ((null *available-devices*)) ((memq (car *default-device*) *available-devices*) (lexpr-funcall 'parse-device *default-device*)) (*available-devices* (parse-device (car *available-devices*))))) (setq *selected-format* (cond (*default-format* (lexpr-funcall 'parse-format *default-format*)) (*tape-format-alist* (parse-format (cdar *tape-format-alist*)))))) '(:now) 'si:tape-warm-initialization-list) ))