;;; -*- Mode: LISP; Package: :cl-user; BASE: 10; Syntax: ANSI-Common-Lisp; -*-
;;;
;;;   Touched: Sun Feb 20 15:20:44 2005 +0530 <enometh@net.meer>
;;;   Time-stamp: <05/03/27 10:24:04 madhu>
;;;
;;; Rsync's file-handling and debugger-interaction
;;;
;;;   (C) Copyright 2005 Madhu. ALL RIGHTS ~RESEDA~
;;;   Bugs-To: <enometh@net.meer>
;;;
(defpackage "DIRED"
  (:use "CL"))
(in-package "DIRED")

(eval-when (:load-toplevel :execute :compile-toplevel) (import '(user::$p)))
(eval-when (:load-toplevel :execute :compile-toplevel)
  (load ($p "home:cl/trie"))
  (load ($p "home:cl/super-restart-case"))
  (load ($p "home:cl/choose-with-restarts")))

;;;
;;;
;;;
(progn
  (defparameter *fileset-entry-cache* (make-hash-table :test #'equal)
    "All fileset-entries are interned here")

  (defparameter *fileset-entry-trie*  (trie:make-trie)
    "fileset-entries are also interned in a directory trie"))

(defclass fileset-entry ()
  ((truename :initarg :truename :accessor fileset-entry-truename)
   (stats :accessor stats :initform nil)
   (md5-sum :accessor md5-sum :initform nil)
   (directory-p :initform nil :accessor directory-p)))

(defmethod freshen-fileset-entry ((fileset-entry fileset-entry)
				  &key) ;TODO md5-sum
  (setf (stats fileset-entry)
	(user::stat2 (fileset-entry-truename fileset-entry)))
  #+cmu
  (progn
    (incf (getf (stats fileset-entry) 'user::atime) user::+unix-epoch+)
    (incf (getf (stats fileset-entry) 'user::mtime) user::+unix-epoch+)
    (incf (getf (stats fileset-entry) 'user::ctime) user::+unix-epoch+)))

(defmethod set-timestamps ((truename pathname) stats)
  #+cmu
  (progn
    (when (getf stats 'user::atime)
      (decf (getf stats 'user::atime) user::+unix-epoch+))
    (when (getf stats 'user::mtime)
      (decf (getf stats 'user::mtime) user::+unix-epoch+)))
  (user::setdates2 truename stats))

(defmethod atime ((fileset-entry fileset-entry))
  (getf (stats fileset-entry) 'user::atime))

(defmethod ctime ((fileset-entry fileset-entry))
  (getf (stats fileset-entry) 'user::ctime))

(defmethod mtime ((fileset-entry fileset-entry))
  (getf (stats fileset-entry) 'user::mtime))

(defun %print-unix-time (utime stream)
  (user::iso-8601-date :utime utime :stream stream))

(defmacro %min-times (plist1 plist2)
 `(let ((mtime1 (getf ,plist1 'user::mtime))
	(atime1 (getf ,plist1 'user::atime))
	(mtime2 (getf ,plist2 'user::mtime))
	(atime2 (getf ,plist2 'user::atime)))
    (nconc (when (and mtime1 mtime2) (list 'user::atime (min atime1 atime2)))
	   (when (and atime1 atime2) (list 'user::mtime (min mtime1 mtime2))))))

(defvar *fileset-entry-verbose-listing* nil)

(defmethod print-object ((fileset-entry fileset-entry) stream)
  (print-unreadable-object (fileset-entry stream :type t :identity t)
    (block nil
    (unless (slot-boundp fileset-entry 'truename) (return))
    (write (fileset-entry-truename fileset-entry) :stream stream)
    (let ((list `(("Created: " ,(ctime fileset-entry))
		  ("Modified: " ,(mtime fileset-entry))
		  ("Accessed: " ,(atime fileset-entry)))))
      (setq list (sort list #'< :key #'cadr))
      (when *fileset-entry-verbose-listing*
	(loop initially (progn (terpri stream)
			       (write-char #\tab stream)
			       (write-string"Total-size: " stream)
			       (write (getf (stats fileset-entry)
					    'user::total-size) :stream stream)
			       (terpri stream))
	      for ((string utime) . rest) on list do
	      (write-char #\tab stream)
	      (write-string string stream)
	      (%print-unix-time utime stream)
	      (when rest (terpri stream))))))))

(defmacro ensure-truename (truename)	; truename is a place
  `(let ((real-truename (truename ,truename)))
     (unless (equal real-truename ,truename)
       (warn "Ensure-truename:
using ~A instead of supplied purported-truename ~A."
	     real-truename ,truename)
       (setf ,truename real-truename))))


(defun %probe-directory (truename)
  (if #+cmu (user::probe-directory truename)
      #+clisp (ignore-errors (ext:probe-directory truename))
      t
      nil))

(defun %delete-directory (file-a)
  #+cmu(unix:unix-rmdir (unix::unix-namestring file-a))
  #+clisp(ext:delete-dir file-a))

(defmethod initialize-instance :after
    ((fileset-entry fileset-entry) &rest initargs &key
     (truename (error "key :truename must be supplied."))
     ((:fileset-entry-trie	  ; supply nil to inhibit trie caching
       *fileset-entry-trie*) *fileset-entry-trie*)
     &allow-other-keys)
  (check-type truename pathname)
  (ensure-truename truename)
  ;; primary cache
  (multiple-value-bind (value present-p) ;enforce-singletons
      (gethash truename *fileset-entry-cache*)
    (when present-p
      (error "make-instance 'fileset-entry: ~A:
fileset-entry (~A) exists in *fileset-entry-cache*. (Use
intern-fileset-entry to get at it.)" truename value)))
  (setf (gethash truename *fileset-entry-cache*) fileset-entry)
  ;; cache on trie
  (when *fileset-entry-trie*
    (let* ((dirs (pathname-directory truename))
	   (file-namestring (file-namestring truename))
	   key)
      (assert (eq (pop dirs) :absolute)) ; remove check?
      (setq key (if file-namestring (append dirs (list file-namestring)) dirs))
      (let ((value (trie:trie-get key *fileset-entry-trie*
				  nil :test #'string=)))
	(when value
	  (error "make-instance 'fileset-entry: ~A:g
fileset-entry (~A) exists in *fileset-entry-cachetrie*. (Use
intern-fileset-entry to get at it.)" truename value)))
      (trie:trie-set key *fileset-entry-trie* fileset-entry)))

  ;; allow a :soft keyword arg to inhibit `stat'ing. TODO test
  (let* ((soft-cons (member :soft initargs))
	 (soft-p (if soft-cons (cadr soft-cons))))
    (unless soft-p (freshen-fileset-entry fileset-entry)))

  (setf (directory-p fileset-entry)
	(%probe-directory truename)))

#+nil
(defparameter $a
  (make-instance 'fileset-entry :truename (truename ($p "~/.clisprc.lisp"))
		 :soft nil))

;; Public
;;
(defun intern-fileset-entry (pathname)
  (let ((truename (truename pathname)))
    (multiple-value-bind (value present-p)
	(cl:gethash truename *fileset-entry-cache*)
      (cond (present-p value)
	    (t (make-instance 'fileset-entry :truename truename))))))

#+nil
(defparameter $a
  (intern-fileset-entry ($p "~/.clisprc.lisp")))

#+nil
(let ((*fileset-entry-verbose-listing* t))
  (pprint (intern-fileset-entry ($p "home:/"))))


;;; ----------------------------------------------------------------------
;;;
;;;
(defclass trie ()
  ((trie :initform (trie:make-trie))))

(defclass directory-trie (trie) ())

(defmethod trie-get ((sequence sequence) (directory-trie  directory-trie))
  (with-slots (trie) directory-trie
    (trie:trie-get sequence trie nil :test #'string=)))

(defmethod (setf trie-get)
    ((value fileset-entry) (sequence sequence) (directory-trie directory-trie))
  (with-slots (trie) directory-trie
    (trie:trie-set sequence trie value :test #'string=)))

;;
;;
(defun mystring= (string1 string2)	; string= or eql
  (cond ((and (stringp string1)
	      (stringp string1)) (string= string1 string2))
	(t (or (eql string1 string2)))))

(defmethod trie-key ((fileset-entry fileset-entry) (root-pathname pathname))
  "Returns the key-sequence [RO] which would index fileset-entry
in any trie rooted in root-pathname.
The second value is nil if the fileset-entry cannot be rooted in
root-pathname."
  (ensure-truename root-pathname)
  (let* ((pathname (fileset-entry-truename fileset-entry))
	 (dirs (loop for (x . rest-x) on (pathname-directory pathname)
		     for (y . rest-y) on (pathname-directory root-pathname)
		     unless (mystring= x y) do (loop-finish)
		     if (null rest-y) return rest-x
		     finally (return-from trie-key (values nil nil)))))
    (values (if (directory-p fileset-entry)
		dirs
		(append dirs (list (file-namestring pathname)))) T)))

(defun %find-files (directory-pathname &key (include-directories t))
  (let ((filelist
	 (directory (merge-pathnames
		     (make-pathname
		      :name :wild :version :wild
		      #-clisp :type #-clisp :wild
		      :directory '(:relative :wild-inferiors))
		     directory-pathname nil)
		    #+clisp :if-does-not-exist #+clisp :ignore
		    #+cmu :follow-links #+cmu nil)))
    #+clisp
    (when include-directories
      (setq filelist (nconc filelist
			    (directory (merge-pathnames
					(make-pathname
					 :directory '(:relative :wild))
					directory-pathname nil)))))
    #+cmu
    (unless include-directories
      (setq filelist (delete-if  #'(lambda (pathname)
				     (null (file-namestring pathname)))
				 filelist)))
    filelist))

(defmethod initialize-instance :after
    ((directory-trie directory-trie) &key
     (directory-pathname (error "Key :directory-pathname must be supplied."))
     &allow-other-keys)
  (declare (optimize (debug 3)))
  (check-type directory-pathname pathname)
  (ensure-truename directory-pathname)
  (loop	for f in (let ((x (%find-files directory-pathname)))
		   (pushnew (truename directory-pathname) x :test #'equal) x)
	for entry = (intern-fileset-entry f)
	do (multiple-value-bind  (key ok)
	       (trie-key entry directory-pathname)
	     (unless ok
	       (error "Entry ~A cannot fit in a trie rooted at ~A"
		      entry directory-pathname))
	     (let ((obj (trie-get key directory-trie)))
	       (when obj
		 (error "fileset entry ~A already present: ~A" obj entry)))
	     (setf (trie-get key directory-trie) entry))))

#+nil
(defparameter $x (intern-fileset-entry  ($p "home:spki/crypticl/")))

(defun walk-trie (directory-trie-1 &key
		   (pre-process (lambda (k v)
				  (declare (ignorable k))
				  (warn "pre-processing ~A" v)
				  :descend))
		   (post-process (lambda (k v)
				   (declare (ignorable k))
				   (warn "post-processing ~A" v))))
  ;; TODO make this a method combination.  The :pre-process method is
  ;; invoked before descending a level. If this returns nil, the level
  ;; is not descended, and the post-processing method is not invoked.
  ;; Otherwise the level is descended, and The :post-process method is
  ;; invoked when the recursion unwinds
  (with-slots (trie) directory-trie-1
    (let ((key-so-far (make-array 20 :adjustable t :fill-pointer 0)))
      (labels ((recurse-1 (trie)
		 (vector-push-extend 0 key-so-far)
		 (unwind-protect
		      (loop for pair in (cdr trie) do
			    (setf (aref key-so-far
					(1- (fill-pointer key-so-far)))
				  (car pair))
			    (recurse (cdr pair)))
		   (decf (fill-pointer key-so-far))))
	       (recurse (trie &optional obj1)
		 (let ((descend-p t))
		   (when (setf obj1 (car trie))
		     (when pre-process
		       (setf descend-p (funcall pre-process key-so-far obj1))))
		   (when descend-p
		     (recurse-1 trie)
		     (when obj1
		       (when post-process
			 (funcall post-process key-so-far obj1)))))))
	(recurse trie)))))

(defmethod trie-root-pathname ((directory-trie directory-trie))
  (let ((entry (trie-get nil directory-trie)))
    (when entry (fileset-entry-truename entry))))

(defmethod print-object ((directory-trie directory-trie) stream)
  (print-unreadable-object (directory-trie stream :type t :identity t)
    (let ((root (namestring (trie-root-pathname directory-trie))))
      (when root
	(write-string root stream)))))


;;; ----------------------------------------------------------------------
;;;
;;;
(defvar *move-policy* :update)
(declaim (type (member :update 	; update target inplace, delete source
		       :rename		; delete target, rename source
		       )
	       *move-policy*))

(defvar *timestamp-reset-policy* :minimum)
(declaim (type (member :source 	; preserve source's times
		       :minimum	; keep lowest times
		       :target	; preserve target's times
		       )
	       *timestamp-reset-policy*))

(defun change-policy-settings-restarts ()
  (user::super-restart-case
      (error "Change policy settings")
    (change-move-policy ()
      :report ("Toggle move policy from ~A to ~A"
	       *move-policy*
	       (cond ((eq *move-policy* :update) :rename)
		     (t :update)))
      (setf *move-policy*
	    (cond ((eq *move-policy* :update) :rename)
		  (t :update)))
      (user::retry))
    (change-timestamp-reset-policy ()
      :report ("Change timestamp reset policy (current value: ~A)"
	       (ecase *timestamp-reset-policy*
		 ((:source :minimum :target) *timestamp-reset-policy*)))
      (let ((choices (remove *timestamp-reset-policy*
			     (list :source :minimum :target))))
	(ecase (user::choose-with-restarts choices
		 (error "Choose new timestamp reset policy."))
	  (:source (setf *timestamp-reset-policy* :source))
	  (:target (setf *timestamp-reset-policy* :target))
	  (:minimum (setf *timestamp-reset-policy* :minimum)))
	(user::retry)))
    (done ()
      :report "Finish changing policies"
      (user::unwind))))

;;;
;;;
;;;
(defun set-default-restart (variable choices)
    (set variable
	 (user::choose-with-restarts choices
	   (error "Set default restart on ~A.
No more questions will be asked." variable))))

(defmacro with-default-restart ((variable) (error condition-type &rest args))
  "The macro signals an error of type CONDITION-TYPE with
arguments ARGS. VARIABLE names a special variable whose value is
a restart identifier. If VARIABLE is bound and its value is an
active restart, it is automatically invoked."
  (assert (eq error 'error))		;; NOTE: shady macro
  (let ((condition (etypecase condition-type
		     ;; evaluate it so we can fake ERROR's signature
		     (symbol condition-type)
		     (list (funcall
			    (compile nil `(lambda nil ,condition-type)))))))
    `(handler-bind
	 ((,condition
	   (lambda (c)
	     (declare (ignore c))
	     (declare (special ,variable))
	     (when (and (boundp ',variable) ,variable)
	       (let ((restart (find-restart ,variable)))
		 (when restart
		   (invoke-restart restart)))))))
       (error ',condition ,@args))))

#+nil
(let ((*default-restart* 'foo))
  (declare (special *default-restart*))
  (restart-case
      (with-default-restart (*default-restart*)
	(error 'error))
    (foo ()
	42)))

;;;
;;;
;;;
(defun read-lines (stream)
  (declare (type stream stream))
  (loop for x = (read-line stream nil)	while x collect x))

(defmacro %shell-command (&rest args)
  `(let ((stream
	  #+clisp(ext:run-shell-command (format nil ,@args)
					:input nil :output :stream)
	  #+cmu
	  (let ((process
		 (ext:run-program "/bin/sh" (list "-c"
						  (format nil ,@args))
				  :wait t
				  :pty nil
				  :input nil
				  :output :stream
				  :error t)))
	    (ext:process-output process))))
     (read-lines stream)))

;;;
;;;
;;;
(defun typeout-line (format-string &rest args)
  (declare (special *typeout-lines*))
  (when (and (boundp '*typeout-lines*) (listp *typeout-lines*))
    (push (apply #'format nil format-string args) *typeout-lines*)))

(defun flush-typeout (stream)
  (declare (special *typeout-lines*))
  (when (and (boundp '*typeout-lines*) (listp *typeout-lines*) *typeout-lines*)
    (format stream "Typeout history:~&~{~A~&~}" *typeout-lines*)
    (finish-output stream)))

(define-condition source-and-target ()
  ((source :initarg :source :reader source :type fileset-entry)
   (target :initarg :target :reader target :type fileset-entry))
  (:report
   (lambda (condition stream)
     (let ((*fileset-entry-verbose-listing* t))
       (let ((source (source condition)) (target (target condition)))
	 (format stream "Source and Target:~%~A~%~A~%" source target))
       (flush-typeout stream)))))

#+nil
(let ((*typeout-lines* nil))
  (declare (special *typeout-lines*))
  (typeout-line "foo")
  (typeout-line "bar")
  (error 'source-and-target
	 :source (intern-fileset-entry"cmu/cl-pdf/#config.lisp#")
	 :target (intern-fileset-entry #P"cmu/cl-pdf/config.lisp")))



(defvar *rsync-1-default-restart* nil)

(defun rsync-1 (source target)
  (check-type source fileset-entry)
  (check-type target fileset-entry)
  (let ((file-a (fileset-entry-truename source))
	(file-b (fileset-entry-truename target))
	(stats-a (stats source))
	(stats-b (stats target))
	(*typeout-lines* nil))
    (declare (special *typeout-lines*))
    (flet ((rename ()			;actions
	     (rename-file file-a file-b)
	     (warn "rm ~A; mv ~A ~A" file-b file-a file-b))
	   (update ()
	     (user::|cat a > b| file-a file-b)
	     (warn "cat ~A > ~A; rm ~A" file-a file-b file-a))
	   (delete-source ()
	     (cond ((directory-p source)
		    (%delete-directory file-a)
		    (warn "rmdir ~A" file-a))
		   (t
		    (delete-file file-a)
		    (warn "rm ~A" file-a))))
	   (delete-target ()
	     (cond ((directory-p target)
		    (%delete-directory file-b)
		    (warn "rmdir ~A" file-b))
		   (t (delete-file file-b)
		      (warn "rm ~A" file-a))))
	   (set-target-timestamps (stats)
	     (set-timestamps file-b stats)
	     (freshen-fileset-entry target)
	     (let ((*fileset-entry-verbose-listing* t))
	       (warn "Reset Timestamps. Target=~%~A~%" target)))
	   (set-source-timestamps (stats)
	     (set-timestamps file-a stats)
	     (freshen-fileset-entry source)
	     (let ((*fileset-entry-verbose-listing* t))
	       (warn "Reset Timestamps. Source=~%~A~%" target)))
	   (warn (&rest args)
	     (apply #'typeout-line args)
	     (apply #'warn args)))
      (user::super-restart-case
	  (let ((maybe-reset-atimes (/= (getf stats-a 'user::atime)
					(getf stats-b 'user::atime)))
		(maybe-reset-mtimes (/= (getf stats-a 'user::mtime)
					(getf stats-b 'user::mtime)))
		(file-sizes-differ (/= (getf stats-a 'user::total-size)
				       (getf stats-b 'user::total-size))))
	    (when (or maybe-reset-mtimes maybe-reset-atimes file-sizes-differ)
	      (typeout-line "Diagnostics: files differ in their ~:[~;Access-times~] ~:[~;Modification-times~] ~:[~;File-Sizes~]"
			    maybe-reset-atimes maybe-reset-mtimes
			    file-sizes-differ))
	    (with-default-restart (*rsync-1-default-restart*)
	      (error 'source-and-target :source source :target target)))
	;;
	;; the restarts:
	;;
	(set-default-restart ()
	  :report ("Set default restart to be automatically invoked on encountering this condition.
~@[Current Value: ~A.~]"
		   *rsync-1-default-restart*)
	  (set-default-restart
	   '*rsync-1-default-restart*
	   '(default-action rename update delete-source delete-target nil)))
	(default-action ()
	  :report ("Default policy: ~A and~&Reset target timestamp to ~A"
		   *move-policy* *timestamp-reset-policy*)
	  :test (lambda (c)
		  (declare (ignore c))
		  (not (directory-p target)))
	  (let (stats)
	    (ecase *move-policy*
	      (:rename
	       (delete-source)
	       (rename)
	       (setf stats (ecase *timestamp-reset-policy*
			     (:target
			      (warn "touch -r ~A.ORIG ~A" file-b file-b)
			      stats-b)
			     ((:source :none))
			     (:minimum (%min-times stats-a stats-b)))))
	      (:update
	       (update)
	       (setf stats (ecase *timestamp-reset-policy*
			     (:target
			      (warn "touch -r ~A.orig ~A" file-a file-a)
			      stats-b)
			     (:source
			      (warn "touch -r ~A.ORIG ~A" file-a file-b)
			      stats-a)
			     (:none)
			     (:minimum (%min-times stats-a stats-b))))))
	    (when stats
	      (set-target-timestamps stats)))
	  (user::unwind))
	(rename ()
	  :report "just rename source to target"
	  (rename)
	  (user::retry))		;XXX freshen
	(update ()
	  :report "just update target by copying source inplace"
	  :test (lambda (c)
		  (declare (ignore c))
		  (not (directory-p target)))
	  (update)			;XXX freshen
	  (user::retry))
	(delete-source ()
	  :report "just delete source"
	  (delete-source)
	  (user::unwind))
	(delete-target ()
	  :report "just delete target"
	  (delete-target)
	  (user::unwind))
	(touch-source-to-target ()
	  :report "Set source to target's times."
	  (warn "touch -r ~a ~a" file-b file-a)
	  (set-source-timestamps stats-b)
	  (user::retry))
	(touch-target-to-source ()
	  :report "Set target to source's times."
	  (warn "touch -r ~a ~a" file-a file-b)
	  (set-target-timestamps stats-a)
	  (user::retry))
	(touch-target-minimum-times ()
	  :report "Set source to minimum times"
	  (set-target-timestamps (%min-times stats-a stats-b))
	  (user::retry))
	(touch-source-minimum-times ()
	  :report "Set target to minimum times"
	  (set-source-timestamps (%min-times stats-a stats-b))
	  (user::retry))
	(run-diff ()
	  :report ("run diff ~a ~a" file-a file-b)
	  :test (lambda (c)
		  (declare (ignore c))
		  (notevery #'directory-p (list source target)))
	  (setf *typeout-lines*
		(cons "Diff output:"
		      (%shell-command "diff ~S ~S" (namestring file-a)
				      (namestring file-b))))
	  (user::retry))
	(change-policies ()
	  :report "change default policies"
	  (change-policy-settings-restarts)
	  (user::retry))
	(do-nothing ()
	  :report "Skip these files"
	  (user::unwind))))))


;;;
;;;
;;;

(define-condition missing-target ()
  ((source :initarg :source :type fileset-entry :reader source))
  (:report (lambda (condition stream)
	     (let ((*fileset-entry-verbose-listing* t))
	       (format stream "Missing Target for source~&~A."
		       (source condition))))))

(defvar *rsync-2-default-restart* nil)

(defun rsync-2 (source target)
  (declare (special $a $b))
  (check-type source fileset-entry)
  (check-type target null)
  (let* ((key (trie-key source (trie-root-pathname $a)))
	 (file-namestring (if (directory-p source) nil (car (last key))))
	 (path (if (directory-p source) key (butlast key)))
	 (target-parent (trie-get path $b))
	 (target-root (trie-root-pathname $b))
	 (target-parent-constructed-pathname
	  (when target-root
	    (make-pathname :name nil :version nil :type nil
			   :directory (append
				       (pathname-directory target-root)
				       path)
			   :defaults target-root)))
	 (target-parent-pathname
	  (if target-parent
	      (prog1 (fileset-entry-truename target-parent)
		(when target-parent
		  (assert (eq target-parent
			      (intern-fileset-entry
			       target-parent-constructed-pathname)))))
	      target-parent-constructed-pathname))
	 (target-pathname
	  (if file-namestring
	      (merge-pathnames file-namestring target-parent-pathname)
	      target-parent-pathname)))
    (user::super-restart-case	 ; still have to test the directories case
	(with-default-restart (*rsync-2-default-restart*)
	  (error 'missing-target :source source))
      (set-default-restart ()
	:report ("Set default restart to invoke whenever this condition is raised~&~@[Current value: ~A~]" *rsync-2-default-restart*)
	(set-default-restart
	 '*rsync-2-default-restart*
	 '(move-to-parent move-to-target nil))
	(user::retry))
      (move-to-parent ()
	:report ("move ~a~&to target parent ~a" (fileset-entry-truename source)
						target-parent-pathname)
	(rename-file (fileset-entry-truename source)
		     target-parent-pathname)
	(warn "mv ~a ~a" (namestring (fileset-entry-truename source))
	      (namestring target-parent-pathname))
	(user::unwind))
      (move-to-target ()
	:report ("move ~a~&to ~a" (fileset-entry-truename source)
				  target-pathname)
	(rename-file (fileset-entry-truename source) target-pathname)
	(warn "mv ~a ~a" (namestring (fileset-entry-truename source))
	      (namestring target-parent-pathname))
	(user::unwind))
      (delete-source ()
	:report ("Just delete ~A" (fileset-entry-truename source))
	(cond ((directory-p source)
	       (%delete-directory (fileset-entry-truename source))
	       (warn "rmdir ~a"
		     (namestring (fileset-entry-truename source))))
	      (t (delete-file (fileset-entry-truename source))
		 (warn "rm ~a" (namestring (fileset-entry-truename source))))))
      (create-target-parent ()
	:test (lambda (c)
		(declare (ignore c))
		(not (%probe-directory target-parent-pathname)))
	:report ("Create parent directory exists: ~A"
		 target-parent-pathname)
	(ensure-directories-exist target-parent-pathname)
	(user::retry))
      (do-nothing ()
	:report "Skip this target"
	(user::unwind)))))


(defun rsync (source target)
  (declare (special $a $b))
  (check-type source fileset-entry)
  (etypecase target
    (fileset-entry
     (unless (if (directory-p source)
		 (directory-p target)
		 (not (directory-p target)))
       (cerror "Continue without understanding consquences?"
	       "Source and target aren't of same type."))
     (rsync-1 source target))
    (null (rsync-2 source target))))


(defun cmp-1 ($a $b)			; but this is the entry-point
  (declare (special $a $b))
  (flet ((pre-process (key entry)
	   (declare (ignore key entry))	; do everything post-process
	   t)
	 (post-process (key entry)
	   (let ((obj2 (trie-get key $b)))
	     (rsync entry obj2))))
  (setf *rsync-2-default-restart* nil
	*rsync-1-default-restart* nil)
    (walk-trie $a
		:pre-process #'pre-process
		:post-process #'post-process)))

#+nil
(progn
  (defparameter $a
    (make-instance 'directory-trie
		   :directory-pathname ($p "home:Outbox/crypticl/")))
  (defparameter $b
    (make-instance 'directory-trie
		   :directory-pathname ($p "home:cmu/crypticl/"))))

#+nil
(cmp-1 $a $b)


;;; ----------------------------------------------------------------------
;;;
;;;

;;;
;;; aux
;;;
(defun basename (file-namestring)	; my basename-filter
  (let ((length (length file-namestring)))
    (or (some #'(lambda (ends-with &optional (sub-length (length ends-with))
			 &aux (pos  (- length sub-length)))
		  (when (> pos 0)
		    (when (search ends-with file-namestring
				  :start2 pos
				  :test #'string-equal)
		      (basename
		       (subseq file-namestring 0 pos)))))
	      '(".gz" ".Z" ".bz2" ".zip"  ".tz2" ".ps" ".pdf" ".txt" ".html")
	      '(    3   2      4      4       4     3      4      4       5))
	file-namestring)))

#+nil
(basename "foo.txt.BZ2")

(defclass directory-contents ()
  ((filter-function :initform (user::compose #'basename #'file-namestring)
		    :initarg :filter-function
		    :documentation "Function of one argument, a
pathname, returning a string which represents a key,")
   (directory-pathname :initarg :directory-pathname)
   (file-namestring-hash :initform (make-hash-table :test #'equal)
			 :accessor file-namestring-hash)
   (filelist :initform nil :accessor filelist)))

(defmethod initialize-instance :after
    ((directory-contents directory-contents) &rest initargs
     &key (directory-pathname
	   (error "Key :directory-pathname must be supplied."))
     &allow-other-keys)
  (declare (ignore initargs))
  (check-type directory-pathname pathname)
  (with-slots (filelist file-namestring-hash filter-function)
      directory-contents
    (setf filelist (%find-files directory-pathname :include-directories nil))
    (loop for f in filelist
	  for key = (funcall filter-function f)
	  for fileset-entry = (intern-fileset-entry f)
	  do
	  (multiple-value-bind (fileset-entries present-p)
	      (cl:gethash key file-namestring-hash)
	    (cond ((not present-p)
		   (setf (cl:gethash key file-namestring-hash) fileset-entry))
		  (t (etypecase fileset-entries	; root-of-evil
		       (cons
			(cond ((find fileset-entry fileset-entries)
			       (warn "Ignoring duplicate
			       fileset-entry ~A for ~A."
				     fileset-entry f))
			      (t (setf (cl:gethash key file-namestring-hash)
				       (push fileset-entry fileset-entries)))))
		       (fileset-entry
			(cond ((eql fileset-entry fileset-entries)
			       (warn "ignoring duplicate
			       fileset-entry ~A for ~A."
				     fileset-entry f))
			      (t (setf (cl:gethash key file-namestring-hash)
				       (list fileset-entry fileset-entries))))))))))))



(define-condition multiple-files ()
  ((fileset-list :initarg :fileset-list :reader fileset-list))
  (:report (lambda (condition stream)
	     (format stream "Multiple files found: ~&")
	     (loop for i from 0
		   for (fileset-entry . rest) on (fileset-list condition)
		   do (format stream "~D:~T~A~@[~&~]" i fileset-entry rest)))))


;;;; ----------------------------------------------------------------------

(defvar *fileset-list*)

(defun read-fileno (&optional (*fileset-list* *fileset-list*)
		    (length (length *fileset-list*)))
  "Print the choices and return the chosen position in choices"
  (format t "~& ==-=---- READ-FILENO  ----------------=-==~&")
  (loop with *fileset-entry-verbose-listing* = t
	for i from 0 for file in *fileset-list* do ; make-menu
	(format t "~D:~T ~A~&" i file))
  (loop
     (format t "Enter a number between 0 and ~D: ~&" (1- length)) ; XXX
     (let* ((*read-eval* nil) (val (read)))
       (format t "~&Read: ~S.~&" val)
``       (finish-output t)
       (when  (and (integerp val) (<= 0 val) (< val length))
	 (return (multiple-value-list (nth val *fileset-list*))))
       (format t  "Invalid input: ~A.~&" val))))

#+nil
(read-fileno (list $c $d))

(defun handle-multiple-files (fileset-list)
  (let ((*fileset-list* fileset-list))
    (restart-case (error 'multiple-files :fileset-list fileset-list)
      (keep-one-file (file)
	:report "Keep one file, delete the Rest"
;;;	:test (lambda (c) (when c (typep c 'multiple-files)))
	:interactive read-fileno
	(format t "Keeping file=~S, deleting rest.~%" file)
	(let ((min-times  (stats (car fileset-list))))
	  (loop for x in (cdr fileset-list) do
		(setf min-times (%min-times min-times (stats x))))
	  (warn "min-times=~S" min-times)
	  (set-timestamps (fileset-entry-truename file) min-times)
	  (let ((*fileset-entry-verbose-listing* t))
	    (warn "Reset minimum times: ~S" file)))

	(loop for fileset-entry in (delete file fileset-list) do
	      (warn "deleting ~S" fileset-entry)
	      (delete-file (fileset-entry-truename fileset-entry))))
      (do-nothing ()
	:report "Do nothing"
;;;	:test (lambda (c) (when c (typep c 'multiple-files)))
	))))

(defmethod find-duplicates ((directory-contents directory-contents))
  (loop for file-key being each hash-key
	of (file-namestring-hash directory-contents)
	using (hash-value fileset-list)
	when (consp fileset-list)
	do (handle-multiple-files fileset-list)))

(defun purge-duplicates ($a $b)
  (loop for file-a being each hash-key of  (file-namestring-hash $a)
	do (multiple-value-bind (value-b present-p)
	       (cl:gethash  file-a (file-namestring-hash $b))
	     (when present-p
	       (let* ((value-a (cl:gethash file-a (file-namestring-hash $a)))
		      (fileset-list (sort
				     (etypecase value-a
				       (cons (etypecase value-b
					       (cons (nconc value-a value-b))
					       (atom (cons value-b value-a))))
				       (atom (etypecase value-b
					       (cons (cons value-a value-b))
					       (atom (list value-a value-b)))))
				     #'< :key #'ctime)))
		 (handle-multiple-files fileset-list))))))
#+nil
(purge-duplicates $a $b)

#+nil
(setq $a (make-instance 'directory-contents
	   :directory-pathname #p"home:/docs/hp-sdi/"))

#+nil
(setq $b (make-instance 'directory-contents
	   :directory-pathname #p"/mnt/win98/madhu/hp/"))

#+nil
(setq $a (make-instance 'directory-contents
			:directory-pathname (truename ($p "home:/cl/"))))

#+nil
(loop for key being each hash-key of (file-namestring-hash $a)
      using (hash-value value)
      if (consp value)
      do (format t "~&;; ---------- ~A~&(~{~A~&~^ ~})" key value))

#+nil
(progn
  (defparameter $a
    (make-instance 'directory-contents
		   :directory-pathname #P"home:spki/crypticl/"))
  (defparameter $b
    (make-instance 'directory-contents
		   :directory-pathname #P"home:cmu/crypticl/")))

;; if files are identical, set the timestamp to lower one


;;; ----------------------------------------------------------------------
;;;
;;; Tue Mar 22 21:18:01 2005 +0530

#+nil
(progn
(defvar $a (make-instance 'directory-trie :directory-pathname
			  ($p "home:News/cache/comp.lang.lisp/")))

(defun index (directory-trie)
  (flet ((pre-process (key entry) :postprocess)
	 (post-process (key entry)
	   (if (directory-p entry)
	       nil
	       (prog1 :postprocess
		 (warn "processing key ~A" key)))
	   (idx:add-text-file-to-document-universe
	    (fileset-entry-truename  entry))))
    (walk-trie directory-trie
		:pre-process #'pre-process
		:post-process #'post-process)))



(index $a))

;; BUG 050323 in processing root item (in walk-trie?) - shouldnt be
;; processed.
; (defindent user::choose-with-restarts (4 &lambda &body)))


;;; ----------------------------------------------------------------------
;;;
;;;
(defun %last (vector &key (if-does-not-exist :soft))
  (declare (type vector vector))
  (let ((length (length vector)))
    (cond ((zerop length)
	   (ecase if-does-not-exist
	     (soft nil)
	     (error "Cannot aref the last element of an empty vector")))
	  (t (aref vector (1- length))))))

(defsetf %last (vector) (new-element)
  (declare (type vector vector))
  `(let ((length (length ,vector)))
     (cond ((zerop length))
	   (t (setf (aref ,vector (1- length)) ,new-element)))))

(defun %butlast (vector &optional)
  (declare (type vector vector))
  (let ((length (length vector)))
    (subseq vector 0 (1- length))))

(defun %nbutlast (vector &optional)
  (declare (type vector vector))
  (let ((length (length vector)))
    (if (array-has-fill-pointer-p vector)
	(prog1 vector (setf (fill-pointer vector) (1- length)))
	(%butlast vector))))


#+nil(progn
       (%last "25234523")
       (let ((a  "25234523")) (setf (%last) #\a) a)
(%butlast "25234523")
(let ((a (make-array 8 :initial-contents "12345678"
		     :fill-pointer t)))
  (assert (eq (%nbutlast a) a))a))

#+nil
(setq $y
 (with-input-from-string (s user::$str)
  (loop for x = (read-line s nil)
	while x
	if (eql (%last x) #\#)
	collect (parse-namestring x))))

#+nil
(defmacro %shell-command (&rest args)
  `(warn "~A" (format nil ,@args)))


#+nil
(%shell-command "diff ~s ~s"
	       (namestring #P"#.newsrc-dribble#")
	       (namestring #P"#.newsrc-dribble"))

(defun original-pathname (backup-pathname)
  (let ((file-namestring (file-namestring backup-pathname)))
    (assert (eql (%last file-namestring) #\#))
    (assert (eql (aref file-namestring 0) #\#))
    (merge-pathnames (subseq (%butlast file-namestring) 1)
		     (make-pathname :name nil :version nil :type nil
				    :directory
				    (pathname-directory backup-pathname)
				    :defaults backup-pathname))))

#+nil
(loop for x in $y
      for y = (original-pathname x)
      when (and x y (probe-file x) (probe-file y))
      do
      (let ((x  (intern-fileset-entry x))
	    (y  (intern-fileset-entry y))
	    (*typeout-lines* nil))
	(declare (special *typeout-lines*))
	(user::super-restart-case
	    (error  'source-and-target :source x :target y)
	  (run-diff ()
	    :report "run diff"
	    (setf *typeout-lines*
		  (%shell-command "diff ~a ~a"
				 (namestring (fileset-entry-truename x))
				 (namestring (fileset-entry-truename y))))
	    (user::retry))
	  (do-nothing ()
	    :report "skip this"
	    (user::unwind)))))