sort.el 16.3 KB
Newer Older
Richard M. Stallman's avatar
Richard M. Stallman committed
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50
;; Commands to sort text in an Emacs buffer.
;; Copyright (C) 1986, 1987 Free Software Foundation, Inc.

;; This file is part of GNU Emacs.

;; 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
;; the Free Software Foundation; either version 1, 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
;; 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 GNU Emacs; see the file COPYING.  If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.

(provide 'sort)

;; Original version of most of this contributed by Howie Kaye

(defun sort-subr (reverse nextrecfun endrecfun &optional startkeyfun endkeyfun)
  "General text sorting routine to divide buffer into records and sort them.
Arguments are REVERSE NEXTRECFUN ENDRECFUN &optional STARTKEYFUN ENDKEYFUN.

We consider this portion of the buffer to be divided into disjoint pieces
called sort records.  A portion of each sort record (perhaps all of it)
is designated as the sort key.  The records are rearranged in the buffer
in order by their sort keys.  The records may or may not be contiguous.

Usually the records are rearranged in order of ascending sort key.
If REVERSE is non-nil, they are rearranged in order of descending sort key.

The next four arguments are functions to be called to move point
across a sort record.  They will be called many times from within sort-subr.

NEXTRECFUN is called with point at the end of the previous record.
It moves point to the start of the next record.
It should move point to the end of the buffer if there are no more records.
The first record is assumed to start at the position of point when sort-subr
is called.

ENDRECFUN is is called with point within the record.
It should move point to the end of the record.

STARTKEYFUN may moves from the start of the record to the start of the key.
It may return either return a non-nil value to be used as the key, or
else the key will be the substring between the values of point after
51 52
STARTKEYFUN and ENDKEYFUN are called.  If STARTKEYFUN is nil, the key
starts at the beginning of the record.
Richard M. Stallman's avatar
Richard M. Stallman committed
53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68

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."
  (save-excursion
    (message "Finding sort keys...")
    (let* ((sort-lists (sort-build-lists nextrecfun endrecfun
					 startkeyfun endkeyfun))
	   (old (reverse sort-lists)))
      (if (null sort-lists)
	  ()
	(or reverse (setq sort-lists (nreverse sort-lists)))
	(message "Sorting records...")
	(setq sort-lists
	      (if (fboundp 'sortcar)
		  (sortcar sort-lists
69 70
			   (cond ((numberp (car (car sort-lists)))
				  ;; This handles both ints and floats.
Richard M. Stallman's avatar
Richard M. Stallman committed
71 72 73 74 75 76
				  '<)
				 ((consp (car (car sort-lists)))
				  'buffer-substring-lessp)
				 (t
				  'string<)))
		  (sort sort-lists
77
			(cond ((numberp (car (car sort-lists)))
Richard M. Stallman's avatar
Richard M. Stallman committed
78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95
			       (function
				(lambda (a b)
				  (< (car a) (car b)))))
			      ((consp (car (car sort-lists)))
			       (function
				(lambda (a b)
				  (buffer-substring-lessp (car a) (car b)))))
			      (t
			       (function
				(lambda (a b)
				  (string< (car a) (car b)))))))))
	(if reverse (setq sort-lists (nreverse sort-lists)))
	(message "Reordering buffer...")
	(sort-reorder-buffer sort-lists old)))
    (message "Reordering buffer... Done"))
  nil)

;; Parse buffer into records using the arguments as Lisp expressions;
root's avatar
root committed
96
;; return a list of records.  Each record looks like (KEY STARTPOS . ENDPOS)
Richard M. Stallman's avatar
Richard M. Stallman committed
97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133
;; where KEY is the sort key (a number or string),
;; and STARTPOS and ENDPOS are the bounds of this record in the buffer.

;; The records appear in the list lastmost first!

(defun sort-build-lists (nextrecfun endrecfun startkeyfun endkeyfun)
  (let ((sort-lists ())
	(start-rec nil)
	done key)
    ;; Loop over sort records.
    ;(goto-char (point-min)) -- it is the caller's responsibility to
    ;arrange this if necessary
    (while (not (eobp))
      (setq start-rec (point))		;save record start
      (setq done nil)
      ;; Get key value, or move to start of key.
      (setq key (catch 'key
		  (or (and startkeyfun (funcall startkeyfun))
		      ;; If key was not returned as value,
		      ;; move to end of key and get key from the buffer.
		      (let ((start (point)))
			(funcall (or endkeyfun
				     (prog1 endrecfun (setq done t))))
			(if (fboundp 'buffer-substring-lessp)
			    (cons start (point))
			  (buffer-substring start (point)))))))
      ;; Move to end of this record (start of next one, or end of buffer).
      (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)
134 135
				   (cons key (cons start-rec (point))))
				 sort-lists)))
Richard M. Stallman's avatar
Richard M. Stallman committed
136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156
      (and (not done) nextrecfun (funcall nextrecfun)))
    sort-lists))

(defun sort-reorder-buffer (sort-lists old)
  (let ((inhibit-quit t)
	(last (point-min))
	(min (point-min)) (max (point-max)))
    ;; 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 (point-max))
    (insert-before-markers " ")
    (narrow-to-region min (1- (point-max)))
    (while sort-lists
      (goto-char (point-max))
      (insert-buffer-substring (current-buffer)
			       last
			       (nth 1 (car old)))
      (goto-char (point-max))
      (insert-buffer-substring (current-buffer)
			       (nth 1 (car sort-lists))
157 158
			       (cdr (cdr (car sort-lists))))
      (setq last (cdr (cdr (car old)))
Richard M. Stallman's avatar
Richard M. Stallman committed
159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225
	    sort-lists (cdr sort-lists)
	    old (cdr old)))
    (goto-char (point-max))
    (insert-buffer-substring (current-buffer)
			     last
			     max)
    ;; Delete the original copy of the text.
    (delete-region min max)
    ;; Get rid of the separator " ".
    (goto-char (point-max))
    (narrow-to-region min (1+ (point)))
    (delete-region (point) (1+ (point)))))

(defun sort-lines (reverse beg end) 
  "Sort lines in region alphabetically; argument means descending order.
Called from a program, there are three arguments:
REVERSE (non-nil means reverse order), BEG and END (region to sort)."
  (interactive "P\nr")
  (save-excursion
    (save-restriction
      (narrow-to-region beg end)
      (goto-char (point-min))
      (sort-subr reverse 'forward-line 'end-of-line))))

(defun sort-paragraphs (reverse beg end)
  "Sort paragraphs in region alphabetically; argument means descending order.
Called from a program, there are three arguments:
REVERSE (non-nil means reverse order), BEG and END (region to sort)."
  (interactive "P\nr")
  (save-excursion
    (save-restriction
      (narrow-to-region beg end)
      (goto-char (point-min))
      (sort-subr reverse
		 (function (lambda () (skip-chars-forward "\n \t\f")))
		 'forward-paragraph))))

(defun sort-pages (reverse beg end)
  "Sort pages in region alphabetically; argument means descending order.
Called from a program, there are three arguments:
REVERSE (non-nil means reverse order), BEG and END (region to sort)."
  (interactive "P\nr")
  (save-excursion
    (save-restriction
      (narrow-to-region beg end)
      (goto-char (point-min))
      (sort-subr reverse
		 (function (lambda () (skip-chars-forward "\n")))
		 'forward-page))))

(defvar sort-fields-syntax-table nil)
(if sort-fields-syntax-table nil
  (let ((table (make-syntax-table))
	(i 0))
    (while (< i 256)
      (modify-syntax-entry i "w" table)
      (setq i (1+ i)))
    (modify-syntax-entry ?\  " " 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)))

(defun sort-numeric-fields (field beg end)
  "Sort lines in region numerically by the ARGth field of each line.
Fields are separated by whitespace and numbered from 1 up.
Specified field must contain a number in each line of the region.
root's avatar
root committed
226
With a negative arg, sorts by the ARGth field counted from the right.
Richard M. Stallman's avatar
Richard M. Stallman committed
227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242
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
		 (function (lambda ()
			     (sort-skip-fields (1- field))
			     (string-to-int
			      (buffer-substring
			        (point)
				(save-excursion
				  ;; This is just wrong! Even without floats...
				  ;; (skip-chars-forward "[0-9]")
				  (forward-sexp 1)
				  (point))))))
		 nil))

root's avatar
root committed
243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262
(defun sort-float-fields (field beg end)
  "Sort lines in region numerically by the ARGth field of each line.
Fields are separated by whitespace and numbered from 1 up.  Specified field
must contain a floating point number in each line of the region.  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")
  (sort-fields-1 field beg end
		 (function (lambda ()
			     (sort-skip-fields (1- field))
			     (string-to-float
			      (buffer-substring
			       (point)
			       (save-excursion
				 (re-search-forward
				  "[+-]?[0-9]*\.?[0-9]*\\([eE][+-]?[0-9]+\\)?")
				 (point))))))
		 nil))

Richard M. Stallman's avatar
Richard M. Stallman committed
263 264 265
(defun sort-fields (field beg end)
  "Sort lines in region lexicographically by the ARGth field of each line.
Fields are separated by whitespace and numbered from 1 up.
root's avatar
root committed
266
With a negative arg, sorts by the ARGth field counted from the right.
Richard M. Stallman's avatar
Richard M. Stallman committed
267 268 269 270 271 272 273 274 275 276
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
		 (function (lambda ()
			     (sort-skip-fields (1- field))
			     nil))
		 (function (lambda () (skip-chars-forward "^ \t\n")))))

(defun sort-fields-1 (field beg end startkeyfun endkeyfun)
root's avatar
root committed
277 278
  (let ((tbl (syntax-table)))
    (if (zerop field) (setq field 1))
Richard M. Stallman's avatar
Richard M. Stallman committed
279 280 281 282 283 284
    (unwind-protect
	(save-excursion
	  (save-restriction
	    (narrow-to-region beg end)
	    (goto-char (point-min))
	    (set-syntax-table sort-fields-syntax-table)
root's avatar
root committed
285
	    (sort-subr nil
Richard M. Stallman's avatar
Richard M. Stallman committed
286 287 288 289 290
		       'forward-line 'end-of-line
		       startkeyfun endkeyfun)))
      (set-syntax-table tbl))))

(defun sort-skip-fields (n)
root's avatar
root committed
291 292 293 294 295 296 297 298 299 300
  (let ((bol (point))
	(eol (save-excursion (end-of-line 1) (point))))
    (if (> n 0) (forward-word n)
      (end-of-line)
      (forward-word (1+ n)))
    (if (or (and (>= (point) eol) (> n 0))
	    ;; this is marginally wrong; if the first line of the sort
	    ;; at bob has the wrong number of fields the error won't be
	    ;; reported until the next short line.
	    (and (< (point) bol) (< n 0)))
Richard M. Stallman's avatar
Richard M. Stallman committed
301
	(error "Line has too few fields: %s"
root's avatar
root committed
302
	       (buffer-substring bol eol)))
Richard M. Stallman's avatar
Richard M. Stallman committed
303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322
    (skip-chars-forward " \t")))


(defun sort-regexp-fields (reverse record-regexp key-regexp beg end)
  "Sort the region lexicographically as specifed by RECORD-REGEXP and KEY.
RECORD-REGEXP specifies the textual units which should be sorted.
  For example, to sort lines RECORD-REGEXP would be \"^.*$\"
KEY specifies the part of each record (ie each match for RECORD-REGEXP)
  is to be used for sorting.
  If it is \"\\digit\" then the digit'th \"\\(...\\)\" match field from
  RECORD-REGEXP is used.
  If it is \"\\&\" then the whole record is used.
  Otherwise, it is a regular-expression for which to search within the record.
If a match for KEY is not found within a record then that record is ignored.

With a negative prefix arg sorts in reverse order.

For example: to sort lines in the region by the first word on each line
 starting with the letter \"f\",
 RECORD-REGEXP would be \"^.*$\" and KEY would be \"\\=\\<f\\w*\\>\""
root's avatar
root committed
323 324 325
  ;; using negative prefix arg to mean "reverse" is now inconsistent with
  ;; other sort-.*fields functions but then again this was before, since it
  ;; didn't use the magnitude of the arg to specify anything.
Richard M. Stallman's avatar
Richard M. Stallman committed
326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407
  (interactive "P\nsRegexp specifying records to sort: 
sRegexp specifying key within record: \nr")
  (cond ((or (equal key-regexp "") (equal key-regexp "\\&"))
	 (setq key-regexp 0))
	((string-match "\\`\\\\[1-9]\\'" key-regexp)
	 (setq key-regexp (- (aref key-regexp 1) ?0))))
  (save-excursion
    (save-restriction
      (narrow-to-region beg end)
      (goto-char (point-min))
      (let (sort-regexp-record-end) ;isn't dynamic scoping wonderful?
	(re-search-forward record-regexp)
	(setq sort-regexp-record-end (point))
	(goto-char (match-beginning 0))
	(sort-subr reverse
		   (function (lambda ()
			       (and (re-search-forward record-regexp nil 'move)
				    (setq sort-regexp-record-end (match-end 0))
				    (goto-char (match-beginning 0)))))
		   (function (lambda ()
			       (goto-char sort-regexp-record-end)))
		   (function (lambda ()
			       (let ((n 0))
				 (cond ((numberp key-regexp)
					(setq n key-regexp))
				       ((re-search-forward
					  key-regexp sort-regexp-record-end t)
					(setq n 0))
				       (t (throw 'key nil)))
				 (condition-case ()
				     (if (fboundp 'buffer-substring-lessp)
					 (cons (match-beginning n)
					       (match-end n))
					 (buffer-substring (match-beginning n)
							   (match-end n)))
				   ;; if there was no such register
				   (error (throw 'key nil)))))))))))


(defvar sort-columns-subprocess t)

(defun sort-columns (reverse &optional beg end)
  "Sort lines in region alphabetically by a certain range of columns.
For the purpose of this command, the region includes
the entire line that point is in and the entire line the mark is in.
The column positions of point and mark bound the range of columns to sort on.
A prefix argument means sort into reverse order.

Note that `sort-columns' rejects text that contains tabs,
because tabs could be split across the specified columns
and it doesn't know how to handle that.  Also, when possible,
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
    (let (beg1 end1 col-beg1 col-end1 col-start col-end)
      (goto-char (min beg end))
      (setq col-beg1 (current-column))
      (beginning-of-line)
      (setq beg1 (point))
      (goto-char (max beg end))
      (setq col-end1 (current-column))
      (forward-line)
      (setq end1 (point))
      (setq col-start (min col-beg1 col-end1))
      (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 (eq system-type 'vax-vms))
	  ;; Use the sort utility if we can; it is 4 times as fast.
	  (call-process-region beg1 end1 "sort" t t nil
			       (if reverse "-rt\n" "-t\n")
			       (concat "+0." col-start)
			       (concat "-0." col-end))
	;; On VMS, use Emacs's own facilities.
	(save-excursion
	  (save-restriction
	    (narrow-to-region beg1 end1)
	    (goto-char beg1)
	    (sort-subr reverse 'forward-line 'end-of-line
		       (function (lambda () (move-to-column col-start) nil))
		       (function (lambda () (move-to-column col-end) nil)))))))))
root's avatar
root committed
408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438

(defun reverse-region (beg end)
  "Reverse the order of lines in a region.
From a program takes two point or marker arguments, BEG and END."
  (interactive "r")
  (if (> beg end)
      (let (mid) (setq mid end end beg beg mid)))
  (save-excursion
    ;; put beg at the start of a line and end and the end of one --
    ;; the largest possible region which fits this criteria
    (goto-char beg)
    (or (bolp) (forward-line 1))
    (setq beg (point))
    (goto-char end)
    ;; the test for bolp is for those times when end is on an empty line;
    ;; it is probably not the case that the line should be included in the
    ;; reversal; it isn't difficult to add it afterward.
    (or (and (eolp) (not (bolp))) (progn (forward-line -1) (end-of-line)))
    (setq end (point-marker))
    ;; the real work.  this thing cranks through memory on large regions.
    (let (ll (do t))
      (while do
	(goto-char beg)
	(setq ll (cons (buffer-substring (point) (progn (end-of-line) (point)))
		       ll))
	(setq do (/= (point) end))
	(delete-region beg (if do (1+ (point)) (point))))
      (while (cdr ll)
	(insert (car ll) "\n")
	(setq ll (cdr ll)))
      (insert (car ll)))))