;;; dired-sort.el --- Sort by by size, date, field, name and type

;; This file is not part of Emacs

;; {{{ Id

;; Maintainer:      Jari Aalto
;; Created:         1989-03
;; Keywords:        extensions
;;
;; This program is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by the Free
;; Software Foundation; either version 2 of the License, or (at your option)
;; any later version.
;;
;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
;; for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with program; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;
;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information

;; }}}
;; {{{ Install

;;; Install:

;;  Put this file on your Emacs-Lisp load path, add following into your
;;  ~/.emacs startup file.
;;
;;      (add-hook 'dired-mode-hook '(lambda () (require 'dired-sort)))
;;
;;  NOTE: ls-lisp.el, which dired.el uses, by default inserts month names
;;  in national format. If the setting is anything other than English,
;;  this module *cannot* parse the dired lines. Please add this setting
;;  to your Emacs (21.4+) to make dired listing use ISO 8601 date stamps:
;;
;;   (setq ls-lisp-format-time-list
;;       '("%Y-%m-%d %H:%M"
;;         "%Y-%m-%d      "))

;; }}}
;; {{{

;;; Commentary:

;;
;;  Preface, Nov 1997
;;
;;      Not much to say. I have had this package lying in my lisp directory
;;      since Emacs 18.xx days. When I noticed that this package doesn't
;;      exist in the OHIO archive, neither did the ftpsearch locate it,
;;      I decided to clen it up and put publically available.
;;
;;      The original author is unknown And the only thing that was in the
;;      original documentation was this line:
;;
;;      $Header: /tmp_mnt/am/p7/utility/gmacs/f2/RCS/dired-resort.el,v
;;      1.1 88/11/03 13:22:08 fad Exp $
;;
;;  New bindings in dired
;;
;;      When you load this file, function `dired-sort-default-keys' is called.
;;      The following bindings to dired mode are defined.
;;
;;          S" "    dired-sort-resort    (that's an "s" + SPACE)
;;          Ss      dired-sort-by-size
;;          Sd      dired-sort-by-date
;;          Sf      dired-sort-by-field
;;          Sn      dired-sort-by-name
;;          St      dired-sort-by-type
;;
;; }}}

;;; Change Log:

;;; Code:

(require 'date-parse)

(eval-and-compile
  ;;  Silence Byte compiler
  (defvar revert-buffer-function)
  (defvar current-prefix-arg) ;; Elint.el
  ;; Not exported from sort.el
  (autoload 'sort-subr                "sort")
  (autoload 'sort-fields-1            "sort")
  (autoload 'dired-revert             "dired")
  (autoload 'dired-get-filename       "dired")
  (autoload 'dired-move-to-filename   "dired")
  (autoload 'sort-skip-fields         "sort"))

;;; ....................................................... &variables ...

(defvar dired-sort-load-hook '(dired-sort-default-keys)
  "Hook run when file is loaded.")

;; File property caching mechanism for dired

(defvar dired-sort-line-property-table nil
  "Buffer local obarray:
Each symbol is a file name whose plist caches file properties,
accessed by #'dired-line-property")
(make-variable-buffer-local 'dired-sort-line-property-table)

(defvar dired-sort-resort-last-kind '(date)
  "What the last sort did to the buffer.")
(make-variable-buffer-local 'dired-sort-resort-last-kind)

(defvar dired-sort-resort-alist
  '(("name" dired-sort-by-name nil "ascending order")
    (nil dired-sort-by-name t "descending order")
    ("date" dired-sort-by-date nil "most recent first")
    (nil dired-sort-by-date t "oldest first")
    ("size" dired-sort-by-size nil "biggest first")
    (nil dired-sort-by-size t "smallest first")
    ("type" dired-sort-by-type t "alphabetically")
    ("modes" dired-sort-by-field 1 "file modes")
    ("links" dired-sort-by-field 2 "number of links")
    ("owner" dired-sort-by-field 3 "file owner")
    ("field" dired-sort-by-field (1) "textual field")))

;;; ............................................................ &code ...

(defvar dired-sort-last-sort  nil
  "Last sort indication.")

(defun dired-sort-revert-and-decache (&optional arg noconfirm)
  "Revert buffer using `dired-revert' ARG and NOCONFIRM."
  (if dired-sort-line-property-table
      (mapatoms (function (lambda (file) (setplist file nil)))
                dired-sort-line-property-table))
  (dired-revert arg noconfirm))

(defun dired-sort-line-property (func)
  "Call FUNC with one argument:  The (absolute) file name of this dired line.
Cache the result, and return it the next time without calling FUNC.
   The caches are cleared when the buffer is reverted.
   See dired-sort-line-property-table."
  (or dired-sort-line-property-table
      (progn
        (if (eq revert-buffer-function 'dired-revert)
            (setq revert-buffer-function 'dired-sort-revert-and-decache))
        (setq dired-sort-line-property-table (make-vector 31 0))))
  (let ((file (intern (dired-get-filename t) dired-sort-line-property-table)))
    (or (get file func)
        (put file func
             (funcall func (symbol-name file))))))

(defun dired-sort-move-word-backward ()
  "move one space dlimited word backward. Must already be on word."
  (skip-chars-backward "^ \t" (line-beginning-position))
  (skip-chars-backward " \t" (line-beginning-position))
  (skip-chars-backward "^ \t" (line-beginning-position)))

;;   FIXME: It is unreliable to read words from dired buffer,
;;   because the Month name can be in national format.
;;   => There is no eas way, doing file stat() would be too
;;   expensive to find out the month name?
;;   => It is bets to configure Emacs to always use
;;   ISO dates only.

(defun dired-sort-move-to-date (&optional and-extract)
  "Details depend on the `dired-extract-size' AND-EXTRACT."
  ;;  Go two words backward
  ;;                         4694 Month 16   19:44 file
  ;; -rw-rw----   1 foo foo  2082 2004-10-14 17:23 .
  ;;                                               |
  ;;                                      start here
  (when (dired-move-to-filename)
    (let ((end (point)))
      (dired-sort-move-word-backward)
      (dired-sort-move-word-backward)
      ;;  Now, should we still take on leap due to Month name?
      (unless (looking-at "[0-9][0-9][0-9][0-9]-")
        (dired-sort-move-word-backward))
      (if and-extract
          (parse-date (buffer-substring (point) end) t)
        (point)))))

(defun dired-sort-extract-date ()
  "Call `dired-sort-move-to-date'."
  (dired-sort-move-to-date t))

(defun dired-sort-extract-size ()
  "Read size with regular expression."
  (let ((ret -1))
    (when (dired-sort-move-to-date)
      (skip-chars-backward " " (line-beginning-position))
      (skip-chars-backward "0-9" (line-beginning-position))
      (if (looking-at "[0-9]+ ")
          (setq ret (read (current-buffer)))))
    ret))

(defun dired-sort-header-line-p ()
  "Check `dired-sort-extract-size'."
  (save-excursion
    (minusp (dired-sort-extract-size))))

(defun dired-sort-first-file ()
  "Goto first file."
  (interactive)
  (goto-char (point-min))
  (while (and (dired-sort-header-line-p)
              (not (eobp)))
    (forward-line 1))
  (dired-move-to-filename))

(defun dired-sort-extract-date-key (&optional ignore)
  "Extract key with IGNORE."
  (let ((date (dired-sort-extract-date)))
    (if date
        (date-compare-key date 'integer))))

(defun dired-sort-by-size-key (&optional ignore)
  "Sort by zise or IGNORE."
  (dired-sort-by-size-key-1 nil))

(defun dired-sort-by-size-increasing-key (&optional ignore)
  "Sort by zise or IGNORE."
  (dired-sort-by-size-key-1 t))

(defun dired-sort-resort-menu-options ()
  "See `dired-sort-resort-alist'."
  (list "Help"
        (cons "Sort Dired listing by:"
              (mapcar
               (function(lambda (elt)
                          (cons
                           (format "%5s (%s)"
                                   (capitalize (or (nth 0 elt) " '' "))
                                   (nth 3 elt))
                           elt)))
               dired-sort-resort-alist))))

(defun dired-sort-by-size-key-1 (incr-p)
  "Sort possibly with INCR-P."
  (let ((size (dired-sort-extract-size))
        (char (save-excursion
                (forward-line 0)
                (skip-chars-forward " ")
                (following-char))))
    (setq char (downcase char))
    (cond
     ((not incr-p))
     ((= char ?-) (setq char ?~))
     ((>= char ?a) (setq char (- (+ ?a ?z) char))))
    (format "%c%09d" char size)))

(defun dired-sort-read-resort-args (&optional res)
  "Produce a 1- or 2- list.
Suitable for non-interactive calling of dired-sort-resort.
Optional RES is a line from dired-sort-resort-alist."
  (or res
      (setq res
            (completing-read
             (format "Sort by: [%s] " (car dired-sort-resort-last-kind))
             dired-sort-resort-alist
             nil t)))
  (if (zerop (length res))
      dired-sort-resort-last-kind
    (if (atom res)
        (setq res (or (assoc res dired-sort-resort-alist)
                      (error "reading resort"))))
    (let ((type (nth 0 res))
          (func (nth 1 res))
          (arg (nth 2 res))
          (what (nth 3 res)))
      (let ((ptr dired-sort-resort-alist) elt)
        (while (and ptr (null type))
          (setq elt (car ptr) ptr (cdr ptr))
          (if (eq func (nth 1 elt))
              (setq type (nth 0 elt)))))
      (setq type (intern type))
      (cond
       ((atom arg))
       (current-prefix-arg
        (setq arg
              (if (integerp (car arg))
                  (prefix-numeric-value current-prefix-arg)
                (and current-prefix-arg t))))
       ((integerp (car arg))
        (setq arg (read-string (format "What %s? " what))))
       (t (setq arg (y-or-n-p (format "%s? " what)))))
      (if (null arg)
          type
        (list type arg)))))

;;; ..................................................... &interactive ...

(defun dired-sort-last-file ()
  "Go to last file."
  (interactive)
  (goto-char (point-max))
  (while (and (dired-sort-header-line-p)
              (not (bobp)))
    (forward-line -1))
  (dired-move-to-filename))

(defun dired-sort-narrow-to-files ()
  "Narrow to visible files."
  (interactive)
  (narrow-to-region
   (save-excursion
     (dired-sort-first-file)
     (forward-line 0)
     (point))
   (save-excursion
     (dired-sort-last-file)
     (forward-line 1)
     (point))))

;;;###autoload
(defun dired-sort-by-date (&optional arg)
  "In dired, sort the lines by date, newest first.
With ARG, sorts oldest first."
  (interactive "P")
  (save-restriction
    (dired-sort-narrow-to-files)
    (let (buffer-read-only)
      (goto-char (point-min))
      (sort-subr
       (not arg) 'forward-line 'end-of-line
       (function
        (lambda ()
          (or (dired-sort-line-property 'dired-sort-extract-date-key)))))))
  ;; (throw key 'nil)
  (setq dired-sort-last-sort (if arg
                                 'oldest
                               'newest))
  (message "Dired-sort: Now sorted by date, %s first."
           (if arg
               "oldest"
             "newest")))

(defun dired-sort-by-name (&optional arg skip-to sort-by)
  "In dired, sort the lines by file name.
With ARG, sorts in reverse order. SKIP-TO SORT-BY."
  (interactive "P")
  (or sort-by (setq sort-by 'name))
  (save-restriction
    (dired-sort-narrow-to-files)
    (let ((buffer-read-only nil)
          (reverse-sort-p arg))
      (goto-char (point-min))
      (sort-subr
       reverse-sort-p 'forward-line 'end-of-line
       (function(lambda ()
                  (dired-move-to-filename)
                  (cond
                   ((null skip-to))
                   (reverse-sort-p
                    (let ((here (point)))
                      (end-of-line)
                      (re-search-backward
                       skip-to here 'move)))
                   ((re-search-forward
                     skip-to
                     (save-excursion (end-of-line) (point))
                     'move)
                    (goto-char (match-beginning 0))))
                  nil)))))
  (setq dired-sort-last-sort sort-by)
  (message "Dired-sort: Now sorted by %s%s." sort-by
           (if arg
               ", in reverse order"
             "")))

;;;###autoload
(defun dired-sort-by-type (&optional arg)
  "Sort by type, ARG means reverse."
  (interactive "P")
  (dired-sort-by-name
   arg (if arg
           "[.#~]"
         "[.~0-9#]+")
   'type))

;;;###autoload
(defun dired-sort-by-field (field)
  "In dired, sort the lines by FIELD (defaults to the mode field)."
  (interactive "p")
  (save-restriction
    (dired-sort-narrow-to-files)
    (let ((buffer-read-only nil))
      (goto-char (point-min))
      (sort-fields-1
       field (point-min) (point-max)
       (function(lambda ()
                  (sort-skip-fields (1- field))
                  (skip-chars-backward " ")
                  nil))
       nil)))
  (setq dired-sort-last-sort 'fields)
  (message "Dired-sort: Now sorted by %s."
           (cond ((= field 1) "file mode")
                 ((= field 2) "number of links")
                 ((= field 3) "file owner")
                 (t (format "field #%d" field)))))

;;;###autoload
(defun dired-sort-by-size (&optional arg)
  "In dired, sort the lines by file size, largest first.
With ARG, sorts in the reverse order (smallest first).
All directories are grouped together at the head of the buffer,
and other file types are also grouped."
  (interactive "P")
  (let ((buffer-read-only nil)
        (incr-p arg))
    (save-restriction
      (dired-sort-narrow-to-files)
      (goto-char (point-min))
      (sort-subr
       (not incr-p) 'forward-line 'end-of-line
       (if incr-p
           (function (lambda () (dired-sort-line-property
                                 'dired-sort-by-size-increasing-key)))
         (function (lambda () (dired-sort-line-property
                               'dired-sort-by-size-key))))))
    (setq dired-sort-last-sort (if incr-p
                                   'smallest
                                 'largest))
    (message "Dired-sort: Now sorted by type and size, %s first."
             (if incr-p
                 "smallest"
               "largest"))))

;;;###autoload
(defun dired-sort-resort (kind &optional args)
  "In dired, change the sorting of lines. Prompt for the KIND of sorting.
Non-interactively, takes a sort-kind, and an optional argument for
the associated function. To get a list of such arguments interactively,
call dired-sort-read-resort-args. ARGS are passed to sort."
  (interactive (list (dired-sort-read-resort-args)))
  (if (null kind)
      (setq kind dired-sort-resort-last-kind))
  (if (consp kind)
      (setq args (cdr kind) kind (car kind)))
  (if (symbolp kind) (setq kind (symbol-name kind)))
  (apply
   (or (nth 1 (assoc kind dired-sort-resort-alist))
       (error "No such sorting method: %s" kind))
   args)
  (setq dired-sort-resort-last-kind (cons kind args)))

;;;###autoload
(defun dired-sort-default-keys-dired-mode-map ()
  "Define default bindings to dired map."
  (interactive)
  (let* ((map (symbol-value 'dired-mode-map)))
    (unless map
      (error "dired-sort.el: [ERROR] dired is not yet loaded."))
    (define-key map  "\C-cs"  nil)
    (define-key map  "\C-cs " 'dired-sort-resort)
    (define-key map  "\C-css" 'dired-sort-by-size)
    (define-key map  "\C-csd" 'dired-sort-by-date)
    (define-key map  "\C-csf" 'dired-sort-by-field)
    (define-key map  "\C-csn" 'dired-sort-by-name)
    (define-key map  "\C-cst" 'dired-sort-by-type)))

;;;###autoload
(defun dired-sort-default-keys ()
  "Define default bindings to dired map."
  (eval-after-load "dired"
    '(progn (dired-sort-default-keys-dired-mode-map))))

;;;###autoload
(add-hook  'dired-mode-hook 'dired-sort-default-keys 'end)

(run-hooks 'dired-sort-load-hook)
(provide   'dired-sort)

;;; dired-sort.el ends here