lisp/eshell/em-ls.el

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