lisp/ls-lisp.el

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