| 1 | ;;; ls-lisp.el --- emulate insert-directory completely in Emacs Lisp |
| 2 | |
| 3 | ;; Copyright (C) 1992, 1994, 2000, 2002, 2003, 2004, |
| 4 | ;; 2005, 2006 Free Software Foundation, Inc. |
| 5 | |
| 6 | ;; Author: Sebastian Kremer <sk@thp.uni-koeln.de> |
| 7 | ;; Modified by: Francis J. Wright <F.J.Wright@maths.qmw.ac.uk> |
| 8 | ;; Maintainer: FSF |
| 9 | ;; Keywords: unix, dired |
| 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 2, or (at your option) |
| 16 | ;; 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; see the file COPYING. If not, write to the |
| 25 | ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
| 26 | ;; Boston, MA 02110-1301, USA. |
| 27 | |
| 28 | ;;; Commentary: |
| 29 | |
| 30 | ;; OVERVIEW ========================================================== |
| 31 | |
| 32 | ;; This file redefines the function `insert-directory' to implement it |
| 33 | ;; directly from Emacs lisp, without running ls in a subprocess. It |
| 34 | ;; is useful if you cannot afford to fork Emacs on a real memory UNIX, |
| 35 | ;; under VMS or other non-UNIX platforms if you don't have the ls |
| 36 | ;; program, or if you want a different format from what ls offers. |
| 37 | |
| 38 | ;; This function can use regexps instead of shell wildcards. If you |
| 39 | ;; enter regexps remember to double each $ sign. For example, to |
| 40 | ;; include files *.el, enter `.*\.el$$', resulting in the regexp |
| 41 | ;; `.*\.el$'. |
| 42 | |
| 43 | ;; RESTRICTIONS ====================================================== |
| 44 | |
| 45 | ;; * A few obscure ls switches are still ignored: see the docstring of |
| 46 | ;; `insert-directory'. |
| 47 | |
| 48 | ;; TO DO ============================================================= |
| 49 | |
| 50 | ;; Complete handling of F switch (if/when possible). |
| 51 | |
| 52 | ;; FJW: May be able to sort much faster by consing the sort key onto |
| 53 | ;; the front of each list element, sorting and then stripping the key |
| 54 | ;; off again! |
| 55 | |
| 56 | ;;; History: |
| 57 | |
| 58 | ;; Written originally by Sebastian Kremer <sk@thp.uni-koeln.de> |
| 59 | ;; Revised by Andrew Innes and Geoff Volker (and maybe others). |
| 60 | |
| 61 | ;; Modified by Francis J. Wright <F.J.Wright@maths.qmw.ac.uk>, mainly |
| 62 | ;; to support many more ls options, "platform emulation" and more |
| 63 | ;; robust sorting. |
| 64 | |
| 65 | ;;; Code: |
| 66 | |
| 67 | (eval-when-compile (require 'cl)) |
| 68 | |
| 69 | (defgroup ls-lisp nil |
| 70 | "Emulate the ls program completely in Emacs Lisp." |
| 71 | :version "21.1" |
| 72 | :group 'dired) |
| 73 | |
| 74 | (defcustom ls-lisp-emulation |
| 75 | (cond ((eq system-type 'macos) 'MacOS) |
| 76 | ;; ((eq system-type 'windows-nt) 'MS-Windows) |
| 77 | ((memq system-type |
| 78 | '(hpux dgux usg-unix-v unisoft-unix rtu irix 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 the atoms: nil, MacOS, MS-Windows, UNIX. |
| 83 | Sets default values for: `ls-lisp-ignore-case', `ls-lisp-dirs-first', |
| 84 | `ls-lisp-verbosity'. Need not match actual platform. Changing this |
| 85 | option will have no effect until you restart Emacs." |
| 86 | :type '(choice (const :tag "GNU" nil) |
| 87 | (const MacOS) |
| 88 | (const MS-Windows) |
| 89 | (const UNIX)) |
| 90 | :group 'ls-lisp) |
| 91 | |
| 92 | (defcustom ls-lisp-ignore-case |
| 93 | ;; Name change for consistency with other option names. |
| 94 | (or (memq ls-lisp-emulation '(MS-Windows MacOS)) |
| 95 | (and (boundp 'ls-lisp-dired-ignore-case) ls-lisp-dired-ignore-case)) |
| 96 | "*Non-nil causes ls-lisp alphabetic sorting to ignore case." |
| 97 | :type 'boolean |
| 98 | :group 'ls-lisp) |
| 99 | |
| 100 | (defcustom ls-lisp-dirs-first (eq ls-lisp-emulation 'MS-Windows) |
| 101 | "*Non-nil causes ls-lisp to sort directories first in any ordering. |
| 102 | \(Or last if it is reversed.) Follows Microsoft Windows Explorer." |
| 103 | ;; Functionality suggested by Chris McMahan <cmcmahan@one.net> |
| 104 | :type 'boolean |
| 105 | :group 'ls-lisp) |
| 106 | |
| 107 | (defcustom ls-lisp-verbosity |
| 108 | (cond ((eq ls-lisp-emulation 'MacOS) nil) |
| 109 | ((eq ls-lisp-emulation 'MS-Windows) |
| 110 | (if (and (fboundp 'w32-using-nt) (w32-using-nt)) |
| 111 | '(links))) ; distinguish NT/2K from 9x |
| 112 | ((eq ls-lisp-emulation 'UNIX) '(links uid)) ; UNIX ls |
| 113 | (t '(links uid gid))) ; GNU ls |
| 114 | "*A list of optional file attributes that ls-lisp should display. |
| 115 | It should contain none or more of the symbols: links, uid, gid. |
| 116 | nil (or an empty list) means display none of them. |
| 117 | |
| 118 | Concepts come from UNIX: `links' means count of names associated with |
| 119 | the file\; `uid' means user (owner) identifier\; `gid' means group |
| 120 | identifier. |
| 121 | |
| 122 | If emulation is MacOS then default is nil\; |
| 123 | if emulation is MS-Windows then default is `(links)' if platform is |
| 124 | Windows NT/2K, nil otherwise\; |
| 125 | if emulation is UNIX then default is `(links uid)'\; |
| 126 | if emulation is GNU then default is `(links uid gid)'." |
| 127 | ;; Functionality suggested by Howard Melman <howard@silverstream.com> |
| 128 | :type '(set (const :tag "Show Link Count" links) |
| 129 | (const :tag "Show User" uid) |
| 130 | (const :tag "Show Group" gid)) |
| 131 | :group 'ls-lisp) |
| 132 | |
| 133 | (defcustom ls-lisp-use-insert-directory-program |
| 134 | (not (memq system-type '(macos ms-dos windows-nt))) |
| 135 | "*Non-nil causes ls-lisp to revert back to using `insert-directory-program'. |
| 136 | This is useful on platforms where ls-lisp is dumped into Emacs, such as |
| 137 | Microsoft Windows, but you would still like to use a program to list |
| 138 | the contents of a directory." |
| 139 | :type 'boolean |
| 140 | :group 'ls-lisp) |
| 141 | |
| 142 | ;;; Autoloaded because it is let-bound in `recover-session', `mail-recover-1'. |
| 143 | ;;;###autoload |
| 144 | (defcustom ls-lisp-support-shell-wildcards t |
| 145 | "*Non-nil means ls-lisp treats file patterns as shell wildcards. |
| 146 | Otherwise they are treated as Emacs regexps (for backward compatibility)." |
| 147 | :type 'boolean |
| 148 | :group 'ls-lisp) |
| 149 | |
| 150 | (defcustom ls-lisp-format-time-list |
| 151 | '("%b %e %H:%M" |
| 152 | "%b %e %Y") |
| 153 | "*List of `format-time-string' specs to display file time stamps. |
| 154 | They are used whenever a locale is not specified to use instead. |
| 155 | |
| 156 | Syntax: (EARLY-TIME-FORMAT OLD-TIME-FORMAT) |
| 157 | |
| 158 | The EARLY-TIME-FORMAT is used if file has been modified within the |
| 159 | current year. The OLD-TIME-FORMAT is used for older files. To use ISO |
| 160 | 8601 dates, you could set: |
| 161 | |
| 162 | \(setq ls-lisp-format-time-list |
| 163 | '(\"%Y-%m-%d %H:%M\" |
| 164 | \"%Y-%m-%d \"))" |
| 165 | :type '(list (string :tag "Early time format") |
| 166 | (string :tag "Old time format")) |
| 167 | :group 'ls-lisp) |
| 168 | |
| 169 | (defvar original-insert-directory nil |
| 170 | "This holds the original function definition of `insert-directory'.") |
| 171 | |
| 172 | ;; Remember the original insert-directory function |
| 173 | (or (featurep 'ls-lisp) ; FJW: unless this file is being reloaded! |
| 174 | (setq original-insert-directory (symbol-function 'insert-directory))) |
| 175 | |
| 176 | \f |
| 177 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 178 | |
| 179 | (defun insert-directory (file switches &optional wildcard full-directory-p) |
| 180 | "Insert directory listing for FILE, formatted according to SWITCHES. |
| 181 | Leaves point after the inserted text. |
| 182 | SWITCHES may be a string of options, or a list of strings. |
| 183 | Optional third arg WILDCARD means treat FILE as shell wildcard. |
| 184 | Optional fourth arg FULL-DIRECTORY-P means file is a directory and |
| 185 | switches do not contain `d', so that a full listing is expected. |
| 186 | |
| 187 | This version of the function comes from `ls-lisp.el'. |
| 188 | If the value of `ls-lisp-use-insert-directory-program' is non-nil then |
| 189 | it works exactly like the version from `files.el' and runs a directory |
| 190 | listing program whose name is in the variable |
| 191 | `insert-directory-program'; if also WILDCARD is non-nil then it runs |
| 192 | the shell specified by `shell-file-name'. If the value of |
| 193 | `ls-lisp-use-insert-directory-program' is nil then it runs a Lisp |
| 194 | emulation. |
| 195 | |
| 196 | The Lisp emulation does not run any external programs or shells. It |
| 197 | supports ordinary shell wildcards if `ls-lisp-support-shell-wildcards' |
| 198 | is non-nil; otherwise, it interprets wildcards as regular expressions |
| 199 | to match file names. It does not support all `ls' switches -- those |
| 200 | that work are: A a c i r S s t u U X g G B C R and F partly." |
| 201 | (if ls-lisp-use-insert-directory-program |
| 202 | (funcall original-insert-directory |
| 203 | file switches wildcard full-directory-p) |
| 204 | ;; We need the directory in order to find the right handler. |
| 205 | (let ((handler (find-file-name-handler (expand-file-name file) |
| 206 | 'insert-directory)) |
| 207 | wildcard-regexp) |
| 208 | (if handler |
| 209 | (funcall handler 'insert-directory file switches |
| 210 | wildcard full-directory-p) |
| 211 | ;; Remove --dired switch |
| 212 | (if (string-match "--dired " switches) |
| 213 | (setq switches (replace-match "" nil nil switches))) |
| 214 | ;; Convert SWITCHES to a list of characters. |
| 215 | (setq switches (delete ?- (append switches nil))) |
| 216 | ;; Sometimes we get ".../foo*/" as FILE. While the shell and |
| 217 | ;; `ls' don't mind, we certainly do, because it makes us think |
| 218 | ;; there is no wildcard, only a directory name. |
| 219 | (if (and ls-lisp-support-shell-wildcards |
| 220 | (string-match "[[?*]" file)) |
| 221 | (progn |
| 222 | (or (not (eq (aref file (1- (length file))) ?/)) |
| 223 | (setq file (substring file 0 (1- (length file))))) |
| 224 | (setq wildcard t))) |
| 225 | (if wildcard |
| 226 | (setq wildcard-regexp |
| 227 | (if ls-lisp-support-shell-wildcards |
| 228 | (wildcard-to-regexp (file-name-nondirectory file)) |
| 229 | (file-name-nondirectory file)) |
| 230 | file (file-name-directory file)) |
| 231 | (if (memq ?B switches) (setq wildcard-regexp "[^~]\\'"))) |
| 232 | (ls-lisp-insert-directory |
| 233 | file switches (ls-lisp-time-index switches) |
| 234 | wildcard-regexp full-directory-p) |
| 235 | ;; Try to insert the amount of free space. |
| 236 | (save-excursion |
| 237 | (goto-char (point-min)) |
| 238 | ;; First find the line to put it on. |
| 239 | (when (re-search-forward "^total" nil t) |
| 240 | (let ((available (get-free-disk-space "."))) |
| 241 | (when available |
| 242 | ;; Replace "total" with "total used", to avoid confusion. |
| 243 | (replace-match "total used in directory") |
| 244 | (end-of-line) |
| 245 | (insert " available " available))))))))) |
| 246 | |
| 247 | (defun ls-lisp-insert-directory |
| 248 | (file switches time-index wildcard-regexp full-directory-p) |
| 249 | "Insert directory listing for FILE, formatted according to SWITCHES. |
| 250 | Leaves point after the inserted text. This is an internal function |
| 251 | optionally called by the `ls-lisp.el' version of `insert-directory'. |
| 252 | It is called recursively if the -R switch is used. |
| 253 | SWITCHES is a *list* of characters. TIME-INDEX is the time index into |
| 254 | file-attributes according to SWITCHES. WILDCARD-REGEXP is nil or an *Emacs |
| 255 | regexp*. FULL-DIRECTORY-P means file is a directory and SWITCHES does |
| 256 | not contain `d', so that a full listing is expected." |
| 257 | (if (or wildcard-regexp full-directory-p) |
| 258 | (let* ((dir (file-name-as-directory file)) |
| 259 | (default-directory dir) ; so that file-attributes works |
| 260 | (file-alist |
| 261 | (directory-files-and-attributes dir nil wildcard-regexp t 'string)) |
| 262 | (now (current-time)) |
| 263 | (sum 0) |
| 264 | ;; do all bindings here for speed |
| 265 | total-line files elt short file-size fil attr) |
| 266 | (cond ((memq ?A switches) |
| 267 | (setq file-alist |
| 268 | (ls-lisp-delete-matching "^\\.\\.?$" file-alist))) |
| 269 | ((not (memq ?a switches)) |
| 270 | ;; if neither -A nor -a, flush . files |
| 271 | (setq file-alist |
| 272 | (ls-lisp-delete-matching "^\\." file-alist)))) |
| 273 | (setq file-alist |
| 274 | (ls-lisp-handle-switches file-alist switches)) |
| 275 | (if (memq ?C switches) ; column (-C) format |
| 276 | (ls-lisp-column-format file-alist) |
| 277 | (setq total-line (cons (point) (car-safe file-alist))) |
| 278 | (setq files file-alist) |
| 279 | (while files ; long (-l) format |
| 280 | (setq elt (car files) |
| 281 | files (cdr files) |
| 282 | short (car elt) |
| 283 | attr (cdr elt) |
| 284 | file-size (nth 7 attr)) |
| 285 | (and attr |
| 286 | (setq sum (+ file-size |
| 287 | ;; Even if neither SUM nor file's size |
| 288 | ;; overflow, their sum could. |
| 289 | (if (or (< sum (- 134217727 file-size)) |
| 290 | (floatp sum) |
| 291 | (floatp file-size)) |
| 292 | sum |
| 293 | (float sum)))) |
| 294 | (insert (ls-lisp-format short attr file-size |
| 295 | switches time-index now)))) |
| 296 | ;; Insert total size of all files: |
| 297 | (save-excursion |
| 298 | (goto-char (car total-line)) |
| 299 | (or (cdr total-line) |
| 300 | ;; Shell says ``No match'' if no files match |
| 301 | ;; the wildcard; let's say something similar. |
| 302 | (insert "(No match)\n")) |
| 303 | (insert (format "total %.0f\n" (fceiling (/ sum 1024.0)))))) |
| 304 | (if (memq ?R switches) |
| 305 | ;; List the contents of all directories recursively. |
| 306 | ;; cadr of each element of `file-alist' is t for |
| 307 | ;; directory, string (name linked to) for symbolic |
| 308 | ;; link, or nil. |
| 309 | (while file-alist |
| 310 | (setq elt (car file-alist) |
| 311 | file-alist (cdr file-alist)) |
| 312 | (when (and (eq (cadr elt) t) ; directory |
| 313 | (not (string-match "\\`\\.\\.?\\'" (car elt)))) |
| 314 | (setq elt (expand-file-name (car elt) dir)) |
| 315 | (insert "\n" elt ":\n") |
| 316 | (ls-lisp-insert-directory |
| 317 | elt switches time-index wildcard-regexp full-directory-p))))) |
| 318 | ;; If not full-directory-p, FILE *must not* end in /, as |
| 319 | ;; file-attributes will not recognize a symlink to a directory, |
| 320 | ;; so must make it a relative filename as ls does: |
| 321 | (if (eq (aref file (1- (length file))) ?/) |
| 322 | (setq file (substring file 0 -1))) |
| 323 | (let ((fattr (file-attributes file 'string))) |
| 324 | (if fattr |
| 325 | (insert (ls-lisp-format file fattr (nth 7 fattr) |
| 326 | switches time-index (current-time))) |
| 327 | (message "%s: doesn't exist or is inaccessible" file) |
| 328 | (ding) (sit-for 2))))) ; to show user the message! |
| 329 | |
| 330 | (defun ls-lisp-column-format (file-alist) |
| 331 | "Insert the file names (only) in FILE-ALIST into the current buffer. |
| 332 | Format in columns, sorted vertically, following GNU ls -C. |
| 333 | Responds to the window width as ls should but may not!" |
| 334 | (let (files fmt ncols collen (nfiles 0) (colwid 0)) |
| 335 | ;; Count number of files as `nfiles', build list of filenames as |
| 336 | ;; `files', and find maximum filename length as `colwid': |
| 337 | (let (file len) |
| 338 | (while file-alist |
| 339 | (setq nfiles (1+ nfiles) |
| 340 | file (caar file-alist) |
| 341 | files (cons file files) |
| 342 | file-alist (cdr file-alist) |
| 343 | len (length file)) |
| 344 | (if (> len colwid) (setq colwid len)))) |
| 345 | (setq files (nreverse files) |
| 346 | colwid (+ 2 colwid) ; 2 character column gap |
| 347 | fmt (format "%%-%ds" colwid) ; print format |
| 348 | ncols (/ (window-width) colwid) ; no of columns |
| 349 | collen (/ nfiles ncols)) ; floor of column length |
| 350 | (if (> nfiles (* collen ncols)) (setq collen (1+ collen))) |
| 351 | ;; Output the file names in columns, sorted vertically: |
| 352 | (let ((i 0) j) |
| 353 | (while (< i collen) |
| 354 | (setq j i) |
| 355 | (while (< j nfiles) |
| 356 | (insert (format fmt (nth j files))) |
| 357 | (setq j (+ j collen))) |
| 358 | ;; FJW: This is completely unnecessary, but I don't like |
| 359 | ;; trailing white space... |
| 360 | (delete-region (point) (progn (skip-chars-backward " \t") (point))) |
| 361 | (insert ?\n) |
| 362 | (setq i (1+ i)))))) |
| 363 | |
| 364 | (defun ls-lisp-delete-matching (regexp list) |
| 365 | "Delete all elements matching REGEXP from LIST, return new list." |
| 366 | ;; Should perhaps use setcdr for efficiency. |
| 367 | (let (result) |
| 368 | (while list |
| 369 | (or (string-match regexp (caar list)) |
| 370 | (setq result (cons (car list) result))) |
| 371 | (setq list (cdr list))) |
| 372 | result)) |
| 373 | |
| 374 | (defsubst ls-lisp-string-lessp (s1 s2) |
| 375 | "Return t if string S1 is less than string S2 in lexicographic order. |
| 376 | Case is significant if `ls-lisp-ignore-case' is nil. |
| 377 | Unibyte strings are converted to multibyte for comparison." |
| 378 | (let ((u (compare-strings s1 0 nil s2 0 nil ls-lisp-ignore-case))) |
| 379 | (and (numberp u) (< u 0)))) |
| 380 | |
| 381 | (defun ls-lisp-handle-switches (file-alist switches) |
| 382 | "Return new FILE-ALIST sorted according to SWITCHES. |
| 383 | SWITCHES is a list of characters. Default sorting is alphabetic." |
| 384 | ;; FILE-ALIST's elements are (FILE . FILE-ATTRIBUTES). |
| 385 | (or (memq ?U switches) ; unsorted |
| 386 | ;; Catch and ignore unexpected sorting errors |
| 387 | (condition-case err |
| 388 | (setq file-alist |
| 389 | (let (index) |
| 390 | ;; Copy file-alist in case of error |
| 391 | (sort (copy-sequence file-alist) ; modifies its argument! |
| 392 | (cond ((memq ?S switches) |
| 393 | (lambda (x y) ; sorted on size |
| 394 | ;; 7th file attribute is file size |
| 395 | ;; Make largest file come first |
| 396 | (< (nth 7 (cdr y)) |
| 397 | (nth 7 (cdr x))))) |
| 398 | ((setq index (ls-lisp-time-index switches)) |
| 399 | (lambda (x y) ; sorted on time |
| 400 | (ls-lisp-time-lessp (nth index (cdr y)) |
| 401 | (nth index (cdr x))))) |
| 402 | ((memq ?X switches) |
| 403 | (lambda (x y) ; sorted on extension |
| 404 | (ls-lisp-string-lessp |
| 405 | (ls-lisp-extension (car x)) |
| 406 | (ls-lisp-extension (car y))))) |
| 407 | (t |
| 408 | (lambda (x y) ; sorted alphabetically |
| 409 | (ls-lisp-string-lessp (car x) (car y)))))))) |
| 410 | (error (message "Unsorted (ls-lisp sorting error) - %s" |
| 411 | (error-message-string err)) |
| 412 | (ding) (sit-for 2)))) ; to show user the message! |
| 413 | (if (memq ?F switches) ; classify switch |
| 414 | (setq file-alist (mapcar 'ls-lisp-classify file-alist))) |
| 415 | (if ls-lisp-dirs-first |
| 416 | ;; Re-sort directories first, without otherwise changing the |
| 417 | ;; ordering, and reverse whole list. cadr of each element of |
| 418 | ;; `file-alist' is t for directory, string (name linked to) for |
| 419 | ;; symbolic link, or nil. |
| 420 | (let (el dirs files) |
| 421 | (while file-alist |
| 422 | (if (or (eq (cadr (setq el (car file-alist))) t) ; directory |
| 423 | (and (stringp (cadr el)) |
| 424 | (file-directory-p (cadr el)))) ; symlink to a directory |
| 425 | (setq dirs (cons el dirs)) |
| 426 | (setq files (cons el files))) |
| 427 | (setq file-alist (cdr file-alist))) |
| 428 | (setq file-alist |
| 429 | (if (memq ?U switches) ; unsorted order is reversed |
| 430 | (nconc dirs files) |
| 431 | (nconc files dirs) |
| 432 | )))) |
| 433 | ;; Finally reverse file alist if necessary. |
| 434 | ;; (eq below MUST compare `(not (memq ...))' to force comparison of |
| 435 | ;; `t' or `nil', rather than list tails!) |
| 436 | (if (eq (eq (not (memq ?U switches)) ; unsorted order is reversed |
| 437 | (not (memq ?r switches))) ; reversed sort order requested |
| 438 | ls-lisp-dirs-first) ; already reversed |
| 439 | (nreverse file-alist) |
| 440 | file-alist)) |
| 441 | |
| 442 | (defun ls-lisp-classify (filedata) |
| 443 | "Append a character to each file name indicating the file type. |
| 444 | Also, for regular files that are executable, append `*'. |
| 445 | The file type indicators are `/' for directories, `@' for symbolic |
| 446 | links, `|' for FIFOs, `=' for sockets, and nothing for regular files. |
| 447 | \[But FIFOs and sockets are not recognized.] |
| 448 | FILEDATA has the form (filename . `file-attributes'). Its `cadr' is t |
| 449 | for directory, string (name linked to) for symbolic link, or nil." |
| 450 | (let ((file-name (car filedata)) |
| 451 | (type (cadr filedata))) |
| 452 | (cond (type |
| 453 | (cons |
| 454 | (concat file-name (if (eq type t) "/" "@")) |
| 455 | (cdr filedata))) |
| 456 | ((string-match "x" (nth 9 filedata)) |
| 457 | (cons |
| 458 | (concat file-name "*") |
| 459 | (cdr filedata))) |
| 460 | (t filedata)))) |
| 461 | |
| 462 | (defun ls-lisp-extension (filename) |
| 463 | "Return extension of FILENAME (ignoring any version extension) |
| 464 | FOLLOWED by null and full filename, SOLELY for full alpha sort." |
| 465 | ;; Force extension sort order: `no ext' then `null ext' then `ext' |
| 466 | ;; to agree with GNU ls. |
| 467 | (concat |
| 468 | (let* ((i (length filename)) end) |
| 469 | (if (= (aref filename (1- i)) ?.) ; null extension |
| 470 | "\0" |
| 471 | (while (and (>= (setq i (1- i)) 0) |
| 472 | (/= (aref filename i) ?.))) |
| 473 | (if (< i 0) "\0\0" ; no extension |
| 474 | (if (/= (aref filename (1+ i)) ?~) |
| 475 | (substring filename (1+ i)) |
| 476 | ;; version extension found -- ignore it |
| 477 | (setq end i) |
| 478 | (while (and (>= (setq i (1- i)) 0) |
| 479 | (/= (aref filename i) ?.))) |
| 480 | (if (< i 0) "\0\0" ; no extension |
| 481 | (substring filename (1+ i) end)))) |
| 482 | )) "\0" filename)) |
| 483 | |
| 484 | ;; From Roland McGrath. Can use this to sort on time. |
| 485 | (defun ls-lisp-time-lessp (time0 time1) |
| 486 | "Return t if time TIME0 is earlier than time TIME1." |
| 487 | (let ((hi0 (car time0)) (hi1 (car time1))) |
| 488 | (or (< hi0 hi1) |
| 489 | (and (= hi0 hi1) |
| 490 | (< (cadr time0) (cadr time1)))))) |
| 491 | |
| 492 | (defun ls-lisp-format (file-name file-attr file-size switches time-index now) |
| 493 | "Format one line of long ls output for file FILE-NAME. |
| 494 | FILE-ATTR and FILE-SIZE give the file's attributes and size. |
| 495 | SWITCHES, TIME-INDEX and NOW give the full switch list and time data." |
| 496 | (let ((file-type (nth 0 file-attr)) |
| 497 | ;; t for directory, string (name linked to) |
| 498 | ;; for symbolic link, or nil. |
| 499 | (drwxrwxrwx (nth 8 file-attr))) ; attribute string ("drwxrwxrwx") |
| 500 | (concat (if (memq ?i switches) ; inode number |
| 501 | (format " %6d" (nth 10 file-attr))) |
| 502 | ;; nil is treated like "" in concat |
| 503 | (if (memq ?s switches) ; size in K |
| 504 | (format " %4.0f" (fceiling (/ file-size 1024.0)))) |
| 505 | drwxrwxrwx ; attribute string |
| 506 | (if (memq 'links ls-lisp-verbosity) |
| 507 | (format " %3d" (nth 1 file-attr))) ; link count |
| 508 | ;; Numeric uid/gid are more confusing than helpful; |
| 509 | ;; Emacs should be able to make strings of them. |
| 510 | ;; They tend to be bogus on non-UNIX platforms anyway so |
| 511 | ;; optionally hide them. |
| 512 | (if (memq 'uid ls-lisp-verbosity) |
| 513 | ;; uid can be a sting or an integer |
| 514 | (let ((uid (nth 2 file-attr))) |
| 515 | (format (if (stringp uid) " %-8s" " %-8d") uid))) |
| 516 | (if (not (memq ?G switches)) ; GNU ls -- shows group by default |
| 517 | (if (or (memq ?g switches) ; UNIX ls -- no group by default |
| 518 | (memq 'gid ls-lisp-verbosity)) |
| 519 | (let ((gid (nth 3 file-attr))) |
| 520 | (format (if (stringp gid) " %-8s" " %-8d") gid)))) |
| 521 | (ls-lisp-format-file-size file-size (memq ?h switches)) |
| 522 | " " |
| 523 | (ls-lisp-format-time file-attr time-index now) |
| 524 | " " |
| 525 | (propertize file-name 'dired-filename t) |
| 526 | (if (stringp file-type) ; is a symbolic link |
| 527 | (concat " -> " file-type)) |
| 528 | "\n" |
| 529 | ))) |
| 530 | |
| 531 | (defun ls-lisp-time-index (switches) |
| 532 | "Return time index into file-attributes according to ls SWITCHES list. |
| 533 | Return nil if no time switch found." |
| 534 | ;; FJW: Default of nil is IMPORTANT and used in `ls-lisp-handle-switches'! |
| 535 | (cond ((memq ?c switches) 6) ; last mode change |
| 536 | ((memq ?t switches) 5) ; last modtime |
| 537 | ((memq ?u switches) 4))) ; last access |
| 538 | |
| 539 | (defun ls-lisp-time-to-seconds (time) |
| 540 | "Convert TIME to a floating point number." |
| 541 | (+ (* (car time) 65536.0) |
| 542 | (cadr time) |
| 543 | (/ (or (nth 2 time) 0) 1000000.0))) |
| 544 | |
| 545 | (defun ls-lisp-format-time (file-attr time-index now) |
| 546 | "Format time for file with attributes FILE-ATTR according to TIME-INDEX. |
| 547 | Use the same method as ls to decide whether to show time-of-day or year, |
| 548 | depending on distance between file date and NOW. |
| 549 | All ls time options, namely c, t and u, are handled." |
| 550 | (let* ((time (nth (or time-index 5) file-attr)) ; default is last modtime |
| 551 | (diff (- (ls-lisp-time-to-seconds time) |
| 552 | (ls-lisp-time-to-seconds now))) |
| 553 | ;; Consider a time to be recent if it is within the past six |
| 554 | ;; months. A Gregorian year has 365.2425 * 24 * 60 * 60 == |
| 555 | ;; 31556952 seconds on the average, and half of that is 15778476. |
| 556 | ;; Write the constant explicitly to avoid roundoff error. |
| 557 | (past-cutoff -15778476)) ; half a Gregorian year |
| 558 | (condition-case nil |
| 559 | ;; Use traditional time format in the C or POSIX locale, |
| 560 | ;; ISO-style time format otherwise, so columns line up. |
| 561 | (let ((locale system-time-locale)) |
| 562 | (if (not locale) |
| 563 | (let ((vars '("LC_ALL" "LC_TIME" "LANG"))) |
| 564 | (while (and vars (not (setq locale (getenv (car vars))))) |
| 565 | (setq vars (cdr vars))))) |
| 566 | (if (member locale '("C" "POSIX")) |
| 567 | (setq locale nil)) |
| 568 | (format-time-string |
| 569 | (if (and (<= past-cutoff diff) (<= diff 0)) |
| 570 | (if locale "%m-%d %H:%M" (nth 0 ls-lisp-format-time-list)) |
| 571 | (if locale "%Y-%m-%d " (nth 1 ls-lisp-format-time-list))) |
| 572 | time)) |
| 573 | (error "Unk 0 0000")))) |
| 574 | |
| 575 | (defun ls-lisp-format-file-size (file-size human-readable) |
| 576 | (if (or (not human-readable) |
| 577 | (< file-size 1024)) |
| 578 | (format (if (floatp file-size) " %9.0f" " %9d") file-size) |
| 579 | (do ((file-size (/ file-size 1024.0) (/ file-size 1024.0)) |
| 580 | ;; kilo, mega, giga, tera, peta, exa |
| 581 | (post-fixes (list "k" "M" "G" "T" "P" "E") (cdr post-fixes))) |
| 582 | ((< file-size 1024) (format " %8.0f%s" file-size (car post-fixes)))))) |
| 583 | |
| 584 | (provide 'ls-lisp) |
| 585 | |
| 586 | ;;; arch-tag: e55f399b-05ec-425c-a6d5-f5e349c35ab4 |
| 587 | ;;; ls-lisp.el ends here |