;;; -*- Mode: Common-Lisp; Package: User; Base: 10.; Patch-File: T -*-

;;; Reason:  Modified primitive-copy-directory to check for end-of-record-media errors when writing to a tape and allow user to continue with another tape.

;;;                           RESTRICTED RIGHTS LEGEND
;;;
;;; Use, duplication, or disclosure by the Government is subject to
;;; restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;; Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;   TEXAS INSTRUMENTS INCORPORATED      
;;;   P.O. BOX 2909, M/S 2151             
;;;   AUSTIN, TEXAS 78769                 
;;;
;;; Copyright (C) 1989 Texas Instruments Incorporated.
;;; All rights reserved.

;;; Patch file for BASIC-FILE version 6.11
;;; Written 05/22/90 15:20:19 by BERGER,
;;; while running on Pasteur from band LOD2
;;; With SYSTEM 6.31, VIRTUAL-MEMORY 6.3, EH 6.7, MAKE-SYSTEM 6.3, MICRONET 6.0, LOCAL-FILE 6.2,
;;;  BASIC-PATHNAME 6.4, NETWORK-SUPPORT-COLD 6.2, BASIC-NAMESPACE 6.7, NETWORK-NAMESPACE 6.1,
;;;  DISK-IO 6.3, DISK-LABEL 6.0, BASIC-FILE 6.10, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.2,
;;;  COMPILER 6.14, TV 6.25, DATALINK 6.0, CHAOSNET 6.6, GC 6.3, MEMORY-AUX 6.0, NVRAM 6.2,
;;;  SYSLOG 6.2, STREAMER-TAPE 6.5, UCL 6.0, INPUT-EDITOR 6.0, METER 6.1, ZWEI 6.16,
;;;  DEBUG-TOOLS 6.4, NETWORK-SUPPORT 6.1, NETWORK-SERVICE 6.2, DATALINK-DISPLAYS 6.0,
;;;  FONT-EDITOR 6.1, SERIAL 6.0, PRINTER 6.5, MAC-PRINTER-TYPES 6.2, PRINTER-TYPES 6.2,
;;;  IMAGEN 6.1, SUGGESTIONS 6.1, MAIL-DAEMON 6.6, MAIL-READER 6.8, TELNET 6.1, VT100 6.0,
;;;  NAMESPACE-EDITOR 6.4, PROFILE 6.3, VISIDOC 6.7, TI-CLOS 6.46, CLEH 6.5, IP 3.62,
;;;  Experimental CLX 6.11, CLUE 6.104, X11M 6.24, Experimental BUG 11.19,  microcode 648,
;;;  Band Name: rel6.0 1/23

#!C
; From file DIRECTORY-SUPPORT.LISP#> BASIC-FILE; sys:
#10R FILE-SYSTEM#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "FILE-SYSTEM"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: BASIC-FILE; DIRECTORY-SUPPORT.#"


(defun handle-eom-and-maybe-proceed-in-mt (&rest args)  ; DAB 05-15-90
  "Dummy function. It will be redefined by the MT subsystem when loaded."
  (declare (ignore args))
  ())


