code.delx.au - gnu-emacs/blob - lisp/eshell/em-ls.el

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