| 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: 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 | (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 |