lisp/ls-lisp.el

   1 ;;;; dired-lisp.el - emulate ls completely in Emacs Lisp. $Revision: 1.4 $
   2 ;;;; Copyright (C) 1991 Sebastian Kremer <sk@thp.uni-koeln.de>
   3
   4 ;;;; READ THE WARNING BELOW BEFORE USING THIS PROGRAM!
   5
   6 ;;;; Useful if you cannot afford to fork Emacs on a real memory UNIX,
   7 ;;;; under VMS, or if you don't have the ls program.
   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 1, 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
  23 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  24
  25 ;;;; WARNING:
  26
  27 ;;;; With earlier version of this program I sometimes got an internal
  28 ;;;; Emacs error:
  29
  30 ;;;;   Signalling: (wrong-type-argument natnump #<EMACS BUG: ILLEGAL
  31 ;;;;   DATATYPE (#o37777777727) Save your buffers immediately and please
  32 ;;;;   report this bug>)
  33
  34 ;;;; The datatype differs (I also got #o67 once).
  35
  36 ;;;; Sometimes emacs just crashed with a fatal error.
  37
  38 ;;;; After I've avoided using directory-files and file-attributes
  39 ;;;; together inside a mapcar, the bug didn't surface any longer.
  40
  41 ;;;  RESTRICTIONS:
  42 ;;;; ls switches are mostly ignored
  43 ;;;; Cannot display date of file, displays a fake date "Jan 00 00:00" instead
  44 ;;;; Only numeric uid/gid
  45 ;;;; Loading ange-ftp breaks it
  46
  47 ;;;; It is surprisingly fast, though!
  48
  49 ;;;; TODO:
  50 ;;;; Recognize at some more ls switches: R F
  51
  52 (require 'dired)                        ; we will redefine dired-ls:
  53 (or (fboundp 'dired-lisp-unix-ls)
  54     (fset 'dired-lisp-unix-ls (symbol-function 'dired-ls)))
  55
  56 (fset 'dired-ls 'dired-lisp-ls)
  57
  58 (defun dired-lisp-ls (file &optional switches wildcard full-directory-p)
  59   "dired-lisp.el's version of dired-ls.
  60 Known switches: A a S r i s
  61 Others are ignored.
  62
  63   Insert ls output of FILE, optionally formatted with SWITCHES.
  64 Optional third arg WILDCARD means treat non-directory part of FILE
  65 as emacs regexp (_not_ a shell wildcard).
  66
  67 Optional fourth arg FULL-DIRECTORY-P means file is a directory and
  68 switches do not contain `d'.
  69
  70 SWITCHES default to dired-listing-switches."
  71   (or switches (setq switches dired-listing-switches))
  72   (or (consp switches)                  ; convert to list of chars
  73       (setq switches (mapcar 'identity switches)))
  74   (if wildcard
  75       (setq wildcard (file-name-nondirectory file) ; actually emacs regexp
  76             ;; perhaps convert it from shell to emacs syntax?
  77             file (file-name-directory file)))
  78   (if (or wildcard
  79           full-directory-p)
  80       (let* ((dir (file-name-as-directory file))
  81              (default-directory dir);; so that file-attributes works
  82              (sum 0)
  83              elt
  84              (file-list (directory-files dir nil wildcard))
  85              file-alist
  86              ;; do all bindings here for speed
  87              fil attr)
  88         (cond ((memq ?A switches)
  89                (setq file-list
  90                      (dired-lisp-delete-matching "^\\.\\.?$" file-list)))
  91               ((not (memq ?a switches))
  92                ;; if neither -A  nor -a, flush . files
  93                (setq file-list
  94                      (dired-lisp-delete-matching "^\\." file-list))))
  95         (setq file-alist
  96               (mapcar
  97                (function
  98                 (lambda (x)
  99                   ;; file-attributes("~bogus") bombs
 100                   (cons x (file-attributes (expand-file-name x)))))
 101                ;; inserting the call to directory-files right here
 102                ;; seems to stimulate an Emacs bug
 103                ;; ILLEGAL DATATYPE (#o37777777727) or #o67
 104                file-list))
 105         (insert "total \007\n")         ; filled in afterwards
 106         (setq file-alist
 107               (dired-lisp-handle-switches file-alist switches))
 108         (while file-alist
 109           (setq elt (car file-alist)
 110                 short (car elt)
 111                 attr  (cdr elt)
 112                 file-alist (cdr file-alist)
 113                 fil (concat dir short)
 114                 sum (+ sum (nth 7 attr)))
 115           (insert (dired-lisp-format short attr switches)))
 116         (save-excursion
 117           (search-backward "total \007")
 118           (goto-char (match-end 0))
 119           (delete-char -1)
 120           (insert (format "%d" (1+ (/ sum 1024)))))
 121         )
 122     ;; if not full-directory-p, FILE *must not* end in /, as
 123     ;; file-attributes will not recognize a symlink to a directory
 124     ;; must make it a relative filename as ls does:
 125     (setq file (file-name-nondirectory file))
 126     (insert (dired-lisp-format file (file-attributes file) switches))))
 127
 128 (defun dired-lisp-delete-matching (regexp list)
 129   ;; Delete all elements matching REGEXP from LIST, return new list.
 130   ;; Should perhaps use setcdr for efficiency.
 131   (let (result)
 132     (while list
 133       (or (string-match regexp (car list))
 134           (setq result (cons (car list) result)))
 135       (setq list (cdr list)))
 136     result))
 137
 138 (defun dired-lisp-handle-switches (file-alist switches)
 139   ;; FILE-ALIST's elements are (FILE . FILE-ATTRIBUTES).
 140   ;; Return new alist sorted according to switches.
 141   ;; Default sorting is alphabetically.
 142   (setq file-alist
 143         (sort file-alist
 144               (cond ((memq ?S switches)
 145                      (function
 146                       (lambda (x y)
 147                         ;; 7th file attribute is file size
 148                         ;; Make largest file come first
 149                         (< (nth 7 (cdr y)) (nth 7 (cdr x))))))
 150                     (t                  ; sorted alphabetically
 151                      (function
 152                       (lambda (x y)
 153                         (string-lessp (car x) (car y))))))))
 154   (if (memq ?r switches)                ; reverse sort order
 155       (setq file-alist (nreverse file-alist)))
 156   file-alist)
 157
 158 (defun dired-lisp-format (file-name file-attr &optional switches)
 159   (let ((file-type (nth 0 file-attr)))
 160     (concat (if (memq ?i switches)      ; inode number
 161                 (format "%6d " (nth 10 file-attr)))
 162             ;; nil is treated like "" in concat
 163             (if (memq ?s switches)      ; size in K
 164                 (format "%4d " (1+ (/ (nth 7 file-attr) 1024))))
 165             (nth 8 file-attr)           ; permission bits
 166             ;; numeric uid/gid are more confusing than helpful
 167             ;; Emacs should be able to make strings of them.
 168             ;; user-login-name and user-full-name could take an
 169             ;; optional arg.
 170             (format " %3d %-8d %-8d %8d "
 171                     (nth 1 file-attr)   ; no. of links
 172                     (nth 2 file-attr)   ; uid
 173                     (nth 3 file-attr)   ; gid
 174                     (nth 7 file-attr)   ; size in bytes
 175                     )
 176             ;; file-attributes's time is in a braindead format
 177             ;; Emacs should have a ctime function
 178             ;; current-time-string could take an optional arg.
 179             "Jan 00 00:00 "             ; fake time
 180             file-name
 181             (if (stringp file-type)     ; is a symbolic link
 182                 (concat " -> " file-type)
 183               "")
 184             "\n"
 185             )))
 186