lisp/ls-lisp.el

   1 ;;; ls-lisp.el --- emulate insert-directory completely in Emacs Lisp
   2
   3 ;; Copyright (C) 1992, 1994, 2000-2013 Free Software Foundation, Inc.
   4
   5 ;; Author: Sebastian Kremer <sk@thp.uni-koeln.de>
   6 ;; Modified by: Francis J. Wright <F.J.Wright@maths.qmw.ac.uk>
   7 ;; Maintainer: FSF
   8 ;; Keywords: unix, dired
   9 ;; Package: emacs
  10
  11 ;; This file is part of GNU Emacs.
  12
  13 ;; GNU Emacs is free software: you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation, either version 3 of the License, or
  16 ;; (at your option) any later version.
  17
  18 ;; GNU Emacs is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  25
  26 ;;; Commentary:
  27
  28 ;; OVERVIEW ==========================================================
  29
  30 ;; This file redefines the function `insert-directory' to implement it
  31 ;; directly from Emacs lisp, without running ls in a subprocess.  It
  32 ;; is useful if you cannot afford to fork Emacs on a real memory UNIX,
  33 ;; or other non-UNIX platforms if you don't have the ls
  34 ;; program, or if you want a different format from what ls offers.
  35
  36 ;; This function can use regexps instead of shell wildcards.  If you
  37 ;; enter regexps remember to double each $ sign.  For example, to
  38 ;; include files *.el, enter `.*\.el$$', resulting in the regexp
  39 ;; `.*\.el$'.
  40
  41 ;; RESTRICTIONS ======================================================
  42
  43 ;; * A few obscure ls switches are still ignored: see the docstring of
  44 ;; `insert-directory'.
  45
  46 ;; TO DO =============================================================
  47
  48 ;; Complete handling of F switch (if/when possible).
  49
  50 ;; FJW: May be able to sort much faster by consing the sort key onto
  51 ;; the front of each list element, sorting and then stripping the key
  52 ;; off again!
  53
  54 ;;; History:
  55
  56 ;; Written originally by Sebastian Kremer <sk@thp.uni-koeln.de>
  57 ;; Revised by Andrew Innes and Geoff Volker (and maybe others).
  58
  59 ;; Modified by Francis J. Wright <F.J.Wright@maths.qmw.ac.uk>, mainly
  60 ;; to support many more ls options, "platform emulation" and more
  61 ;; robust sorting.
  62
  63 ;;; Code:
  64
  65 (defgroup ls-lisp nil
  66   "Emulate the ls program completely in Emacs Lisp."
  67   :version "21.1"
  68   :group 'dired)
  69
  70 (defun ls-lisp-set-options ()
  71   "Reset the ls-lisp options that depend on `ls-lisp-emulation'."
  72   (mapc 'custom-reevaluate-setting
  73         '(ls-lisp-ignore-case ls-lisp-dirs-first ls-lisp-verbosity)))
  74
  75 (defcustom ls-lisp-emulation
  76   (cond ;; ((eq system-type 'windows-nt) 'MS-Windows)
  77         ((memq system-type '(hpux usg-unix-v irix berkeley-unix))
  78          'UNIX))        ; very similar to GNU
  79   ;; Anything else defaults to nil, meaning GNU.
  80   "Platform to emulate: GNU (default), MacOS, MS-Windows, UNIX.
  81 Corresponding value is one of: nil, `MacOS', `MS-Windows', `UNIX'.
  82 Set this to your preferred value; it need not match the actual platform
  83 you are using.
  84
  85 This variable does not affect the behavior of ls-lisp directly.
  86 Rather, it controls the default values for some variables that do:
  87 `ls-lisp-ignore-case', `ls-lisp-dirs-first', and `ls-lisp-verbosity'.
  88
  89 If you change this variable directly (without using customize)
  90 after loading `ls-lisp', you should use `ls-lisp-set-options' to
  91 update the dependent variables."
  92   :type '(choice (const :tag "GNU" nil)
  93                  (const MacOS)
  94                  (const MS-Windows)
  95                  (const UNIX))
  96   :initialize 'custom-initialize-default
  97   :set (lambda (symbol value)
  98          (unless (equal value (eval symbol))
  99            (custom-set-default symbol value)
 100            (ls-lisp-set-options)))
 101   :group 'ls-lisp)
 102
 103 ;; Only made an obsolete alias in 23.3.  Before that, the initial
 104 ;; value was set according to:
 105 ;;  (or (memq ls-lisp-emulation '(MS-Windows MacOS))
 106 ;;      (and (boundp 'ls-lisp-dired-ignore-case) ls-lisp-dired-ignore-case))
 107 ;; Which isn't the right thing to do.
 108 (define-obsolete-variable-alias 'ls-lisp-dired-ignore-case
 109   'ls-lisp-ignore-case "21.1")
 110
 111 (defcustom ls-lisp-ignore-case
 112   (memq ls-lisp-emulation '(MS-Windows MacOS))
 113   "Non-nil causes ls-lisp alphabetic sorting to ignore case."
 114   :set-after '(ls-lisp-emulation)
 115   :type 'boolean
 116   :group 'ls-lisp)
 117
 118 (defcustom ls-lisp-dirs-first (eq ls-lisp-emulation 'MS-Windows)
 119   "Non-nil causes ls-lisp to sort directories first in any ordering.
 120 \(Or last if it is reversed.)  Follows Microsoft Windows Explorer."
 121   ;; Functionality suggested by Chris McMahan <cmcmahan@one.net>
 122   :set-after '(ls-lisp-emulation)
 123   :type 'boolean
 124   :group 'ls-lisp)
 125
 126 (defcustom ls-lisp-verbosity
 127   (cond ((eq ls-lisp-emulation 'MacOS) nil)
 128         ((eq ls-lisp-emulation 'MS-Windows)
 129          (if (and (fboundp 'w32-using-nt) (w32-using-nt))
 130              '(links)))                 ; distinguish NT/2K from 9x
 131         ((eq ls-lisp-emulation 'UNIX) '(links uid)) ; UNIX ls
 132         (t '(links uid gid)))           ; GNU ls
 133   "A list of optional file attributes that ls-lisp should display.
 134 It should contain none or more of the symbols: links, uid, gid.
 135 A value of nil (or an empty list) means display none of them.
 136
 137 Concepts come from UNIX: `links' means count of names associated with
 138 the file; `uid' means user (owner) identifier; `gid' means group
 139 identifier.
 140
 141 If emulation is MacOS then default is nil;
 142 if emulation is MS-Windows then default is `(links)' if platform is
 143 Windows NT/2K, nil otherwise;
 144 if emulation is UNIX then default is `(links uid)';
 145 if emulation is GNU then default is `(links uid gid)'."
 146   :set-after '(ls-lisp-emulation)
 147   ;; Functionality suggested by Howard Melman <howard@silverstream.com>
 148   :type '(set (const :tag "Show Link Count" links)
 149               (const :tag "Show User" uid)
 150               (const :tag "Show Group" gid))
 151   :group 'ls-lisp)
 152
 153 (defcustom ls-lisp-use-insert-directory-program
 154   (not (memq system-type '(ms-dos windows-nt)))
 155   "Non-nil causes ls-lisp to revert back to using `insert-directory-program'.
 156 This is useful on platforms where ls-lisp is dumped into Emacs, such as
 157 Microsoft Windows, but you would still like to use a program to list
 158 the contents of a directory."
 159   :type 'boolean
 160   :group 'ls-lisp)
 161
 162 ;;; Autoloaded because it is let-bound in `recover-session', `mail-recover-1'.
 163 ;;;###autoload
 164 (defcustom ls-lisp-support-shell-wildcards t
 165   "Non-nil means ls-lisp treats file patterns as shell wildcards.
 166 Otherwise they are treated as Emacs regexps (for backward compatibility)."
 167   :type 'boolean
 168   :group 'ls-lisp)
 169
 170 (defcustom ls-lisp-format-time-list
 171   '("%b %e %H:%M"
 172     "%b %e  %Y")
 173   "List of `format-time-string' specs to display file time stamps.
 174 These specs are used ONLY if a valid locale can not be determined.
 175
 176 If `ls-lisp-use-localized-time-format' is non-nil, these specs are used
 177 regardless of whether the locale can be determined.
 178
 179 Syntax:  (EARLY-TIME-FORMAT OLD-TIME-FORMAT)
 180
 181 The EARLY-TIME-FORMAT is used if file has been modified within the
 182 current year.  The OLD-TIME-FORMAT is used for older files.  To use ISO
 183 8601 dates, you could set:
 184
 185 \(setq ls-lisp-format-time-list
 186        '(\"%Y-%m-%d %H:%M\"
 187          \"%Y-%m-%d      \"))"
 188   :type '(list (string :tag "Early time format")
 189                (string :tag "Old time format"))
 190   :group 'ls-lisp)
 191
 192 (defcustom ls-lisp-use-localized-time-format nil
 193   "Non-nil means to always use `ls-lisp-format-time-list' for time stamps.
 194 This applies even if a valid locale is specified.
 195
 196 WARNING: Using localized date/time format might cause Dired columns
 197 to fail to line up, e.g. if month names are not all of the same length."
 198   :type 'boolean
 199   :group 'ls-lisp)
 200
 201 (defvar original-insert-directory nil
 202   "This holds the original function definition of `insert-directory'.")
 203
 204 (defvar ls-lisp-uid-d-fmt "-%d"
 205   "Format to display integer UIDs.")
 206 (defvar ls-lisp-uid-s-fmt "-%s"
 207   "Format to display user names.")
 208 (defvar ls-lisp-gid-d-fmt "-%d"
 209   "Format to display integer GIDs.")
 210 (defvar ls-lisp-gid-s-fmt "-%s"
 211   "Format to display user group names.")
 212 (defvar ls-lisp-filesize-d-fmt "%d"
 213   "Format to display integer file sizes.")
 214 (defvar ls-lisp-filesize-f-fmt "%.0f"
 215   "Format to display float file sizes.")
 216
 217 ;; Remember the original insert-directory function
 218 (or (featurep 'ls-lisp)  ; FJW: unless this file is being reloaded!
 219     (setq original-insert-directory (symbol-function 'insert-directory)))
 220
 221 \f
 222 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 223
 224 (defun insert-directory (file switches &optional wildcard full-directory-p)
 225   "Insert directory listing for FILE, formatted according to SWITCHES.
 226 Leaves point after the inserted text.
 227 SWITCHES may be a string of options, or a list of strings.
 228 Optional third arg WILDCARD means treat FILE as shell wildcard.
 229 Optional fourth arg FULL-DIRECTORY-P means file is a directory and
 230 switches do not contain `d', so that a full listing is expected.
 231
 232 This version of the function comes from `ls-lisp.el'.
 233 If the value of `ls-lisp-use-insert-directory-program' is non-nil then
 234 it works exactly like the version from `files.el' and runs a directory
 235 listing program whose name is in the variable
 236 `insert-directory-program'; if also WILDCARD is non-nil then it runs
 237 the shell specified by `shell-file-name'.  If the value of
 238 `ls-lisp-use-insert-directory-program' is nil then it runs a Lisp
 239 emulation.
 240
 241 The Lisp emulation does not run any external programs or shells.  It
 242 supports ordinary shell wildcards if `ls-lisp-support-shell-wildcards'
 243 is non-nil; otherwise, it interprets wildcards as regular expressions
 244 to match file names.  It does not support all `ls' switches -- those
 245 that work are: A a B C c F G g h i n R r S s t U u X.  The l switch
 246 is assumed to be always present and cannot be turned off."
 247   (if ls-lisp-use-insert-directory-program
 248       (funcall original-insert-directory
 249                file switches wildcard full-directory-p)
 250     ;; We need the directory in order to find the right handler.
 251     (let ((handler (find-file-name-handler (expand-file-name file)
 252                                            'insert-directory))
 253           (orig-file file)
 254           wildcard-regexp)
 255       (if handler
 256           (funcall handler 'insert-directory file switches
 257                    wildcard full-directory-p)
 258         ;; Remove --dired switch
 259         (if (string-match "--dired " switches)
 260             (setq switches (replace-match "" nil nil switches)))
 261         ;; Convert SWITCHES to a list of characters.
 262         (setq switches (delete ?\  (delete ?- (append switches nil))))
 263         ;; Sometimes we get ".../foo*/" as FILE.  While the shell and
 264         ;; `ls' don't mind, we certainly do, because it makes us think
 265         ;; there is no wildcard, only a directory name.
 266         (if (and ls-lisp-support-shell-wildcards
 267                  (string-match "[[?*]" file)
 268                  ;; Prefer an existing file to wildcards, like
 269                  ;; dired-noselect does.
 270                  (not (file-exists-p file)))
 271             (progn
 272               (or (not (eq (aref file (1- (length file))) ?/))
 273                   (setq file (substring file 0 (1- (length file)))))
 274               (setq wildcard t)))
 275         (if wildcard
 276             (setq wildcard-regexp
 277                   (if ls-lisp-support-shell-wildcards
 278                       (wildcard-to-regexp (file-name-nondirectory file))
 279                     (file-name-nondirectory file))
 280                   file (file-name-directory file))
 281           (if (memq ?B switches) (setq wildcard-regexp "[^~]\\'")))
 282         (condition-case err
 283             (ls-lisp-insert-directory
 284              file switches (ls-lisp-time-index switches)
 285              wildcard-regexp full-directory-p)
 286           (invalid-regexp
 287            ;; Maybe they wanted a literal file that just happens to
 288            ;; use characters special to shell wildcards.
 289            (if (equal (cadr err) "Unmatched [ or [^")
 290                (progn
 291                  (setq wildcard-regexp (if (memq ?B switches) "[^~]\\'")
 292                        file (file-relative-name orig-file))
 293                  (ls-lisp-insert-directory
 294                   file switches (ls-lisp-time-index switches)
 295                   nil full-directory-p))
 296              (signal (car err) (cdr err)))))
 297         ;; Try to insert the amount of free space.
 298         (save-excursion
 299           (goto-char (point-min))
 300           ;; First find the line to put it on.
 301           (when (re-search-forward "^total" nil t)
 302             (let ((available (get-free-disk-space ".")))
 303               (when available
 304                 ;; Replace "total" with "total used", to avoid confusion.
 305                 (replace-match "total used in directory")
 306                 (end-of-line)
 307                 (insert " available " available)))))))))
 308
 309 (defun ls-lisp-insert-directory
 310   (file switches time-index wildcard-regexp full-directory-p)
 311   "Insert directory listing for FILE, formatted according to SWITCHES.
 312 Leaves point after the inserted text.  This is an internal function
 313 optionally called by the `ls-lisp.el' version of `insert-directory'.
 314 It is called recursively if the -R switch is used.
 315 SWITCHES is a *list* of characters.  TIME-INDEX is the time index into
 316 file-attributes according to SWITCHES.  WILDCARD-REGEXP is nil or an *Emacs
 317 regexp*.  FULL-DIRECTORY-P means file is a directory and SWITCHES does
 318 not contain `d', so that a full listing is expected."
 319   (if (or wildcard-regexp full-directory-p)
 320       (let* ((dir (file-name-as-directory file))
 321              (default-directory dir)    ; so that file-attributes works
 322              (file-alist
 323               (directory-files-and-attributes dir nil wildcard-regexp t
 324                                               (if (memq ?n switches)
 325                                                   'integer
 326                                                 'string)))
 327              (sum 0)
 328              (max-uid-len 0)
 329              (max-gid-len 0)
 330              (max-file-size 0)
 331              ;; do all bindings here for speed
 332              total-line files elt short file-size attr
 333              fuid fgid uid-len gid-len)
 334         (setq file-alist (ls-lisp-sanitize file-alist))
 335         (cond ((memq ?A switches)
 336                (setq file-alist
 337                      (ls-lisp-delete-matching "^\\.\\.?$" file-alist)))
 338               ((not (memq ?a switches))
 339                ;; if neither -A  nor -a, flush . files
 340                (setq file-alist
 341                      (ls-lisp-delete-matching "^\\." file-alist))))
 342         (setq file-alist
 343               (ls-lisp-handle-switches file-alist switches))
 344         (if (memq ?C switches)          ; column (-C) format
 345             (ls-lisp-column-format file-alist)
 346           (setq total-line (cons (point) (car-safe file-alist)))
 347           ;; Find the appropriate format for displaying uid, gid, and
 348           ;; file size, by finding the longest strings among all the
 349           ;; files we are about to display.
 350           (dolist (elt file-alist)
 351             (setq attr (cdr elt)
 352                   fuid (nth 2 attr)
 353                   uid-len (if (stringp fuid) (string-width fuid)
 354                             (length (format "%d" fuid)))
 355                   fgid (nth 3 attr)
 356                   gid-len (if (stringp fgid) (string-width fgid)
 357                             (length (format "%d" fgid)))
 358                   file-size (nth 7 attr))
 359             (if (> uid-len max-uid-len)
 360                 (setq max-uid-len uid-len))
 361             (if (> gid-len max-gid-len)
 362                 (setq max-gid-len gid-len))
 363             (if (> file-size max-file-size)
 364                 (setq max-file-size file-size)))
 365           (setq ls-lisp-uid-d-fmt (format " %%-%dd" max-uid-len))
 366           (setq ls-lisp-uid-s-fmt (format " %%-%ds" max-uid-len))
 367           (setq ls-lisp-gid-d-fmt (format " %%-%dd" max-gid-len))
 368           (setq ls-lisp-gid-s-fmt (format " %%-%ds" max-gid-len))
 369           (setq ls-lisp-filesize-d-fmt
 370                 (format " %%%dd"
 371                         (if (memq ?s switches)
 372                             (length (format "%.0f"
 373                                             (fceiling (/ max-file-size 1024.0))))
 374                           (length (format "%.0f" max-file-size)))))
 375           (setq ls-lisp-filesize-f-fmt
 376                 (format " %%%d.0f"
 377                         (if (memq ?s switches)
 378                             (length (format "%.0f"
 379                                             (fceiling (/ max-file-size 1024.0))))
 380                           (length (format "%.0f" max-file-size)))))
 381           (setq files file-alist)
 382           (while files                  ; long (-l) format
 383             (setq elt (car files)
 384                   files (cdr files)
 385                   short (car elt)
 386                   attr (cdr elt)
 387                   file-size (nth 7 attr))
 388             (and attr
 389                  (setq sum (+ file-size
 390                               ;; Even if neither SUM nor file's size
 391                               ;; overflow, their sum could.
 392                               (if (or (< sum (- 134217727 file-size))
 393                                       (floatp sum)
 394                                       (floatp file-size))
 395                                   sum
 396                                 (float sum))))
 397                  (insert (ls-lisp-format short attr file-size
 398                                          switches time-index))))
 399           ;; Insert total size of all files:
 400           (save-excursion
 401             (goto-char (car total-line))
 402             (or (cdr total-line)
 403                 ;; Shell says ``No match'' if no files match
 404                 ;; the wildcard; let's say something similar.
 405                 (insert "(No match)\n"))
 406             (insert (format "total %.0f\n" (fceiling (/ sum 1024.0))))))
 407         (if (memq ?R switches)
 408             ;; List the contents of all directories recursively.
 409             ;; cadr of each element of `file-alist' is t for
 410             ;; directory, string (name linked to) for symbolic
 411             ;; link, or nil.
 412             (while file-alist
 413               (setq elt (car file-alist)
 414                     file-alist (cdr file-alist))
 415               (when (and (eq (cadr elt) t) ; directory
 416                          ;; Under -F, we have already decorated all
 417                          ;; directories, including "." and "..", with
 418                          ;; a /, so allow for that as well.
 419                          (not (string-match "\\`\\.\\.?/?\\'" (car elt))))
 420                 (setq elt (expand-file-name (car elt) dir))
 421                 (insert "\n" elt ":\n")
 422                 (ls-lisp-insert-directory
 423                  elt switches time-index wildcard-regexp full-directory-p)))))
 424     ;; If not full-directory-p, FILE *must not* end in /, as
 425     ;; file-attributes will not recognize a symlink to a directory,
 426     ;; so must make it a relative filename as ls does:
 427     (if (file-name-absolute-p file) (setq file (expand-file-name file)))
 428     (if (eq (aref file (1- (length file))) ?/)
 429         (setq file (substring file 0 -1)))
 430     (let ((fattr (file-attributes file 'string)))
 431       (if fattr
 432           (insert (ls-lisp-format
 433                    (if (memq ?F switches)
 434                        (ls-lisp-classify-file file fattr)
 435                      file)
 436                    fattr (nth 7 fattr)
 437                                   switches time-index))
 438         (message "%s: doesn't exist or is inaccessible" file)
 439         (ding) (sit-for 2)))))          ; to show user the message!
 440
 441 (defun ls-lisp-sanitize (file-alist)
 442   "Sanitize the elements in FILE-ALIST.
 443 Fixes any elements in the alist for directory entries whose file
 444 attributes are nil (meaning that `file-attributes' failed for
 445 them).  This is known to happen for some network shares, in
 446 particular for the \"..\" directory entry.
 447
 448 If the \"..\" directory entry has nil attributes, the attributes
 449 are copied from the \".\" entry, if they are non-nil.  Otherwise,
 450 the offending element is removed from the list, as are any
 451 elements for other directory entries with nil attributes."
 452   (if (and (null (cdr (assoc ".." file-alist)))
 453            (cdr (assoc "." file-alist)))
 454       (setcdr (assoc ".." file-alist) (cdr (assoc "." file-alist))))
 455   (rassq-delete-all nil file-alist))
 456
 457 (defun ls-lisp-column-format (file-alist)
 458   "Insert the file names (only) in FILE-ALIST into the current buffer.
 459 Format in columns, sorted vertically, following GNU ls -C.
 460 Responds to the window width as ls should but may not!"
 461   (let (files fmt ncols collen (nfiles 0) (colwid 0))
 462     ;; Count number of files as `nfiles', build list of filenames as
 463     ;; `files', and find maximum filename length as `colwid':
 464     (let (file len)
 465       (while file-alist
 466         (setq nfiles (1+ nfiles)
 467               file (caar file-alist)
 468               files (cons file files)
 469               file-alist (cdr file-alist)
 470               len (length file))
 471         (if (> len colwid) (setq colwid len))))
 472     (setq files (nreverse files)
 473           colwid (+ 2 colwid)           ; 2 character column gap
 474           fmt (format "%%-%ds" colwid)  ; print format
 475           ncols (/ (window-width) colwid) ; no of columns
 476           collen (/ nfiles ncols))      ; floor of column length
 477     (if (> nfiles (* collen ncols)) (setq collen (1+ collen)))
 478     ;; Output the file names in columns, sorted vertically:
 479     (let ((i 0) j)
 480       (while (< i collen)
 481         (setq j i)
 482         (while (< j nfiles)
 483           (insert (format fmt (nth j files)))
 484           (setq j (+ j collen)))
 485         ;; FJW: This is completely unnecessary, but I don't like
 486         ;; trailing white space...
 487         (delete-region (point) (progn (skip-chars-backward " \t") (point)))
 488         (insert ?\n)
 489         (setq i (1+ i))))))
 490
 491 (defun ls-lisp-delete-matching (regexp list)
 492   "Delete all elements matching REGEXP from LIST, return new list."
 493   ;; Should perhaps use setcdr for efficiency.
 494   (let (result)
 495     (while list
 496       (or (string-match regexp (caar list))
 497           (setq result (cons (car list) result)))
 498       (setq list (cdr list)))
 499     result))
 500
 501 (defsubst ls-lisp-string-lessp (s1 s2)
 502   "Return t if string S1 is less than string S2 in lexicographic order.
 503 Case is significant if `ls-lisp-ignore-case' is nil.
 504 Unibyte strings are converted to multibyte for comparison."
 505   (let ((u (compare-strings s1 0 nil s2 0 nil ls-lisp-ignore-case)))
 506     (and (numberp u) (< u 0))))
 507
 508 (defun ls-lisp-handle-switches (file-alist switches)
 509   "Return new FILE-ALIST sorted according to SWITCHES.
 510 SWITCHES is a list of characters.  Default sorting is alphabetic."
 511   ;; FILE-ALIST's elements are (FILE . FILE-ATTRIBUTES).
 512   (or (memq ?U switches)                ; unsorted
 513       ;; Catch and ignore unexpected sorting errors
 514       (condition-case err
 515           (setq file-alist
 516                 (let (index)
 517                   ;; Copy file-alist in case of error
 518                   (sort (copy-sequence file-alist) ; modifies its argument!
 519                         (cond ((memq ?S switches)
 520                                (lambda (x y) ; sorted on size
 521                                  ;; 7th file attribute is file size
 522                                  ;; Make largest file come first
 523                                  (< (nth 7 (cdr y))
 524                                     (nth 7 (cdr x)))))
 525                               ((setq index (ls-lisp-time-index switches))
 526                                (lambda (x y) ; sorted on time
 527                                  (time-less-p (nth index (cdr y))
 528                                               (nth index (cdr x)))))
 529                               ((memq ?X switches)
 530                                (lambda (x y) ; sorted on extension
 531                                  (ls-lisp-string-lessp
 532                                   (ls-lisp-extension (car x))
 533                                   (ls-lisp-extension (car y)))))
 534                               (t
 535                                (lambda (x y) ; sorted alphabetically
 536                                  (ls-lisp-string-lessp (car x) (car y))))))))
 537         (error (message "Unsorted (ls-lisp sorting error) - %s"
 538                         (error-message-string err))
 539                (ding) (sit-for 2))))    ; to show user the message!
 540   (if (memq ?F switches)                ; classify switch
 541       (setq file-alist (mapcar 'ls-lisp-classify file-alist)))
 542   (if ls-lisp-dirs-first
 543   ;; Re-sort directories first, without otherwise changing the
 544   ;; ordering, and reverse whole list.  cadr of each element of
 545   ;; `file-alist' is t for directory, string (name linked to) for
 546   ;; symbolic link, or nil.
 547       (let (el dirs files)
 548         (while file-alist
 549           (if (or (eq (cadr (setq el (car file-alist))) t) ; directory
 550                   (and (stringp (cadr el))
 551                        (file-directory-p (cadr el)))) ; symlink to a directory
 552               (setq dirs (cons el dirs))
 553             (setq files (cons el files)))
 554           (setq file-alist (cdr file-alist)))
 555         (setq file-alist
 556               (if (memq ?U switches)    ; unsorted order is reversed
 557                   (nconc dirs files)
 558                 (nconc files dirs)
 559                 ))))
 560   ;; Finally reverse file alist if necessary.
 561   ;; (eq below MUST compare `(not (memq ...))' to force comparison of
 562   ;; `t' or `nil', rather than list tails!)
 563   (if (eq (eq (not (memq ?U switches))  ; unsorted order is reversed
 564               (not (memq ?r switches))) ; reversed sort order requested
 565           ls-lisp-dirs-first)           ; already reversed
 566       (nreverse file-alist)
 567     file-alist))
 568
 569 (defun ls-lisp-classify-file (filename fattr)
 570   "Append a character to FILENAME indicating the file type.
 571
 572 FATTR is the file attributes returned by `file-attributes' for the file.
 573 The file type indicators are `/' for directories, `@' for symbolic
 574 links, `|' for FIFOs, `=' for sockets, `*' for regular files that
 575 are executable, and nothing for other types of files."
 576   (let* ((type (car fattr))
 577          (modestr (nth 8 fattr))
 578          (typestr (substring modestr 0 1)))
 579     (cond
 580      (type
 581       (concat filename (if (eq type t) "/" "@")))
 582      ((string-match "x" modestr)
 583       (concat filename "*"))
 584      ((string= "p" typestr)
 585       (concat filename "|"))
 586      ((string= "s" typestr)
 587       (concat filename "="))
 588      (t filename))))
 589
 590 (defun ls-lisp-classify (filedata)
 591   "Append a character to file name in FILEDATA indicating the file type.
 592
 593 FILEDATA has the form (FILENAME . ATTRIBUTES), where ATTRIBUTES is the
 594 structure returned by `file-attributes' for that file.
 595
 596 The file type indicators are `/' for directories, `@' for symbolic
 597 links, `|' for FIFOs, `=' for sockets, `*' for regular files that
 598 are executable, and nothing for other types of files."
 599   (let ((file-name (car filedata))
 600         (fattr (cdr filedata)))
 601     (setq file-name (propertize file-name 'dired-filename t))
 602     (cons (ls-lisp-classify-file file-name fattr) fattr)))
 603
 604 (defun ls-lisp-extension (filename)
 605   "Return extension of FILENAME (ignoring any version extension)
 606 FOLLOWED by null and full filename, SOLELY for full alpha sort."
 607   ;; Force extension sort order: `no ext' then `null ext' then `ext'
 608   ;; to agree with GNU ls.
 609   (concat
 610    (let* ((i (length filename)) end)
 611      (if (= (aref filename (1- i)) ?.) ; null extension
 612          "\0"
 613        (while (and (>= (setq i (1- i)) 0)
 614                    (/= (aref filename i) ?.)))
 615        (if (< i 0) "\0\0"               ; no extension
 616          (if (/= (aref filename (1+ i)) ?~)
 617              (substring filename (1+ i))
 618            ;; version extension found -- ignore it
 619            (setq end i)
 620            (while (and (>= (setq i (1- i)) 0)
 621                        (/= (aref filename i) ?.)))
 622            (if (< i 0) "\0\0"   ; no extension
 623              (substring filename (1+ i) end))))
 624        )) "\0" filename))
 625
 626 (defun ls-lisp-format (file-name file-attr file-size switches time-index)
 627   "Format one line of long ls output for file FILE-NAME.
 628 FILE-ATTR and FILE-SIZE give the file's attributes and size.
 629 SWITCHES and TIME-INDEX give the full switch list and time data."
 630   (let ((file-type (nth 0 file-attr))
 631         ;; t for directory, string (name linked to)
 632         ;; for symbolic link, or nil.
 633         (drwxrwxrwx (nth 8 file-attr))) ; attribute string ("drwxrwxrwx")
 634     (concat (if (memq ?i switches)      ; inode number
 635                 (let ((inode (nth 10 file-attr)))
 636                   (if (consp inode)
 637                       (if (consp (cdr inode))
 638                           ;; 2^(24+16) = 1099511627776.0, but
 639                           ;; multiplying by it and then adding the
 640                           ;; other members of the cons cell in one go
 641                           ;; loses precision, since a double does not
 642                           ;; have enough significant digits to hold a
 643                           ;; full 64-bit value.  So below we split
 644                           ;; 1099511627776 into high 13 and low 5
 645                           ;; digits and compute in two parts.
 646                           (let ((p1 (* (car inode) 10995116.0))
 647                                 (p2 (+ (* (car inode) 27776.0)
 648                                        (* (cadr inode) 65536.0)
 649                                        (cddr inode))))
 650                             (format " %13.0f%05.0f "
 651                                     ;; Use floor to emulate integer
 652                                     ;; division.
 653                                     (+ p1 (floor p2 100000.0))
 654                                     (mod p2 100000.0)))
 655                         (format " %18.0f "
 656                                 (+ (* (car inode) 65536.0)
 657                                    (cdr inode))))
 658                     (format " %18d " inode))))
 659             ;; nil is treated like "" in concat
 660             (if (memq ?s switches)      ; size in K
 661                 (format ls-lisp-filesize-f-fmt
 662                         (fceiling (/ file-size 1024.0))))
 663             drwxrwxrwx                  ; attribute string
 664             (if (memq 'links ls-lisp-verbosity)
 665                 (format "%3d" (nth 1 file-attr))) ; link count
 666             ;; Numeric uid/gid are more confusing than helpful;
 667             ;; Emacs should be able to make strings of them.
 668             ;; They tend to be bogus on non-UNIX platforms anyway so
 669             ;; optionally hide them.
 670             (if (memq 'uid ls-lisp-verbosity)
 671                 ;; uid can be a string or an integer
 672                 (let ((uid (nth 2 file-attr)))
 673                   (format (if (stringp uid)
 674                               ls-lisp-uid-s-fmt
 675                             ls-lisp-uid-d-fmt)
 676                           uid)))
 677             (if (not (memq ?G switches)) ; GNU ls -- shows group by default
 678                 (if (or (memq ?g switches) ; UNIX ls -- no group by default
 679                         (memq 'gid ls-lisp-verbosity))
 680                     (let ((gid (nth 3 file-attr)))
 681                       (format (if (stringp gid)
 682                                   ls-lisp-gid-s-fmt
 683                                 ls-lisp-gid-d-fmt)
 684                               gid))))
 685             (ls-lisp-format-file-size file-size (memq ?h switches))
 686             " "
 687             (ls-lisp-format-time file-attr time-index)
 688             " "
 689             (if (not (memq ?F switches)) ; ls-lisp-classify already did that
 690                 (propertize file-name 'dired-filename t)
 691               file-name)
 692             (if (stringp file-type)     ; is a symbolic link
 693                 (concat " -> " file-type))
 694             "\n"
 695             )))
 696
 697 (defun ls-lisp-time-index (switches)
 698   "Return time index into file-attributes according to ls SWITCHES list.
 699 Return nil if no time switch found."
 700   ;; FJW: Default of nil is IMPORTANT and used in `ls-lisp-handle-switches'!
 701   (cond ((memq ?c switches) 6)          ; last mode change
 702         ((memq ?t switches) 5)          ; last modtime
 703         ((memq ?u switches) 4)))        ; last access
 704
 705 (defun ls-lisp-format-time (file-attr time-index)
 706   "Format time for file with attributes FILE-ATTR according to TIME-INDEX.
 707 Use the same method as ls to decide whether to show time-of-day or year,
 708 depending on distance between file date and the current time.
 709 All ls time options, namely c, t and u, are handled."
 710   (let* ((time (nth (or time-index 5) file-attr)) ; default is last modtime
 711          (diff (- (float-time time) (float-time)))
 712          ;; Consider a time to be recent if it is within the past six
 713          ;; months.  A Gregorian year has 365.2425 * 24 * 60 * 60 ==
 714          ;; 31556952 seconds on the average, and half of that is 15778476.
 715          ;; Write the constant explicitly to avoid roundoff error.
 716          (past-cutoff -15778476)) ; half a Gregorian year
 717     (condition-case nil
 718         ;; Use traditional time format in the C or POSIX locale,
 719         ;; ISO-style time format otherwise, so columns line up.
 720         (let ((locale system-time-locale))
 721           (if (not locale)
 722               (let ((vars '("LC_ALL" "LC_TIME" "LANG")))
 723                 (while (and vars (not (setq locale (getenv (car vars)))))
 724                   (setq vars (cdr vars)))))
 725           (if (member locale '("C" "POSIX"))
 726               (setq locale nil))
 727           (format-time-string
 728            (if (and (<= past-cutoff diff) (<= diff 0))
 729                (if (and locale (not ls-lisp-use-localized-time-format))
 730                    "%m-%d %H:%M"
 731                  (nth 0 ls-lisp-format-time-list))
 732              (if (and locale (not ls-lisp-use-localized-time-format))
 733                  "%Y-%m-%d "
 734                (nth 1 ls-lisp-format-time-list)))
 735            time))
 736       (error "Unk  0  0000"))))
 737
 738 (defun ls-lisp-format-file-size (file-size human-readable)
 739   (if (not human-readable)
 740       (format (if (floatp file-size)
 741                   ls-lisp-filesize-f-fmt
 742                 ls-lisp-filesize-d-fmt)
 743               file-size)
 744     (format " %7s" (file-size-human-readable file-size))))
 745
 746 (provide 'ls-lisp)
 747
 748 ;;; ls-lisp.el ends here