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

   1 ;;; em-ls.el --- implementation of ls in Lisp
   2
   3 ;; Copyright (C) 1999, 2000, 2005 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., 51 Franklin Street, Fifth Floor,
  22 ;; Boston, MA 02110-1301, 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
 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 ;; backward-compatibility alias
 116 (put 'eshell-ls-directory-face 'face-alias 'eshell-ls-directory)
 117
 118 (defface eshell-ls-symlink
 119   '((((class color) (background light)) (:foreground "Dark Cyan" :weight bold))
 120     (((class color) (background dark)) (:foreground "Cyan" :weight bold)))
 121   "*The face used for highlight symbolic links."
 122   :group 'eshell-ls)
 123 ;; backward-compatibility alias
 124 (put 'eshell-ls-symlink-face 'face-alias 'eshell-ls-symlink)
 125
 126 (defface eshell-ls-executable
 127   '((((class color) (background light)) (:foreground "ForestGreen" :weight bold))
 128     (((class color) (background dark)) (:foreground "Green" :weight bold)))
 129   "*The face used for highlighting executables (not directories, though)."
 130   :group 'eshell-ls)
 131 ;; backward-compatibility alias
 132 (put 'eshell-ls-executable-face 'face-alias 'eshell-ls-executable)
 133
 134 (defface eshell-ls-readonly
 135   '((((class color) (background light)) (:foreground "Brown"))
 136     (((class color) (background dark)) (:foreground "Pink")))
 137   "*The face used for highlighting read-only files."
 138   :group 'eshell-ls)
 139 ;; backward-compatibility alias
 140 (put 'eshell-ls-readonly-face 'face-alias 'eshell-ls-readonly)
 141
 142 (defface eshell-ls-unreadable
 143   '((((class color) (background light)) (:foreground "Grey30"))
 144     (((class color) (background dark)) (:foreground "DarkGrey")))
 145   "*The face used for highlighting unreadable files."
 146   :group 'eshell-ls)
 147 ;; backward-compatibility alias
 148 (put 'eshell-ls-unreadable-face 'face-alias 'eshell-ls-unreadable)
 149
 150 (defface eshell-ls-special
 151   '((((class color) (background light)) (:foreground "Magenta" :weight bold))
 152     (((class color) (background dark)) (:foreground "Magenta" :weight bold)))
 153   "*The face used for highlighting non-regular files."
 154   :group 'eshell-ls)
 155 ;; backward-compatibility alias
 156 (put 'eshell-ls-special-face 'face-alias 'eshell-ls-special)
 157
 158 (defface eshell-ls-missing
 159   '((((class color) (background light)) (:foreground "Red" :weight bold))
 160     (((class color) (background dark)) (:foreground "Red" :weight bold)))
 161   "*The face used for highlighting non-existant file names."
 162   :group 'eshell-ls)
 163 ;; backward-compatibility alias
 164 (put 'eshell-ls-missing-face 'face-alias 'eshell-ls-missing)
 165
 166 (defcustom eshell-ls-archive-regexp
 167   (concat "\\.\\(t\\(a[rz]\\|gz\\)\\|arj\\|lzh\\|"
 168           "zip\\|[zZ]\\|gz\\|bz2\\|deb\\|rpm\\)\\'")
 169   "*A regular expression that matches names of file archives.
 170 This typically includes both traditional archives and compressed
 171 files."
 172   :type 'regexp
 173   :group 'eshell-ls)
 174
 175 (defface eshell-ls-archive
 176   '((((class color) (background light)) (:foreground "Orchid" :weight bold))
 177     (((class color) (background dark)) (:foreground "Orchid" :weight bold)))
 178   "*The face used for highlighting archived and compressed file names."
 179   :group 'eshell-ls)
 180 ;; backward-compatibility alias
 181 (put 'eshell-ls-archive-face 'face-alias 'eshell-ls-archive)
 182
 183 (defcustom eshell-ls-backup-regexp
 184   "\\(\\`\\.?#\\|\\(\\.bak\\|~\\)\\'\\)"
 185   "*A regular expression that matches names of backup files."
 186   :type 'regexp
 187   :group 'eshell-ls)
 188
 189 (defface eshell-ls-backup
 190   '((((class color) (background light)) (:foreground "OrangeRed"))
 191     (((class color) (background dark)) (:foreground "LightSalmon")))
 192   "*The face used for highlighting backup file names."
 193   :group 'eshell-ls)
 194 ;; backward-compatibility alias
 195 (put 'eshell-ls-backup-face 'face-alias 'eshell-ls-backup)
 196
 197 (defcustom eshell-ls-product-regexp
 198   "\\.\\(elc\\|o\\(bj\\)?\\|a\\|lib\\|res\\)\\'"
 199   "*A regular expression that matches names of product files.
 200 Products are files that get generated from a source file, and hence
 201 ought to be recreatable if they are deleted."
 202   :type 'regexp
 203   :group 'eshell-ls)
 204
 205 (defface eshell-ls-product
 206   '((((class color) (background light)) (:foreground "OrangeRed"))
 207     (((class color) (background dark)) (:foreground "LightSalmon")))
 208   "*The face used for highlighting files that are build products."
 209   :group 'eshell-ls)
 210 ;; backward-compatibility alias
 211 (put 'eshell-ls-product-face 'face-alias 'eshell-ls-product)
 212
 213 (defcustom eshell-ls-clutter-regexp
 214   "\\(^texput\\.log\\|^core\\)\\'"
 215   "*A regular expression that matches names of junk files.
 216 These are mainly files that get created for various reasons, but don't
 217 really need to stick around for very long."
 218   :type 'regexp
 219   :group 'eshell-ls)
 220
 221 (defface eshell-ls-clutter
 222   '((((class color) (background light)) (:foreground "OrangeRed" :weight bold))
 223     (((class color) (background dark)) (:foreground "OrangeRed" :weight bold)))
 224   "*The face used for highlighting junk file names."
 225   :group 'eshell-ls)
 226 ;; backward-compatibility alias
 227 (put 'eshell-ls-clutter-face 'face-alias 'eshell-ls-clutter)
 228
 229 (defsubst eshell-ls-filetype-p (attrs type)
 230   "Test whether ATTRS specifies a directory."
 231   (if (nth 8 attrs)
 232       (eq (aref (nth 8 attrs) 0) type)))
 233
 234 (defmacro eshell-ls-applicable (attrs index func file)
 235   "Test whether, for ATTRS, the user UID can do what corresponds to INDEX.
 236 This is really just for efficiency, to avoid having to stat the file
 237 yet again."
 238   `(if (numberp (nth 2 ,attrs))
 239        (if (= (user-uid) (nth 2 ,attrs))
 240            (not (eq (aref (nth 8 ,attrs) ,index) ?-))
 241          (,(eval func) ,file))
 242      (not (eq (aref (nth 8 ,attrs)
 243                     (+ ,index (if (member (nth 2 ,attrs)
 244                                           (eshell-current-ange-uids))
 245                                   0 6)))
 246               ?-))))
 247
 248 (defcustom eshell-ls-highlight-alist nil
 249   "*This alist correlates test functions to color.
 250 The format of the members of this alist is
 251
 252   (TEST-SEXP . FACE)
 253
 254 If TEST-SEXP evals to non-nil, that face will be used to highlight the
 255 name of the file.  The first match wins.  `file' and `attrs' are in
 256 scope during the evaluation of TEST-SEXP."
 257   :type '(repeat (cons function face))
 258   :group 'eshell-ls)
 259
 260 ;;; Functions:
 261
 262 (defun eshell-ls-insert-directory
 263   (file switches &optional wildcard full-directory-p)
 264   "Insert directory listing for FILE, formatted according to SWITCHES.
 265 Leaves point after the inserted text.
 266 SWITCHES may be a string of options, or a list of strings.
 267 Optional third arg WILDCARD means treat FILE as shell wildcard.
 268 Optional fourth arg FULL-DIRECTORY-P means file is a directory and
 269 switches do not contain `d', so that a full listing is expected.
 270
 271 This version of the function uses `eshell/ls'.  If any of the switches
 272 passed are not recognized, the operating system's version will be used
 273 instead."
 274   (let ((handler (find-file-name-handler file 'insert-directory)))
 275     (if handler
 276         (funcall handler 'insert-directory file switches
 277                  wildcard full-directory-p)
 278       (if (stringp switches)
 279           (setq switches (split-string switches)))
 280       (let (eshell-current-handles
 281             eshell-current-subjob-p)
 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 (eval-when-compile
 307   (defvar block-size)
 308   (defvar dereference-links)
 309   (defvar dir-literal)
 310   (defvar error-func)
 311   (defvar flush-func)
 312   (defvar human-readable)
 313   (defvar ignore-pattern)
 314   (defvar insert-func)
 315   (defvar listing-style)
 316   (defvar numeric-uid-gid)
 317   (defvar reverse-list)
 318   (defvar show-all)
 319   (defvar show-recursive)
 320   (defvar show-size)
 321   (defvar sort-method)
 322   (defvar ange-cache))
 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 modification 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 "help" nil nil
 375           "show this usage display")
 376      :external "ls"
 377      :usage "[OPTION]... [FILE]...
 378 List information about the FILEs (the current directory by default).
 379 Sort entries alphabetically across.")
 380    ;; setup some defaults, based on what the user selected
 381    (unless block-size
 382      (setq block-size eshell-ls-default-blocksize))
 383    (unless listing-style
 384      (setq listing-style 'by-columns))
 385    (unless args
 386      (setq args (list ".")))
 387    (let ((eshell-ls-exclude-regexp eshell-ls-exclude-regexp) ange-cache)
 388      (when ignore-pattern
 389        (unless (eshell-using-module 'eshell-glob)
 390          (error (concat "-I option requires that `eshell-glob'"
 391                         " be a member of `eshell-modules-list'")))
 392        (set-text-properties 0 (length ignore-pattern) nil ignore-pattern)
 393        (setq eshell-ls-exclude-regexp
 394              (if eshell-ls-exclude-regexp
 395                  (concat "\\(" eshell-ls-exclude-regexp "\\|"
 396                          (eshell-glob-regexp ignore-pattern) "\\)")
 397                (eshell-glob-regexp ignore-pattern))))
 398      ;; list the files!
 399      (eshell-ls-entries
 400       (mapcar (function
 401                (lambda (arg)
 402                  (cons (if (and (eshell-under-windows-p)
 403                                 (file-name-absolute-p arg))
 404                            (expand-file-name arg)
 405                          arg)
 406                        (eshell-file-attributes arg))))
 407               args)
 408       t (expand-file-name default-directory)))
 409    (funcall flush-func)))
 410
 411 (defsubst eshell-ls-printable-size (filesize &optional by-blocksize)
 412   "Return a printable FILESIZE."
 413   (eshell-printable-size filesize human-readable
 414                          (and by-blocksize block-size)
 415                          eshell-ls-use-colors))
 416
 417 (defsubst eshell-ls-size-string (attrs size-width)
 418   "Return the size string for ATTRS length, using SIZE-WIDTH."
 419   (let* ((str (eshell-ls-printable-size (nth 7 attrs) t))
 420          (len (length str)))
 421     (if (< len size-width)
 422         (concat (make-string (- size-width len) ? ) str)
 423       str)))
 424
 425 (defun eshell-ls-annotate (fileinfo)
 426   "Given a FILEINFO object, return a resolved, decorated FILEINFO.
 427 This means resolving any symbolic links, determining what face the
 428 name should be displayed as, etc.  Think of it as cooking a FILEINFO."
 429   (if (not (and (stringp (cadr fileinfo))
 430                 (or dereference-links
 431                     (eq listing-style 'long-listing))))
 432       (setcar fileinfo (eshell-ls-decorated-name fileinfo))
 433     (let (dir attr)
 434       (unless (file-name-absolute-p (cadr fileinfo))
 435         (setq dir (file-truename
 436                    (file-name-directory
 437                     (expand-file-name (car fileinfo))))))
 438       (setq attr
 439             (eshell-file-attributes
 440              (let ((target (if dir
 441                                (expand-file-name (cadr fileinfo) dir)
 442                              (cadr fileinfo))))
 443                (if dereference-links
 444                    (file-truename target)
 445                  target))))
 446       (if (or dereference-links
 447               (string-match "^\\.\\.?$" (car fileinfo)))
 448           (progn
 449             (setcdr fileinfo attr)
 450             (setcar fileinfo (eshell-ls-decorated-name fileinfo)))
 451         (assert (eq listing-style 'long-listing))
 452         (setcar fileinfo
 453                 (concat (eshell-ls-decorated-name fileinfo) " -> "
 454                         (eshell-ls-decorated-name
 455                          (cons (cadr fileinfo) attr)))))))
 456   fileinfo)
 457
 458 (defun eshell-ls-file (fileinfo &optional size-width copy-fileinfo)
 459   "Output FILE in long format.
 460 FILE may be a string, or a cons cell whose car is the filename and
 461 whose cdr is the list of file attributes."
 462   (if (not (cdr fileinfo))
 463       (funcall error-func (format "%s: No such file or directory\n"
 464                                   (car fileinfo)))
 465     (setq fileinfo
 466           (eshell-ls-annotate (if copy-fileinfo
 467                                   (cons (car fileinfo)
 468                                         (cdr fileinfo))
 469                                 fileinfo)))
 470     (let ((file (car fileinfo))
 471           (attrs (cdr fileinfo)))
 472       (if (not (eq listing-style 'long-listing))
 473           (if show-size
 474               (funcall insert-func (eshell-ls-size-string attrs size-width)
 475                        " " file "\n")
 476             (funcall insert-func file "\n"))
 477         (let ((line
 478                (concat
 479                 (if show-size
 480                     (concat (eshell-ls-size-string attrs size-width) " "))
 481                 (format
 482                  "%s%4d %-8s %-8s "
 483                  (or (nth 8 attrs) "??????????")
 484                  (or (nth 1 attrs) 0)
 485                  (or (let ((user (nth 2 attrs)))
 486                        (and (not numeric-uid-gid)
 487                             user
 488                             (eshell-substring
 489                              (if (numberp user)
 490                                  (user-login-name user)
 491                                user) 8)))
 492                      (nth 2 attrs)
 493                      "")
 494                  (or (let ((group (nth 3 attrs)))
 495                        (and (not numeric-uid-gid)
 496                             group
 497                             (eshell-substring
 498                              (if (numberp group)
 499                                  (eshell-group-name group)
 500                                group) 8)))
 501                      (nth 3 attrs)
 502                      ""))
 503                 (let* ((str (eshell-ls-printable-size (nth 7 attrs)))
 504                        (len (length str)))
 505                   (if (< len (or size-width 4))
 506                       (concat (make-string (- (or size-width 4) len) ? ) str)
 507                     str))
 508                 " " (format-time-string
 509                      (concat
 510                       "%b %e "
 511                       (if (= (nth 5 (decode-time (current-time)))
 512                              (nth 5 (decode-time
 513                                      (nth (cond
 514                                            ((eq sort-method 'by-atime) 4)
 515                                            ((eq sort-method 'by-ctime) 6)
 516                                            (t 5)) attrs))))
 517                           "%H:%M"
 518                         " %Y")) (nth (cond
 519                         ((eq sort-method 'by-atime) 4)
 520                         ((eq sort-method 'by-ctime) 6)
 521                         (t 5)) attrs)) " ")))
 522           (funcall insert-func line file "\n"))))))
 523
 524 (defun eshell-ls-dir (dirinfo &optional insert-name root-dir size-width)
 525   "Output the entries in DIRINFO.
 526 If INSERT-NAME is non-nil, the name of DIRINFO will be output.  If
 527 ROOT-DIR is also non-nil, and a directory name, DIRINFO will be output
 528 relative to that directory."
 529   (let ((dir (car dirinfo)))
 530     (if (not (cdr dirinfo))
 531         (funcall error-func (format "%s: No such file or directory\n" dir))
 532       (if dir-literal
 533           (eshell-ls-file dirinfo size-width)
 534         (if insert-name
 535             (funcall insert-func
 536                      (eshell-ls-decorated-name
 537                       (cons (concat
 538                              (if root-dir
 539                                  (file-relative-name dir root-dir)
 540                                (expand-file-name dir)))
 541                             (cdr dirinfo))) ":\n"))
 542         (let ((entries (eshell-directory-files-and-attributes
 543                         dir nil (and (not show-all)
 544                                      eshell-ls-exclude-hidden
 545                                      "\\`[^.]") t)))
 546           (when (and (not show-all) eshell-ls-exclude-regexp)
 547             (while (and entries (string-match eshell-ls-exclude-regexp
 548                                               (caar entries)))
 549               (setq entries (cdr entries)))
 550             (let ((e entries))
 551               (while (cdr e)
 552                 (if (string-match eshell-ls-exclude-regexp (car (cadr e)))
 553                     (setcdr e (cddr e))
 554                   (setq e (cdr e))))))
 555           (when (or (eq listing-style 'long-listing) show-size)
 556             (let ((total 0.0))
 557               (setq size-width 0)
 558               (eshell-for e entries
 559                 (if (nth 7 (cdr e))
 560                     (setq total (+ total (nth 7 (cdr e)))
 561                           size-width
 562                           (max size-width
 563                                (length (eshell-ls-printable-size
 564                                         (nth 7 (cdr e)) t))))))
 565               (funcall insert-func "total "
 566                        (eshell-ls-printable-size total t) "\n")))
 567           (let ((default-directory (expand-file-name dir)))
 568             (if show-recursive
 569                 (eshell-ls-entries
 570                  (let ((e entries) (good-entries (list t)))
 571                    (while e
 572                      (unless (let ((len (length (caar e))))
 573                                (and (eq (aref (caar e) 0) ?.)
 574                                     (or (= len 1)
 575                                         (and (= len 2)
 576                                              (eq (aref (caar e) 1) ?.)))))
 577                        (nconc good-entries (list (car e))))
 578                      (setq e (cdr e)))
 579                    (cdr good-entries))
 580                  nil root-dir)
 581               (eshell-ls-files (eshell-ls-sort-entries entries)
 582                                size-width))))))))
 583
 584 (defsubst eshell-ls-compare-entries (l r inx func)
 585   "Compare the time of two files, L and R, the attribute indexed by INX."
 586   (let ((lt (nth inx (cdr l)))
 587         (rt (nth inx (cdr r))))
 588     (if (equal lt rt)
 589         (string-lessp (directory-file-name (car l))
 590                       (directory-file-name (car r)))
 591       (funcall func rt lt))))
 592
 593 (defun eshell-ls-sort-entries (entries)
 594   "Sort the given ENTRIES, which may be files, directories or both.
 595 In Eshell's implementation of ls, ENTRIES is always reversed."
 596   (if (eq sort-method 'unsorted)
 597       (nreverse entries)
 598     (sort entries
 599           (function
 600            (lambda (l r)
 601              (let ((result
 602                     (cond
 603                      ((eq sort-method 'by-atime)
 604                       (eshell-ls-compare-entries l r 4 'eshell-time-less-p))
 605                      ((eq sort-method 'by-mtime)
 606                       (eshell-ls-compare-entries l r 5 'eshell-time-less-p))
 607                      ((eq sort-method 'by-ctime)
 608                       (eshell-ls-compare-entries l r 6 'eshell-time-less-p))
 609                      ((eq sort-method 'by-size)
 610                       (eshell-ls-compare-entries l r 7 '<))
 611                      ((eq sort-method 'by-extension)
 612                       (let ((lx (file-name-extension
 613                                  (directory-file-name (car l))))
 614                             (rx (file-name-extension
 615                                  (directory-file-name (car r)))))
 616                         (cond
 617                          ((or (and (not lx) (not rx))
 618                               (equal lx rx))
 619                           (string-lessp (directory-file-name (car l))
 620                                         (directory-file-name (car r))))
 621                          ((not lx) t)
 622                          ((not rx) nil)
 623                          (t
 624                           (string-lessp lx rx)))))
 625                      (t
 626                       (string-lessp (directory-file-name (car l))
 627                                     (directory-file-name (car r)))))))
 628                (if reverse-list
 629                    (not result)
 630                  result)))))))
 631
 632 (defun eshell-ls-files (files &optional size-width copy-fileinfo)
 633   "Output a list of FILES.
 634 Each member of FILES is either a string or a cons cell of the form
 635 \(FILE .  ATTRS)."
 636   (if (memq listing-style '(long-listing single-column))
 637       (eshell-for file files
 638         (if file
 639             (eshell-ls-file file size-width copy-fileinfo)))
 640     (let ((f files)
 641           last-f
 642           display-files
 643           ignore)
 644       (while f
 645         (if (cdar f)
 646             (setq last-f f
 647                   f (cdr f))
 648           (unless ignore
 649             (funcall error-func
 650                      (format "%s: No such file or directory\n" (caar f))))
 651           (if (eq f files)
 652               (setq files (cdr files)
 653                     f files)
 654             (if (not (cdr f))
 655                 (progn
 656                   (setcdr last-f nil)
 657                   (setq f nil))
 658               (setcar f (cadr f))
 659               (setcdr f (cddr f))))))
 660       (if (not show-size)
 661           (setq display-files (mapcar 'eshell-ls-annotate files))
 662         (eshell-for file files
 663           (let* ((str (eshell-ls-printable-size (nth 7 (cdr file)) t))
 664                  (len (length str)))
 665             (if (< len size-width)
 666                 (setq str (concat (make-string (- size-width len) ? ) str)))
 667             (setq file (eshell-ls-annotate file)
 668                   display-files (cons (cons (concat str " " (car file))
 669                                             (cdr file))
 670                                       display-files))))
 671         (setq display-files (nreverse display-files)))
 672       (let* ((col-vals
 673               (if (eq listing-style 'by-columns)
 674                   (eshell-ls-find-column-lengths display-files)
 675                 (assert (eq listing-style 'by-lines))
 676                 (eshell-ls-find-column-widths display-files)))
 677              (col-widths (car col-vals))
 678              (display-files (cdr col-vals))
 679              (columns (length col-widths))
 680              (col-index 1)
 681              need-return)
 682         (eshell-for file display-files
 683           (let ((name
 684                  (if (car file)
 685                      (if show-size
 686                          (concat (substring (car file) 0 size-width)
 687                                  (eshell-ls-decorated-name
 688                                   (cons (substring (car file) size-width)
 689                                         (cdr file))))
 690                        (eshell-ls-decorated-name file))
 691                    "")))
 692             (if (< col-index columns)
 693                 (setq need-return
 694                       (concat need-return name
 695                               (make-string
 696                                (max 0 (- (aref col-widths
 697                                                (1- col-index))
 698                                          (length name))) ? ))
 699                       col-index (1+ col-index))
 700               (funcall insert-func need-return name "\n")
 701               (setq col-index 1 need-return nil))))
 702         (if need-return
 703             (funcall insert-func need-return "\n"))))))
 704
 705 (defun eshell-ls-entries (entries &optional separate root-dir)
 706   "Output PATH's directory ENTRIES, formatted according to OPTIONS.
 707 Each member of ENTRIES may either be a string or a cons cell, the car
 708 of which is the file name, and the cdr of which is the list of
 709 attributes.
 710 If SEPARATE is non-nil, directories name will be entirely separated
 711 from the filenames.  This is the normal behavior, except when doing a
 712 recursive listing.
 713 ROOT-DIR, if non-nil, specifies the root directory of the listing, to
 714 which non-absolute directory names will be made relative if ever they
 715 need to be printed."
 716   (let (dirs files show-names need-return (size-width 0))
 717     (eshell-for entry entries
 718       (if (and (not dir-literal)
 719                (or (eshell-ls-filetype-p (cdr entry) ?d)
 720                    (and (eshell-ls-filetype-p (cdr entry) ?l)
 721                         (file-directory-p (car entry)))))
 722           (progn
 723             (unless separate
 724               (setq files (cons entry files)
 725                     size-width
 726                     (if show-size
 727                         (max size-width
 728                              (length (eshell-ls-printable-size
 729                                       (nth 7 (cdr entry)) t))))))
 730             (setq dirs (cons entry dirs)))
 731         (setq files (cons entry files)
 732               size-width
 733               (if show-size
 734                   (max size-width
 735                        (length (eshell-ls-printable-size
 736                                 (nth 7 (cdr entry)) t)))))))
 737     (when files
 738       (eshell-ls-files (eshell-ls-sort-entries files)
 739                        size-width show-recursive)
 740       (setq need-return t))
 741     (setq show-names (or show-recursive
 742                          (> (+ (length files) (length dirs)) 1)))
 743     (eshell-for dir (eshell-ls-sort-entries dirs)
 744       (if (and need-return (not dir-literal))
 745           (funcall insert-func "\n"))
 746       (eshell-ls-dir dir show-names
 747                      (unless (file-name-absolute-p (car dir)) root-dir)
 748                      size-width)
 749       (setq need-return t))))
 750
 751 (defun eshell-ls-find-column-widths (files)
 752   "Find the best fitting column widths for FILES.
 753 It will be returned as a vector, whose length is the number of columns
 754 to use, and each member of which is the width of that column
 755 \(including spacing)."
 756   (let* ((numcols 0)
 757          (width 0)
 758          (widths
 759           (mapcar
 760            (function
 761             (lambda (file)
 762               (+ 2 (length (car file)))))
 763            files))
 764          ;; must account for the added space...
 765          (max-width (+ (window-width) 2))
 766          (best-width 0)
 767          col-widths)
 768
 769     ;; determine the largest number of columns in the first row
 770     (let ((w widths))
 771       (while (and w (< width max-width))
 772         (setq width (+ width (car w))
 773               numcols (1+ numcols)
 774               w (cdr w))))
 775
 776     ;; refine it based on the following rows
 777     (while (> numcols 0)
 778       (let ((i 0)
 779             (colw (make-vector numcols 0))
 780             (w widths))
 781         (while w
 782           (if (= i numcols)
 783               (setq i 0))
 784           (aset colw i (max (aref colw i) (car w)))
 785           (setq w (cdr w) i (1+ i)))
 786         (setq i 0 width 0)
 787         (while (< i numcols)
 788           (setq width (+ width (aref colw i))
 789                 i (1+ i)))
 790         (if (and (< width max-width)
 791                  (> width best-width))
 792             (setq col-widths colw
 793                   best-width width)))
 794       (setq numcols (1- numcols)))
 795
 796     (cons (or col-widths (vector max-width)) files)))
 797
 798 (defun eshell-ls-find-column-lengths (files)
 799   "Find the best fitting column lengths for FILES.
 800 It will be returned as a vector, whose length is the number of columns
 801 to use, and each member of which is the width of that column
 802 \(including spacing)."
 803   (let* ((numcols 1)
 804          (width 0)
 805          (widths
 806           (mapcar
 807            (function
 808             (lambda (file)
 809               (+ 2 (length (car file)))))
 810            files))
 811          (max-width (+ (window-width) 2))
 812          col-widths
 813          colw)
 814
 815     ;; refine it based on the following rows
 816     (while numcols
 817       (let* ((rows (ceiling (/ (length widths)
 818                                (float numcols))))
 819              (w widths)
 820              (len (* rows numcols))
 821              (index 0)
 822              (i 0))
 823         (setq width 0)
 824         (unless (or (= rows 0)
 825                     (<= (/ (length widths) (float rows))
 826                         (float (1- numcols))))
 827           (setq colw (make-vector numcols 0))
 828           (while (> len 0)
 829             (if (= i numcols)
 830                 (setq i 0 index (1+ index)))
 831             (aset colw i
 832                   (max (aref colw i)
 833                        (or (nth (+ (* i rows) index) w) 0)))
 834             (setq len (1- len) i (1+ i)))
 835           (setq i 0)
 836           (while (< i numcols)
 837             (setq width (+ width (aref colw i))
 838                   i (1+ i))))
 839         (if (>= width max-width)
 840             (setq numcols nil)
 841           (if colw
 842               (setq col-widths colw))
 843           (if (>= numcols (length widths))
 844               (setq numcols nil)
 845             (setq numcols (1+ numcols))))))
 846
 847     (if (not col-widths)
 848         (cons (vector max-width) files)
 849       (setq numcols (length col-widths))
 850       (let* ((rows (ceiling (/ (length widths)
 851                                (float numcols))))
 852              (len (* rows numcols))
 853              (newfiles (make-list len nil))
 854              (index 0)
 855              (i 0)
 856              (j 0))
 857         (while (< j len)
 858           (if (= i numcols)
 859               (setq i 0 index (1+ index)))
 860           (setcar (nthcdr j newfiles)
 861                   (nth (+ (* i rows) index) files))
 862           (setq j (1+ j) i (1+ i)))
 863         (cons col-widths newfiles)))))
 864
 865 (defun eshell-ls-decorated-name (file)
 866   "Return FILE, possibly decorated.
 867 Use TRUENAME for predicate tests, if passed."
 868   (if eshell-ls-use-colors
 869       (let ((face
 870              (cond
 871               ((not (cdr file))
 872                'eshell-ls-missing)
 873
 874               ((stringp (cadr file))
 875                'eshell-ls-symlink)
 876
 877               ((eq (cadr file) t)
 878                'eshell-ls-directory)
 879
 880               ((not (eshell-ls-filetype-p (cdr file) ?-))
 881                'eshell-ls-special)
 882
 883               ((and (/= (user-uid) 0) ; root can execute anything
 884                     (eshell-ls-applicable (cdr file) 3
 885                                           'file-executable-p (car file)))
 886                'eshell-ls-executable)
 887
 888               ((not (eshell-ls-applicable (cdr file) 1
 889                                           'file-readable-p (car file)))
 890                'eshell-ls-unreadable)
 891
 892               ((string-match eshell-ls-archive-regexp (car file))
 893                'eshell-ls-archive)
 894
 895               ((string-match eshell-ls-backup-regexp (car file))
 896                'eshell-ls-backup)
 897
 898               ((string-match eshell-ls-product-regexp (car file))
 899                'eshell-ls-product)
 900
 901               ((string-match eshell-ls-clutter-regexp (car file))
 902                'eshell-ls-clutter)
 903
 904               ((not (eshell-ls-applicable (cdr file) 2
 905                                           'file-writable-p (car file)))
 906                'eshell-ls-readonly)
 907               (eshell-ls-highlight-alist
 908                (let ((tests eshell-ls-highlight-alist)
 909                      value)
 910                  (while tests
 911                    (if (funcall (caar tests) (car file) (cdr file))
 912                        (setq value (cdar tests) tests nil)
 913                      (setq tests (cdr tests))))
 914                  value)))))
 915         (if face
 916             (add-text-properties 0 (length (car file))
 917                                  (list 'face face)
 918                                  (car file)))))
 919   (car file))
 920
 921 ;;; Code:
 922
 923 ;;; arch-tag: 9295181c-0cb2-499c-999b-89f5359842cb
 924 ;;; em-ls.el ends here