/[emacs]/emacs/lisp/dired-aux.el
ViewVC logotype

Diff of /emacs/lisp/dired-aux.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.102 by rms, Sun May 12 16:42:26 2002 UTC revision 1.102.2.1 by miles, Fri Apr 4 06:20:03 2003 UTC
# Line 145  This calls chmod, thus symbolic modes li Line 145  This calls chmod, thus symbolic modes li
145  ;; allowing 3 extra characters of separator per file name.  ;; allowing 3 extra characters of separator per file name.
146  (defun dired-bunch-files (max function args files)  (defun dired-bunch-files (max function args files)
147    (let (pending    (let (pending
148            past
149          (pending-length 0)          (pending-length 0)
150          failures)          failures)
151      ;; Accumulate files as long as they fit in MAX chars,      ;; Accumulate files as long as they fit in MAX chars,
# Line 156  This calls chmod, thus symbolic modes li Line 157  This calls chmod, thus symbolic modes li
157          ;; If we have at least 1 pending file          ;; If we have at least 1 pending file
158          ;; and this file won't fit in the length limit, process now.          ;; and this file won't fit in the length limit, process now.
159          (if (and pending (> (+ thislength pending-length) max))          (if (and pending (> (+ thislength pending-length) max))
160              (setq failures              (setq pending (nreverse pending)
161                    (nconc (apply function (append args (nreverse pending)))                    ;; The elements of PENDING are now in forward order.
162                           failures)                    ;; Do the operation and record failures.
163                      failures (nconc (apply function (append args pending))
164                                      failures)
165                      ;; Transfer the elemens of PENDING onto PAST
166                      ;; and clear it out.  Now PAST contains the first N files
167                      ;; specified (for some N), and FILES contains the rest.
168                      past (nconc past pending)
169                    pending nil                    pending nil
170                    pending-length 0))                    pending-length 0))
171          ;; Do (setq pending (cons thisfile pending))          ;; Do (setq pending (cons thisfile pending))
# Line 167  This calls chmod, thus symbolic modes li Line 174  This calls chmod, thus symbolic modes li
174          (setq pending files)          (setq pending files)
175          (setq pending-length (+ thislength pending-length))          (setq pending-length (+ thislength pending-length))
176          (setq files rest)))          (setq files rest)))
177      (nconc (apply function (append args (nreverse pending)))      (setq pending (nreverse pending))
178             failures)))      (prog1
179            (nconc (apply function (append args pending))
180                   failures)
181          ;; Now the original list FILES has been put back as it was.
182          (nconc past pending))))
183    
184  ;;;###autoload  ;;;###autoload
185  (defun dired-do-print (&optional arg)  (defun dired-do-print (&optional arg)
# Line 666  Otherwise, the rule is a compression rul Line 677  Otherwise, the rule is a compression rul
677    '((?\y . y) (?\040 . y)               ; `y' or SPC means accept once    '((?\y . y) (?\040 . y)               ; `y' or SPC means accept once
678      (?n . n) (?\177 . n)                ; `n' or DEL skips once      (?n . n) (?\177 . n)                ; `n' or DEL skips once
679      (?! . yes)                          ; `!' accepts rest      (?! . yes)                          ; `!' accepts rest
680      (?q. no) (?\e . no)                 ; `q' or ESC skips rest      (?q . no) (?\e . no)                ; `q' or ESC skips rest
681      ;; None of these keys quit - use C-g for that.      ;; None of these keys quit - use C-g for that.
682      ))      ))
683    
# Line 825  a prefix arg lets you edit the `ls' swit Line 836  a prefix arg lets you edit the `ls' swit
836                    (if (eq (following-char) ?\r)                    (if (eq (following-char) ?\r)
837                        (dired-unhide-subdir))                        (dired-unhide-subdir))
838                    ;; We are already where we should be, except when                    ;; We are already where we should be, except when
839                   ;; point is before the subdir line or its total line.                    ;; point is before the subdir line or its total line.
840                    (let ((p (dired-after-subdir-garbage cur-dir)))                    (let ((p (dired-after-subdir-garbage cur-dir)))
841                      (if (< (point) p)                      (if (< (point) p)
842                          (goto-char p))))                          (goto-char p))))
# Line 843  a prefix arg lets you edit the `ls' swit Line 854  a prefix arg lets you edit the `ls' swit
854              (let (buffer-read-only opoint)              (let (buffer-read-only opoint)
855                (beginning-of-line)                (beginning-of-line)
856                (setq opoint (point))                (setq opoint (point))
857                (dired-add-entry-do-indentation marker-char)                ;; Don't expand `.'.  Show just the file name within directory.
        ;; don't expand `.'.  Show just the file name within directory.  
858                (let ((default-directory directory))                (let ((default-directory directory))
859                  (insert-directory filename                  (dired-insert-directory directory
860                                    (concat dired-actual-switches "d")))                                          (concat dired-actual-switches "d")
861                                            (list filename)))
862                  (goto-char opoint)
863                  ;; Put in desired marker char.
864                  (when marker-char
865                    (let ((dired-marker-char
866                           (if (integerp marker-char) marker-char dired-marker-char)))
867                      (dired-mark nil)))
868                ;; Compensate for a bug in ange-ftp.                ;; Compensate for a bug in ange-ftp.
869                ;; It inserts the file's absolute name, rather than                ;; It inserts the file's absolute name, rather than
870                ;; the relative one.  That may be hard to fix since it                ;; the relative one.  That may be hard to fix since it
# Line 855  a prefix arg lets you edit the `ls' swit Line 872  a prefix arg lets you edit the `ls' swit
872                (goto-char opoint)                (goto-char opoint)
873                (let ((inserted-name (dired-get-filename 'verbatim)))                (let ((inserted-name (dired-get-filename 'verbatim)))
874                  (if (file-name-directory inserted-name)                  (if (file-name-directory inserted-name)
875                      (progn                      (let (props)
876                        (end-of-line)                        (end-of-line)
877                        (delete-char (- (length inserted-name)))                        (forward-char (- (length inserted-name)))
878                        (insert filename)                        (setq props (text-properties-at (point)))
879                          (delete-char (length inserted-name))
880                          (let ((pt (point)))
881                            (insert filename)
882                            (set-text-properties pt (point) props))
883                        (forward-char 1))                        (forward-char 1))
884                    (forward-line 1)))                    (forward-line 1)))
             ;; Give each line a text property recording info about it.  
               (dired-insert-set-properties opoint (point))  
885                (forward-line -1)                (forward-line -1)
886                (if dired-after-readin-hook ;; the subdir-alist is not affected...                (if dired-after-readin-hook ;; the subdir-alist is not affected...
887                    (save-excursion ;; ...so we can run it right now:                    (save-excursion ;; ...so we can run it right now:
# Line 878  a prefix arg lets you edit the `ls' swit Line 897  a prefix arg lets you edit the `ls' swit
897          (goto-char opoint))          (goto-char opoint))
898      (not reason))) ; return t on success, nil else      (not reason))) ; return t on success, nil else
899    
 ;; This is a separate function for the sake of nested dired format.  
 (defun dired-add-entry-do-indentation (marker-char)  
   ;; two spaces or a marker plus a space:  
   (insert (if marker-char  
               (if (integerp marker-char) marker-char dired-marker-char)  
             ?\040)  
           ?\040))  
   
