*** empty log message ***

[gnu-emacs] / lisp / sort.el

diff --git a/lisp/sort.el b/lisp/sort.el
index 84a2f9eec815f2d1c2cc71883ccdc28870a32603..c9230da3e915db7d8544e0d93b94bb1322a2e4b3 100644 (file)
--- a/lisp/sort.el
+++ b/lisp/sort.el
@@ -1,6 +1,7 @@
 ;;; sort.el --- commands to sort text in an Emacs buffer
 
 ;;; sort.el --- commands to sort text in an Emacs buffer
 

-;; Copyright (C) 1986, 1987, 1994, 1995, 2003 Free Software Foundation, Inc.
+;; Copyright (C) 1986, 1987, 1994, 1995, 2001, 2002, 2003,
+;;   2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.

 
 ;; Author: Howie Kaye
 ;; Maintainer: FSF
 
 ;; Author: Howie Kaye
 ;; Maintainer: FSF


@@ -8,10 +9,10 @@
 
 ;; This file is part of GNU Emacs.
 
 
 ;; This file is part of GNU Emacs.
 

-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; GNU Emacs is free software: you can redistribute it and/or modify

 ;; it under the terms of the GNU General Public License as published by
 ;; it under the terms of the GNU General Public License as published by

-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.

 
 ;; GNU Emacs is distributed in the hope that it will be useful,
 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 
 ;; GNU Emacs is distributed in the hope that it will be useful,
 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of


@@ -19,9 +20,7 @@
 ;; GNU General Public License for more details.
 
 ;; You should have received a copy of the GNU General Public License
 ;; GNU General Public License for more details.
 
 ;; You should have received a copy of the GNU General Public License

-;; along with GNU Emacs; see the file COPYING.  If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

 
 ;;; Commentary:
 
 
 ;;; Commentary:
 


