;;; ls-lisp.el --- emulate insert-directory completely in Emacs Lisp
-;; Copyright (C) 1992, 1994, 2000 Free Software Foundation, Inc.
+;; Copyright (C) 1992, 1994, 2000, 2001, 2002, 2003, 2004,
+;; 2005, 2006, 2007 Free Software Foundation, Inc.
;; Author: Sebastian Kremer <sk@thp.uni-koeln.de>
;; Modified by: Francis J. Wright <F.J.Wright@maths.qmw.ac.uk>
;; 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,
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; * A few obscure ls switches are still ignored: see the docstring of
;; `insert-directory'.
-;; * Generally only numeric uid/gid.
-
;; TO DO =============================================================
;; Complete handling of F switch (if/when possible).
;; Revised by Andrew Innes and Geoff Volker (and maybe others).
;; Modified by Francis J. Wright <F.J.Wright@maths.qmw.ac.uk>, mainly
-;; to support many more ls options, "platform emulation", hooks for
-;; external symbolic link support and more robust sorting.
+;; to support many more ls options, "platform emulation" and more
+;; robust sorting.
;;; Code:
-;;;###autoload
+(eval-when-compile (require 'cl))
+
(defgroup ls-lisp nil
"Emulate the ls program completely in Emacs Lisp."
:version "21.1"
(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.
+A value of 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
(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
: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.
+These specs are used ONLY if a valid locale can not be determined.
+
+If `ls-lisp-use-localized-time-format' is non-nil, these specs are used
+regardless of whether the locale can be determined.
+
+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)
+
+(defcustom ls-lisp-use-localized-time-format nil
+ "*Non-nil causes ls-lisp to use `ls-lisp-format-time-list' even if
+a valid locale is specified.
+
+WARNING: Using localized date/time format might cause Dired columns
+to fail to lign up, e.g. if month names are not all of the same length."
+ :type 'boolean
+ :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)))
-
-;; 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/:
-(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."
- nil)
+ (setq original-insert-directory (symbol-function 'insert-directory)))
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
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))
+ (orig-file file)
+ 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)
+ ;; Prefer an existing file to wildcards, like
+ ;; dired-noselect does.
+ (not (file-exists-p 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 "[^~]\\'")))
- (ls-lisp-insert-directory
- file switches (ls-lisp-time-index switches)
- wildcard full-directory-p)
+ (if (memq ?B switches) (setq wildcard-regexp "[^~]\\'")))
+ (condition-case err
+ (ls-lisp-insert-directory
+ file switches (ls-lisp-time-index switches)
+ wildcard-regexp full-directory-p)
+ (invalid-regexp
+ ;; Maybe they wanted a literal file that just happens to
+ ;; use characters special to shell wildcards.
+ (if (equal (cadr err) "Unmatched [ or [^")
+ (progn
+ (setq wildcard-regexp (if (memq ?B switches) "[^~]\\'")
+ file (file-relative-name orig-file))
+ (ls-lisp-insert-directory
+ file switches (ls-lisp-time-index switches)
+ nil full-directory-p))
+ (signal (car err) (cdr err)))))
;; Try to insert the amount of free space.
(save-excursion
(goto-char (point-min))
(when (re-search-forward "^total" nil t)
(let ((available (get-free-disk-space ".")))
(when available
- ;; Replace "total" with "used", to avoid confusion.
- (replace-match "used")
+ ;; 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
(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)))
;; symbolic link, or nil.
(let (el dirs files)
(while file-alist
- (if (eq (cadr (setq el (car file-alist))) t) ; directory
+ (if (or (eq (cadr (setq el (car file-alist))) t) ; directory
+ (and (stringp (cadr el))
+ (file-directory-p (cadr el)))) ; symlink to a directory
(setq dirs (cons el dirs))
(setq files (cons el files)))
(setq file-alist (cdr file-alist)))
Also, for regular files that are executable, append `*'.
The file type indicators are `/' for directories, `@' for symbolic
links, `|' for FIFOs, `=' for sockets, and nothing for regular files.
-\[But FIFOs and sockets are not recognised.]
+\[But FIFOs and sockets are not recognized.]
FILEDATA has the form (filename . `file-attributes'). Its `cadr' is t
for directory, string (name linked to) for symbolic link, or nil."
- (let ((dir (cadr filedata)) (file-name (car filedata)))
- (cond ((or dir
- ;; Parsing .lnk files here is perhaps overkill!
- (setq dir (ls-lisp-parse-symlink file-name)))
+ (let ((file-name (car filedata))
+ (type (cadr filedata)))
+ (cond (type
(cons
- (concat file-name (if (eq dir t) "/" "@"))
+ (concat file-name (if (eq type t) "/" "@"))
(cdr filedata)))
((string-match "x" (nth 9 filedata))
(cons
;; t for directory, string (name linked to)
;; for symbolic link, or nil.
(drwxrwxrwx (nth 8 file-attr))) ; attribute string ("drwxrwxrwx")
- (and (null file-type)
- ;; Maybe no kernel support for symlinks, so...
- (setq file-type (ls-lisp-parse-symlink file-name))
- (aset drwxrwxrwx 0 ?l)) ; symbolic link - update attribute string
(concat (if (memq ?i switches) ; inode number
(format " %6d" (nth 10 file-attr)))
;; nil is treated like "" in concat
;; 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"
(setq locale nil))
(format-time-string
(if (and (<= past-cutoff diff) (<= diff 0))
- (if locale "%m-%d %H:%M" "%b %e %H:%M")
- (if locale "%Y-%m-%d " "%b %e %Y"))
+ (if (and locale (not ls-lisp-use-localized-time-format))
+ "%m-%d %H:%M"
+ (nth 0 ls-lisp-format-time-list))
+ (if (and locale (not ls-lisp-use-localized-time-format))
+ "%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) " %9.0f" " %9d") 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 " %8.0f%s" file-size (car post-fixes))))))
+
(provide 'ls-lisp)
+;;; arch-tag: e55f399b-05ec-425c-a6d5-f5e349c35ab4
;;; ls-lisp.el ends here
HCoop / bpt / emacs.git / blobdiff