code.delx.au - gnu-emacs/blob - lisp/ls-lisp.el

   1 ;;; ls-lisp.el --- emulate insert-directory completely in Emacs Lisp
   2
   3 ;; Copyright (C) 1992, 1994 by Sebastian Kremer <sk@thp.uni-koeln.de>
   4
   5 ;; Author: Sebastian Kremer <sk@thp.uni-koeln.de>
   6 ;; Maintainer: FSF
   7 ;; Keywords: unix
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Commentary:
  27
  28 ;; INSTALLATION =======================================================
  29 ;;
  30 ;; Put this file into your load-path.  To use it, load it
  31 ;; with (load "ls-lisp").
  32
  33 ;; OVERVIEW ===========================================================
  34
  35 ;; This file overloads the function insert-directory to implement it
  36 ;; directly from Emacs lisp, without running `ls' in a subprocess.
  37
  38 ;; It is useful if you cannot afford to fork Emacs on a real memory UNIX,
  39 ;; under VMS, or if you don't have the ls program, or if you want
  40 ;; different format from what ls offers.
  41
  42 ;; This function uses regexps instead of shell
  43 ;; wildcards.  If you enter regexps remember to double each $ sign.
  44 ;; For example, to include files *.el, enter `.*\.el$$',
  45 ;; resulting in the regexp `.*\.el$'.
  46
  47 ;;  RESTRICTIONS =====================================================
  48
  49 ;; * many ls switches are ignored, see docstring of `insert-directory'.
  50
  51 ;; * Only numeric uid/gid
  52
  53 ;; TODO ==============================================================
  54
  55 ;; Recognize some more ls switches: R F
  56 \f
  57 ;;; Code:
  58
  59 ;;;###autoload
  60 (defvar ls-lisp-support-shell-wildcards t
  61   "*Non-nil means file patterns are treated as shell wildcards.
  62 nil means they are treated as Emacs regexps (for backward compatibility).
  63 This variable is checked by \\[insert-directory] only when `ls-lisp.el'
  64 package is used.")
  65
  66 (defvar ls-lisp-dired-ignore-case nil
  67   "Non-nil causes dired buffers to sort alphabetically regardless of case.")
  68
  69 (defun insert-directory (file &optional switches wildcard full-directory-p)
  70   "Insert directory listing for FILE, formatted according to SWITCHES.
  71 Leaves point after the inserted text.
  72 Optional third arg WILDCARD means treat FILE as shell wildcard.
  73 Optional fourth arg FULL-DIRECTORY-P means file is a directory and
  74 switches do not contain `d', so that a full listing is expected.
  75
  76 This version of the function comes from `ls-lisp.el'.  It doesn not
  77 run any external programs or shells.  It supports ordinary shell
  78 wildcards if `ls-lisp-support-shell-wildcards' variable is non-nil;
  79 otherwise, it interprets wildcards as regular expressions to match
  80 file names.
  81
  82 Not all `ls' switches are supported.  The switches that work
  83 are: A a c i r S s t u"
  84   (let ((handler (find-file-name-handler file 'insert-directory)))
  85     (if handler
  86         (funcall handler 'insert-directory file switches
  87                  wildcard full-directory-p)
  88       ;; Sometimes we get ".../foo*/" as FILE.  While the shell and
  89       ;; `ls' don't mind, we certainly do, because it makes us think
  90       ;; there is no wildcard, only a directory name.
  91       (if (and ls-lisp-support-shell-wildcards
  92                (string-match "[[?*]" file))
  93           (progn
  94             (or (not (eq (aref file (1- (length file))) ?/))
  95                 (setq file (substring file 0 (1- (length file)))))
  96             (setq wildcard t)))
  97       ;; Convert SWITCHES to a list of characters.
  98       (setq switches (append switches nil))
  99       (if wildcard
 100           (setq wildcard
 101                 (if ls-lisp-support-shell-wildcards
 102                     (wildcard-to-regexp (file-name-nondirectory file))
 103                   (file-name-nondirectory file))
 104                 file (file-name-directory file)))
 105       (if (or wildcard
 106               full-directory-p)
 107           (let* ((dir (file-name-as-directory file))
 108                  (default-directory dir);; so that file-attributes works
 109                  (sum 0)
 110                  elt
 111                  short
 112                  (file-list (directory-files dir nil wildcard))
 113                  file-alist
 114                  (now (current-time))
 115                  ;; do all bindings here for speed
 116                  fil attr)
 117             (cond ((memq ?A switches)
 118                    (setq file-list
 119                          (ls-lisp-delete-matching "^\\.\\.?$" file-list)))
 120                   ((not (memq ?a switches))
 121                    ;; if neither -A  nor -a, flush . files
 122                    (setq file-list
 123                          (ls-lisp-delete-matching "^\\." file-list))))
 124             (setq file-alist
 125                   (mapcar
 126                    (function
 127                     (lambda (x)
 128                       ;; file-attributes("~bogus") bombs
 129                       (cons x (file-attributes (expand-file-name x)))))
 130                    ;; inserting the call to directory-files right here
 131                    ;; seems to stimulate an Emacs bug
 132                    ;; ILLEGAL DATATYPE (#o37777777727) or #o67
 133                    file-list))
 134             ;; ``Total'' line (filled in afterwards).
 135             (insert (if (car-safe file-alist)
 136                         "total \007\n"
 137                       ;; Shell says ``No match'' if no files match
 138                       ;; the wildcard; let's say something similar.
 139                       "(No match)\ntotal \007\n"))
 140             (setq file-alist
 141                   (ls-lisp-handle-switches file-alist switches))
 142             (while file-alist
 143               (setq elt (car file-alist)
 144                     file-alist (cdr file-alist)
 145                     short (car elt)
 146                     attr (cdr elt))
 147               (and attr
 148                    (setq sum (+ sum (nth 7 attr)))
 149                    (insert (ls-lisp-format short attr switches now))))
 150             ;; Fill in total size of all files:
 151             (save-excursion
 152               (search-backward "total \007")
 153               (goto-char (match-end 0))
 154               (delete-char -1)
 155               (insert (format "%d" (if (zerop sum) 0 (1+ (/ sum 1024)))))))
 156         ;; if not full-directory-p, FILE *must not* end in /, as
 157         ;; file-attributes will not recognize a symlink to a directory
 158         ;; must make it a relative filename as ls does:
 159         (setq file (file-name-nondirectory file))
 160         (insert (ls-lisp-format file (file-attributes file) switches
 161                                 (current-time)))))))
 162
 163 (defun ls-lisp-delete-matching (regexp list)
 164   ;; Delete all elements matching REGEXP from LIST, return new list.
 165   ;; Should perhaps use setcdr for efficiency.
 166   (let (result)
 167     (while list
 168       (or (string-match regexp (car list))
 169           (setq result (cons (car list) result)))
 170       (setq list (cdr list)))
 171     result))
 172
 173 (defun ls-lisp-handle-switches (file-alist switches)
 174   ;; FILE-ALIST's elements are (FILE . FILE-ATTRIBUTES).
 175   ;; Return new alist sorted according to SWITCHES which is a list of
 176   ;; characters.  Default sorting is alphabetically.
 177   (let (index)
 178     (setq file-alist
 179           (sort file-alist
 180                 (cond ((memq ?S switches) ; sorted on size
 181                        (function
 182                         (lambda (x y)
 183                           ;; 7th file attribute is file size
 184                           ;; Make largest file come first
 185                           (< (nth 7 (cdr y))
 186                              (nth 7 (cdr x))))))
 187                       ((memq ?t switches) ; sorted on time
 188                        (setq index (ls-lisp-time-index switches))
 189                        (function
 190                         (lambda (x y)
 191                           (ls-lisp-time-lessp (nth index (cdr y))
 192                                               (nth index (cdr x))))))
 193                       (t                ; sorted alphabetically
 194                        (if ls-lisp-dired-ignore-case
 195                            (function
 196                             (lambda (x y)
 197                               (string-lessp (upcase (car x))
 198                                             (upcase (car y)))))
 199                          (function
 200                           (lambda (x y)
 201                             (string-lessp (car x)
 202                                           (car y))))))))))
 203   (if (memq ?r switches)                ; reverse sort order
 204       (setq file-alist (nreverse file-alist)))
 205   file-alist)
 206
 207 ;; From Roland McGrath.  Can use this to sort on time.
 208 (defun ls-lisp-time-lessp (time0 time1)
 209   (let ((hi0 (car time0))
 210         (hi1 (car time1))
 211         (lo0 (car (cdr time0)))
 212         (lo1 (car (cdr time1))))
 213     (or (< hi0 hi1)
 214         (and (= hi0 hi1)
 215              (< lo0 lo1)))))
 216
 217
 218 (defun ls-lisp-format (file-name file-attr switches now)
 219   (let ((file-type (nth 0 file-attr)))
 220     (concat (if (memq ?i switches)      ; inode number
 221                 (format "%6d " (nth 10 file-attr)))
 222             ;; nil is treated like "" in concat
 223             (if (memq ?s switches)      ; size in K
 224                 (format "%4d " (1+ (/ (nth 7 file-attr) 1024))))
 225             (nth 8 file-attr)           ; permission bits
 226             ;; numeric uid/gid are more confusing than helpful
 227             ;; Emacs should be able to make strings of them.
 228             ;; user-login-name and user-full-name could take an
 229             ;; optional arg.
 230             (format " %3d %-8s %-8s %8d "
 231                     (nth 1 file-attr)   ; no. of links
 232                     (if (= (user-uid) (nth 2 file-attr))
 233                         (user-login-name)
 234                       (int-to-string (nth 2 file-attr)))        ; uid
 235                     (if (eq system-type 'ms-dos)
 236                         "root"          ; everything is root on MSDOS.
 237                       (int-to-string (nth 3 file-attr)))        ; gid
 238                     (nth 7 file-attr)   ; size in bytes
 239                     )
 240             (ls-lisp-format-time file-attr switches now)
 241             " "
 242             file-name
 243             (if (stringp file-type)     ; is a symbolic link
 244                 (concat " -> " file-type)
 245               "")
 246             "\n"
 247             )))
 248
 249 (defun ls-lisp-time-index (switches)
 250   ;; Return index into file-attributes according to ls SWITCHES.
 251   (cond
 252    ((memq ?c switches) 6)               ; last mode change
 253    ((memq ?u switches) 4)               ; last access
 254    ;; default is last modtime
 255    (t 5)))
 256
 257 (defun ls-lisp-format-time (file-attr switches now)
 258   ;; Format time string for file with attributes FILE-ATTR according
 259   ;; to SWITCHES (a list of ls option letters of which c and u are recognized).
 260   ;; Use the same method as `ls' to decide whether to show time-of-day or year,
 261   ;; depending on distance between file date and NOW.
 262   (let* ((time (nth (ls-lisp-time-index switches) file-attr))
 263          (diff16 (- (car time) (car now)))
 264          (diff (+ (ash diff16 16) (- (car (cdr time)) (car (cdr now)))))
 265          (past-cutoff (- (* 6 30 24 60 60)))    ; 6 30-day months
 266          (future-cutoff (* 60 60)))             ; 1 hour
 267     (format-time-string
 268      (if (and
 269           (<= past-cutoff diff) (<= diff future-cutoff)
 270           ;; Sanity check in case `diff' computation overflowed.
 271           (<= (1- (ash past-cutoff -16)) diff16)
 272           (<= diff16 (1+ (ash future-cutoff -16))))
 273          "%b %e %H:%M"
 274        "%b %e  %Y")
 275      time)))
 276
 277 (provide 'ls-lisp)
 278
 279 ;;; ls-lisp.el ends here