lisp/ls-lisp.el

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