X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/5553563924453df2e3c5bf011bf5b7527172b2f6..ca088b04376178d1305ff9d0866c20263f4a79bf:/lisp/ls-lisp.el diff --git a/lisp/ls-lisp.el b/lisp/ls-lisp.el index aeada6ef88..8944d4c20c 100644 --- a/lisp/ls-lisp.el +++ b/lisp/ls-lisp.el @@ -65,7 +65,8 @@ ;;; Code: -;;;###autoload +(eval-when-compile (require 'cl)) + (defgroup ls-lisp nil "Emulate the ls program completely in Emacs Lisp." :version "21.1" @@ -113,7 +114,7 @@ option will have no effect until you restart Emacs." (t '(links uid gid))) ; GNU ls "*A list of optional file attributes that ls-lisp should display. It should contain none or more of the symbols: links, uid, gid. -Nil (or an empty list) means display none of them. +nil (or an empty list) means display none of them. Concepts come from UNIX: `links' means count of names associated with the file\; `uid' means user (owner) identifier\; `gid' means group @@ -130,7 +131,8 @@ if emulation is GNU then default is `(links uid gid)'." (const :tag "Show Group" gid)) :group 'ls-lisp) -(defcustom ls-lisp-use-insert-directory-program nil +(defcustom ls-lisp-use-insert-directory-program + (not (memq system-type '(macos ms-dos windows-nt))) "*Non-nil causes ls-lisp to revert back to using `insert-directory-program'. This is useful on platforms where ls-lisp is dumped into Emacs, such as Microsoft Windows, but you would still like to use a program to list @@ -138,19 +140,43 @@ the contents of a directory." :type 'boolean :group 'ls-lisp) +;;; Autoloaded because it is let-bound in `recover-session', `mail-recover-1'. +;;;###autoload (defcustom ls-lisp-support-shell-wildcards t "*Non-nil means ls-lisp treats file patterns as shell wildcards. Otherwise they are treated as Emacs regexps (for backward compatibility)." :type 'boolean :group 'ls-lisp) +(defcustom ls-lisp-format-time-list + '("%b %e %H:%M" + "%b %e %Y") + "*List of `format-time-string' specs to display file time stamps. +They are used whenever a locale is not specified to use instead. + +Syntax: (EARLY-TIME-FORMAT OLD-TIME-FORMAT) + +The EARLY-TIME-FORMAT is used if file has been modified within the +current year. The OLD-TIME-FORMAT is used for older files. To use ISO +8601 dates, you could set: + +\(setq ls-lisp-format-time-list + '(\"%Y-%m-%d %H:%M\" + \"%Y-%m-%d \"))" + :type '(list (string :tag "Early time format") + (string :tag "Old time format")) + :group 'ls-lisp) + +(defvar original-insert-directory nil + "This holds the original function definition of `insert-directory'.") + ;; Remember the original insert-directory function (or (featurep 'ls-lisp) ; FJW: unless this file is being reloaded! - (fset 'original-insert-directory (symbol-function 'insert-directory))) + (setq original-insert-directory (symbol-function 'insert-directory))) ;; This stub is to allow ls-lisp to parse symbolic links via another ;; library such as w32-symlinks.el from -;; http://centaur.qmw.ac.uk/Emacs/: +;; http://centaur.maths.qmw.ac.uk/Emacs/: (defun ls-lisp-parse-symlink (file-name) "This stub may be redefined to parse FILE-NAME as a symlink. It should return nil or the link target as a string." @@ -182,50 +208,66 @@ is non-nil; otherwise, it interprets wildcards as regular expressions to match file names. It does not support all `ls' switches -- those that work are: A a c i r S s t u U X g G B C R and F partly." (if ls-lisp-use-insert-directory-program - (original-insert-directory file switches wildcard full-directory-p) + (funcall original-insert-directory + file switches wildcard full-directory-p) ;; We need the directory in order to find the right handler. (let ((handler (find-file-name-handler (expand-file-name file) - 'insert-directory))) + 'insert-directory)) + wildcard-regexp) (if handler (funcall handler 'insert-directory file switches wildcard full-directory-p) + ;; Remove --dired switch + (if (string-match "--dired " switches) + (setq switches (replace-match "" nil nil switches))) ;; Convert SWITCHES to a list of characters. (setq switches (delete ?- (append switches nil))) + ;; Sometimes we get ".../foo*/" as FILE. While the shell and + ;; `ls' don't mind, we certainly do, because it makes us think + ;; there is no wildcard, only a directory name. + (if (and ls-lisp-support-shell-wildcards + (string-match "[[?*]" file)) + (progn + (or (not (eq (aref file (1- (length file))) ?/)) + (setq file (substring file 0 (1- (length file))))) + (setq wildcard t))) (if wildcard - (setq wildcard + (setq wildcard-regexp (if ls-lisp-support-shell-wildcards (wildcard-to-regexp (file-name-nondirectory file)) (file-name-nondirectory file)) file (file-name-directory file)) - (if (memq ?B switches) (setq wildcard "[^~]\\'"))) + (if (memq ?B switches) (setq wildcard-regexp "[^~]\\'"))) (ls-lisp-insert-directory file switches (ls-lisp-time-index switches) - wildcard full-directory-p))))) + wildcard-regexp full-directory-p) + ;; Try to insert the amount of free space. + (save-excursion + (goto-char (point-min)) + ;; First find the line to put it on. + (when (re-search-forward "^total" nil t) + (let ((available (get-free-disk-space "."))) + (when available + ;; Replace "total" with "total used", to avoid confusion. + (replace-match "total used in directory") + (end-of-line) + (insert " available " available))))))))) (defun ls-lisp-insert-directory - (file switches time-index wildcard full-directory-p) + (file switches time-index wildcard-regexp full-directory-p) "Insert directory listing for FILE, formatted according to SWITCHES. Leaves point after the inserted text. This is an internal function optionally called by the `ls-lisp.el' version of `insert-directory'. It is called recursively if the -R switch is used. SWITCHES is a *list* of characters. TIME-INDEX is the time index into -file-attributes according to SWITCHES. WILDCARD is nil or an *Emacs +file-attributes according to SWITCHES. WILDCARD-REGEXP is nil or an *Emacs regexp*. FULL-DIRECTORY-P means file is a directory and SWITCHES does not contain `d', so that a full listing is expected." - ;; Sometimes we get ".../foo*/" as FILE. While the shell and - ;; `ls' don't mind, we certainly do, because it makes us think - ;; there is no wildcard, only a directory name. - (if (and ls-lisp-support-shell-wildcards - (string-match "[[?*]" file)) - (progn - (or (not (eq (aref file (1- (length file))) ?/)) - (setq file (substring file 0 (1- (length file))))) - (setq wildcard t))) - (if (or wildcard full-directory-p) + (if (or wildcard-regexp full-directory-p) (let* ((dir (file-name-as-directory file)) (default-directory dir) ; so that file-attributes works (file-alist - (directory-files-and-attributes dir nil wildcard t)) + (directory-files-and-attributes dir nil wildcard-regexp t 'string)) (now (current-time)) (sum 0) ;; do all bindings here for speed @@ -281,13 +323,13 @@ not contain `d', so that a full listing is expected." (setq elt (expand-file-name (car elt) dir)) (insert "\n" elt ":\n") (ls-lisp-insert-directory - elt switches time-index wildcard full-directory-p))))) + elt switches time-index wildcard-regexp full-directory-p))))) ;; If not full-directory-p, FILE *must not* end in /, as ;; file-attributes will not recognize a symlink to a directory, ;; so must make it a relative filename as ls does: (if (eq (aref file (1- (length file))) ?/) (setq file (substring file 0 -1))) - (let ((fattr (file-attributes file))) + (let ((fattr (file-attributes file 'string))) (if fattr (insert (ls-lisp-format file fattr (nth 7 fattr) switches time-index (current-time))) @@ -480,28 +522,19 @@ SWITCHES, TIME-INDEX and NOW give the full switch list and time data." ;; They tend to be bogus on non-UNIX platforms anyway so ;; optionally hide them. (if (memq 'uid ls-lisp-verbosity) - ;; (user-login-name uid) works on Windows NT but not - ;; on 9x and maybe not on some other platforms, so... + ;; uid can be a sting or an integer (let ((uid (nth 2 file-attr))) - (if (= uid (user-uid)) - (format " %-8s" (user-login-name)) - (format " %-8d" uid)))) + (format (if (stringp uid) " %-8s" " %-8d") uid))) (if (not (memq ?G switches)) ; GNU ls -- shows group by default (if (or (memq ?g switches) ; UNIX ls -- no group by default (memq 'gid ls-lisp-verbosity)) - (if (memq system-type '(macos windows-nt ms-dos)) - ;; No useful concept of group... - " root" - (let* ((gid (nth 3 file-attr)) - (group (user-login-name gid))) - (if group - (format " %-8s" group) - (format " %-8d" gid)))))) - (format (if (floatp file-size) " %8.0f" " %8d") file-size) + (let ((gid (nth 3 file-attr))) + (format (if (stringp gid) " %-8s" " %-8d") gid)))) + (ls-lisp-format-file-size file-size (memq ?h switches)) " " (ls-lisp-format-time file-attr time-index now) " " - file-name + (propertize file-name 'dired-filename t) (if (stringp file-type) ; is a symbolic link (concat " -> " file-type)) "\n" @@ -515,28 +548,52 @@ Return nil if no time switch found." ((memq ?t switches) 5) ; last modtime ((memq ?u switches) 4))) ; last access +(defun ls-lisp-time-to-seconds (time) + "Convert TIME to a floating point number." + (+ (* (car time) 65536.0) + (cadr time) + (/ (or (nth 2 time) 0) 1000000.0))) + (defun ls-lisp-format-time (file-attr time-index now) "Format time for file with attributes FILE-ATTR according to TIME-INDEX. Use the same method as ls to decide whether to show time-of-day or year, depending on distance between file date and NOW. All ls time options, namely c, t and u, are handled." (let* ((time (nth (or time-index 5) file-attr)) ; default is last modtime - (diff16 (- (car time) (car now))) - (diff (+ (ash diff16 16) (- (car (cdr time)) (car (cdr now))))) - (past-cutoff (- (* 6 30 24 60 60))) ; 6 30-day months - (future-cutoff (* 60 60))) ; 1 hour + (diff (- (ls-lisp-time-to-seconds time) + (ls-lisp-time-to-seconds now))) + ;; Consider a time to be recent if it is within the past six + ;; months. A Gregorian year has 365.2425 * 24 * 60 * 60 == + ;; 31556952 seconds on the average, and half of that is 15778476. + ;; Write the constant explicitly to avoid roundoff error. + (past-cutoff -15778476)) ; half a Gregorian year (condition-case nil - (format-time-string - (if (and - (<= past-cutoff diff) (<= diff future-cutoff) - ;; Sanity check in case `diff' computation overflowed. - (<= (1- (ash past-cutoff -16)) diff16) - (<= diff16 (1+ (ash future-cutoff -16)))) - "%b %e %H:%M" - "%b %e %Y") - time) + ;; Use traditional time format in the C or POSIX locale, + ;; ISO-style time format otherwise, so columns line up. + (let ((locale system-time-locale)) + (if (not locale) + (let ((vars '("LC_ALL" "LC_TIME" "LANG"))) + (while (and vars (not (setq locale (getenv (car vars))))) + (setq vars (cdr vars))))) + (if (member locale '("C" "POSIX")) + (setq locale nil)) + (format-time-string + (if (and (<= past-cutoff diff) (<= diff 0)) + (if locale "%m-%d %H:%M" (nth 0 ls-lisp-format-time-list)) + (if locale "%Y-%m-%d " (nth 1 ls-lisp-format-time-list))) + time)) (error "Unk 0 0000")))) +(defun ls-lisp-format-file-size (file-size human-readable) + (if (or (not human-readable) + (< file-size 1024)) + (format (if (floatp file-size) " %8.0f" " %8d") file-size) + (do ((file-size (/ file-size 1024.0) (/ file-size 1024.0)) + ;; kilo, mega, giga, tera, peta, exa + (post-fixes (list "k" "M" "G" "T" "P" "E") (cdr post-fixes))) + ((< file-size 1024) (format " %7.0f%s" file-size (car post-fixes)))))) + (provide 'ls-lisp) +;;; arch-tag: e55f399b-05ec-425c-a6d5-f5e349c35ab4 ;;; ls-lisp.el ends here