sort.el 16.5 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
;; 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.

;; 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
49 50
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
51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66

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
67 68
			   (cond ((numberp (car (car sort-lists)))
				  ;; This handles both ints and floats.
Richard M. Stallman's avatar
Richard M. Stallman committed
69 70 71 72 73 74
				  '<)
				 ((consp (car (car sort-lists)))
				  'buffer-substring-lessp)
				 (t
				  'string<)))
		  (sort sort-lists
75
			(cond ((numberp (car (car sort-lists)))
Richard M. Stallman's avatar
Richard M. Stallman committed
76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93
			       (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
94
;; return a list of records.  Each record looks like (KEY STARTPOS . ENDPOS)
Richard M. Stallman's avatar
Richard M. Stallman committed
95 96 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
;; 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)
132 133
				   (cons key (cons start-rec (point))))
				 sort-lists)))
Richard M. Stallman's avatar
Richard M. Stallman committed
134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154
      (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))
155 156
			       (cdr (cdr (car sort-lists))))
      (setq last (cdr (cdr (car old)))
Richard M. Stallman's avatar
Richard M. Stallman committed
157 158 159 160 161 162 163 164 165 166 167 168 169
	    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)))))

Jim Blandy's avatar
Jim Blandy committed
170
;;;###autoload
Richard M. Stallman's avatar
Richard M. Stallman committed
171 172 173 174 175 176 177 178 179 180 181
(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))))

Jim Blandy's avatar
Jim Blandy committed
182
;;;###autoload
Richard M. Stallman's avatar
Richard M. Stallman committed
183 184 185 186 187 188 189 190 191 192 193 194 195
(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))))

Jim Blandy's avatar
Jim Blandy committed
196
;;;###autoload
Richard M. Stallman's avatar
Richard M. Stallman committed
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
(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)))

Jim Blandy's avatar
Jim Blandy committed
223
;;;###autoload
Richard M. Stallman's avatar
Richard M. Stallman committed
224 225 226 227
(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
228
With a negative arg, sorts by the ARGth field counted from the right.
Richard M. Stallman's avatar
Richard M. Stallman committed
229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244
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
245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264
(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))

Jim Blandy's avatar
Jim Blandy committed
265
;;;###autoload
Richard M. Stallman's avatar
Richard M. Stallman committed
266 267 268
(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
269
With a negative arg, sorts by the ARGth field counted from the right.
Richard M. Stallman's avatar
Richard M. Stallman committed
270 271 272 273 274 275 276 277 278 279
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
280 281
  (let ((tbl (syntax-table)))
    (if (zerop field) (setq field 1))
Richard M. Stallman's avatar
Richard M. Stallman committed
282 283 284 285 286 287
    (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
288
	    (sort-subr nil
Richard M. Stallman's avatar
Richard M. Stallman committed
289 290 291 292 293
		       'forward-line 'end-of-line
		       startkeyfun endkeyfun)))
      (set-syntax-table tbl))))

(defun sort-skip-fields (n)
root's avatar
root committed
294 295 296 297 298 299 300 301 302 303
  (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
304
	(error "Line has too few fields: %s"
root's avatar
root committed
305
	       (buffer-substring bol eol)))
Richard M. Stallman's avatar
Richard M. Stallman committed
306 307 308
    (skip-chars-forward " \t")))


Jim Blandy's avatar
Jim Blandy committed
309
;;;###autoload
Richard M. Stallman's avatar
Richard M. Stallman committed
310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326
(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
327 328 329
  ;; 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
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
  (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)

Jim Blandy's avatar
Jim Blandy committed
371
;;;###autoload
Richard M. Stallman's avatar
Richard M. Stallman committed
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 408 409 410 411 412
(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
413

Jim Blandy's avatar
Jim Blandy committed
414
;;;###autoload
root's avatar
root committed
415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444
(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)))))
Jim Blandy's avatar
Jim Blandy committed
445 446 447

(provide 'sort)