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

   1 ;;; ls-lisp.el --- emulate insert-directory completely in Emacs Lisp
   2
   3 ;; Author: Sebastian Kremer <sk@thp.uni-koeln.de>
   4 ;; Keywords: unix
   5
   6 ;; Copyright (C) 1992, 1994 by Sebastian Kremer <sk@thp.uni-koeln.de>
   7
   8 ;; This program is free software; you can redistribute it and/or modify
   9 ;; it under the terms of the GNU General Public License as published by
  10 ;; the Free Software Foundation; either version 1, or (at your option)
  11 ;; any later version.
  12 ;;
  13 ;; This program is distributed in the hope that it will be useful,
  14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;; GNU General Public License for more details.
  17 ;;
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with this program; if not, write to the Free Software
  20 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  21
  22 ;; INSTALLATION =======================================================
  23 ;;
  24 ;; Put this file into your load-path.  To use it, load it
  25 ;; with (load "ls-lisp").
  26
  27 ;; OVERVIEW ===========================================================
  28
  29 ;; This file overloads the function insert-directory to implement it
  30 ;; directly from Emacs lisp, without running `ls' in a subprocess.
  31
  32 ;; It is useful if you cannot afford to fork Emacs on a real memory UNIX,
  33 ;; under VMS, or if you don't have the ls program, or if you want
  34 ;; different format from what ls offers.
  35
  36 ;; This function uses regexps instead of shell
  37 ;; wildcards.  If you enter regexps remember to double each $ sign.
  38 ;; For example, to include files *.el, enter `.*\.el$$',
  39 ;; resulting in the regexp `.*\.el$'.
  40
  41 ;;  RESTRICTIONS =====================================================
  42
  43 ;; * many ls switches are ignored, see docstring of `insert-directory'.
  44
  45 ;; * Only numeric uid/gid
  46
  47 ;; TODO ==============================================================
  48
  49 ;; Recognize some more ls switches: R F
  50 \f
  51 ;;; Code:
  52
  53 (defun insert-directory (file &optional switches wildcard full-directory-p)
  54   "Insert directory listing for of FILE, formatted according to SWITCHES.
  55 Leaves point after the inserted text.
  56 Optional third arg WILDCARD means treat FILE as shell wildcard.
  57 Optional fourth arg FULL-DIRECTORY-P means file is a directory and
  58 switches do not contain `d', so that a full listing is expected.
  59
  60 This version of the function comes from `ls-lisp.el'.
  61 It does not support ordinary shell wildcards; instead, it allows
  62 regular expressions to match file names.
  63
  64 The switches that work are: A a c i r S s t u"
  65   (let ((handler (find-file-name-handler file 'insert-directory)))
  66     (if handler
  67         (funcall handler 'insert-directory file switches
  68                  wildcard full-directory-p)
  69       ;; Convert SWITCHES to a list of characters.
  70       (setq switches (append switches nil))
  71       (if wildcard
  72           (setq wildcard (file-name-nondirectory file) ; actually emacs regexp
  73                 ;; perhaps convert it from shell to emacs syntax?
  74                 file (file-name-directory file)))
  75       (if (or wildcard
  76               full-directory-p)
  77           (let* ((dir (file-name-as-directory file))
  78                  (default-directory dir);; so that file-attributes works
  79                  (sum 0)
  80                  elt
  81                  short
  82                  (file-list (directory-files dir nil wildcard))
  83                  file-alist
  84                  ;; do all bindings here for speed
  85                  fil attr)
  86             (cond ((memq ?A switches)
  87                    (setq file-list
  88                          (ls-lisp-delete-matching "^\\.\\.?$" file-list)))
  89                   ((not (memq ?a switches))
  90                    ;; if neither -A  nor -a, flush . files
  91                    (setq file-list
  92                          (ls-lisp-delete-matching "^\\." file-list))))
  93             (setq file-alist
  94                   (mapcar
  95                    (function
  96                     (lambda (x)
  97                       ;; file-attributes("~bogus") bombs
  98                       (cons x (file-attributes (expand-file-name x)))))
  99                    ;; inserting the call to directory-files right here
 100                    ;; seems to stimulate an Emacs bug
 101                    ;; ILLEGAL DATATYPE (#o37777777727) or #o67
 102                    file-list))
 103             (insert "total \007\n")     ; filled in afterwards
 104             (setq file-alist
 105                   (ls-lisp-handle-switches file-alist switches))
 106             (while file-alist
 107               (setq elt (car file-alist)
 108                     file-alist (cdr file-alist)
 109                     short (car elt)
 110                     attr (cdr elt))
 111               (and attr
 112                    (setq sum (+ sum (nth 7 attr)))
 113                    (insert (ls-lisp-format short attr switches))))
 114             ;; Fill in total size of all files:
 115             (save-excursion
 116               (search-backward "total \007")
 117               (goto-char (match-end 0))
 118               (delete-char -1)
 119               (insert (format "%d" (1+ (/ sum 1024))))))
 120         ;; if not full-directory-p, FILE *must not* end in /, as
 121         ;; file-attributes will not recognize a symlink to a directory
 122         ;; must make it a relative filename as ls does:
 123         (setq file (file-name-nondirectory file))
 124         (insert (ls-lisp-format file (file-attributes file) switches))))))
 125
 126 (defun ls-lisp-delete-matching (regexp list)
 127   ;; Delete all elements matching REGEXP from LIST, return new list.
 128   ;; Should perhaps use setcdr for efficiency.
 129   (let (result)
 130     (while list
 131       (or (string-match regexp (car list))
 132           (setq result (cons (car list) result)))
 133       (setq list (cdr list)))
 134     result))
 135
 136 (defun ls-lisp-handle-switches (file-alist switches)
 137   ;; FILE-ALIST's elements are (FILE . FILE-ATTRIBUTES).
 138   ;; Return new alist sorted according to SWITCHES which is a list of
 139   ;; characters.  Default sorting is alphabetically.
 140   (let (index)
 141     (setq file-alist
 142           (sort file-alist
 143                 (cond ((memq ?S switches) ; sorted on size
 144                        (function
 145                         (lambda (x y)
 146                           ;; 7th file attribute is file size
 147                           ;; Make largest file come first
 148                           (< (nth 7 (cdr y))
 149                              (nth 7 (cdr x))))))
 150                       ((memq ?t switches) ; sorted on time
 151                        (setq index (ls-lisp-time-index switches))
 152                        (function
 153                         (lambda (x y)
 154                           (ls-lisp-time-lessp (nth index (cdr y))
 155                                               (nth index (cdr x))))))
 156                       (t                ; sorted alphabetically
 157                        (function
 158                         (lambda (x y)
 159                           (string-lessp (car x)
 160                                         (car y)))))))))
 161   (if (memq ?r switches)                ; reverse sort order
 162       (setq file-alist (nreverse file-alist)))
 163   file-alist)
 164
 165 ;; From Roland McGrath.  Can use this to sort on time.
 166 (defun ls-lisp-time-lessp (time0 time1)
 167   (let ((hi0 (car time0))
 168         (hi1 (car time1))
 169         (lo0 (car (cdr time0)))
 170         (lo1 (car (cdr time1))))
 171     (or (< hi0 hi1)
 172         (and (= hi0 hi1)
 173              (< lo0 lo1)))))
 174
 175
 176 (defun ls-lisp-format (file-name file-attr &optional switches)
 177   (let ((file-type (nth 0 file-attr)))
 178     (concat (if (memq ?i switches)      ; inode number
 179                 (format "%6d " (nth 10 file-attr)))
 180             ;; nil is treated like "" in concat
 181             (if (memq ?s switches)      ; size in K
 182                 (format "%4d " (1+ (/ (nth 7 file-attr) 1024))))
 183             (nth 8 file-attr)           ; permission bits
 184             ;; numeric uid/gid are more confusing than helpful
 185             ;; Emacs should be able to make strings of them.
 186             ;; user-login-name and user-full-name could take an
 187             ;; optional arg.
 188             (format " %3d %8s %8s %8d "
 189                     (nth 1 file-attr)   ; no. of links
 190                     (if (= (user-uid) (nth 2 file-attr))
 191                         (user-login-name)
 192                       (int-to-string (nth 2 file-attr)))        ; uid
 193                     (if (eq system-type 'ms-dos)
 194                         "root"          ; everything is root on MSDOS.
 195                       (int-to-string (nth 3 file-attr)))        ; gid
 196                     (nth 7 file-attr)   ; size in bytes
 197                     )
 198             (ls-lisp-format-time file-attr switches)
 199             " "
 200             file-name
 201             (if (stringp file-type)     ; is a symbolic link
 202                 (concat " -> " file-type)
 203               "")
 204             "\n"
 205             )))
 206
 207 (defun ls-lisp-time-index (switches)
 208   ;; Return index into file-attributes according to ls SWITCHES.
 209   (cond
 210    ((memq ?c switches) 6)               ; last mode change
 211    ((memq ?u switches) 4)               ; last access
 212    ;; default is last modtime
 213    (t 5)))
 214
 215 (defun ls-lisp-format-time (file-attr switches)
 216   ;; Format time string for file with attributes FILE-ATTR according
 217   ;; to SWITCHES (a list of ls option letters of which c and u are recognized).
 218   ;; file-attributes's time is in a braindead format
 219   ;; Emacs 19 can format it using a new optional argument to
 220   ;; current-time-string, for Emacs 18 we just return the faked fixed
 221   ;; date "Jan 00 00:00 ".
 222   (condition-case error-data
 223       (let* ((time (current-time-string
 224                     (nth (ls-lisp-time-index switches) file-attr)))
 225              (date (substring time 4 11)) ; "Apr 30 "
 226              (clock (substring time 11 16)) ; "11:27"
 227              (year (substring time 19 24)) ; " 1992"
 228              (same-year (equal year (substring (current-time-string) 19 24))))
 229         (concat date                    ; has trailing SPC
 230                 (if same-year
 231                     ;; this is not exactly the same test used by ls
 232                     ;; ls tests if the file is older than 6 months
 233                     ;; but we can't do time differences easily
 234                     clock
 235                   year)))
 236     (error
 237      "Jan 00 00:00")))
 238
 239 (provide 'ls-lisp)
 240
 241 ;;; ls-lisp.el ends here