;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
+;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;;;###autoload
(defun dired-do-chmod (&optional arg)
"Change the mode of the marked (or next ARG) files.
-This calls chmod, thus symbolic modes like `g+w' are allowed."
+Symbolic modes like `g+w' are allowed."
(interactive "P")
- (dired-do-chxxx "Mode" dired-chmod-program 'chmod arg))
+ (let* ((files (dired-get-marked-files t arg))
+ (modes (dired-mark-read-string
+ "Change mode of %s to: " nil
+ 'chmod arg files))
+ (num-modes (if (string-match "^[0-7]+" modes)
+ (string-to-number modes 8))))
+ (dolist (file files)
+ (set-file-modes
+ file
+ (if num-modes num-modes
+ (file-modes-symbolic-to-number modes (file-modes file)))))
+ (dired-do-redisplay arg)))
;;;###autoload
(defun dired-do-chgrp (&optional arg)
\f
;;; Shell commands
+(declare-function mailcap-parse-mailcaps "mailcap" (&optional path force))
+(declare-function mailcap-parse-mimetypes "mailcap" (&optional path force))
+(declare-function mailcap-extension-to-mime "mailcap" (extn))
+(declare-function mailcap-mime-info "mailcap"
+ (string &optional request no-decode))
+
+(defun dired-read-shell-command-default (files)
+ "Return a list of default commands for `dired-read-shell-command'."
+ (require 'mailcap)
+ (mailcap-parse-mailcaps)
+ (mailcap-parse-mimetypes)
+ (let* ((all-mime-type
+ ;; All unique MIME types from file extensions
+ (delete-dups (mapcar (lambda (file)
+ (mailcap-extension-to-mime
+ (file-name-extension file t)))
+ files)))
+ (all-mime-info
+ ;; All MIME info lists
+ (delete-dups (mapcar (lambda (mime-type)
+ (mailcap-mime-info mime-type 'all))
+ all-mime-type)))
+ (common-mime-info
+ ;; Intersection of mime-infos from different mime-types;
+ ;; or just the first MIME info for a single MIME type
+ (if (cdr all-mime-info)
+ (delq nil (mapcar (lambda (mi1)
+ (unless (memq nil (mapcar
+ (lambda (mi2)
+ (member mi1 mi2))
+ (cdr all-mime-info)))
+ mi1))
+ (car all-mime-info)))
+ (car all-mime-info)))
+ (commands
+ ;; Command strings from `viewer' field of the MIME info
+ (delq nil (mapcar (lambda (mime-info)
+ (let ((command (cdr (assoc 'viewer mime-info))))
+ (if (stringp command)
+ (replace-regexp-in-string
+ ;; Replace mailcap's `%s' placeholder
+ ;; with dired's `?' placeholder
+ "%s" "?"
+ (replace-regexp-in-string
+ ;; Remove the final filename placeholder
+ "\s*\\('\\)?%s\\1?\s*\\'" "" command nil t)
+ nil t))))
+ common-mime-info))))
+ commands))
+
(defun dired-read-shell-command (prompt arg files)
;; "Read a dired shell command prompting with PROMPT (using read-string).
;;ARG is the prefix arg and may be used to indicate in the prompt which
nil 'shell files
(function read-string)
(format prompt (dired-mark-prompt arg files))
- nil 'shell-command-history))
+ nil 'shell-command-history
+ (dired-read-shell-command-default files)))
;; The in-background argument is only needed in Emacs 18 where
;; shell-command doesn't understand an appended ampersand `&'.
;; Return nil for sake of nconc in dired-bunch-files.
nil)
\f
-;; In Emacs 19 this will return program's exit status.
-;; This is a separate function so that ange-ftp can redefine it.
-(defun dired-call-process (program discard &rest arguments)
-; "Run PROGRAM with output to current buffer unless DISCARD is t.
-;Remaining arguments are strings passed as command arguments to PROGRAM."
- ;; Look for a handler for default-directory in case it is a remote file name.
- (let ((handler
- (find-file-name-handler (directory-file-name default-directory)
- 'dired-call-process)))
- (if handler (apply handler 'dired-call-process
- program discard arguments)
- (apply 'call-process program nil (not discard) nil arguments))))
(defun dired-check-process (msg program &rest arguments)
; "Display MSG while running PROGRAM, and check for output.
(set-buffer err-buffer)
(erase-buffer)
(setq default-directory dir ; caller's default-directory
- err (not (eq 0
- (apply (function dired-call-process) program nil arguments))))
+ err (not (eq 0 (apply 'process-file program nil t nil arguments))))
(if err
(progn
(dired-log (concat program " " (prin1-to-string arguments) "\n"))
(dired-copy-file-recursive from to ok-flag dired-copy-preserve-time t
dired-recursive-copies))
+(declare-function make-symbolic-link "fileio.c")
+
(defun dired-copy-file-recursive (from to ok-flag &optional
preserve-time top recursive)
(let ((attrs (file-attributes from))
(or (eq recursive 'always)
(yes-or-no-p (format "Recursive copies of %s? " from))))
;; This is a directory.
- (let ((files
+ (let ((mode (file-modes from))
+ (files
(condition-case err
(directory-files from nil dired-re-no-dot)
(file-error
(if (file-exists-p to)
(or top (dired-handle-overwrite to))
(condition-case err
- (make-directory to)
+ (progn
+ (make-directory to)
+ (set-file-modes to #o700))
(file-error
(push (dired-make-relative from)
dired-create-files-failures)
(file-error
(push (dired-make-relative thisfrom)
dired-create-files-failures)
- (dired-log "Copying error for %s:\n%s\n" thisfrom err))))))
+ (dired-log "Copying error for %s:\n%s\n" thisfrom err)))))
+ (when (file-directory-p to)
+ (set-file-modes to mode)))
;; Not a directory.
(or top (dired-handle-overwrite to))
(condition-case err
;; It is a symlink
(make-symbolic-link (car attrs) to ok-flag)
(copy-file from to ok-flag dired-copy-preserve-time))
- (file-date-error
+ (file-date-error
(push (dired-make-relative from)
dired-create-files-failures)
(dired-log "Can't set date on %s:\n%s\n" from err))))))
skipped (success-count 0) (total (length fn-list)))
(let (to overwrite-query
overwrite-backup-query) ; for dired-handle-overwrite
- (mapcar
+ (mapc
(function
(lambda (from)
(setq to (funcall name-constructor from))
"Create a directory called DIRECTORY."
(interactive
(list (read-file-name "Create directory: " (dired-current-directory))))
- (let ((expanded (directory-file-name (expand-file-name directory))))
- (make-directory expanded)
- (dired-add-file expanded)
- (dired-move-to-filename)))
+ (let* ((expanded (directory-file-name (expand-file-name directory)))
+ (try expanded) new)
+ ;; Find the topmost nonexistent parent dir (variable `new')
+ (while (and try (not (file-exists-p try)) (not (equal new try)))
+ (setq new try
+ try (directory-file-name (file-name-directory try))))
+ (make-directory expanded t)
+ (when new
+ (dired-add-file new)
+ (dired-move-to-filename))))
(defun dired-into-dir-with-symlinks (target)
(and (file-directory-p target)
and new symbolic links are made in that directory
with the same names that the files currently have. The default
suggested for the target directory depends on the value of
-`dired-dwim-target', which see."
+`dired-dwim-target', which see.
+
+For relative symlinks, use \\[dired-do-relsymlink]."
(interactive "P")
(dired-do-create-files 'symlink (function make-symbolic-link)
"Symlink" arg dired-keep-marker-symlink))
(defun dired-tree-lessp (dir1 dir2)
;; Lexicographic order on file name components, like `ls -lR':
- ;; DIR1 < DIR2 iff DIR1 comes *before* DIR2 in an `ls -lR' listing,
- ;; i.e., iff DIR1 is a (grand)parent dir of DIR2,
+ ;; DIR1 < DIR2 if DIR1 comes *before* DIR2 in an `ls -lR' listing,
+ ;; i.e., if DIR1 is a (grand)parent dir of DIR2,
;; or DIR1 and DIR2 are in the same parentdir and their last
;; components are string-lessp.
;; Thus ("/usr/" "/usr/bin") and ("/usr/a/" "/usr/b/") are tree-lessp.