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

;;; Reason: Misc fixes to copy-newer-files.

;;;                           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.12
;;; Written 05/24/90 13:17:06 by BERGER,
;;; while running on Pasteur from band LOD2
;;; With SYSTEM 6.35, VIRTUAL-MEMORY 6.3, EH 6.8, 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.11, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.2,
;;;  COMPILER 6.14, TV 6.25, DATALINK 6.0, CHAOSNET 6.7, GC 6.4, MEMORY-AUX 6.0, NVRAM 6.3,
;;;  SYSLOG 6.2, STREAMER-TAPE 6.6, UCL 6.0, INPUT-EDITOR 6.0, METER 6.2, ZWEI 6.17,
;;;  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.6, 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.5, PROFILE 6.3, VISIDOC 6.7, TI-CLOS 6.47, 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 copy-newer-files (from-directory to-directory &rest options)
  "For each file in FROM-DIRECTORY that is more recent than the corresponding 
file in TO-DIRECTORY, copy the file from FROM-DIRECTORY to TO-DIRECTORY.
This is particularly useful for updating copies on Unix or Macintosh where 
there aren't any version numbers.  The keyword options have the same meaning 
as for COPY-FILE, although many of the default values are different."
  (declare (arglist from-directory to-directory &key (:selective t) (:report-stream t) :after
		    (:create-directories t) (:characters :maybe-ask)
		    (:not-backed-up-only nil) (:set-backed-up-flag nil)))
  (when (= (length options) 1)
    ;; for compatibility with old calling sequence
    (setf options (list ':selective (first options))))
  (let* ((from-path (pathname from-directory))
	 (to-path (pathname to-directory))
	 ;; Carefully avoid using pathname merging because it is too hard to
	 ;; get it to do what I want.
	 (from-dir (send from-path :new-pathname
			 :name (or (send from-path :name) :wild)
			 :type (or (send from-path :type) :wild)
			 :version :newest))
	 (to-dir (send (send to-path :new-pathname
			     :directory (or (send to-path :directory)
					    (send from-path :directory))
			     :name nil
			     :type nil
			     :version nil)
		       :translated-pathname))
	 (from-list (fs:directory-list from-dir))
	 (to-list (fs:directory-list (send to-dir :new-pathname
					   :name (or (send from-path :name) :wild)
					   :type (or (send from-path :canonical-type) :wild)	;ab 3/18/88
					   :version :newest)
				     :noerror ))	;ab 3/17/88
	 (files-to-copy '())
	 (directories-to-copy '())
	 (source-versions '?)
	 (destination-versions '?))
    (declare (list files-to-copy))
    (multiple-value-bind (query-p after copy-file-options)
	(apply #'(lambda (&key (selective t) (report-stream t) (after most-negative-fixnum)
			       (create-directories t) (characters :maybe-ask)
			       (not-backed-up-only nil) (set-backed-up-flag nil))
		   (values selective
			   (if (integerp after) after (time:parse-universal-time after 0 nil nil))
			   (list :report-stream report-stream :characters characters
				 :create-directories create-directories
				 :not-backed-up-only not-backed-up-only
				 :set-backed-up-flag set-backed-up-flag)))
	       options)
      (flet ((newer-pathname-p (from-file from-plist to-file to-plist)
			       ;; is from-file newer than to-file?
			       (let ((from-version (send from-file :version))
				     (to-version (send to-file :version)))
				 (if (and (numberp from-version)
					  (numberp to-version))
				     (> from-version to-version)
				     (> (getf from-plist :creation-date 0)
					(getf to-plist :creation-date 0))))))
	(dolist (from-info from-list)
	  (let ((from-file (car from-info))
		(from-plist (cdr from-info)))
	    (cond ((null from-file))		; information about current directory, ignore.
		  ((getf from-plist :directory nil)	; a sub-directory
		   (let* ((from-name (send from-file :name))
			  (sub-dir (send from-file :new-pathname
					 :directory (append (send from-file :directory)
							    (list from-name))
					 :name nil :type nil :version nil)))
		     (when (or (not query-p)
			       (y-or-n-p "Copy sub-directory \"~A\"?" sub-dir))
		       (push (list sub-dir
				   (send to-dir :new-pathname
					 :directory (append (send to-dir :directory)
							    (list from-name))
					 ))
			     directories-to-copy)) ))
		  (t				; else a file.
		   (when (eq source-versions '?)
		     (setq source-versions (numberp (send from-file :version))))
		   (let* ((from-name (send from-file :name))
			  (from-type (send from-file :canonical-type))
			  (to-pathname (send to-dir :new-pathname
					     :name from-name
					     :canonical-type (send from-file :canonical-type)
					     :version (if (and source-versions destination-versions)
							  (send from-file :version)
							  :newest)))
			  (to-file nil)
			  (to-plist nil)
			  )
		     (when (listp to-list)
		       (dolist (to-info to-list)
			 (unless (null (car to-info))
			   (when (eq destination-versions '?)
			     (setq destination-versions (numberp (send (car to-info) :version))))
			   (when (and (string-equal from-name
						    (send (car to-info) :name))
				      (equal from-type (send (car to-info) :canonical-type)))
			     (setq to-file (car to-info))
			     (setq to-plist (cdr to-info))
			     (return)))))
		     (when (and (or (null to-file)
				    (newer-pathname-p from-file from-plist to-file to-plist))
				(>= (getf from-plist :creation-date 0) after)
				(or (not query-p)
				    (y-or-n-p "Copy \"~A\" to \"~A\"?" from-file to-pathname)))
		       (push (list from-file to-pathname)
			     files-to-copy))))))))
      (setq directories-to-copy (nreverse directories-to-copy))
      (dolist (elt directories-to-copy)
	(CATCH-ERROR-RESTART (ERROR "Give up copying sub-directory \"~A\"" (first elt))
	  (apply #'copy-newer-files (first elt) (second elt) options)
	  ))
      (setq files-to-copy (nreverse files-to-copy))
      (dolist (elt files-to-copy)
	(CATCH-ERROR-RESTART (ERROR "Give up copying \"~A\" and continue with the next file."
				    (first elt))
	  (apply #'copy-file (first elt) (second elt) copy-file-options)
	  )))
    (values)))
))