lisp/eshell/em-ls.el

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