(DEFUN PRIMITIVE-COPY-DIRECTORY (INPUT-PLIST-OR-PATHNAME MAPPED-PATHNAME OUTPUT-SPEC INPUT-STREAM &OPTIONAL IGNORE &REST
				 OPTIONS &KEY SELECTIVE &ALLOW-OTHER-KEYS &AUX INPUT-PATHNAME INPUT-PLIST)
  (declare (special *REMOTE-TAPE-STREAM*))
  (IF (ATOM INPUT-PLIST-OR-PATHNAME)
      (SETQ INPUT-PATHNAME INPUT-PLIST-OR-PATHNAME
	    INPUT-PLIST ())
     (SETQ INPUT-PATHNAME (CAR INPUT-PLIST-OR-PATHNAME)
	    INPUT-PLIST INPUT-PLIST-OR-PATHNAME))
  (UNLESS INPUT-PLIST
    (WHEN INPUT-PATHNAME
      (SETQ INPUT-PLIST (FILE-PROPERTIES INPUT-PATHNAME)
	    INPUT-PATHNAME (CAR INPUT-PLIST))))
  (LET ((BACKED-UP-FILES-LIST
	  (IF (and (MEMBER :DIRECTORY (CDR INPUT-PLIST) :TEST #'EQ)
		   (second (MEMBER :DIRECTORY (CDR INPUT-PLIST) :TEST #'EQ)))   ;02-03-88 DAB must be :directory t
	      (LET* ((DES-DIR (SEND OUTPUT-SPEC :DIRECTORY))
		     (SOURCE (CAR INPUT-PLIST))
		     (ORIGINAL-SELECTIVE (GETF OPTIONS :SELECTIVE))	; save the :selective value 6/26/87 cc
		     (SRC-DIR
		       (SEND (SEND SOURCE :PATHNAME-AS-DIRECTORY) :NEW-PATHNAME :NAME () :TYPE ()
			     :VERSION ())))
		(SETF (GETF OPTIONS :SET-BACKED-UP-FLAG) ())
		(WHEN (OR (NOT SELECTIVE)
			  (CASE (FQUERY
				 '(:CHOICES
				    (((:SELECT "Selective.") #\s) ((T "Yes.") #\y #\t #\SPACE #\)
				     ((NIL "No.") #\n #\RUBOUT #\
))
				    :HELP-FUNCTION SELECTIVE-HELPER)
				 "~&Copy Subdirectory ~A ? " SRC-DIR)
			    ((T) (SETF (GETF OPTIONS :SELECTIVE) ()) T)
			    ((NIL) NIL)
			    ((:SELECT) (SETF (GETF OPTIONS :SELECTIVE) T) T)))
		  (prog1
		    (multiple-value-bind (v1 v2 v3 v4)
			(APPLY #'COPY-DIRECTORY (MERGE-PATHNAME-DEFAULTS SRC-DIR MAPPED-PATHNAME)
			       (SEND OUTPUT-SPEC :NEW-PATHNAME :DIRECTORY
				     (IF (OR (MEMBER DES-DIR '(:ROOT :WILD NIL) :TEST #'EQ)
					     (AND (CONSP DES-DIR) (= (LENGTH DES-DIR) 1.)
						  (MEMBER (CAR DES-DIR) '(:ROOT :WILD NIL) :TEST #'EQ)))
					 (LET ((SSS (SEND SOURCE :DIRECTORY)))
					   (IF (OR
						 (MEMBER (SEND SOURCE :DIRECTORY) '(:ROOT :WILD NIL) :TEST #'EQ)
						 (AND (CONSP SSS) (= (LENGTH SSS) 1.)
						      (MEMBER (CAR SSS) '(:ROOT :WILD NIL) :TEST #'EQ)))
					       (SEND SOURCE :NAME)
					       (APPEND (IF (ATOM SSS)
							   (LIST SSS)
							   SSS)
						       (CONS (SEND SOURCE :NAME) ()))))
					 (APPEND (IF (ATOM DES-DIR)
						     (LIST DES-DIR)
						     DES-DIR)
						 (CONS (SEND SOURCE :NAME) ()))))
			       OPTIONS)
		      (list  v1  v2 v3 v4)

		      )				;bind
		    (SETF (GETF OPTIONS :SELECTIVE) ORIGINAL-SELECTIVE)
		    )				;prog1
		  
		  ))				; reset :selective 6/26/87 cc
	      (LET* (COPIED-FILES)
		(loop  ; DAB 05-22-90 Handle end-of physical tape.
		  
		  (condition-case (condition)
		      (progn
		       (SETF (GETF OPTIONS :SET-BACKED-UP-FLAG) ())
		       (return (SETQ COPIED-FILES
				     (append copied-files
					     (APPLY #'PRIMITIVE-COPY-FILE INPUT-PLIST-OR-PATHNAME MAPPED-PATHNAME
						    OUTPUT-SPEC INPUT-STREAM OPTIONS))))
		       )
		    
		    (error			; DAB 05-15-90 Catch end-of-media errors
		     ;;Check if we are writing to a tape drive, if so check for the end-of-recorded-media.
		     (if
		       (and (not *REMOTE-TAPE-STREAM*)
			    (or (search "END-OF-TAPE"
					(send condition :report-string))	; DAB 04-03-89 Trap for end-of-tape
				(search "EOM" (send condition :report-string))
				(search "Volume overflow" (send condition :report-string))))	; DAB 06-08-89
		       (unless (handle-eom-and-maybe-proceed-in-mt 
				 (format nil "~%~%The end of tape was encountered before completing the backup on ~a.~%Do you what to continue with a new tape?"
					 (if (consp INPUT-PLIST-OR-PATHNAME)
					     (car  INPUT-PLIST-OR-PATHNAME)  INPUT-PLIST-OR-PATHNAME))
				 *terminal-io*)
			 ;;then continue () ;Yes, the new tape is installed, lets continue.
			 ;; else
			 (signal-condition condition))	;otherwise signal error
		       (signal-condition condition))
		     
		     ))
		  (when *REMOTE-TAPE-STREAM*
		    (reject-command *REMOTE-TAPE-STREAM* (if (pathnamep (fourth copied-files))	;06-06-88 DAB
							     (send (FOURTH COPIED-FILES) :string-for-printing)
							     (fourth copied-files))))
		  (list (third COPIED-FILES) (FOURTH COPIED-FILES) (fifth COPIED-FILES) (sixth COPIED-FILES))
		  )				; DAB 05-15-90 loop body
		)
	      )))
    BACKED-UP-FILES-LIST))

))



#!C
; From file OPEN.LISP#> BASIC-FILE; sys:
#10R FILE-SYSTEM#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "FILE-SYSTEM"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: BASIC-FILE; OPEN.#"

(DEFUN PRIMITIVE-COPY-FILE (INPUT-PLIST-OR-PATHNAME MAPPED-PATHNAME OUTPUT-SPEC INPUT-STREAM
			    &KEY (ERROR T)  (COPY-CREATION-DATE T) (COPY-AUTHOR T) REPORT-STREAM VERBOSE
			    (CREATE-DIRECTORIES :QUERY)  (CHARACTERS :DEFAULT) (BYTE-SIZE :DEFAULT)
			    (default-type :default)
			    IF-EXISTS DELETE AFTER (DO-NOT-COPY-PROPERTIES T)  DIRECTORY-LIST    ;5/18/87 HW
			    DEFAULT-BYTE-SIZE OUTPUT-DIRECTORY-LIST CREATE-DIRECTORY ONLY-LATEST
			    SINCE  SELECTIVE NOT-BACKED-UP-ONLY COPY-ONLY OPEN-PARAMETERS
			    &ALLOW-OTHER-KEYS &AUX INPUT-PLIST INPUT-PATHNAME INPUT-TRUENAME
			    TRUE-CHARACTERS TRUE-BYTE-SIZE KNOWN-BYTE-SIZE  ORIGINALLY-NOT-A-STREAM
			    QFASLP OUTNAME DESTEX OUTPUT-DEFAULTS-FROM-STREAMING OUTPUT-TRUENAME
			    (ABORT-FLAG T))
  
  (condition-case-if (not error)  (error)	  ;CONDITION-CASE-IF moved up, 1/26/87 MP
      (PROGN                                 
       (UNWIND-PROTECT				 
	   (PROGN
	     
	     (WHEN CREATE-DIRECTORY		  ; THIS IS FOR COMPATIBILITY
	       (WHEN (MEMBER CREATE-DIRECTORIES '(:QUERY) :TEST #'EQ)
		 (SETQ CREATE-DIRECTORIES CREATE-DIRECTORY)))
	     
	     (WHEN ONLY-LATEST			  ; THIS IS FOR COMPATIBILITY
	       (PUSH :NEWEST COPY-ONLY))
	     
	     (WHEN SINCE			  ; THIS IS FOR COMPATIBILITY
	       (SETQ AFTER SINCE))
	     
	     (WHEN VERBOSE			  ; THIS IS FOR COMPATIBILITY
	       (UNLESS REPORT-STREAM
		 (SETQ REPORT-STREAM T)))
	     
	     (IF (NOT (LISTP INPUT-PLIST-OR-PATHNAME))
		 (SETQ INPUT-PATHNAME INPUT-PLIST-OR-PATHNAME
		       INPUT-PLIST ())
		 (SETQ INPUT-PATHNAME (CAR INPUT-PLIST-OR-PATHNAME)
		       INPUT-PLIST INPUT-PLIST-OR-PATHNAME))

	     ;;if :IF-EXISTS was not specified, see if the host object specifies an overwrite/supersede default.
	     ;;This is used by hosts like unix that don't support versions.
	     
	     (WHEN (and (NULL if-exists)	                         ;5/18/87  HW
			(PATHNAMEP output-spec))
	       
	       (WHEN (send (pathname-host (merge-pathnames output-spec (when (pathnamep input-pathname)
										   input-pathname)))
				     :send-if-handles :overwrite-default)
		 (SETF if-exists :supersede)
		 )
	       )
	     
	     (WHEN (AND (EQUAL if-exists :new-version)	;if user specified :new-version, give it to him  5/18/87  HW
			(PATHNAMEP output-spec))
	       (SETF output-spec (SEND output-spec :new-version :newest)))

	     (if (equal if-exists :copy-if-newer-date)  ;; check the creation-date if this option is specified  mp.
		 (setq if-exists (determine-copy-if-newer-date
				   input-plist output-spec input-stream if-exists)))

	     (UNLESS INPUT-PLIST
	       (IF DIRECTORY-LIST
		   (SETQ INPUT-PLIST DIRECTORY-LIST)
		   (WHEN INPUT-PATHNAME
		     (SETQ INPUT-PLIST (FILE-PROPERTIES INPUT-PATHNAME t))	  ;Set error-p to t, 1/26/87 MP
		     (IF (NULL INPUT-PLIST)
			 (RETURN-FROM PRIMITIVE-COPY-FILE
			   (LIST MAPPED-PATHNAME INPUT-PATHNAME OUTNAME INPUT-PLIST INPUT-PLIST ()))
			 (SETQ INPUT-PATHNAME (CAR INPUT-PLIST))))))
	     
	     (WHEN INPUT-PLIST
	       (MULTIPLE-VALUE-SETQ (TRUE-CHARACTERS TRUE-BYTE-SIZE)
		 (DETERMINE-CHARACTERS-AND-BYTE-SIZE INPUT-PLIST INPUT-STREAM INPUT-PATHNAME
						     INPUT-STREAM DEFAULT-BYTE-SIZE QFASLP CHARACTERS
						     BYTE-SIZE DEFAULT-TYPE))
	       
	       (SETQ KNOWN-BYTE-SIZE TRUE-BYTE-SIZE))
	     
	     (UNLESS INPUT-STREAM
	       (SETQ INPUT-TRUENAME INPUT-PATHNAME
		     ORIGINALLY-NOT-A-STREAM T)
	       
	       (MULTIPLE-VALUE-SETQ (OUTNAME OUTPUT-DEFAULTS-FROM-STREAMING DESTEX)
		 (GET-OUTPUT-DESTINATION OUTPUT-SPEC INPUT-STREAM MAPPED-PATHNAME
					 INPUT-TRUENAME INPUT-PLIST IF-EXISTS
					 OUTPUT-DIRECTORY-LIST REPORT-STREAM QFASLP
					 NOT-BACKED-UP-ONLY AFTER COPY-ONLY SELECTIVE))
	       
	       (AND DESTEX
		    (RETURN-FROM PRIMITIVE-COPY-FILE
		      (LIST MAPPED-PATHNAME INPUT-PATHNAME OUTNAME INPUT-TRUENAME
			    (COND
			      ((EQ DESTEX :FILE-ALREADY-EXISTS)
			       (if                             ;;Check if a file with greater version exists, mp. 3/30
				 (determine-if-greater-version-exists input-truename outname)   
				 (make-condition 'file-already-exists
						 "~a A file with greater version exists." outname)
				 
				 (MAKE-CONDITION 'FILE-ALREADY-EXISTS
						 "~A File already exists." OUTNAME))
			       (MAKE-CONDITION 'FILE-ALREADY-EXISTS
					       "~A File already exists." OUTNAME))
			      (T (MAKE-CONDITION DESTEX "~a" OUTNAME)))
			    ())))
	       
	       
	       
	       (SETQ INPUT-STREAM		   
		     (APPLY 'OPEN INPUT-PATHNAME :CHARACTERS TRUE-CHARACTERS
			    :BYTE-SIZE (OR TRUE-BYTE-SIZE :DEFAULT) :ERROR error  ;Set :ERROR to error 1/26/87 MP 
			    (CAR OPEN-PARAMETERS)))
	       (WHEN (ERRORP INPUT-STREAM)
		 (WHEN REPORT-STREAM
		   (FORMAT REPORT-STREAM "~%~A~50T~A" INPUT-PATHNAME INPUT-STREAM))
		 (RETURN-FROM PRIMITIVE-COPY-FILE
		   (LIST MAPPED-PATHNAME INPUT-PATHNAME OUTNAME INPUT-STREAM
			 INPUT-STREAM ()))))
	     
	     
	     (SETQ QFASLP (SEND INPUT-STREAM :QFASLP))
	     
	     (UNLESS OUTNAME
	       (MULTIPLE-VALUE-SETQ (OUTNAME OUTPUT-DEFAULTS-FROM-STREAMING DESTEX)
		 (GET-OUTPUT-DESTINATION OUTPUT-SPEC INPUT-STREAM MAPPED-PATHNAME
					 (IF INPUT-STREAM
					     (SEND INPUT-STREAM :TRUENAME)
					     INPUT-TRUENAME)
					 INPUT-PLIST IF-EXISTS OUTPUT-DIRECTORY-LIST
					 REPORT-STREAM QFASLP NOT-BACKED-UP-ONLY
					 AFTER COPY-ONLY SELECTIVE))
	       (AND DESTEX
		    (RETURN-FROM PRIMITIVE-COPY-FILE
		      (LIST MAPPED-PATHNAME INPUT-PATHNAME OUTNAME INPUT-TRUENAME
			    (COND
			      ((EQ DESTEX :FILE-ALREADY-EXISTS)
			       (MAKE-CONDITION 'FILE-ALREADY-EXISTS
					       "~A File already exists." OUTNAME))
			      (T (MAKE-CONDITION DESTEX "~a" OUTNAME)))
			    ())))
	       )
	     (let ( (enough nil))		  ;mp 12/12/86
	       (multiple-value-setq (enough characters byte-size)
		 (check-if-enough-info characters byte-size enough))
	       (if enough
		   
		   (MULTIPLE-VALUE-SETQ (TRUE-CHARACTERS TRUE-BYTE-SIZE)
		     (DETERMINE-CHARACTERS-AND-BYTE-SIZE INPUT-PLIST INPUT-STREAM
							 INPUT-TRUENAME
							 (NOT ORIGINALLY-NOT-A-STREAM)
							 DEFAULT-BYTE-SIZE QFASLP
							 (OR TRUE-CHARACTERS CHARACTERS)
							 (OR TRUE-BYTE-SIZE BYTE-SIZE)
							 default-type))
		   ))
	     
	     (IF (EQ BYTE-SIZE :DEFAULT)
		 (SETQ TRUE-BYTE-SIZE
		       (OR TRUE-BYTE-SIZE (GETF (CDR INPUT-PLIST) :BYTE-SIZE) :DEFAULT))
		 (SETQ TRUE-BYTE-SIZE BYTE-SIZE))
	     
	     (WHEN ORIGINALLY-NOT-A-STREAM
	       (UNLESS (AND
			 (OR KNOWN-BYTE-SIZE
			     (= TRUE-BYTE-SIZE
				(OR (FUNCALL INPUT-STREAM :SEND-IF-HANDLES :BYTE-SIZE)
				    (IF (FUNCALL INPUT-STREAM :CHARACTERS)
					8
					16)))
			     (EQ TRUE-BYTE-SIZE :DEFAULT))
			 (OR (EQ TRUE-CHARACTERS (FUNCALL INPUT-STREAM :CHARACTERS))
			     (EQ TRUE-CHARACTERS :DEFAULT)))
		 (PRINC " -- Must reopen stream")
		 (CLOSE INPUT-STREAM)
		 
		 
		 (SETQ INPUT-STREAM
		       (APPLY 'OPEN INPUT-TRUENAME :ERROR error :BYTE-SIZE	  ;Set :error to error, 1/26/87 MP
			      TRUE-BYTE-SIZE :CHARACTERS true-characters   
			      (CAR OPEN-PARAMETERS)))
		 
		 (WHEN (ERRORP INPUT-STREAM) 
		   (WHEN REPORT-STREAM
		     (FORMAT REPORT-STREAM "~%~A~50T~A" INPUT-PATHNAME INPUT-STREAM))
		   (RETURN-FROM PRIMITIVE-COPY-FILE
		     (LIST MAPPED-PATHNAME INPUT-PATHNAME OUTNAME INPUT-STREAM
			   INPUT-STREAM ())))))
	     
	     

	     (when (EQ TRUE-BYTE-SIZE :DEFAULT)
	       (let ((input-byte-size (send input-stream :send-if-handles :byte-size)))	   ;6.17.87
		 (when input-byte-size (setf true-byte-size input-byte-size))))

	     (WHEN (NEQ TRUE-CHARACTERS (SEND INPUT-STREAM :CHARACTERS))
	       (SETF TRUE-CHARACTERS (SEND INPUT-STREAM :CHARACTERS)))

	     (WHEN (AND (EQ TRUE-CHARACTERS :DEFAULT) (EQ TRUE-BYTE-SIZE :DEFAULT))
	       (IF (SEND INPUT-STREAM :CHARACTERS)
		   (SETF TRUE-CHARACTERS T
			 TRUE-BYTE-SIZE 8)
		   (SETF TRUE-CHARACTERS ()
			 TRUE-BYTE-SIZE 16)))
	     
	     
	     (SETQ INPUT-TRUENAME (SEND INPUT-STREAM :SEND-IF-HANDLES :TRUENAME))
	     
	     (LET ((OUTSTREAM)
		   (*MAC-NFS-COPY-FHANDLE* ())		;; for performance
		   (*MAC-NFS-COPY-CREATION-DATE* ())
		   (AUTHOR
		     (OR (GETF (CDR INPUT-PLIST) :AUTHOR)
			 (FUNCALL INPUT-STREAM :GET :AUTHOR)
			 "Unknown")))
	       (UNWIND-PROTECT (PROGN
				(SETQ OUTSTREAM
				       (OPEN-OUTPUT-FOR-COPY OUTPUT-SPEC OUTNAME
							     INPUT-STREAM
							     TRUE-CHARACTERS
							     TRUE-BYTE-SIZE IF-EXISTS
							     AUTHOR
							     (CADR OPEN-PARAMETERS)
							     CREATE-DIRECTORIES))
				 
				 
				 
				 (IF outstream	  ; Removed re-signaling the error, 1/26/87. MP
				     (PROGN
						;need change in both places, because some xfer protocols
						;need it before close and some need it after.  2.10.88 MBC
						;Moved change properties to after last close. 2.02.88 MBC

				       (CHANGE-PROPERTIES-FOR-COPY INPUT-STREAM	;2.02.88 MBC
						 OUTSTREAM AUTHOR
						 COPY-AUTHOR
						 COPY-CREATION-DATE
						 DO-NOT-COPY-PROPERTIES
						 OUTPUT-DEFAULTS-FROM-STREAMING)
				       (WHEN (NEQ	
					       (IF (AND (FBOUNDP 'MAGTAPE-EOT-STREAM-COPY)
							(OR (MAGTAPE-FILEHANDLE INPUT-STREAM)
							    (MAGTAPE-FILEHANDLE OUTSTREAM)))
						   (MAGTAPE-EOT-STREAM-COPY INPUT-STREAM
									    OUTSTREAM
									    INPUT-PLIST-OR-PATHNAME
									    MAPPED-PATHNAME
									    OUTPUT-SPEC
									    INPUT-STREAM ERROR
									    COPY-CREATION-DATE
									    COPY-AUTHOR
									    REPORT-STREAM
									    VERBOSE
									    CREATE-DIRECTORIES
									    CHARACTERS BYTE-SIZE
									    IF-EXISTS DELETE
									    AFTER DIRECTORY-LIST
									    DEFAULT-BYTE-SIZE
									    OUTPUT-DIRECTORY-LIST
									    SELECTIVE
									    NOT-BACKED-UP-ONLY
									    COPY-ONLY)


						   (prog1 
						     (STREAM-COPY-UNTIL-EOF INPUT-STREAM OUTSTREAM)
						     ;;If the input-stream is a magtape, check the status
                                                     ;; on the device. If end-of-recorded-media, delete the 
                                                     ;; output file we just created.  ; DAB 05-23-90
						     (when (and
							     (type-specifier-p 'mt-filehandle) 
							     (or (TYPEp input-stream 'MT-FILEHANDLE) ; is a mag-tape.
								 (ignore-errors (locate-in-instance
										  input-stream 'mt:header-format))
								 )
							     (EQ (SI::GET-LAST-ERROR
								   (symbol-value 'mt:*CURRENT-UNIT*))
								 :END-OF-RECORDED-MEDIA))
						       ;;If so abort the outstream, otherwise an empty file may result.
						       (close outstream :abort T)) 
						     )
						   )
					       :RE-COPY)
					 (SETQ OUTPUT-TRUENAME
					       (OR
						 (SEND OUTSTREAM :SEND-IF-HANDLES
						       :TRUENAME)
						 OUTSTREAM))
					 (WHEN REPORT-STREAM
					   (FORMAT REPORT-STREAM "~&Copied ~A to ~A "
						   (OR INPUT-TRUENAME INPUT-STREAM)
						   OUTPUT-TRUENAME)
					   (FORMAT REPORT-STREAM
						   "~%Byte size ~D, Characters ~S"
						   TRUE-BYTE-SIZE TRUE-CHARACTERS))
					 (SETQ ABORT-FLAG ())))))
		 (PROGN
		   (unless (or (NULL OUTSTREAM) (ERRORP OUTSTREAM))
		     (CLOSE OUTSTREAM)
		     (CHANGE-PROPERTIES-FOR-COPY INPUT-STREAM	;2.02.88 MBC
						 OUTSTREAM AUTHOR
						 COPY-AUTHOR
						 COPY-CREATION-DATE
						 DO-NOT-COPY-PROPERTIES
						 OUTPUT-DEFAULTS-FROM-STREAMING))
		   (UNLESS OUTPUT-TRUENAME
		     (SETQ OUTPUT-TRUENAME OUTSTREAM))))))
	 
	 (OR (NULL INPUT-STREAM) (ERRORP INPUT-STREAM)
	     (PROGN
	       (AND (NOT ABORT-FLAG) DELETE (FUNCALL INPUT-STREAM :SEND-IF-HANDLES :DELETE ()))
	       (FUNCALL INPUT-STREAM :CLOSE))))
       
       (LIST MAPPED-PATHNAME INPUT-PATHNAME OUTNAME INPUT-TRUENAME OUTPUT-TRUENAME
	     (IF INPUT-STREAM
		 (STREAM-ELEMENT-TYPE INPUT-STREAM)
		 ())))
    
    (ERROR					  ; Detect any error, 1/26/87 MP
     (LIST MAPPED-PATHNAME INPUT-PATHNAME
	   (LET ((*ALWAYS-MERGE-TYPE-AND-VERSION* T))
	     (MERGE-PATHNAME-DEFAULTS
	       (SEND MAPPED-PATHNAME :TRANSLATE-WILD-PATHNAME OUTPUT-SPEC
		     (OR INPUT-TRUENAME INPUT-PATHNAME))
	       (OR INPUT-TRUENAME INPUT-PATHNAME)))
	   INPUT-PATHNAME ERROR))))

))