900  (defun dired-after-subdir-garbage (dir)  (defun dired-after-subdir-garbage (dir)
901    ;; Return pos of first file line of DIR, skipping header and total    ;; Return pos of first file line of DIR, skipping header and total
902    ;; or wildcard lines.    ;; or wildcard lines.
# Line 915  a prefix arg lets you edit the `ls' swit Line 926  a prefix arg lets you edit the `ls' swit
926    
927  ;;;###autoload  ;;;###autoload
928  (defun dired-relist-file (file)  (defun dired-relist-file (file)
929      "Create or update the line for FILE in all Dired buffers it would belong in."
930    (dired-fun-in-all-buffers (file-name-directory file)    (dired-fun-in-all-buffers (file-name-directory file)
931                              (file-name-nondirectory file)                              (file-name-nondirectory file)
932                              (function dired-relist-entry) file))                              (function dired-relist-entry) file))
# Line 961  Special value `always' suppresses confir Line 973  Special value `always' suppresses confir
973  (defvar dired-overwrite-confirmed)  (defvar dired-overwrite-confirmed)
974    
975  (defun dired-handle-overwrite (to)  (defun dired-handle-overwrite (to)
976    ;; Save old version of a to be overwritten file TO.    ;; Save old version of file TO that is to be overwritten.
977    ;; `dired-overwrite-confirmed' and `overwrite-backup-query' are fluid vars    ;; `dired-overwrite-confirmed' and `overwrite-backup-query' are fluid vars
978    ;; from dired-create-files.    ;; from dired-create-files.
979    (let (backup)    (let (backup)
# Line 1006  Special value `always' suppresses confir Line 1018  Special value `always' suppresses confir
1018      (copy-file from to ok-flag dired-copy-preserve-time)))      (copy-file from to ok-flag dired-copy-preserve-time)))
1019    
1020  ;;;###autoload  ;;;###autoload
1021  (defun dired-rename-file (from to ok-flag)  (defun dired-rename-file (file newname ok-if-already-exists)
1022    (dired-handle-overwrite to)    (dired-handle-overwrite newname)
1023    (rename-file from to ok-flag)         ; error is caught in -create-files    (rename-file file newname ok-if-already-exists) ; error is caught in -create-files
1024    ;; Silently rename the visited file of any buffer visiting this file.    ;; Silently rename the visited file of any buffer visiting this file.
1025    (and (get-file-buffer from)    (and (get-file-buffer file)
1026         (with-current-buffer (get-file-buffer from)         (with-current-buffer (get-file-buffer file)
1027           (set-visited-file-name to nil t)))           (set-visited-file-name newname nil t)))
1028    (dired-remove-file from)    (dired-remove-file file)
1029    ;; See if it's an inserted subdir, and rename that, too.    ;; See if it's an inserted subdir, and rename that, too.
1030    (dired-rename-subdir from to))    (dired-rename-subdir file newname))
1031    
1032  (defun dired-rename-subdir (from-dir to-dir)  (defun dired-rename-subdir (from-dir to-dir)
1033    (setq from-dir (file-name-as-directory from-dir)    (setq from-dir (file-name-as-directory from-dir)
# Line 1246  Optional arg HOW-TO is used to set the v Line 1258  Optional arg HOW-TO is used to set the v
1258                            ;; will return t because the filesystem is                            ;; will return t because the filesystem is
1259                            ;; case-insensitive, and Emacs will try to move                            ;; case-insensitive, and Emacs will try to move
1260                            ;; foo -> foo/foo, which fails.                            ;; foo -> foo/foo, which fails.
1261                            (if (and (memq system-type '(ms-dos windows-nt))                            (if (and (memq system-type '(ms-dos windows-nt cygwin))
1262                                     (eq op-symbol 'move)                                     (eq op-symbol 'move)
1263                                     dired-one-file                                     dired-one-file
1264                                     (string= (downcase                                     (string= (downcase
# Line 1379  with the same names that the files curre Line 1391  with the same names that the files curre
1391  suggested for the target directory depends on the value of  suggested for the target directory depends on the value of
1392  `dired-dwim-target', which see."  `dired-dwim-target', which see."
1393    (interactive "P")    (interactive "P")
1394    (dired-do-create-files 'hardlink (function add-name-to-file)    (dired-do-create-files 'hardlink (function dired-hardlink)
1395                             "Hardlink" arg dired-keep-marker-hardlink))                             "Hardlink" arg dired-keep-marker-hardlink))
1396    
1397    (defun dired-hardlink (file newname &optional ok-if-already-exists)
1398      (dired-handle-overwrite newname)
1399      ;; error is caught in -create-files
1400      (add-name-to-file file newname ok-if-already-exists)
1401      ;; Update the link count
1402      (dired-relist-file file))
1403    
1404  ;;;###autoload  ;;;###autoload
1405  (defun dired-do-rename (&optional arg)  (defun dired-do-rename (&optional arg)
1406    "Rename current file or all marked (or next ARG) files.    "Rename current file or all marked (or next ARG) files.
1407  When renaming just the current file, you specify the new name.  When renaming just the current file, you specify the new name.
1408  When renaming multiple or marked files, you specify a directory.  When renaming multiple or marked files, you specify a directory.
1409    This command also renames any buffers that are visiting the files.
1410  The default suggested for the target directory depends on the value  The default suggested for the target directory depends on the value
1411  of `dired-dwim-target', which see."  of `dired-dwim-target', which see."
1412    (interactive "P")    (interactive "P")
# Line 1397  of `dired-dwim-target', which see." Line 1417  of `dired-dwim-target', which see."
1417  ;;; 5K  ;;; 5K
1418  ;;;###begin dired-re.el  ;;;###begin dired-re.el
1419  (defun dired-do-create-files-regexp  (defun dired-do-create-files-regexp
1420    (file-creator operation arg regexp newname &optional whole-path marker-char)    (file-creator operation arg regexp newname &optional whole-name marker-char)
1421    ;; Create a new file for each marked file using regexps.    ;; Create a new file for each marked file using regexps.
1422    ;; FILE-CREATOR and OPERATION as in dired-create-files.    ;; FILE-CREATOR and OPERATION as in dired-create-files.
1423    ;; ARG as in dired-get-marked-files.    ;; ARG as in dired-get-marked-files.
1424    ;; Matches each marked file against REGEXP and constructs the new    ;; Matches each marked file against REGEXP and constructs the new
1425    ;;   filename from NEWNAME (like in function replace-match).    ;;   filename from NEWNAME (like in function replace-match).
1426    ;; Optional arg WHOLE-PATH means match/replace the whole file name    ;; Optional arg WHOLE-NAME means match/replace the whole file name
1427    ;;   instead of only the non-directory part of the file.    ;;   instead of only the non-directory part of the file.
1428    ;; Optional arg MARKER-CHAR as in dired-create-files.    ;; Optional arg MARKER-CHAR as in dired-create-files.
1429    (let* ((fn-list (dired-get-marked-files nil arg))    (let* ((fn-list (dired-get-marked-files nil arg))
# Line 1416  Type SPC or `y' to %s one match, DEL or Line 1436  Type SPC or `y' to %s one match, DEL or
1436                                            (downcase operation)))                                            (downcase operation)))
1437           (regexp-name-constructor           (regexp-name-constructor
1438            ;; Function to construct new filename using REGEXP and NEWNAME:            ;; Function to construct new filename using REGEXP and NEWNAME:
1439            (if whole-path                ; easy (but rare) case            (if whole-name                ; easy (but rare) case
1440                (function                (function
1441                 (lambda (from)                 (lambda (from)
1442                   (let ((to (dired-string-replace-match regexp from newname))                   (let ((to (dired-string-replace-match regexp from newname))
# Line 1431  Type SPC or `y' to %s one match, DEL or Line 1451  Type SPC or `y' to %s one match, DEL or
1451                              to)                              to)
1452                       (dired-log "%s: %s did not match regexp %s\n"                       (dired-log "%s: %s did not match regexp %s\n"
1453                                  operation from regexp)))))                                  operation from regexp)))))
1454              ;; not whole-path, replace non-directory part only              ;; not whole-name, replace non-directory part only
1455              (function              (function
1456               (lambda (from)               (lambda (from)
1457                 (let* ((new (dired-string-replace-match                 (let* ((new (dired-string-replace-match
# Line 1454  Type SPC or `y' to %s one match, DEL or Line 1474  Type SPC or `y' to %s one match, DEL or
1474    
1475  (defun dired-mark-read-regexp (operation)  (defun dired-mark-read-regexp (operation)
1476    ;; Prompt user about performing OPERATION.    ;; Prompt user about performing OPERATION.
1477    ;; Read and return list of: regexp newname arg whole-path.    ;; Read and return list of: regexp newname arg whole-name.
1478    (let* ((whole-path    (let* ((whole-name
1479            (equal 0 (prefix-numeric-value current-prefix-arg)))            (equal 0 (prefix-numeric-value current-prefix-arg)))
1480           (arg           (arg
1481            (if whole-path nil current-prefix-arg))            (if whole-name nil current-prefix-arg))
1482           (regexp           (regexp
1483            (dired-read-regexp            (dired-read-regexp
1484             (concat (if whole-path "Path " "") operation " from (regexp): ")))             (concat (if whole-name "Abs. " "") operation " from (regexp): ")))
1485           (newname           (newname
1486            (read-string            (read-string
1487             (concat (if whole-path "Path " "") operation " " regexp " to: "))))             (concat (if whole-name "Abs. " "") operation " " regexp " to: "))))
1488      (list regexp newname arg whole-path)))      (list regexp newname arg whole-name)))
1489    
1490  ;;;###autoload  ;;;###autoload
1491  (defun dired-do-rename-regexp (regexp newname &optional arg whole-path)  (defun dired-do-rename-regexp (regexp newname &optional arg whole-name)
1492    "Rename selected files whose names match REGEXP to NEWNAME.    "Rename selected files whose names match REGEXP to NEWNAME.
1493    
1494  With non-zero prefix argument ARG, the command operates on the next ARG  With non-zero prefix argument ARG, the command operates on the next ARG
# Line 1485  Normally, only the non-directory part of Line 1505  Normally, only the non-directory part of
1505    (interactive (dired-mark-read-regexp "Rename"))    (interactive (dired-mark-read-regexp "Rename"))
1506    (dired-do-create-files-regexp    (dired-do-create-files-regexp
1507     (function dired-rename-file)     (function dired-rename-file)
1508     "Rename" arg regexp newname whole-path dired-keep-marker-rename))     "Rename" arg regexp newname whole-name dired-keep-marker-rename))
1509    
1510  ;;;###autoload  ;;;###autoload
1511  (defun dired-do-copy-regexp (regexp newname &optional arg whole-path)  (defun dired-do-copy-regexp (regexp newname &optional arg whole-name)
1512    "Copy selected files whose names match REGEXP to NEWNAME.    "Copy selected files whose names match REGEXP to NEWNAME.
1513  See function `dired-do-rename-regexp' for more info."  See function `dired-do-rename-regexp' for more info."
1514    (interactive (dired-mark-read-regexp "Copy"))    (interactive (dired-mark-read-regexp "Copy"))
# Line 1496  See function `dired-do-rename-regexp' fo Line 1516  See function `dired-do-rename-regexp' fo
1516      (dired-do-create-files-regexp      (dired-do-create-files-regexp
1517       (function dired-copy-file)       (function dired-copy-file)
1518       (if dired-copy-preserve-time "Copy [-p]" "Copy")       (if dired-copy-preserve-time "Copy [-p]" "Copy")
1519       arg regexp newname whole-path dired-keep-marker-copy)))       arg regexp newname whole-name dired-keep-marker-copy)))
1520    
1521  ;;;###autoload  ;;;###autoload
1522  (defun dired-do-hardlink-regexp (regexp newname &optional arg whole-path)  (defun dired-do-hardlink-regexp (regexp newname &optional arg whole-name)
1523    "Hardlink selected files whose names match REGEXP to NEWNAME.    "Hardlink selected files whose names match REGEXP to NEWNAME.
1524  See function `dired-do-rename-regexp' for more info."  See function `dired-do-rename-regexp' for more info."
1525    (interactive (dired-mark-read-regexp "HardLink"))    (interactive (dired-mark-read-regexp "HardLink"))
1526    (dired-do-create-files-regexp    (dired-do-create-files-regexp
1527     (function add-name-to-file)     (function add-name-to-file)
1528     "HardLink" arg regexp newname whole-path dired-keep-marker-hardlink))     "HardLink" arg regexp newname whole-name dired-keep-marker-hardlink))
1529    
1530  ;;;###autoload  ;;;###autoload
1531  (defun dired-do-symlink-regexp (regexp newname &optional arg whole-path)  (defun dired-do-symlink-regexp (regexp newname &optional arg whole-name)
1532    "Symlink selected files whose names match REGEXP to NEWNAME.    "Symlink selected files whose names match REGEXP to NEWNAME.
1533  See function `dired-do-rename-regexp' for more info."  See function `dired-do-rename-regexp' for more info."
1534    (interactive (dired-mark-read-regexp "SymLink"))    (interactive (dired-mark-read-regexp "SymLink"))
1535    (dired-do-create-files-regexp    (dired-do-create-files-regexp
1536     (function make-symbolic-link)     (function make-symbolic-link)
1537     "SymLink" arg regexp newname whole-path dired-keep-marker-symlink))     "SymLink" arg regexp newname whole-name dired-keep-marker-symlink))
1538    
1539  (defun dired-create-files-non-directory  (defun dired-create-files-non-directory
1540    (file-creator basename-constructor operation arg)    (file-creator basename-constructor operation arg)
# Line 1707  With optional arg REMEMBER-MARKS, return Line 1727  With optional arg REMEMBER-MARKS, return
1727        (delete-region begin-marker (point)))))        (delete-region begin-marker (point)))))
1728    
1729  (defun dired-insert-subdir-doinsert (dirname switches)  (defun dired-insert-subdir-doinsert (dirname switches)
1730    ;; Insert ls output after point and put point on the correct    ;; Insert ls output after point.
   ;; position for the subdir alist.  
1731    ;; Return the boundary of the inserted text (as list of BEG and END).    ;; Return the boundary of the inserted text (as list of BEG and END).
1732    (let ((begin (point)) end)    (save-excursion
1733      (message "Reading directory %s..." dirname)      (let ((begin (point)))
1734      (let ((dired-actual-switches        (message "Reading directory %s..." dirname)
1735             (or switches        (let ((dired-actual-switches
1736                 (dired-replace-in-string "R" "" dired-actual-switches))))               (or switches
1737        (if (equal dirname (car (car (reverse dired-subdir-alist))))                   (dired-replace-in-string "R" "" dired-actual-switches))))
1738            ;; top level directory may contain wildcards:          (if (equal dirname (car (car (last dired-subdir-alist))))
1739            (dired-readin-insert dired-directory)              ;; If doing the top level directory of the buffer,
1740          (let ((opoint (point)))              ;; redo it as specified in dired-directory.
1741            (insert-directory dirname dired-actual-switches nil t)              (dired-readin-insert)
1742            (dired-insert-set-properties opoint (point)))))            (dired-insert-directory dirname dired-actual-switches nil nil t)))
1743      (message "Reading directory %s...done" dirname)        (message "Reading directory %s...done" dirname)
1744      (setq end (point-marker))        (list begin (point)))))
     (indent-rigidly begin end 2)  
     ;;  call dired-insert-headerline afterwards, as under VMS dired-ls  
     ;;  does insert the headerline itself and the insert function just  
     ;;  moves point.  
     ;;  Need a marker for END as this inserts text.  
     (goto-char begin)  
     (if (not (looking-at "^  /.*:$"))  
         (dired-insert-headerline dirname))  
     ;; point is now like in dired-build-subdir-alist  
     (prog1  
         (list begin (marker-position end))  
       (set-marker end nil))))  
1745    
1746  (defun dired-insert-subdir-doupdate (dirname elt beg-end)  (defun dired-insert-subdir-doupdate (dirname elt beg-end)
1747    ;; Point is at the correct subdir alist position for ELT,    ;; Point is at the correct subdir alist position for ELT,
# Line 2026  true then the type of the file linked to Line 2033  true then the type of the file linked to
2033        (call-process "file" nil t t "--" file))        (call-process "file" nil t t "--" file))
2034      (when (bolp)      (when (bolp)
2035        (backward-delete-char 1))        (backward-delete-char 1))
2036      (message (buffer-string))))      (message "%s" (buffer-string))))
2037    
2038  (provide 'dired-aux)  (provide 'dired-aux)
2039    

Legend:
Removed from v.1.102  
changed lines
  Added in v.1.102.2.1

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26