lisp/eshell/em-ls.el

   1 ;;; em-ls.el --- implementation of ls in Lisp
   2
   3 ;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
   4 ;;   2005, 2006 Free Software Foundation, Inc.
   5
   6 ;; Author: John Wiegley <johnw@gnu.org>
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301, USA.
  24
  25 (provide 'em-ls)
  26
  27 (eval-when-compile (require 'esh-maint))
  28
  29 (defgroup eshell-ls nil
  30   "This module implements the \"ls\" utility fully in Lisp.  If it is
  31 passed any unrecognized command switches, it will revert to the
  32 operating system's version.  This version of \"ls\" uses text
  33 properties to colorize its output based on the setting of
  34 `eshell-ls-use-colors'."
  35   :tag "Implementation of `ls' in Lisp"
  36   :group 'eshell-module)
  37
  38 ;;; Commentary:
  39
  40 ;; Most of the command switches recognized by GNU's ls utility are
  41 ;; supported ([(fileutils)ls invocation]).
  42
  43 (require 'esh-util)
  44 (require 'esh-opt)
  45
  46 ;;; User Variables:
  47
  48 (defvar eshell-ls-orig-insert-directory
  49   (symbol-function 'insert-directory)
  50   "Preserve the original definition of `insert-directory'.")
  51
  52 (defcustom eshell-ls-unload-hook
  53   (list
  54    (function
  55     (lambda ()
  56       (fset 'insert-directory eshell-ls-orig-insert-directory))))
  57   "*When unloading `eshell-ls', restore the definition of `insert-directory'."
  58   :type 'hook
  59   :group 'eshell-ls)
  60
  61 (defcustom eshell-ls-initial-args nil
  62   "*If non-nil, this list of args is included before any call to `ls'.
  63 This is useful for enabling human-readable format (-h), for example."
  64   :type '(repeat :tag "Arguments" string)
  65   :group 'eshell-ls)
  66
  67 (defcustom eshell-ls-dired-initial-args nil
  68   "*If non-nil, args is included before any call to `ls' in Dired.
  69 This is useful for enabling human-readable format (-h), for example."
  70   :type '(repeat :tag "Arguments" string)
  71   :group 'eshell-ls)
  72
  73 (defcustom eshell-ls-use-in-dired nil
  74   "*If non-nil, use `eshell-ls' to read directories in Dired."
  75   :set (lambda (symbol value)
  76          (if value
  77              (unless (and (boundp 'eshell-ls-use-in-dired)
  78                           eshell-ls-use-in-dired)
  79                (fset 'insert-directory 'eshell-ls-insert-directory))
  80            (when (and (boundp 'eshell-ls-insert-directory)
  81                       eshell-ls-use-in-dired)
  82              (fset 'insert-directory eshell-ls-orig-insert-directory)))
  83          (setq eshell-ls-use-in-dired value))
  84   :type 'boolean
  85   :require 'em-ls
  86   :group 'eshell-ls)
  87
  88 (defcustom eshell-ls-default-blocksize 1024
  89   "*The default blocksize to use when display file sizes with -s."
  90   :type 'integer
  91   :group 'eshell-ls)
  92
  93 (defcustom eshell-ls-exclude-regexp nil
  94   "*Unless -a is specified, files matching this regexp will not be shown."
  95   :type '(choice regexp (const nil))
  96   :group 'eshell-ls)
  97
  98 (defcustom eshell-ls-exclude-hidden t
  99   "*Unless -a is specified, files beginning with . will not be shown.
 100 Using this boolean, instead of `eshell-ls-exclude-regexp', is both
 101 faster and conserves more memory."
 102   :type 'boolean
 103   :group 'eshell-ls)
 104
 105 (defcustom eshell-ls-use-colors t
 106   "*If non-nil, use colors in file listings."
 107   :type 'boolean
 108   :group 'eshell-ls)
 109
 110 (defface eshell-ls-directory
 111   '((((class color) (background light)) (:foreground "Blue" :weight bold))
 112     (((class color) (background dark)) (:foreground "SkyBlue" :weight bold))
 113     (t (:weight bold)))
 114   "*The face used for highlight directories."
 115   :group 'eshell-ls)
 116 ;; backward-compatibility alias
 117 (put 'eshell-ls-directory-face 'face-alias 'eshell-ls-directory)
 118
 119 (defface eshell-ls-symlink
 120   '((((class color) (background light)) (:foreground "Dark Cyan" :weight bold))
 121     (((class color) (background dark)) (:foreground "Cyan" :weight bold)))
 122   "*The face used for highlight symbolic links."
 123   :group 'eshell-ls)
 124 ;; backward-compatibility alias
 125 (put 'eshell-ls-symlink-face 'face-alias 'eshell-ls-symlink)
 126
 127 (defface eshell-ls-executable
 128   '((((class color) (background light)) (:foreground "ForestGreen" :weight bold))
 129     (((class color) (background dark)) (:foreground "Green" :weight bold)))
 130   "*The face used for highlighting executables (not directories, though)."
 131   :group 'eshell-ls)
 132 ;; backward-compatibility alias
 133 (put 'eshell-ls-executable-face 'face-alias 'eshell-ls-executable)
 134
 135 (defface eshell-ls-readonly
 136   '((((class color) (background light)) (:foreground "Brown"))
 137     (((class color) (background dark)) (:foreground "Pink")))
 138   "*The face used for highlighting read-only files."
 139   :group 'eshell-ls)
 140 ;; backward-compatibility alias
 141 (put 'eshell-ls-readonly-face 'face-alias 'eshell-ls-readonly)
 142
 143 (defface eshell-ls-unreadable
 144   '((((class color) (background light)) (:foreground "Grey30"))
 145     (((class color) (background dark)) (:foreground "DarkGrey")))
 146   "*The face used for highlighting unreadable files."
 147   :group 'eshell-ls)
 148 ;; backward-compatibility alias
 149 (put 'eshell-ls-unreadable-face 'face-alias 'eshell-ls-unreadable)
 150
 151 (defface eshell-ls-special
 152   '((((class color) (background light)) (:foreground "Magenta" :weight bold))
 153     (((class color) (background dark)) (:foreground "Magenta" :weight bold)))
 154   "*The face used for highlighting non-regular files."
 155   :group 'eshell-ls)
 156 ;; backward-compatibility alias
 157 (put 'eshell-ls-special-face 'face-alias 'eshell-ls-special)
 158
 159 (defface eshell-ls-missing
 160   '((((class color) (background light)) (:foreground "Red" :weight bold))
 161     (((class color) (background dark)) (:foreground "Red" :weight bold)))
 162   "*The face used for highlighting non-existent file names."
 163   :group 'eshell-ls)
 164 ;; backward-compatibility alias
 165 (put 'eshell-ls-missing-face 'face-alias 'eshell-ls-missing)
 166
 167 (defcustom eshell-ls-archive-regexp
 168   (concat "\\.\\(t\\(a[rz]\\|gz\\)\\|arj\\|lzh\\|"
 169           "zip\\|[zZ]\\|gz\\|bz2\\|deb\\|rpm\\)\\'")
 170   "*A regular expression that matches names of file archives.
 171 This typically includes both traditional archives and compressed
 172 files."
 173   :type 'regexp
 174   :group 'eshell-ls)
 175
 176 (defface eshell-ls-archive
 177   '((((class color) (background light)) (:foreground "Orchid" :weight bold))
 178     (((class color) (background dark)) (:foreground "Orchid" :weight bold)))
 179   "*The face used for highlighting archived and compressed file names."
 180   :group 'eshell-ls)
 181 ;; backward-compatibility alias
 182 (put 'eshell-ls-archive-face 'face-alias 'eshell-ls-archive)
 183
 184 (defcustom eshell-ls-backup-regexp
 185   "\\(\\`\\.?#\\|\\(\\.bak\\|~\\)\\'\\)"
 186   "*A regular expression that matches names of backup files."
 187   :type 'regexp
 188   :group 'eshell-ls)
 189
 190 (defface eshell-ls-backup
 191   '((((class color) (background light)) (:foreground "OrangeRed"))
 192     (((class color) (background dark)) (:foreground "LightSalmon")))
 193   "*The face used for highlighting backup file names."
 194   :group 'eshell-ls)
 195 ;; backward-compatibility alias
 196 (put 'eshell-ls-backup-face 'face-alias 'eshell-ls-backup)
 197
 198 (defcustom eshell-ls-product-regexp
 199   "\\.\\(elc\\|o\\(bj\\)?\\|a\\|lib\\|res\\)\\'"
 200   "*A regular expression that matches names of product files.
 201 Products are files that get generated from a source file, and hence
 202 ought to be recreatable if they are deleted."
 203   :type 'regexp
 204   :group 'eshell-ls)
 205
 206 (defface eshell-ls-product
 207   '((((class color) (background light)) (:foreground "OrangeRed"))
 208     (((class color) (background dark)) (:foreground "LightSalmon")))
 209   "*The face used for highlighting files that are build products."
 210   :group 'eshell-ls)
 211 ;; backward-compatibility alias
 212 (put 'eshell-ls-product-face 'face-alias 'eshell-ls-product)
 213
 214 (defcustom eshell-ls-clutter-regexp
 215   "\\(^texput\\.log\\|^core\\)\\'"
 216   "*A regular expression that matches names of junk files.
 217 These are mainly files that get created for various reasons, but don't
 218 really need to stick around for very long."
 219   :type 'regexp
 220   :group 'eshell-ls)
 221
 222 (defface eshell-ls-clutter
 223   '((((class color) (background light)) (:foreground "OrangeRed" :weight bold))
 224     (((class color) (background dark)) (:foreground "OrangeRed" :weight bold)))
 225   "*The face used for highlighting junk file names."
 226   :group 'eshell-ls)
 227 ;; backward-compatibility alias
 228 (put 'eshell-ls-clutter-face 'face-alias 'eshell-ls-clutter)
 229
 230 (defsubst eshell-ls-filetype-p (attrs type)
 231   "Test whether ATTRS specifies a directory."
 232   (if (nth 8 attrs)
 233       (eq (aref (nth 8 attrs) 0) type)))
 234
 235 (defmacro eshell-ls-applicable (attrs index func file)
 236   "Test whether, for ATTRS, the user UID can do what corresponds to INDEX.
 237 This is really just for efficiency, to avoid having to stat the file
 238 yet again."
 239   `(if (numberp (nth 2 ,attrs))
 240        (if (= (user-uid) (nth 2 ,attrs))
 241            (not (eq (aref (nth 8 ,attrs) ,index) ?-))
 242          (,(eval func) ,file))
 243      (not (eq (aref (nth 8 ,attrs)
 244                     (+ ,index (if (member (nth 2 ,attrs)
 245                                           (eshell-current-ange-uids))
 246                                   0 6)))
 247               ?-))))
 248
 249 (defcustom eshell-ls-highlight-alist nil
 250   "*This alist correlates test functions to color.
 251 The format of the members of this alist is
 252
 253   (TEST-SEXP . FACE)
 254
 255 If TEST-SEXP evals to non-nil, that face will be used to highlight the
 256 name of the file.  The first match wins.  `file' and `attrs' are in
 257 scope during the evaluation of TEST-SEXP."
 258   :type '(repeat (cons function face))
 259   :group 'eshell-ls)
 260
 261 ;;; Functions:
 262
 263 (defun eshell-ls-insert-directory
 264   (file switches &optional wildcard full-directory-p)
 265   "Insert directory listing for FILE, formatted according to SWITCHES.
 266 Leaves point after the inserted text.
 267 SWITCHES may be a string of options, or a list of strings.
 268 Optional third arg WILDCARD means treat FILE as shell wildcard.
 269 Optional fourth arg FULL-DIRECTORY-P means file is a directory and
 270 switches do not contain `d', so that a full listing is expected.
 271
 272 This version of the function uses `eshell/ls'.  If any of the switches
 273 passed are not recognized, the operating system's version will be used
 274 instead."
 275   (let ((handler (find-file-name-handler file 'insert-directory)))
 276     (if handler
 277         (funcall handler 'insert-directory file switches
 278                  wildcard full-directory-p)
 279       (if (stringp switches)
 280           (setq switches (split-string switches)))
 281       (let (eshell-current-handles
 282             eshell-current-subjob-p
 283             font-lock-mode)
 284         ;; use the fancy highlighting in `eshell-ls' rather than font-lock
 285         (when (and eshell-ls-use-colors
 286                    (featurep 'font-lock))
 287           (font-lock-mode -1)
 288           (setq font-lock-defaults nil)
 289           (if (boundp 'font-lock-buffers)
 290               (set 'font-lock-buffers
 291                    (delq (current-buffer)
 292                          (symbol-value 'font-lock-buffers)))))
 293         (let ((insert-func 'insert)
 294               (error-func 'insert)
 295               (flush-func 'ignore)
 296               eshell-ls-dired-initial-args)
 297           (eshell-do-ls (append switches (list file))))))))
 298
 299 (defsubst eshell/ls (&rest args)
 300   "An alias version of `eshell-do-ls'."
 301   (let ((insert-func 'eshell-buffered-print)
 302         (error-func 'eshell-error)
 303         (flush-func 'eshell-flush))
 304     (eshell-do-ls args)))
 305
 306 (put 'eshell/ls 'eshell-no-numeric-conversions t)
 307
 308 (eval-when-compile
 309   (defvar block-size)
 310   (defvar dereference-links)
 311   (defvar dir-literal)
 312   (defvar error-func)
 313   (defvar flush-func)
 314   (defvar human-readable)
 315   (defvar ignore-pattern)
 316   (defvar insert-func)
 317   (defvar listing-style)
 318   (defvar numeric-uid-gid)
 319   (defvar reverse-list)
 320   (defvar show-all)
 321   (defvar show-recursive)
 322   (defvar show-size)
 323   (defvar sort-method)
 324   (defvar ange-cache)
 325   (defvar dired-flag))
 326
 327 (defun eshell-do-ls (&rest args)
 328   "Implementation of \"ls\" in Lisp, passing ARGS."
 329   (funcall flush-func -1)
 330   ;; process the command arguments, and begin listing files
 331   (eshell-eval-using-options
 332    "ls" (if eshell-ls-initial-args
 333             (list eshell-ls-initial-args args)
 334           args)
 335    `((?a "all" nil show-all
 336          "show all files in directory")
 337      (?c nil by-ctime sort-method
 338          "sort by last status change time")
 339      (?d "directory" nil dir-literal
 340          "list directory entries instead of contents")
 341      (?k "kilobytes" 1024 block-size
 342          "using 1024 as the block size")
 343      (?h "human-readable" 1024 human-readable
 344          "print sizes in human readable format")
 345      (?H "si" 1000 human-readable
 346          "likewise, but use powers of 1000 not 1024")
 347      (?I "ignore" t ignore-pattern
 348          "do not list implied entries matching pattern")
 349      (?l nil long-listing listing-style
 350          "use a long listing format")
 351      (?n "numeric-uid-gid" nil numeric-uid-gid
 352          "list numeric UIDs and GIDs instead of names")
 353      (?r "reverse" nil reverse-list
 354          "reverse order while sorting")
 355      (?s "size" nil show-size
 356          "print size of each file, in blocks")
 357      (?t nil by-mtime sort-method
 358          "sort by modification time")
 359      (?u nil by-atime sort-method
 360          "sort by last access time")
 361      (?x nil by-lines listing-style
 362          "list entries by lines instead of by columns")
 363      (?C nil by-columns listing-style
 364          "list entries by columns")
 365      (?L "deference" nil dereference-links
 366          "list entries pointed to by symbolic links")
 367      (?R "recursive" nil show-recursive
 368          "list subdirectories recursively")
 369      (?S nil by-size sort-method
 370          "sort by file size")
 371      (?U nil unsorted sort-method
 372          "do not sort; list entries in directory order")
 373      (?X nil by-extension sort-method
 374          "sort alphabetically by entry extension")
 375      (?1 nil single-column listing-style
 376          "list one file per line")
 377      (nil "dired" nil dired-flag
 378           "Here for compatibility with GNU ls.")
 379      (nil "help" nil nil
 380           "show this usage display")
 381      :external "ls"
 382      :usage "[OPTION]... [FILE]...
 383 List information about the FILEs (the current directory by default).
 384 Sort entries alphabetically across.")
 385    ;; setup some defaults, based on what the user selected
 386    (unless block-size
 387      (setq block-size eshell-ls-default-blocksize))
 388    (unless listing-style
 389      (setq listing-style 'by-columns))
 390    (unless args
 391      (setq args (list ".")))
 392    (let ((eshell-ls-exclude-regexp eshell-ls-exclude-regexp) ange-cache)
 393      (when ignore-pattern
 394        (unless (eshell-using-module 'eshell-glob)
 395          (error (concat "-I option requires that `eshell-glob'"
 396                         " be a member of `eshell-modules-list'")))
 397        (set-text-properties 0 (length ignore-pattern) nil ignore-pattern)
 398        (setq eshell-ls-exclude-regexp
 399              (if eshell-ls-exclude-regexp
 400                  (concat "\\(" eshell-ls-exclude-regexp "\\|"
 401                          (eshell-glob-regexp ignore-pattern) "\\)")
 402                (eshell-glob-regexp ignore-pattern))))
 403      ;; list the files!
 404      (eshell-ls-entries
 405       (mapcar (function
 406                (lambda (arg)
 407                  (cons (if (and (eshell-under-windows-p)
 408                                 (file-name-absolute-p arg))
 409                            (expand-file-name arg)
 410                          arg)
 411                        (eshell-file-attributes arg))))
 412               args)
 413       t (expand-file-name default-directory)))
 414    (funcall flush-func)))
 415
 416 (defsubst eshell-ls-printable-size (filesize &optional by-blocksize)
 417   "Return a printable FILESIZE."
 418   (eshell-printable-size filesize human-readable
 419                          (and by-blocksize block-size)
 420                          eshell-ls-use-colors))
 421
 422 (defsubst eshell-ls-size-string (attrs size-width)
 423   "Return the size string for ATTRS length, using SIZE-WIDTH."
 424   (let* ((str (eshell-ls-printable-size (nth 7 attrs) t))
 425          (len (length str)))
 426     (if (< len size-width)
 427         (concat (make-string (- size-width len) ? ) str)
 428       str)))
 429
 430 (defun eshell-ls-annotate (fileinfo)
 431   "Given a FILEINFO object, return a resolved, decorated FILEINFO.
 432 This means resolving any symbolic links, determining what face the
 433 name should be displayed as, etc.  Think of it as cooking a FILEINFO."
 434   (if (not (and (stringp (cadr fileinfo))
 435                 (or dereference-links
 436                     (eq listing-style 'long-listing))))
 437       (setcar fileinfo (eshell-ls-decorated-name fileinfo))
 438     (let (dir attr)
 439       (unless (file-name-absolute-p (cadr fileinfo))
 440         (setq dir (file-truename
 441                    (file-name-directory
 442                     (expand-file-name (car fileinfo))))))
 443       (setq attr
 444             (eshell-file-attributes
 445              (let ((target (if dir
 446                                (expand-file-name (cadr fileinfo) dir)
 447                              (cadr fileinfo))))
 448                (if dereference-links
 449                    (file-truename target)
 450                  target))))
 451       (if (or dereference-links
 452               (string-match "^\\.\\.?$" (car fileinfo)))
 453           (progn
 454             (setcdr fileinfo attr)
 455             (setcar fileinfo (eshell-ls-decorated-name fileinfo)))
 456         (assert (eq listing-style 'long-listing))
 457         (setcar fileinfo
 458                 (concat (eshell-ls-decorated-name fileinfo) " -> "
 459                         (eshell-ls-decorated-name
 460                          (cons (cadr fileinfo) attr)))))))
 461   fileinfo)
 462
 463 (defun eshell-ls-file (fileinfo &optional size-width copy-fileinfo)
 464   "Output FILE in long format.
 465 FILE may be a string, or a cons cell whose car is the filename and
 466 whose cdr is the list of file attributes."
 467   (if (not (cdr fileinfo))
 468       (funcall error-func (format "%s: No such file or directory\n"
 469                                   (car fileinfo)))
 470     (setq fileinfo
 471           (eshell-ls-annotate (if copy-fileinfo
 472                                   (cons (car fileinfo)
 473                                         (cdr fileinfo))
 474                                 fileinfo)))
 475     (let ((file (car fileinfo))
 476           (attrs (cdr fileinfo)))
 477       (if (not (eq listing-style 'long-listing))
 478           (if show-size
 479               (funcall insert-func (eshell-ls-size-string attrs size-width)
 480                        " " file "\n")
 481             (funcall insert-func file "\n"))
 482         (let ((line
 483                (concat
 484                 (if show-size
 485                     (concat (eshell-ls-size-string attrs size-width) " "))
 486                 (format
 487                  "%s%4d %-8s %-8s "
 488                  (or (nth 8 attrs) "??????????")
 489                  (or (nth 1 attrs) 0)
 490                  (or (let ((user (nth 2 attrs)))
 491                        (and (not numeric-uid-gid)
 492                             user
 493                             (eshell-substring
 494                              (if (numberp user)
 495                                  (user-login-name user)
 496                                user) 8)))
 497                      (nth 2 attrs)
 498                      "")
 499                  (or (let ((group (nth 3 attrs)))
 500                        (and (not numeric-uid-gid)
 501                             group
 502                             (eshell-substring
 503                              (if (numberp group)
 504                                  (eshell-group-name group)
 505                                group) 8)))
 506                      (nth 3 attrs)
 507                      ""))
 508                 (let* ((str (eshell-ls-printable-size (nth 7 attrs)))
 509                        (len (length str)))
 510                   (if (< len (or size-width 4))
 511                       (concat (make-string (- (or size-width 4) len) ? ) str)
 512                     str))
 513                 " " (format-time-string
 514                      (concat
 515                       "%b %e "
 516                       (if (= (nth 5 (decode-time (current-time)))
 517                              (nth 5 (decode-time
 518                                      (nth (cond
 519                                            ((eq sort-method 'by-atime) 4)
 520                                            ((eq sort-method 'by-ctime) 6)
 521                                            (t 5)) attrs))))
 522                           "%H:%M"
 523                         " %Y")) (nth (cond
 524                         ((eq sort-method 'by-atime) 4)
 525                         ((eq sort-method 'by-ctime) 6)
 526                         (t 5)) attrs)) " ")))
 527           (funcall insert-func line file "\n"))))))
 528
 529 (defun eshell-ls-dir (dirinfo &optional insert-name root-dir size-width)
 530   "Output the entries in DIRINFO.
 531 If INSERT-NAME is non-nil, the name of DIRINFO will be output.  If
 532 ROOT-DIR is also non-nil, and a directory name, DIRINFO will be output
 533 relative to that directory."
 534   (let ((dir (car dirinfo)))
 535     (if (not (cdr dirinfo))
 536         (funcall error-func (format "%s: No such file or directory\n" dir))
 537       (if dir-literal
 538           (eshell-ls-file dirinfo size-width)
 539         (if insert-name
 540             (funcall insert-func
 541                      (eshell-ls-decorated-name
 542                       (cons (concat
 543                              (if root-dir
 544                                  (file-relative-name dir root-dir)
 545                                (expand-file-name dir)))
 546                             (cdr dirinfo))) ":\n"))
 547         (let ((entries (eshell-directory-files-and-attributes
 548                         dir nil (and (not show-all)
 549                                      eshell-ls-exclude-hidden
 550                                      "\\`[^.]") t)))
 551           (when (and (not show-all) eshell-ls-exclude-regexp)
 552             (while (and entries (string-match eshell-ls-exclude-regexp
 553                                               (caar entries)))
 554               (setq entries (cdr entries)))
 555             (let ((e entries))
 556               (while (cdr e)
 557                 (if (string-match eshell-ls-exclude-regexp (car (cadr e)))
 558                     (setcdr e (cddr e))
 559                   (setq e (cdr e))))))
 560           (when (or (eq listing-style 'long-listing) show-size)
 561             (let ((total 0.0))
 562               (setq size-width 0)
 563               (eshell-for e entries
 564                 (if (nth 7 (cdr e))
 565                     (setq total (+ total (nth 7 (cdr e)))
 566                           size-width
 567                           (max size-width
 568                                (length (eshell-ls-printable-size
 569                                         (nth 7 (cdr e)) t))))))
 570               (funcall insert-func "total "
 571                        (eshell-ls-printable-size total t) "\n")))
 572           (let ((default-directory (expand-file-name dir)))
 573             (if show-recursive
 574                 (eshell-ls-entries
 575                  (let ((e entries) (good-entries (list t)))
 576                    (while e
 577                      (unless (let ((len (length (caar e))))
 578                                (and (eq (aref (caar e) 0) ?.)
 579                                     (or (= len 1)
 580                                         (and (= len 2)
 581                                              (eq (aref (caar e) 1) ?.)))))
 582                        (nconc good-entries (list (car e))))
 583                      (setq e (cdr e)))
 584                    (cdr good-entries))
 585                  nil root-dir)
 586               (eshell-ls-files (eshell-ls-sort-entries entries)
 587                                size-width))))))))
 588
 589 (defsubst eshell-ls-compare-entries (l r inx func)
 590   "Compare the time of two files, L and R, the attribute indexed by INX."
 591   (let ((lt (nth inx (cdr l)))
 592         (rt (nth inx (cdr r))))
 593     (if (equal lt rt)
 594         (string-lessp (directory-file-name (car l))
 595                       (directory-file-name (car r)))
 596       (funcall func rt lt))))
 597
 598 (defun eshell-ls-sort-entries (entries)
 599   "Sort the given ENTRIES, which may be files, directories or both.
 600 In Eshell's implementation of ls, ENTRIES is always reversed."
 601   (if (eq sort-method 'unsorted)
 602       (nreverse entries)
 603     (sort entries
 604           (function
 605            (lambda (l r)
 606              (let ((result
 607                     (cond
 608                      ((eq sort-method 'by-atime)
 609                       (eshell-ls-compare-entries l r 4 'eshell-time-less-p))
 610                      ((eq sort-method 'by-mtime)
 611                       (eshell-ls-compare-entries l r 5 'eshell-time-less-p))
 612                      ((eq sort-method 'by-ctime)
 613                       (eshell-ls-compare-entries l r 6 'eshell-time-less-p))
 614                      ((eq sort-method 'by-size)
 615                       (eshell-ls-compare-entries l r 7 '<))
 616                      ((eq sort-method 'by-extension)
 617                       (let ((lx (file-name-extension
 618                                  (directory-file-name (car l))))
 619                             (rx (file-name-extension
 620                                  (directory-file-name (car r)))))
 621                         (cond
 622                          ((or (and (not lx) (not rx))
 623                               (equal lx rx))
 624                           (string-lessp (directory-file-name (car l))
 625                                         (directory-file-name (car r))))
 626                          ((not lx) t)
 627                          ((not rx) nil)
 628                          (t
 629                           (string-lessp lx rx)))))
 630                      (t
 631                       (string-lessp (directory-file-name (car l))
 632                                     (directory-file-name (car r)))))))
 633                (if reverse-list
 634                    (not result)
 635                  result)))))))
 636
 637 (defun eshell-ls-files (files &optional size-width copy-fileinfo)
 638   "Output a list of FILES.
 639 Each member of FILES is either a string or a cons cell of the form
 640 \(FILE .  ATTRS)."
 641   (if (memq listing-style '(long-listing single-column))
 642       (eshell-for file files
 643         (if file
 644             (eshell-ls-file file size-width copy-fileinfo)))
 645     (let ((f files)
 646           last-f
 647           display-files
 648           ignore)
 649       (while f
 650         (if (cdar f)
 651             (setq last-f f
 652                   f (cdr f))
 653           (unless ignore
 654             (funcall error-func
 655                      (format "%s: No such file or directory\n" (caar f))))
 656           (if (eq f files)
 657               (setq files (cdr files)
 658                     f files)
 659             (if (not (cdr f))
 660                 (progn
 661                   (setcdr last-f nil)
 662                   (setq f nil))
 663               (setcar f (cadr f))
 664               (setcdr f (cddr f))))))
 665       (if (not show-size)
 666           (setq display-files (mapcar 'eshell-ls-annotate files))
 667         (eshell-for file files
 668           (let* ((str (eshell-ls-printable-size (nth 7 (cdr file)) t))
 669                  (len (length str)))
 670             (if (< len size-width)
 671                 (setq str (concat (make-string (- size-width len) ? ) str)))
 672             (setq file (eshell-ls-annotate file)
 673                   display-files (cons (cons (concat str " " (car file))
 674                                             (cdr file))
 675                                       display-files))))
 676         (setq display-files (nreverse display-files)))
 677       (let* ((col-vals
 678               (if (eq listing-style 'by-columns)
 679                   (eshell-ls-find-column-lengths display-files)
 680                 (assert (eq listing-style 'by-lines))
 681                 (eshell-ls-find-column-widths display-files)))
 682              (col-widths (car col-vals))
 683              (display-files (cdr col-vals))
 684              (columns (length col-widths))
 685              (col-index 1)
 686              need-return)
 687         (eshell-for file display-files
 688           (let ((name
 689                  (if (car file)
 690                      (if show-size
 691                          (concat (substring (car file) 0 size-width)
 692                                  (eshell-ls-decorated-name
 693                                   (cons (substring (car file) size-width)
 694                                         (cdr file))))
 695                        (eshell-ls-decorated-name file))
 696                    "")))
 697             (if (< col-index columns)
 698                 (setq need-return
 699                       (concat need-return name
 700                               (make-string
 701                                (max 0 (- (aref col-widths
 702                                                (1- col-index))
 703                                          (length name))) ? ))
 704                       col-index (1+ col-index))
 705               (funcall insert-func need-return name "\n")
 706               (setq col-index 1 need-return nil))))
 707         (if need-return
 708             (funcall insert-func need-return "\n"))))))
 709
 710 (defun eshell-ls-entries (entries &optional separate root-dir)
 711   "Output PATH's directory ENTRIES, formatted according to OPTIONS.
 712 Each member of ENTRIES may either be a string or a cons cell, the car
 713 of which is the file name, and the cdr of which is the list of
 714 attributes.
 715 If SEPARATE is non-nil, directories name will be entirely separated
 716 from the filenames.  This is the normal behavior, except when doing a
 717 recursive listing.
 718 ROOT-DIR, if non-nil, specifies the root directory of the listing, to
 719 which non-absolute directory names will be made relative if ever they
 720 need to be printed."
 721   (let (dirs files show-names need-return (size-width 0))
 722     (eshell-for entry entries
 723       (if (and (not dir-literal)
 724                (or (eshell-ls-filetype-p (cdr entry) ?d)
 725                    (and (eshell-ls-filetype-p (cdr entry) ?l)
 726                         (file-directory-p (car entry)))))
 727           (progn
 728             (unless separate
 729               (setq files (cons entry files)
 730                     size-width
 731                     (if show-size
 732                         (max size-width
 733                              (length (eshell-ls-printable-size
 734                                       (nth 7 (cdr entry)) t))))))
 735             (setq dirs (cons entry dirs)))
 736         (setq files (cons entry files)
 737               size-width
 738               (if show-size
 739                   (max size-width
 740                        (length (eshell-ls-printable-size
 741                                 (nth 7 (cdr entry)) t)))))))
 742     (when files
 743       (eshell-ls-files (eshell-ls-sort-entries files)
 744                        size-width show-recursive)
 745       (setq need-return t))
 746     (setq show-names (or show-recursive
 747                          (> (+ (length files) (length dirs)) 1)))
 748     (eshell-for dir (eshell-ls-sort-entries dirs)
 749       (if (and need-return (not dir-literal))
 750           (funcall insert-func "\n"))
 751       (eshell-ls-dir dir show-names
 752                      (unless (file-name-absolute-p (car dir)) root-dir)
 753                      size-width)
 754       (setq need-return t))))
 755
 756 (defun eshell-ls-find-column-widths (files)
 757   "Find the best fitting column widths for FILES.
 758 It will be returned as a vector, whose length is the number of columns
 759 to use, and each member of which is the width of that column
 760 \(including spacing)."
 761   (let* ((numcols 0)
 762          (width 0)
 763          (widths
 764           (mapcar
 765            (function
 766             (lambda (file)
 767               (+ 2 (length (car file)))))
 768            files))
 769          ;; must account for the added space...
 770          (max-width (+ (window-width) 2))
 771          (best-width 0)
 772          col-widths)
 773
 774     ;; determine the largest number of columns in the first row
 775     (let ((w widths))
 776       (while (and w (< width max-width))
 777         (setq width (+ width (car w))
 778               numcols (1+ numcols)
 779               w (cdr w))))
 780
 781     ;; refine it based on the following rows
 782     (while (> numcols 0)
 783       (let ((i 0)
 784             (colw (make-vector numcols 0))
 785             (w widths))
 786         (while w
 787           (if (= i numcols)
 788               (setq i 0))
 789           (aset colw i (max (aref colw i) (car w)))
 790           (setq w (cdr w) i (1+ i)))
 791         (setq i 0 width 0)
 792         (while (< i numcols)
 793           (setq width (+ width (aref colw i))
 794                 i (1+ i)))
 795         (if (and (< width max-width)
 796                  (> width best-width))
 797             (setq col-widths colw
 798                   best-width width)))
 799       (setq numcols (1- numcols)))
 800
 801     (cons (or col-widths (vector max-width)) files)))
 802
 803 (defun eshell-ls-find-column-lengths (files)
 804   "Find the best fitting column lengths for FILES.
 805 It will be returned as a vector, whose length is the number of columns
 806 to use, and each member of which is the width of that column
 807 \(including spacing)."
 808   (let* ((numcols 1)
 809          (width 0)
 810          (widths
 811           (mapcar
 812            (function
 813             (lambda (file)
 814               (+ 2 (length (car file)))))
 815            files))
 816          (max-width (+ (window-width) 2))
 817          col-widths
 818          colw)
 819
 820     ;; refine it based on the following rows
 821     (while numcols
 822       (let* ((rows (ceiling (/ (length widths)
 823                                (float numcols))))
 824              (w widths)
 825              (len (* rows numcols))
 826              (index 0)
 827              (i 0))
 828         (setq width 0)
 829         (unless (or (= rows 0)
 830                     (<= (/ (length widths) (float rows))
 831                         (float (1- numcols))))
 832           (setq colw (make-vector numcols 0))
 833           (while (> len 0)
 834             (if (= i numcols)
 835                 (setq i 0 index (1+ index)))
 836             (aset colw i
 837                   (max (aref colw i)
 838                        (or (nth (+ (* i rows) index) w) 0)))
 839             (setq len (1- len) i (1+ i)))
 840           (setq i 0)
 841           (while (< i numcols)
 842             (setq width (+ width (aref colw i))
 843                   i (1+ i))))
 844         (if (>= width max-width)
 845             (setq numcols nil)
 846           (if colw
 847               (setq col-widths colw))
 848           (if (>= numcols (length widths))
 849               (setq numcols nil)
 850             (setq numcols (1+ numcols))))))
 851
 852     (if (not col-widths)
 853         (cons (vector max-width) files)
 854       (setq numcols (length col-widths))
 855       (let* ((rows (ceiling (/ (length widths)
 856                                (float numcols))))
 857              (len (* rows numcols))
 858              (newfiles (make-list len nil))
 859              (index 0)
 860              (i 0)
 861              (j 0))
 862         (while (< j len)
 863           (if (= i numcols)
 864               (setq i 0 index (1+ index)))
 865           (setcar (nthcdr j newfiles)
 866                   (nth (+ (* i rows) index) files))
 867           (setq j (1+ j) i (1+ i)))
 868         (cons col-widths newfiles)))))
 869
 870 (defun eshell-ls-decorated-name (file)
 871   "Return FILE, possibly decorated."
 872   (if eshell-ls-use-colors
 873       (let ((face
 874              (cond
 875               ((not (cdr file))
 876                'eshell-ls-missing)
 877
 878               ((stringp (cadr file))
 879                'eshell-ls-symlink)
 880
 881               ((eq (cadr file) t)
 882                'eshell-ls-directory)
 883
 884               ((not (eshell-ls-filetype-p (cdr file) ?-))
 885                'eshell-ls-special)
 886
 887               ((and (/= (user-uid) 0) ; root can execute anything
 888                     (eshell-ls-applicable (cdr file) 3
 889                                           'file-executable-p (car file)))
 890                'eshell-ls-executable)
 891
 892               ((not (eshell-ls-applicable (cdr file) 1
 893                                           'file-readable-p (car file)))
 894                'eshell-ls-unreadable)
 895
 896               ((string-match eshell-ls-archive-regexp (car file))
 897                'eshell-ls-archive)
 898
 899               ((string-match eshell-ls-backup-regexp (car file))
 900                'eshell-ls-backup)
 901
 902               ((string-match eshell-ls-product-regexp (car file))
 903                'eshell-ls-product)
 904
 905               ((string-match eshell-ls-clutter-regexp (car file))
 906                'eshell-ls-clutter)
 907
 908               ((not (eshell-ls-applicable (cdr file) 2
 909                                           'file-writable-p (car file)))
 910                'eshell-ls-readonly)
 911               (eshell-ls-highlight-alist
 912                (let ((tests eshell-ls-highlight-alist)
 913                      value)
 914                  (while tests
 915                    (if (funcall (caar tests) (car file) (cdr file))
 916                        (setq value (cdar tests) tests nil)
 917                      (setq tests (cdr tests))))
 918                  value)))))
 919         (if face
 920             (add-text-properties 0 (length (car file))
 921                                  (list 'face face)
 922                                  (car file)))))
 923   (car file))
 924
 925 ;;; Code:
 926
 927 ;;; arch-tag: 9295181c-0cb2-499c-999b-89f5359842cb
 928 ;;; em-ls.el ends here