lisp/ls-lisp.el

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