lisp/ls-lisp.el

   1 ;;; ls-lisp.el --- emulate insert-directory completely in Emacs Lisp
   2
   3 ;; Copyright (C) 1992, 1994 Free Software Foundation, Inc.
   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 (defvar ls-lisp-use-insert-directory-program nil
  70   "Non-nil causes ls-lisp to revert back to using `insert-directory-program'.
  71 This is useful on platforms where ls-lisp is dumped into Emacs, such as
  72 Microsoft Windows, but you would still like to use a program to list
  73 the contents of a directory.")
  74
  75 ;; Remember the original insert-directory function.
  76 (fset 'original-insert-directory (symbol-function 'insert-directory))
  77
  78 (defun insert-directory (file switches &optional wildcard full-directory-p)
  79   "Insert directory listing for FILE, formatted according to SWITCHES.
  80 Leaves point after the inserted text.
  81 SWITCHES may be a string of options, or a list of strings.
  82 Optional third arg WILDCARD means treat FILE as shell wildcard.
  83 Optional fourth arg FULL-DIRECTORY-P means file is a directory and
  84 switches do not contain `d', so that a full listing is expected.
  85
  86 This version of the function comes from `ls-lisp.el'.  Depending upon
  87 the value of `ls-lisp-use-insert-directory-program', it will use an
  88 external program if non-nil or the lisp function `ls-lisp-insert-directory'
  89 otherwise."
  90   (if ls-lisp-use-insert-directory-program
  91       (original-insert-directory file switches wildcard full-directory-p)
  92     (ls-lisp-insert-directory file switches wildcard full-directory-p)))
  93
  94 (defun ls-lisp-insert-directory (file switches &optional wildcard full-directory-p)
  95   "Insert directory listing for FILE, formatted according to SWITCHES.
  96 Leaves point after the inserted text.
  97 Optional third arg WILDCARD means treat FILE as shell wildcard.
  98 Optional fourth arg FULL-DIRECTORY-P means file is a directory and
  99 switches do not contain `d', so that a full listing is expected.
 100
 101 This version of the function comes from `ls-lisp.el'.  It does not
 102 run any external programs or shells.  It supports ordinary shell
 103 wildcards if `ls-lisp-support-shell-wildcards' variable is non-nil;
 104 otherwise, it interprets wildcards as regular expressions to match
 105 file names.
 106
 107 Not all `ls' switches are supported.  The switches that work
 108 are: A a c i r S s t u"
 109   (let ((handler (find-file-name-handler file 'insert-directory))
 110         fattr)
 111     (if handler
 112         (funcall handler 'insert-directory file switches
 113                  wildcard full-directory-p)
 114       ;; Sometimes we get ".../foo*/" as FILE.  While the shell and
 115       ;; `ls' don't mind, we certainly do, because it makes us think
 116       ;; there is no wildcard, only a directory name.
 117       (if (and ls-lisp-support-shell-wildcards
 118                (string-match "[[?*]" file))
 119           (progn
 120             (or (not (eq (aref file (1- (length file))) ?/))
 121                 (setq file (substring file 0 (1- (length file)))))
 122             (setq wildcard t)))
 123       ;; Convert SWITCHES to a list of characters.
 124       (setq switches (append switches nil))
 125       (if wildcard
 126           (setq wildcard
 127                 (if ls-lisp-support-shell-wildcards
 128                     (wildcard-to-regexp (file-name-nondirectory file))
 129                   (file-name-nondirectory file))
 130                 file (file-name-directory file)))
 131       (if (or wildcard
 132               full-directory-p)
 133           (let* ((dir (file-name-as-directory file))
 134                  (default-directory dir);; so that file-attributes works
 135                  (sum 0)
 136                  elt
 137                  short
 138                  (file-alist (directory-files-and-attributes dir nil wildcard))
 139                  (now (current-time))
 140                  ;; do all bindings here for speed
 141                  file-size
 142                  fil attr)
 143             (cond ((memq ?A switches)
 144                    (setq file-alist
 145                          (ls-lisp-delete-matching "^\\.\\.?$" file-alist)))
 146                   ((not (memq ?a switches))
 147                    ;; if neither -A  nor -a, flush . files
 148                    (setq file-alist
 149                          (ls-lisp-delete-matching "^\\." file-alist))))
 150             ;; ``Total'' line (filled in afterwards).
 151             (insert (if (car-safe file-alist)
 152                         "total \007\n"
 153                       ;; Shell says ``No match'' if no files match
 154                       ;; the wildcard; let's say something similar.
 155                       "(No match)\ntotal \007\n"))
 156             (setq file-alist
 157                   (ls-lisp-handle-switches file-alist switches))
 158             (while file-alist
 159               (setq elt (car file-alist)
 160                     file-alist (cdr file-alist)
 161                     short (car elt)
 162                     attr (cdr elt)
 163                     file-size (nth 7 attr))
 164               (and attr
 165                    (setq sum
 166                          ;; Even if neither SUM nor file's size
 167                          ;; overflow, their sum could.
 168                          (if (or (< sum (- 134217727 file-size))
 169                                  (floatp sum)
 170                                  (floatp file-size))
 171                              (+ sum file-size)
 172                            (+ (float sum) file-size)))
 173                    (insert (ls-lisp-format short attr file-size switches now))
 174                    ))
 175             ;; Fill in total size of all files:
 176             (save-excursion
 177               (search-backward "total \007")
 178               (goto-char (match-end 0))
 179               (delete-char -1)
 180               (insert (format "%.0f" (fceiling (/ sum 1024.0))))))
 181         ;; if not full-directory-p, FILE *must not* end in /, as
 182         ;; file-attributes will not recognize a symlink to a directory
 183         ;; must make it a relative filename as ls does:
 184         (if (eq (aref file (1- (length file))) ?/)
 185             (setq file (substring file 0 (1- (length file)))))
 186         (setq fattr (file-attributes file))
 187         (if fattr
 188             (insert (ls-lisp-format file fattr (nth 7 fattr)
 189                                     switches (current-time)))
 190           (message "%s: doesn't exist or is inaccessible" file)
 191           (ding)
 192           (sit-for 2))))))
 193
 194 (defun ls-lisp-delete-matching (regexp list)
 195   ;; Delete all elements matching REGEXP from LIST, return new list.
 196   ;; Should perhaps use setcdr for efficiency.
 197   (let (result)
 198     (while list
 199       (or (string-match regexp (car (car list)))
 200           (setq result (cons (car list) result)))
 201       (setq list (cdr list)))
 202     result))
 203
 204 (defun ls-lisp-handle-switches (file-alist switches)
 205   ;; FILE-ALIST's elements are (FILE . FILE-ATTRIBUTES).
 206   ;; Return new alist sorted according to SWITCHES which is a list of
 207   ;; characters.  Default sorting is alphabetically.
 208   (let (index)
 209     (setq file-alist
 210           (sort file-alist
 211                 (cond ((memq ?S switches) ; sorted on size
 212                        (function
 213                         (lambda (x y)
 214                           ;; 7th file attribute is file size
 215                           ;; Make largest file come first
 216                           (< (nth 7 (cdr y))
 217                              (nth 7 (cdr x))))))
 218                       ((memq ?t switches) ; sorted on time
 219                        (setq index (ls-lisp-time-index switches))
 220                        (function
 221                         (lambda (x y)
 222                           (ls-lisp-time-lessp (nth index (cdr y))
 223                                               (nth index (cdr x))))))
 224                       (t                ; sorted alphabetically
 225                        (if ls-lisp-dired-ignore-case
 226                            (function
 227                             (lambda (x y)
 228                               (string-lessp (upcase (car x))
 229                                             (upcase (car y)))))
 230                          (function
 231                           (lambda (x y)
 232                             (string-lessp (car x)
 233                                           (car y))))))))))
 234   (if (memq ?r switches)                ; reverse sort order
 235       (setq file-alist (nreverse file-alist)))
 236   file-alist)
 237
 238 ;; From Roland McGrath.  Can use this to sort on time.
 239 (defun ls-lisp-time-lessp (time0 time1)
 240   (let ((hi0 (car time0))
 241         (hi1 (car time1))
 242         (lo0 (car (cdr time0)))
 243         (lo1 (car (cdr time1))))
 244     (or (< hi0 hi1)
 245         (and (= hi0 hi1)
 246              (< lo0 lo1)))))
 247
 248
 249 (defun ls-lisp-format (file-name file-attr file-size switches now)
 250   (let ((file-type (nth 0 file-attr)))
 251     (concat (if (memq ?i switches)      ; inode number
 252                 (format "%6d " (nth 10 file-attr)))
 253             ;; nil is treated like "" in concat
 254             (if (memq ?s switches)      ; size in K
 255                 (format "%4.0f " (fceiling (/ file-size 1024.0))))
 256             (nth 8 file-attr)           ; permission bits
 257             ;; numeric uid/gid are more confusing than helpful
 258             ;; Emacs should be able to make strings of them.
 259             ;; user-login-name and user-full-name could take an
 260             ;; optional arg.
 261             (format (if (floatp file-size)
 262                         " %3d %-8s %-8s %8.0f "
 263                       " %3d %-8s %-8s %8d ")
 264                     (nth 1 file-attr)   ; no. of links
 265                     (if (= (user-uid) (nth 2 file-attr))
 266                         (user-login-name)
 267                       (int-to-string (nth 2 file-attr)))        ; uid
 268                     (if (eq system-type 'ms-dos)
 269                         "root"          ; everything is root on MSDOS.
 270                       (int-to-string (nth 3 file-attr)))        ; gid
 271                     file-size
 272                     )
 273             (ls-lisp-format-time file-attr switches now)
 274             " "
 275             file-name
 276             (if (stringp file-type)     ; is a symbolic link
 277                 (concat " -> " file-type)
 278               "")
 279             "\n"
 280             )))
 281
 282 (defun ls-lisp-time-index (switches)
 283   ;; Return index into file-attributes according to ls SWITCHES.
 284   (cond
 285    ((memq ?c switches) 6)               ; last mode change
 286    ((memq ?u switches) 4)               ; last access
 287    ;; default is last modtime
 288    (t 5)))
 289
 290 (defun ls-lisp-format-time (file-attr switches now)
 291   ;; Format time string for file with attributes FILE-ATTR according
 292   ;; to SWITCHES (a list of ls option letters of which c and u are recognized).
 293   ;; Use the same method as `ls' to decide whether to show time-of-day or year,
 294   ;; depending on distance between file date and NOW.
 295   (let* ((time (nth (ls-lisp-time-index switches) file-attr))
 296          (diff16 (- (car time) (car now)))
 297          (diff (+ (ash diff16 16) (- (car (cdr time)) (car (cdr now)))))
 298          (past-cutoff (- (* 6 30 24 60 60)))    ; 6 30-day months
 299          (future-cutoff (* 60 60)))             ; 1 hour
 300     (condition-case nil
 301         (format-time-string
 302          (if (and
 303               (<= past-cutoff diff) (<= diff future-cutoff)
 304               ;; Sanity check in case `diff' computation overflowed.
 305               (<= (1- (ash past-cutoff -16)) diff16)
 306               (<= diff16 (1+ (ash future-cutoff -16))))
 307              "%b %e %H:%M"
 308            "%b %e  %Y")
 309          time)
 310       (error "Unk  0  0000"))))
 311
 312 (provide 'ls-lisp)
 313
 314 ;;; ls-lisp.el ends here