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