Re: patch-copy-dir-with-stefan-changes

[Stefan Monnier <monnier@iro.umontreal.ca>]

> here another approach to fix copy-directory and dired.

Looks good.

I'm not sure how it can get away with removing dired-do-create-files
without removing any call to it, but other than that it looks like the
best solution.  Any other opinion?


        Stefan


> ---
>  lisp/dired-aux.el |   91 ++---------------------------------------------------
>  lisp/files.el     |   53 +++++++++++++------------------
>  2 files changed, 25 insertions(+), 119 deletions(-)

> diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el
> index 28b285f..5bb9d73 100644
> --- a/lisp/dired-aux.el
> +++ b/lisp/dired-aux.el
> @@ -1345,6 +1345,7 @@ Special value `always' suppresses confirmation."
>  	(when cons (setcar cons cur-dir))))))
>  \f
>  ;; The basic function for half a dozen variations on cp/mv/ln/ln -s.
> +\f
>  (defun dired-create-files (file-creator operation fn-list name-constructor
>  					&optional marker-char)
 
> @@ -1403,6 +1404,8 @@ ESC or `q' to not overwrite any of the remaining files,
>                    (cond  ((integerp marker-char) marker-char)
>                           (marker-char (dired-file-marker from)) ; slow
>                           (t nil))))
> +            (when (and (file-directory-p from) (eq file-creator 'dired-copy-file))
> +              (setq to (file-name-directory to)))
>              (condition-case err
>                  (progn
>                    (funcall file-creator from to dired-overwrite-confirmed)
> @@ -1445,94 +1448,6 @@ ESC or `q' to not overwrite any of the remaining files,
>        (message "%s: %s file%s"
>  	       operation success-count (dired-plural-s success-count)))))
>    (dired-move-to-filename))
> -\f
> -(defun dired-do-create-files (op-symbol file-creator operation arg
> -					&optional marker-char op1
> -					how-to)
> -  "Create a new file for each marked file.
> -Prompts user for target, which is a directory in which to create
> -  the new files.  Target may also be a plain file if only one marked
> -  file exists.  The way the default for the target directory is
> -  computed depends on the value of `dired-dwim-target-directory'.
> -OP-SYMBOL is the symbol for the operation.  Function `dired-mark-pop-up'
> -  will determine whether pop-ups are appropriate for this OP-SYMBOL.
> -FILE-CREATOR and OPERATION as in `dired-create-files'.
> -ARG as in `dired-get-marked-files'.
> -Optional arg MARKER-CHAR as in `dired-create-files'.
> -Optional arg OP1 is an alternate form for OPERATION if there is
> -  only one file.
> -Optional arg HOW-TO determiness how to treat the target.
> -  If HOW-TO is nil, use `file-directory-p' to determine if the
> -   target is a directory.  If so, the marked file(s) are created
> -   inside that directory.  Otherwise, the target is a plain file;
> -   an error is raised unless there is exactly one marked file.
> -  If HOW-TO is t, target is always treated as a plain file.
> -  Otherwise, HOW-TO should be a function of one argument, TARGET.
> -   If its return value is nil, TARGET is regarded as a plain file.
> -   If it return value is a list, TARGET is a generalized
> -    directory (e.g. some sort of archive).  The first element of
> -    this list must be a function with at least four arguments:
> -      operation - as OPERATION above.
> -      rfn-list  - list of the relative names for the marked files.
> -      fn-list   - list of the absolute names for the marked files.
> -      target    - the name of the target itself.
> -      The rest of into-dir are optional arguments.
> -   For any other return value, TARGET is treated as a directory."
> -  (or op1 (setq op1 operation))
> -  (let* ((fn-list (dired-get-marked-files nil arg))
> -	 (rfn-list (mapcar (function dired-make-relative) fn-list))
> -	 (dired-one-file	; fluid variable inside dired-create-files
> -	  (and (consp fn-list) (null (cdr fn-list)) (car fn-list)))
> -	 (target-dir (dired-dwim-target-directory))
> -	 (default (and dired-one-file
> -		       (expand-file-name (file-name-nondirectory (car fn-list))
> -					 target-dir)))
> -	 (defaults (dired-dwim-target-defaults fn-list target-dir))
> -	 (target (expand-file-name ; fluid variable inside dired-create-files
> -		  (minibuffer-with-setup-hook
> -		      (lambda ()
> -			(set (make-local-variable 'minibuffer-default-add-function) nil)
> -			(setq minibuffer-default defaults))
> -		    (dired-mark-read-file-name
> -		     (concat (if dired-one-file op1 operation) " %s to: ")
> -		     target-dir op-symbol arg rfn-list default))))
> -	 (into-dir (cond ((null how-to)
> -			  ;; Allow DOS/Windows users to change the letter
> -			  ;; case of a directory.  If we don't test these
> -			  ;; conditions up front, file-directory-p below
> -			  ;; will return t because the filesystem is
> -			  ;; case-insensitive, and Emacs will try to move
> -			  ;; foo -> foo/foo, which fails.
> -			  (if (and (memq system-type '(ms-dos windows-nt cygwin))
> -				   (eq op-symbol 'move)
> -				   dired-one-file
> -				   (string= (downcase
> -					     (expand-file-name (car fn-list)))
> -					    (downcase
> -					     (expand-file-name target)))
> -				   (not (string=
> -					 (file-name-nondirectory (car fn-list))
> -					 (file-name-nondirectory target))))
> -			      nil
> -			    (file-directory-p target)))
> -			 ((eq how-to t) nil)
> -			 (t (funcall how-to target)))))
> -    (if (and (consp into-dir) (functionp (car into-dir)))
> -	(apply (car into-dir) operation rfn-list fn-list target (cdr into-dir))
> -      (if (not (or dired-one-file into-dir))
> -	  (error "Marked %s: target must be a directory: %s" operation target))
> -      ;; rename-file bombs when moving directories unless we do this:
> -      (or into-dir (setq target (directory-file-name target)))
> -      (dired-create-files
> -       file-creator operation fn-list
> -       (if into-dir			; target is a directory
> -	   ;; This function uses fluid variable target when called
> -	   ;; inside dired-create-files:
> -	   (function
> -	    (lambda (from)
> -	      (expand-file-name (file-name-nondirectory from) target)))
> -	 (function (lambda (from) target)))
> -       marker-char))))
 
>  ;; Read arguments for a marked-files command that wants a file name,
>  ;; perhaps popping up the list of marked files.
> diff --git a/lisp/files.el b/lisp/files.el
> index 7ac88f8..d896020 100644
> --- a/lisp/files.el
> +++ b/lisp/files.el
> @@ -4723,23 +4723,21 @@ If RECURSIVE is non-nil, all files in DIRECTORY are deleted as well."
>  		 directory 'full directory-files-no-dot-files-regexp)))
>        (delete-directory-internal directory)))))
 
> -(defun copy-directory (directory newname &optional keep-time
> -				 parents copy-as-subdir)
> +(defun copy-directory (directory newname &optional keep-time parents)
>    "Copy DIRECTORY to NEWNAME.  Both args must be strings.
> +If NEWNAME names an existing directory, copy DIRECTORY as subdirectory there.
> +
>  This function always sets the file modes of the output files to match
>  the corresponding input file.
 
>  The third arg KEEP-TIME non-nil means give the output files the same
>  last-modified time as the old ones.  (This works on only some systems.)
> -A prefix arg makes KEEP-TIME non-nil.
 
> -Optional arg PARENTS says whether to create parent directories if
> -they don't exist.  When called interactively, PARENTS is t.
> +A prefix arg makes KEEP-TIME non-nil.
 
> -When NEWNAME is an existing directory, copy DIRECTORY into a
> -subdirectory of NEWNAME if optional arg COPY-AS-SUBDIR is
> -non-nil, otherwise copy the contents of DIRECTORY into NEWNAME.
> -When called interactively, copy into a subdirectory by default."
> +Noninteractively, the last argument PARENTS says whether to
> +create parent directories if they don't exist.  Interactively,
> +this happens by default."
>    (interactive
>     (let ((dir (read-directory-name
>  	       "Copy directory: " default-directory default-directory t nil)))
> @@ -4747,7 +4745,7 @@ When called interactively, copy into a subdirectory by default."
>  	   (read-file-name
>  	    (format "Copy directory %s to: " dir)
>  	    default-directory default-directory nil nil)
> -	   current-prefix-arg t t)))
> +	   current-prefix-arg t)))
>    ;; If default-directory is a remote directory, make sure we find its
>    ;; copy-directory handler.
>    (let ((handler (or (find-file-name-handler directory 'copy-directory)
> @@ -4759,17 +4757,12 @@ When called interactively, copy into a subdirectory by default."
>        (setq directory (directory-file-name (expand-file-name directory))
>  	    newname   (directory-file-name (expand-file-name newname)))
 
> -      (unless (file-directory-p directory)
> -	(error "%s is not a directory" directory))
> -
> -      (cond
> -       ((not (file-directory-p newname))
> -	;; If NEWNAME is not an existing directory, create it;
> -	;; that is where we will copy the files of DIRECTORY.
> -	(make-directory newname parents))
> -       (copy-as-subdir
> -	;; If NEWNAME is an existing directory, and we are copying as
> -	;; a subdirectory, the target is NEWNAME/[DIRECTORY-BASENAME].
> +      (if (not (file-directory-p newname))
> +	  ;; If NEWNAME is not an existing directory, create it; that
> +	  ;; is where we will copy the files of DIRECTORY.
> +	  (make-directory newname parents)
> +	;; If NEWNAME is an existing directory, we will copy into
> +	;; NEWNAME/[DIRECTORY-BASENAME].
>  	(setq newname (expand-file-name
>  		       (file-name-nondirectory
>  			(directory-file-name directory))
> @@ -4778,22 +4771,20 @@ When called interactively, copy into a subdirectory by default."
>  	     (not (file-directory-p newname))
>  	     (error "Cannot overwrite non-directory %s with a directory"
>  		    newname))
> -	(make-directory newname t)))
> +	(make-directory newname t))
 
>        ;; Copy recursively.
>        (dolist (file
>  	       ;; We do not want to copy "." and "..".
>  	       (directory-files directory 'full
>  				directory-files-no-dot-files-regexp))
> -	(let ((target (expand-file-name
> -		       (file-name-nondirectory file) newname))
> -	      (attrs (file-attributes file)))
> -	  (cond ((file-directory-p file)
> -		 (copy-directory file target keep-time parents nil))
> -		((stringp (car attrs)) ; Symbolic link
> -		 (make-symbolic-link (car attrs) target t))
> -		(t
> -		 (copy-file file target t keep-time)))))
> +	(if (file-directory-p file)
> +	    (copy-directory file newname keep-time parents)
> +	  (let ((target (expand-file-name (file-name-nondirectory file) newname))
> +		(attrs (file-attributes file)))
> +	    (if (stringp (car attrs)) ; Symbolic link
> +		(make-symbolic-link (car attrs) target t)
> +	      (copy-file file target t keep-time)))))
 
>        ;; Set directory attributes.
>        (set-file-modes newname (file-modes directory))

> -- 
> A+ Thierry
> Get my Gnupg key:
> gpg --keyserver pgp.mit.edu --recv-keys 59F29997