;;; -*- Mode:LISP; Package:USER; Base:10; Readtable:CL -*-

;;; WRITE-BLOCKED-TAPE.LISP

;;; Routines for writing raw tapes in blocked and variable format.

;;; See MAKE-BLOCKED-TAPE and MAKE-VMS-COPY-TAPE, below.

;;; Still to do:
;;;  -- allow to specify recursive pathnames
;;;  -- give usage examples

(defconstant *max-buffer-size* 4096)

(defparameter *write-blocked-tape-verbosely* t
  "If non-NIL, informative information is printed while writing tape.")

(defconstant *write-blocked-tape-lispm-chars*
	     (list #\tab #\page #\return #\line))

;;; Utility functions

(defun string-ascii-translate(string)
  "Destructively modifies STRING to translate LISPM control characters
 (contained in the list *WRITE-BLOCKED-TAPE-LISPM-CHARS*) to their
ASCII equivalents."
  (dotimes(indx (string-length string))
    (when (member (aref string indx) *write-blocked-tape-lispm-chars*)
      (setf (aref string indx) (- (aref string indx) #o200)))))

(defun paths-and-streams(paths-and-streams)
  (unless (listp paths-and-streams)
    (setq paths-and-streams (ncons paths-and-streams)))
  (loop for elt in paths-and-streams
	append
	(etypecase elt
	  ((or pathname string)
	   (directory elt))
	  (stream (ncons elt)))))

;;; VMS special stuff

(defun vms-type(pathname)
  (let((type (send (pathname pathname) :canonical-type)))
    (or (cadr(assoc :vms (getf fs:canonical-types type)))
	type)))

(defun vms-filename-fix(name)
  (substitute-if-not
    #\$
    #'(lambda(char)
	(or (member char (list #\_ #\$ #\.))	;VMS special chars
	    (alphanumericp char)))
    (substitute
      #\_ #\- name)))
    
(defun vms-names(paths)
  (loop for path in paths
	as name = (vms-filename-fix (pathname-name path))
	as ltype = (pathname-type path)
	as vms-type = (vms-type path)
	collect (string-append name #\. vms-type)))

;;; Main I/O routines

;;; Write from stream to tape

(defun write-blocked-stream(input output
			    record-size blocking-factor
			    &optional (ascii-translation t)
			    &aux buffer-size block-size)
  "Copy records from INPUT stream, to OUTPUT, which is either:
  1. The tape device, e.g. TAPE:*SELECTED-DEVICE*, or
  2. An output stream such as a file or window.
Records are blocked according to RECORD-SIZE and BLOCKING-FACTOR;
a RECORD-SIZE of NIL and BLOCKING-FACTOR of one means
variable-length record/blocks."
  (if record-size
      (setq buffer-size (* record-size blocking-factor)
	    block-size buffer-size)
    (setq buffer-size *max-buffer-size*))
  (using-resource (buffer-block si:dma-buffer
				(ceiling (quotient buffer-size 1024.0)))
    (let((record-within-buffer 0)
	 (record-within-input 0)
	 (buffers-to-output 0)
	 (buffer (si:dma-buffer-string buffer-block)))
      (fill buffer #\space)
      ;;"Generic" I/O methods (knows about tape device vs. standard streams)
      (flet((putout()
		   (etypecase output
		     (tape:tapemaster-device
		      (send output :write-block buffer-block block-size))
		     ((or si:output-stream tv:sheet)
		      (send output :line-out buffer 0 block-size)))
		   (incf buffers-to-output))
	    (puteof()
		   (etypecase output
		     (tape:tapemaster-device
		      (send output :write-filemark))
		     ((or si:output-stream tv:sheet)
		      (send output :fresh-line)))))
	;;Main I/O loop
	(do ((line (read-line input nil :eof)
		   (read-line input nil :eof)))
	    ((equal line :eof))
	  (incf record-within-input)
	  (if ascii-translation
	      (string-ascii-translate line))
	  ;;Do we have a full buffer to output?
	  (when (= record-within-buffer blocking-factor)
	    (putout)				;output buffer
	    (fill buffer #\space)		;blank out buffer
	    (setq record-within-buffer 0))
	  ;;Null lines need at least one blank
	  (when (zerop (string-length line))
	      (setq line " "))
	  ;;Set blocksize for variable length
	  (unless record-size
	    (setq block-size (string-length line)))
	  ;;Insert input record into output buffer
	  (replace buffer line
		   :start1
		   (if record-size (* record-within-buffer record-size)
		     0))
	  (incf record-within-buffer))
	;;Final buffer pending?
	(unless (zerop record-within-buffer)
	  (putout))
	(puteof))
      ;;Done I/O
      (when *write-blocked-tape-verbosely*
	  (format t "~%---Wrote ~d record~:P~:[~;, ~d block~:P~]"
		  record-within-input (> blocking-factor 1) buffers-to-output)
	  (format t "~&   from ~s~&   to   ~s"
		  (or (send-if-handles input :name)  input)
		  (or (send-if-handles output :name) output)))
      record-within-input)
    ))

;;; Write a collection of streams and/or files to tape

(defun write-blocked-tape(paths &optional record-size (blocking-factor 1))
  "Write file(s) and/or open streams as specified by the list PATHS
to the selected tape device in blocked format, formatted
according to RECORD-SIZE and BLOCKING-FACTOR."
  (let((tape tape:*selected-device*)
       (tape:*selected-format* (make-instance 'tape:raw-format)))
    (when (null (and record-size blocking-factor))
      (setq blocking-factor 1))
    (when *write-blocked-tape-verbosely*
      (format t "~&+++Write blocked tape:")
      (format t " record size is ~:[variable~;~:*~d~]" record-size)
      (when (> blocking-factor 1)
	(format t ", blocking factor is ~d" blocking-factor)))
    (dolist (path-or-stream paths)
      (typecase path-or-stream
	(pathname
	 (with-open-file(in path-or-stream :direction :input)
	   (write-blocked-stream
	     in tape
	     record-size blocking-factor)))
	(stream
	 (write-blocked-stream
	   path-or-stream tape
	   record-size blocking-factor))))))

;;; Complete user interfaces

;;; MAKE-BLOCKED-TAPE is generalized; given a pathname or list of files,
;;; write them to tape using the specified record size and blocking factor.

(defun make-blocked-tape (paths-and-streams &optional record-size blocking-factor &aux paths)
  "Make a complete blocked record-format tape suitable for reading, e.g., by
  VAX/VMS COPY or UNIX dd.
PATHS-AND-STREAMS can be:
    1) a pathname (object or string), passed to DIRECTORY to
       get the list of files to write; or
    2) an open stream (gets copied to the tape; not closed!), or
    2) a list of pathnames and/or open streams.
BLOCKING-FACTOR is a number of records to write as one block; default
  is NIL, or 1 record per block.
RECORD-SIZE can be NIL, in which case variable-length record blocks are
  written (BLOCKING-FACTOR is set to 1).
The tape is finished off with 2 EOFs."
  (setq paths (paths-and-streams paths-and-streams))
  (when (null paths)
    (error "No file(s) selected by pathname(s)"))
  (write-blocked-tape paths record-size blocking-factor)
  (dotimes(i 2)
    (send tape:*selected-device* :write-filemark))
  (send tape:*selected-device* :search-filemark-reverse 1))

;;; MAKE-VMS-COPY-TAPE is specific to the VAX/VMS COPY format.  It puts a
;;; command file at the head of the tape which can be used to restore the
;;; blocked files. Modifications to the generated COPY-LISPM.COM file may be
;;; needed, e.g.  to use other COPY options.

;;; To restore a tape made with this utility, do, e.g. (if your tape drive is
;;; called MSA0:)

;;;   $ assign msa0: mt:
;;;   $ mount/for mt:
;;;   $ copy mt: temp.com
;;;   $ @temp

(defun make-vms-copy-tape(pathname-list &aux paths)
  "Interface like MAKE-BLOCKED-TAPE, specifically for VAX/VMS; see it for info.
Make a VAX/VMS COPY (text file) tape; the first file on the tape is a VMS
.COM file, which when restored and run, will restore all the files on the tape
with appropriate VMS names.
The tape is finished off with 2 EOFs."
  (setq paths (paths-and-streams pathname-list))
  (when (null paths)
    (error "No file(s) selected by pathname(s)"))
  (let((vms-pathstrings
	 (cons "TEMP.COM"
	       (vms-names paths))))
    (tape:rewind)
    (with-input-from-string
      (comfile
	(apply #'(lambda(&rest strings)
		   (apply #'string-append
			  (loop for str in strings
				collect (string-append "$ " str #\return))))
	       "! Machine-generated, tape-specific command file for"
	       "! restoring a VMS COPY-format source tape created on"
	       "! a Lambda LISP machine with the utility"
	       "! WRITE-VMS-COPY-TAPE."
	       "set noon"
	       "DISMOUNT/NOUNLOAD MT:"
	       "MOUNT/FOR MT: NOLABEL MYTAPE:"
	       (loop for path in vms-pathstrings
		     collect (string-append "COPY/LO MYTAPE: " path))))
      (write-blocked-tape (ncons comfile))
      (write-blocked-tape paths)))
  (dotimes(i 2)
    (send tape:*selected-device* :write-filemark))
  (send tape:*selected-device* :search-filemark-reverse 1))