@@ -35,12 +34,14 @@
   :group 'data)
 
 (defcustom sort-fold-case nil
   :group 'data)
 
 (defcustom sort-fold-case nil

-  "*Non-nil if the buffer sort functions should ignore case."
+  "Non-nil if the buffer sort functions should ignore case."

   :group 'sort
   :type 'boolean)
   :group 'sort
   :type 'boolean)

+;;;###autoload(put 'sort-fold-case 'safe-local-variable 'booleanp)

 
 ;;;###autoload
 
 ;;;###autoload

-(defun sort-subr (reverse nextrecfun endrecfun &optional startkeyfun endkeyfun)
+(defun sort-subr (reverse nextrecfun endrecfun
+                         &optional startkeyfun endkeyfun predicate)

   "General text sorting routine to divide buffer into records and sort them.
 
 We divide the accessible portion of the buffer into disjoint pieces
   "General text sorting routine to divide buffer into records and sort them.
 
 We divide the accessible portion of the buffer into disjoint pieces


@@ -74,7 +75,10 @@ starts at the beginning of the record.
 
 ENDKEYFUN moves from the start of the sort key to the end of the sort key.
 ENDKEYFUN may be nil if STARTKEYFUN returns a value or if it would be the
 
 ENDKEYFUN moves from the start of the sort key to the end of the sort key.
 ENDKEYFUN may be nil if STARTKEYFUN returns a value or if it would be the

-same as ENDRECFUN."
+same as ENDRECFUN.
+
+PREDICATE is the function to use to compare keys.  If keys are numbers,
+it defaults to `<', otherwise it defaults to `string<'."

   ;; Heuristically try to avoid messages if sorting a small amt of text.
   (let ((messages (> (- (point-max) (point-min)) 50000)))
     (save-excursion
   ;; Heuristically try to avoid messages if sorting a small amt of text.
   (let ((messages (> (- (point-max) (point-min)) 50000)))
     (save-excursion


@@ -88,32 +92,18 @@ same as ENDRECFUN."
          (or reverse (setq sort-lists (nreverse sort-lists)))
          (if messages (message "Sorting records..."))
          (setq sort-lists
          (or reverse (setq sort-lists (nreverse sort-lists)))
          (if messages (message "Sorting records..."))
          (setq sort-lists

-               (if (fboundp 'sortcar)
-                   (sortcar sort-lists
-                            (cond ((numberp (car (car sort-lists)))
-                                   ;; This handles both ints and floats.
-                                   '<)
-                                  ((consp (car (car sort-lists)))
-                                   (function
-                                    (lambda (a b)
-                                      (> 0 (compare-buffer-substrings
-                                            nil (car a) (cdr a)
-                                            nil (car b) (cdr b))))))
-                                  (t
-                                   'string<)))
-                 (sort sort-lists
-                       (cond ((numberp (car (car sort-lists)))
-                              'car-less-than-car)
-                             ((consp (car (car sort-lists)))
-                              (function
-                               (lambda (a b)
-                                 (> 0 (compare-buffer-substrings
-                                       nil (car (car a)) (cdr (car a))
-                                       nil (car (car b)) (cdr (car b)))))))
-                             (t
-                              (function
-                               (lambda (a b)
-                                 (string< (car a) (car b)))))))))
+               (sort sort-lists
+                     (cond (predicate
+                            `(lambda (a b) (,predicate (car a) (car b))))
+                           ((numberp (car (car sort-lists)))
+                            'car-less-than-car)
+                           ((consp (car (car sort-lists)))
+                            (lambda (a b)
+                              (> 0 (compare-buffer-substrings
+                                    nil (car (car a)) (cdr (car a))
+                                    nil (car (car b)) (cdr (car b))))))
+                           (t
+                            (lambda (a b) (string< (car a) (car b)))))))

          (if reverse (setq sort-lists (nreverse sort-lists)))
          (if messages (message "Reordering buffer..."))
          (sort-reorder-buffer sort-lists old)))
          (if reverse (setq sort-lists (nreverse sort-lists)))
          (if messages (message "Reordering buffer..."))
          (sort-reorder-buffer sort-lists old)))


@@ -150,15 +140,14 @@ same as ENDRECFUN."
       (cond ((prog1 done (setq done nil)))
            (endrecfun (funcall endrecfun))
            (nextrecfun (funcall nextrecfun) (setq done t)))
       (cond ((prog1 done (setq done nil)))
            (endrecfun (funcall endrecfun))
            (nextrecfun (funcall nextrecfun) (setq done t)))

-      (if key (setq sort-lists (cons
-                                ;; consing optimization in case in which key
-                                ;; is same as record.
-                                (if (and (consp key)
-                                         (equal (car key) start-rec)
-                                         (equal (cdr key) (point)))
-                                    (cons key key)
-                                  (cons key (cons start-rec (point))))
-                                sort-lists)))
+      (if key (push
+              ;; consing optimization in case in which key is same as record.
+              (if (and (consp key)
+                       (equal (car key) start-rec)
+                       (equal (cdr key) (point)))
+                  (cons key key)
+                (cons key (cons start-rec (point))))
+              sort-lists))

       (and (not done) nextrecfun (funcall nextrecfun)))
     sort-lists))
 
       (and (not done) nextrecfun (funcall nextrecfun)))
     sort-lists))
 


@@ -166,8 +155,10 @@ same as ENDRECFUN."
   (let ((last (point-min))
        (min (point-min)) (max (point-max))
        (old-buffer (current-buffer))
   (let ((last (point-min))
        (min (point-min)) (max (point-max))
        (old-buffer (current-buffer))

+        (mb enable-multibyte-characters)

        temp-buffer)
     (with-temp-buffer
        temp-buffer)
     (with-temp-buffer

+      (set-buffer-multibyte mb)

       ;; Record the temporary buffer.
       (setq temp-buffer (current-buffer))
 
       ;; Record the temporary buffer.
       (setq temp-buffer (current-buffer))
 


@@ -192,16 +183,13 @@ same as ENDRECFUN."
       (set-buffer old-buffer)
       (let ((inhibit-quit t))
        ;; Make sure insertions done for reordering
       (set-buffer old-buffer)
       (let ((inhibit-quit t))
        ;; Make sure insertions done for reordering

-       ;; do not go after any markers at the end of the sorted region,
-       ;; by inserting a space to separate them.
-       (goto-char max)
-       (insert-before-markers " ")
-       ;; Delete the original copy of the text.
-       (delete-region min max)
-       ;; Now replace the separator " " with the sorted text.
-       (goto-char (point-max))
+       ;; saves any markers at the end of the sorted region,
+       ;; by leaving the last character of the region.
+       (delete-region min (1- max))
+       ;; Now replace the one remaining old character with the sorted text.
+       (goto-char (point-min))

        (insert-buffer-substring temp-buffer)
        (insert-buffer-substring temp-buffer)

-       (delete-region min (1+ min))))))
+       (delete-region max (1+ max))))))

 
 ;;;###autoload
 (defun sort-lines (reverse beg end)
 
 ;;;###autoload
 (defun sort-lines (reverse beg end)


@@ -215,7 +203,9 @@ the sort order."
     (save-restriction
       (narrow-to-region beg end)
       (goto-char (point-min))
     (save-restriction
       (narrow-to-region beg end)
       (goto-char (point-min))

-      (sort-subr reverse 'forward-line 'end-of-line))))
+      (let ;; To make `end-of-line' and etc. to ignore fields.
+         ((inhibit-field-text-motion t))
+       (sort-subr reverse 'forward-line 'end-of-line)))))

 
 ;;;###autoload
 (defun sort-paragraphs (reverse beg end)
 
 ;;;###autoload
 (defun sort-paragraphs (reverse beg end)


@@ -259,16 +249,17 @@ the sort order."
     (while (< i 256)
       (modify-syntax-entry i "w" table)
       (setq i (1+ i)))
     (while (< i 256)
       (modify-syntax-entry i "w" table)
       (setq i (1+ i)))

-    (modify-syntax-entry ?\  " " table)
+    (modify-syntax-entry ?\s " " table)

     (modify-syntax-entry ?\t " " table)
     (modify-syntax-entry ?\n " " table)
     (modify-syntax-entry ?\. "_" table)        ; for floating pt. numbers. -wsr
     (setq sort-fields-syntax-table table)))
 
 (defcustom sort-numeric-base 10
     (modify-syntax-entry ?\t " " table)
     (modify-syntax-entry ?\n " " table)
     (modify-syntax-entry ?\. "_" table)        ; for floating pt. numbers. -wsr
     (setq sort-fields-syntax-table table)))
 
 (defcustom sort-numeric-base 10

-  "*The default base used by `sort-numeric-fields'."
+  "The default base used by `sort-numeric-fields'."

   :group 'sort
   :type 'integer)
   :group 'sort
   :type 'integer)

+;;;###autoload(put 'sort-numeric-base 'safe-local-variable 'integerp)

 
 ;;;###autoload
 (defun sort-numeric-fields (field beg end)
 
 ;;;###autoload
 (defun sort-numeric-fields (field beg end)


@@ -281,25 +272,27 @@ With a negative arg, sorts by the ARGth field counted from the right.
 Called from a program, there are three arguments:
 FIELD, BEG and END.  BEG and END specify region to sort."
   (interactive "p\nr")
 Called from a program, there are three arguments:
 FIELD, BEG and END.  BEG and END specify region to sort."
   (interactive "p\nr")

-  (sort-fields-1 field beg end
-                (lambda ()
-                  (sort-skip-fields field)
-                  (let* ((case-fold-search t)
-                         (base
-                          (if (looking-at "\\(0x\\)[0-9a-f]\\|\\(0\\)[0-7]")
-                              (cond ((match-beginning 1)
-                                     (goto-char (match-end 1))
-                                     16)
-                                    ((match-beginning 2)
-                                     (goto-char (match-end 2))
-                                     8)
-                                    (t nil)))))
-                    (string-to-number (buffer-substring (point)
-                                                        (save-excursion
-                                                          (forward-sexp 1)
-                                                          (point)))
-                                      (or base sort-numeric-base))))
-                nil))
+  (let ;; To make `end-of-line' and etc. to ignore fields.
+      ((inhibit-field-text-motion t))
+    (sort-fields-1 field beg end
+                  (lambda ()
+                    (sort-skip-fields field)
+                    (let* ((case-fold-search t)
+                           (base
+                            (if (looking-at "\\(0x\\)[0-9a-f]\\|\\(0\\)[0-7]")
+                                (cond ((match-beginning 1)
+                                       (goto-char (match-end 1))
+                                       16)
+                                      ((match-beginning 2)
+                                       (goto-char (match-end 2))
+                                       8)
+                                      (t nil)))))
+                      (string-to-number (buffer-substring (point)
+                                                          (save-excursion
+                                                            (forward-sexp 1)
+                                                            (point)))
+                                        (or base sort-numeric-base))))
+                  nil)))

 
 ;;;;;###autoload
 ;;(defun sort-float-fields (field beg end)
 
 ;;;;;###autoload
 ;;(defun sort-float-fields (field beg end)


@@ -332,11 +325,13 @@ FIELD, BEG and END.  BEG and END specify region to sort.
 The variable `sort-fold-case' determines whether alphabetic case affects
 the sort order."
   (interactive "p\nr")
 The variable `sort-fold-case' determines whether alphabetic case affects
 the sort order."
   (interactive "p\nr")

-  (sort-fields-1 field beg end
-                (function (lambda ()
-                            (sort-skip-fields field)
-                            nil))
-                (function (lambda () (skip-chars-forward "^ \t\n")))))
+  (let ;; To make `end-of-line' and etc. to ignore fields.
+      ((inhibit-field-text-motion t))
+    (sort-fields-1 field beg end
+                  (function (lambda ()
+                              (sort-skip-fields field)
+                              nil))
+                  (function (lambda () (skip-chars-forward "^ \t\n"))))))

 
 (defun sort-fields-1 (field beg end startkeyfun endkeyfun)
   (let ((tbl (syntax-table)))
 
 (defun sort-fields-1 (field beg end startkeyfun endkeyfun)
   (let ((tbl (syntax-table)))


@@ -481,7 +476,9 @@ it uses the `sort' utility program, which doesn't understand tabs.
 Use \\[untabify] to convert tabs to spaces before sorting."
   (interactive "P\nr")
   (save-excursion
 Use \\[untabify] to convert tabs to spaces before sorting."
   (interactive "P\nr")
   (save-excursion

-    (let (beg1 end1 col-beg1 col-end1 col-start col-end)
+    (let ;; To make `end-of-line' and etc. to ignore fields.
+       ((inhibit-field-text-motion t)
+        beg1 end1 col-beg1 col-end1 col-start col-end)

       (goto-char (min beg end))
       (setq col-beg1 (current-column))
       (beginning-of-line)
       (goto-char (min beg end))
       (setq col-beg1 (current-column))
       (beginning-of-line)


@@ -494,19 +491,32 @@ Use \\[untabify] to convert tabs to spaces before sorting."
       (setq col-end (max col-beg1 col-end1))
       (if (search-backward "\t" beg1 t)
          (error "sort-columns does not work with tabs -- use M-x untabify"))
       (setq col-end (max col-beg1 col-end1))
       (if (search-backward "\t" beg1 t)
          (error "sort-columns does not work with tabs -- use M-x untabify"))

-      (if (not (or (eq system-type 'vax-vms)
-                  (text-properties-at beg1)
-                  (< (next-property-change beg1 nil end1) end1)))
+      (if (not (or (memq system-type '(windows-nt))
+                  (let ((pos beg1) plist fontified)
+                    (catch 'found
+                      (while (< pos end1)
+                        (setq plist (text-properties-at pos))
+                        (setq fontified (plist-get plist 'fontified))
+                        (while (consp plist)
+                          (unless (or (eq (car plist) 'fontified)
+                                      (and (eq (car plist) 'face)
+                                           fontified))
+                            (throw 'found t))
+                          (setq plist (cddr plist)))
+                        (setq pos (next-property-change pos nil end1)))))))

          ;; Use the sort utility if we can; it is 4 times as fast.
          ;; Use the sort utility if we can; it is 4 times as fast.

-         ;; Do not use it if there are any properties in the region,
-         ;; since the sort utility would lose the properties.
-         (let ((sort-args (list (if reverse "-rt\n" "-t\n")
-                                (concat "+0." (int-to-string col-start))
-                                (concat "-0." (int-to-string col-end)))))
+         ;; Do not use it if there are any non-font-lock properties
+         ;; in the region, since the sort utility would lose the
+         ;; properties.  Tabs are used as field separator; on NetBSD,
+         ;; sort complains if "\n" is used as field separator.
+         (let ((sort-args (list (if reverse "-rt\t" "-t\t")
+                                (format "-k1.%d,1.%d"
+                                        (1+ col-start)
+                                        (1+ col-end)))))

            (when sort-fold-case
              (push "-f" sort-args))
            (apply #'call-process-region beg1 end1 "sort" t t nil sort-args))
            (when sort-fold-case
              (push "-f" sort-args))
            (apply #'call-process-region beg1 end1 "sort" t t nil sort-args))

-       ;; On VMS, use Emacs's own facilities.
+       ;; On ms-windows, use Emacs's own facilities.

        (save-excursion
          (save-restriction
            (narrow-to-region beg1 end1)
        (save-excursion
          (save-restriction
            (narrow-to-region beg1 end1)


@@ -549,4 +559,5 @@ From a program takes two point or marker arguments, BEG and END."
 
 (provide 'sort)
 
 
 (provide 'sort)
 

+;; arch-tag: fbac12be-2a7b-4c8a-9665-264d61f70bd9

 ;;; sort.el ends here
 ;;; sort.el ends here