lisp/ls-lisp.el

   1 ;;;; dired-lisp.el - emulate Tree Dired's ls completely in Emacs Lisp
   2
   3 ;;;; READ THE WARNING BELOW BEFORE USING THIS PROGRAM!
   4
   5 (defconst dired-lisp-version (substring "$Revision: 1.7 $" 11 -2)
   6   "$Id: dired-lisp.el,v 1.7 1992/04/30 10:37:15 sk Exp sk $")
   7
   8 ;; Copyright (C) 1992 by Sebastian Kremer <sk@thp.uni-koeln.de>
   9
  10 ;; This program is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 1, or (at your option)
  13 ;; any later version.
  14 ;;
  15 ;; This program is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19 ;;
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with this program; if not, write to the Free Software
  22 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  23
  24 ;; LISPDIR ENTRY for the Elisp Archive ===============================
  25 ;;    LCD Archive Entry:
  26 ;;    dired-lisp|Sebastian Kremer|sk@thp.uni-koeln.de
  27 ;;    |emulate Tree Dired's ls completely in Emacs Lisp
  28 ;;    |$Date: 1992/04/30 10:37:15 $|$Revision: 1.7 $|
  29
  30 ;; INSTALLATION =======================================================
  31 ;;
  32 ;; Put this file into your load-path.  Loading it will result in
  33 ;; redefining function dired-ls to not call ls.
  34
  35 ;; You need tree dired from ftp.cs.buffalo.edu:pub/Emacs/diredall.tar.Z,
  36 ;; classic (e.g. 18.57) dired.el will not work.
  37
  38 ;; OVERVIEW ===========================================================
  39
  40 ;; This file overloads tree dired so that all fileinfo is retrieved
  41 ;; directly from Emacs lisp, without using an ls subprocess.
  42
  43 ;; Useful if you cannot afford to fork Emacs on a real memory UNIX,
  44 ;; under VMS, or if you don't have the ls program, or if you want
  45 ;; different format from what ls offers.
  46
  47 ;; Beware that if you change the output format of dired-ls, you'll
  48 ;; have to change dired-move-to-filename and
  49 ;; dired-move-to-end-of-filename as well.
  50
  51 ;; With this package is loaded, dired uses regexps instead of shell
  52 ;; wildcards. If you enter regexps remember to double each $ sign.
  53 ;; For example, to dired all elisp (*.el) files, enter `.*\.el$$',
  54 ;; resulting in the regexp `.*\.el$'.
  55
  56 ;; WARNING ===========================================================
  57
  58 ;; With earlier version of this program I sometimes got an internal
  59 ;; Emacs error:
  60
  61 ;;   Signalling: (wrong-type-argument natnump #<EMACS BUG: ILLEGAL
  62 ;;   DATATYPE (#o37777777727) Save your buffers immediately and please
  63 ;;   report this bug>)
  64
  65 ;; The datatype differs (I also got #o67 once).
  66
  67 ;; Sometimes emacs just crashed with a fatal error.
  68
  69 ;; After I've avoided using directory-files and file-attributes
  70 ;; together inside a mapcar, the bug didn't surface any longer.
  71
  72 ;;  RESTRICTIONS =====================================================
  73
  74 ;; * many ls switches are ignored, see docstring of `dired-ls'.
  75
  76 ;; * In Emacs 18: cannot display date of file, displays a fake date
  77 ;;   "Jan 00 00:00" instead (dates do work in Emacs 19)
  78
  79 ;; * Only numeric uid/gid
  80
  81 ;; * if you load dired-lisp after ange-ftp, remote listings look
  82 ;;   really strange:
  83 ;;
  84 ;;   total 1
  85 ;;   d?????????  -1 -1       -1             -1 Jan  1  1970 .
  86 ;;   d?????????  -1 -1       -1             -1 Jan  1  1970 ..
  87 ;;
  88 ;;   This is because ange-ftp's file-attributes does not return much
  89 ;;   useful information.
  90 ;;
  91 ;;   If you load dired-lisp first, there seem to be no problems.
  92
  93 ;; TODO ==============================================================
  94
  95 ;; Recognize some more ls switches: R F
  96 \f
  97
  98 (require 'dired)                        ; we will redefine dired-ls:
  99 (or (fboundp 'dired-lisp-unix-ls)
 100     (fset 'dired-lisp-unix-ls (symbol-function 'dired-ls)))
 101
 102 (fset 'dired-ls 'dired-lisp-ls)
 103
 104 (defun dired-lisp-ls (file &optional switches wildcard full-directory-p)
 105   "dired-lisp.el's version of dired-ls.
 106 Known switches: A a S r i s t
 107 In Emacs 19, additional known switches are: c u
 108 Others are ignored.
 109
 110   Insert ls output of FILE, optionally formatted with SWITCHES.
 111 Optional third arg WILDCARD means treat non-directory part of FILE as
 112 emacs regexp (_not_ a shell wildcard).  If you enter regexps remember
 113 to double each $ sign.
 114
 115 Optional fourth arg FULL-DIRECTORY-P means file is a directory and
 116 switches do not contain `d'.
 117
 118 SWITCHES default to dired-listing-switches."
 119   (or switches (setq switches dired-listing-switches))
 120   (or (consp switches)                  ; convert to list of chars
 121       (setq switches (mapcar 'identity switches)))
 122   (if wildcard
 123       (setq wildcard (file-name-nondirectory file) ; actually emacs regexp
 124             ;; perhaps convert it from shell to emacs syntax?
 125             file (file-name-directory file)))
 126   (if (or wildcard
 127           full-directory-p)
 128       (let* ((dir (file-name-as-directory file))
 129              (default-directory dir);; so that file-attributes works
 130              (sum 0)
 131              elt
 132              (file-list (directory-files dir nil wildcard))
 133              file-alist
 134              ;; do all bindings here for speed
 135              fil attr)
 136         (cond ((memq ?A switches)
 137                (setq file-list
 138                      (dired-lisp-delete-matching "^\\.\\.?$" file-list)))
 139               ((not (memq ?a switches))
 140                ;; if neither -A  nor -a, flush . files
 141                (setq file-list
 142                      (dired-lisp-delete-matching "^\\." file-list))))
 143         (setq file-alist
 144               (mapcar
 145                (function
 146                 (lambda (x)
 147                   ;; file-attributes("~bogus") bombs
 148                   (cons x (file-attributes (expand-file-name x)))))
 149                ;; inserting the call to directory-files right here
 150                ;; seems to stimulate an Emacs bug
 151                ;; ILLEGAL DATATYPE (#o37777777727) or #o67
 152                file-list))
 153         (insert "total \007\n")         ; filled in afterwards
 154         (setq file-alist
 155               (dired-lisp-handle-switches file-alist switches))
 156         (while file-alist
 157           (setq elt (car file-alist)
 158                 short (car elt)
 159                 attr  (cdr elt)
 160                 file-alist (cdr file-alist)
 161                 fil (concat dir short)
 162                 sum (+ sum (nth 7 attr)))
 163           (insert (dired-lisp-format short attr switches)))
 164         ;; Fill in total size of all files:
 165         (save-excursion
 166           (search-backward "total \007")
 167           (goto-char (match-end 0))
 168           (delete-char -1)
 169           (insert (format "%d" (1+ (/ sum 1024))))))
 170     ;; if not full-directory-p, FILE *must not* end in /, as
 171     ;; file-attributes will not recognize a symlink to a directory
 172     ;; must make it a relative filename as ls does:
 173     (setq file (file-name-nondirectory file))
 174     (insert (dired-lisp-format file (file-attributes file) switches))))
 175
 176 (defun dired-lisp-delete-matching (regexp list)
 177   ;; Delete all elements matching REGEXP from LIST, return new list.
 178   ;; Should perhaps use setcdr for efficiency.
 179   (let (result)
 180     (while list
 181       (or (string-match regexp (car list))
 182           (setq result (cons (car list) result)))
 183       (setq list (cdr list)))
 184     result))
 185
 186 (defun dired-lisp-handle-switches (file-alist switches)
 187   ;; FILE-ALIST's elements are (FILE . FILE-ATTRIBUTES).
 188   ;; Return new alist sorted according to SWITCHES which is a list of
 189   ;; characters.  Default sorting is alphabetically.
 190   (let (index)
 191     (setq file-alist
 192           (sort file-alist
 193                 (cond ((memq ?S switches) ; sorted on size
 194                        (function
 195                         (lambda (x y)
 196                           ;; 7th file attribute is file size
 197                           ;; Make largest file come first
 198                           (< (nth 7 (cdr y))
 199                              (nth 7 (cdr x))))))
 200                       ((memq ?t switches) ; sorted on time
 201                        (setq index (dired-lisp-time-index switches))
 202                        (function
 203                         (lambda (x y)
 204                           (time-lessp (nth index (cdr y))
 205                                       (nth index (cdr x))))))
 206                       (t                ; sorted alphabetically
 207                        (function
 208                         (lambda (x y)
 209                           (string-lessp (car x)
 210                                         (car y)))))))))
 211   (if (memq ?r switches)                ; reverse sort order
 212       (setq file-alist (nreverse file-alist)))
 213   file-alist)
 214
 215 ;; From Roland McGrath.  Can use this to sort on time.
 216 (defun time-lessp (time0 time1)
 217   (let ((hi0 (car time0))
 218         (hi1 (car time1))
 219         (lo0 (car (cdr time0)))
 220         (lo1 (car (cdr time1))))
 221     (or (< hi0 hi1)
 222         (and (= hi0 hi1)
 223              (< lo0 lo1)))))
 224
 225
 226 (defun dired-lisp-format (file-name file-attr &optional switches)
 227   (let ((file-type (nth 0 file-attr)))
 228     (concat (if (memq ?i switches)      ; inode number
 229                 (format "%6d " (nth 10 file-attr)))
 230             ;; nil is treated like "" in concat
 231             (if (memq ?s switches)      ; size in K
 232                 (format "%4d " (1+ (/ (nth 7 file-attr) 1024))))
 233             (nth 8 file-attr)           ; permission bits
 234             ;; numeric uid/gid are more confusing than helpful
 235             ;; Emacs should be able to make strings of them.
 236             ;; user-login-name and user-full-name could take an
 237             ;; optional arg.
 238             (format " %3d %-8d %-8d %8d "
 239                     (nth 1 file-attr)   ; no. of links
 240                     (nth 2 file-attr)   ; uid
 241                     (nth 3 file-attr)   ; gid
 242                     (nth 7 file-attr)   ; size in bytes
 243                     )
 244             (dired-lisp-format-time file-attr switches)
 245             " "
 246             file-name
 247             (if (stringp file-type)     ; is a symbolic link
 248                 (concat " -> " file-type)
 249               "")
 250             "\n"
 251             )))
 252
 253 (defun dired-lisp-time-index (switches)
 254   ;; Return index into file-attributes according to ls SWITCHES.
 255   (cond
 256    ((memq ?c switches) 6)               ; last mode change
 257    ((memq ?u switches) 4)               ; last access
 258    ;; default is last modtime
 259    (t 5)))
 260
 261 (defun dired-lisp-format-time (file-attr switches)
 262   ;; Format time string for file with attributes FILE-ATTR according
 263   ;; to SWITCHES (a list of ls option letters of which c and u are recognized).
 264   ;; file-attributes's time is in a braindead format
 265   ;; Emacs 19 can format it using a new optional argument to
 266   ;; current-time-string, for Emacs 18 we just return the faked fixed
 267   ;; date "Jan 00 00:00 ".
 268   (condition-case error-data
 269       (let* ((time (current-time-string
 270                     (nth (dired-lisp-time-index switches) file-attr)))
 271              (date (substring time 4 11)) ; "Apr 30 "
 272              (clock (substring time 11 16)) ; "11:27"
 273              (year (substring time 19 24)) ; " 1992"
 274              (same-year (equal year (substring (current-time-string) 19 24))))
 275         (concat date                    ; has trailing SPC
 276                 (if same-year
 277                     ;; this is not exactly the same test used by ls
 278                     ;; ls tests if the file is older than 6 months
 279                     ;; but we can't do time differences easily
 280                     clock
 281                   year)))
 282     (error
 283      "Jan 00 00:00")))
 284
 285 (provide 'dired-lisp)
 286
 287 ; eof