![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to sort.el CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDReno / contrib / emacs-18.55 / lisp|
Return to sort.el CVS log | Up to [CSRG BSD Unix] / 43BSDReno / contrib / emacs-18.55 / lisp |
1.1 root 1: ;; Commands to sort text in an Emacs buffer.
2: ;; Copyright (C) 1986, 1987 Free Software Foundation, Inc.
3:
4: ;; This file is part of GNU Emacs.
5:
6: ;; GNU Emacs is distributed in the hope that it will be useful,
7: ;; but WITHOUT ANY WARRANTY. No author or distributor
8: ;; accepts responsibility to anyone for the consequences of using it
9: ;; or for whether it serves any particular purpose or works at all,
10: ;; unless he says so in writing. Refer to the GNU Emacs General Public
11: ;; License for full details.
12:
13: ;; Everyone is granted permission to copy, modify and redistribute
14: ;; GNU Emacs, but only under the conditions described in the
15: ;; GNU Emacs General Public License. A copy of this license is
16: ;; supposed to have been given to you along with GNU Emacs so you
17: ;; can know your rights and responsibilities. It should be in a
18: ;; file named COPYING. Among other things, the copyright notice
19: ;; and this notice must be preserved on all copies.
20:
21: (provide 'sort)
22:
23: ;; Original version of most of this contributed by Howie Kaye
24:
25: (defun sort-subr (reverse nextrecfun endrecfun &optional startkeyfun endkeyfun)
26: "General text sorting routine to divide buffer into records and sort them.
27: Arguments are REVERSE NEXTRECFUN ENDRECFUN &optional STARTKEYFUN ENDKEYFUN.
28:
29: We consider this portion of the buffer to be divided into disjoint pieces
30: called sort records. A portion of each sort record (perhaps all of it)
31: is designated as the sort key. The records are rearranged in the buffer
32: in order by their sort keys. The records may or may not be contiguous.
33:
34: Usually the records are rearranged in order of ascending sort key.
35: If REVERSE is non-nil, they are rearranged in order of descending sort key.
36:
37: The next four arguments are functions to be called to move point
38: across a sort record. They will be called many times from within sort-subr.
39:
40: NEXTRECFUN is called with point at the end of the previous record.
41: It moves point to the start of the next record.
42: The first record is assumed to start at the position of point when sort-subr
43: is called.
44:
45: ENDRECFUN is is called with point within the record.
46: It should move point to the end of the record.
47:
48: STARTKEYFUN may moves from the start of the record to the start of the key.
49: It may return either return a non-nil value to be used as the key, or
50: else the key will be the substring between the values of point after
51: STARTKEYFUNC and ENDKEYFUN are called.
52:
53: ENDKEYFUN moves from the start of the sort key to the end of the sort key.
54: ENDRECFUN may be nil if STARTKEYFUN returns a value or if it would be the
55: same as ENDRECFUN."
56: (save-excursion
57: (message "Finding sort keys...")
58: (let* ((sort-lists (sort-build-lists nextrecfun endrecfun
59: startkeyfun endkeyfun))
60: (old (reverse sort-lists)))
61: (if (null sort-lists)
62: ()
63: (or reverse (setq sort-lists (nreverse sort-lists)))
64: (message "Sorting records...")
65: (setq sort-lists
66: (if (fboundp 'sortcar)
67: (sortcar sort-lists
68: (cond ((numberp (car (car sort-lists)))
69: '<)
70: ((consp (car (car sort-lists)))
71: 'buffer-substring-lessp)
72: (t
73: 'string<)))
74: (sort sort-lists
75: (cond ((numberp (car (car sort-lists)))
76: (function
77: (lambda (a b)
78: (< (car a) (car b)))))
79: ((consp (car (car sort-lists)))
80: (function
81: (lambda (a b)
82: (buffer-substring-lessp (car a) (car b)))))
83: (t
84: (function
85: (lambda (a b)
86: (string< (car a) (car b)))))))))
87: (if reverse (setq sort-lists (nreverse sort-lists)))
88: (message "Reordering buffer...")
89: (sort-reorder-buffer sort-lists old)))
90: (message "Reordering buffer... Done")))
91:
92: ;; Parse buffer into records using the arguments as Lisp expressions;
93: ;; return a list of records. Each record looks like (KEY STARTPOS ENDPOS)
94: ;; where KEY is the sort key (a number or string),
95: ;; and STARTPOS and ENDPOS are the bounds of this record in the buffer.
96:
97: ;; The records appear in the list lastmost first!
98:
99: (defun sort-build-lists (nextrecfun endrecfun startkeyfun endkeyfun)
100: (let ((sort-lists ())
101: (start-rec nil)
102: done key)
103: ;; Loop over sort records.
104: ;(goto-char (point-min)) -- it is the caller's responsibility to
105: ;arrange this if necessary
106: (while (not (eobp))
107: (setq start-rec (point)) ;save record start
108: (setq done nil)
109: ;; Get key value, or move to start of key.
110: (setq key (catch 'key
111: (or (and startkeyfun (funcall startkeyfun))
112: ;; If key was not returned as value,
113: ;; move to end of key and get key from the buffer.
114: (let ((start (point)))
115: (funcall (or endkeyfun
116: (prog1 endrecfun (setq done t))))
117: (if (fboundp 'buffer-substring-lessp)
118: (cons start (point))
119: (buffer-substring start (point)))))))
120: ;; Move to end of this record (start of next one, or end of buffer).
121: (cond ((prog1 done (setq done nil)))
122: (endrecfun (funcall endrecfun))
123: (nextrecfun (funcall nextrecfun) (setq done t)))
124: (if key (setq sort-lists (cons
125: ;; consing optimization in case in which key
126: ;; is same as record.
127: (if (and (consp key)
128: (equal (car key) start-rec)
129: (equal (cdr key) (point)))
130: (cons key key)
131: (list key start-rec (point)))
132: sort-lists)))
133: (and (not done) nextrecfun (funcall nextrecfun)))
134: sort-lists))
135:
136: (defun sort-reorder-buffer (sort-lists old)
137: (let ((inhibit-quit t)
138: (last (point-min))
139: (min (point-min)) (max (point-max)))
140: (while sort-lists
141: (goto-char (point-max))
142: (insert-buffer-substring (current-buffer)
143: last
144: (nth 1 (car old)))
145: (goto-char (point-max))
146: (insert-buffer-substring (current-buffer)
147: (nth 1 (car sort-lists))
148: (nth 2 (car sort-lists)))
149: (setq last (nth 2 (car old))
150: sort-lists (cdr sort-lists)
151: old (cdr old)))
152: (goto-char (point-max))
153: (insert-buffer-substring (current-buffer)
154: last
155: max)
156: (delete-region min max))) ;get rid of old version
157:
158: (defun sort-lines (reverse beg end)
159: "Sort lines in region alphabetically; argument means descending order.
160: Called from a program, there are three arguments:
161: REVERSE (non-nil means reverse order), BEG and END (region to sort)."
162: (interactive "P\nr")
163: (save-restriction
164: (narrow-to-region beg end)
165: (goto-char (point-min))
166: (sort-subr reverse 'forward-line 'end-of-line)))
167:
168: (defun sort-paragraphs (reverse beg end)
169: "Sort paragraphs in region alphabetically; argument means descending order.
170: Called from a program, there are three arguments:
171: REVERSE (non-nil means reverse order), BEG and END (region to sort)."
172: (interactive "P\nr")
173: (save-restriction
174: (narrow-to-region beg end)
175: (goto-char (point-min))
176: (sort-subr reverse
177: (function (lambda () (skip-chars-forward "\n \t\f")))
178: 'forward-paragraph)))
179:
180: (defun sort-pages (reverse beg end)
181: "Sort pages in region alphabetically; argument means descending order.
182: Called from a program, there are three arguments:
183: REVERSE (non-nil means reverse order), BEG and END (region to sort)."
184: (interactive "P\nr")
185: (save-restriction
186: (narrow-to-region beg end)
187: (goto-char (point-min))
188: (sort-subr reverse
189: (function (lambda () (skip-chars-forward "\n")))
190: 'forward-page)))
191:
192: (defvar sort-fields-syntax-table nil)
193: (if sort-fields-syntax-table nil
194: (let ((table (make-syntax-table))
195: (i 0))
196: (while (< i 256)
197: (modify-syntax-entry i "w" table)
198: (setq i (1+ i)))
199: (modify-syntax-entry ?\ " " table)
200: (modify-syntax-entry ?\t " " table)
201: (modify-syntax-entry ?\n " " table)
202: (setq sort-fields-syntax-table table)))
203:
204: (defun sort-numeric-fields (field beg end)
205: "Sort lines in region numerically by the ARGth field of each line.
206: Fields are separated by whitespace and numbered from 1 up.
207: Specified field must contain a number in each line of the region.
208: With a negative arg, sorts by the -ARG'th field, in reverse order.
209: Called from a program, there are three arguments:
210: FIELD, BEG and END. BEG and END specify region to sort."
211: (interactive "p\nr")
212: (sort-fields-1 field beg end
213: (function (lambda ()
214: (sort-skip-fields (1- field))
215: (string-to-int
216: (buffer-substring
217: (point)
218: (save-excursion
219: (skip-chars-forward "[0-9]")
220: (point))))))
221: nil))
222:
223: (defun sort-fields (field beg end)
224: "Sort lines in region lexicographically by the ARGth field of each line.
225: Fields are separated by whitespace and numbered from 1 up.
226: With a negative arg, sorts by the -ARG'th field, in reverse order.
227: Called from a program, there are three arguments:
228: FIELD, BEG and END. BEG and END specify region to sort."
229: (interactive "p\nr")
230: (sort-fields-1 field beg end
231: (function (lambda ()
232: (sort-skip-fields (1- field))
233: nil))
234: (function (lambda () (skip-chars-forward "^ \t\n")))))
235:
236: (defun sort-fields-1 (field beg end startkeyfun endkeyfun)
237: (let ((reverse (< field 0))
238: (tbl (syntax-table)))
239: (setq field (max 1 field (- field)))
240: (unwind-protect
241: (save-restriction
242: (narrow-to-region beg end)
243: (goto-char (point-min))
244: (set-syntax-table sort-fields-syntax-table)
245: (sort-subr reverse
246: 'forward-line 'end-of-line
247: startkeyfun endkeyfun))
248: (set-syntax-table tbl))))
249:
250: (defun sort-skip-fields (n)
251: (let ((eol (save-excursion (end-of-line 1) (point))))
252: (forward-word n)
253: (if (> (point) eol)
254: (error "Line has too few fields: %s"
255: (buffer-substring (save-excursion
256: (beginning-of-line) (point))
257: eol)))
258: (skip-chars-forward " \t")))
259:
260:
261: (defun sort-regexp-fields (reverse record-regexp key-regexp beg end)
262: "Sort the region lexicographically as specifed by RECORD-REGEXP and KEY.
263: RECORD-REGEXP specifies the textual units which should be sorted.
264: For example, to sort lines RECORD-REGEXP would be \"^.*$\"
265: KEY specifies the part of each record (ie each match for RECORD-REGEXP)
266: is to be used for sorting.
267: If it is \"\\digit\" then the digit'th \"\\(...\\)\" match field from
268: RECORD-REGEXP is used.
269: If it is \"\\&\" then the whole record is used.
270: Otherwise, it is a regular-expression for which to search within the record.
271: If a match for KEY is not found within a record then that record is ignored.
272:
273: With a negative prefix arg sorts in reverse order.
274:
275: For example: to sort lines in the region by the first word on each line
276: starting with the letter \"f\",
277: RECORD-REGEXP would be \"^.*$\" and KEY \"\\<f\\w*\\>\""
278: (interactive "P\nsRegexp specifying records to sort:
279: sRegexp specifying key within record: \nr")
280: (cond ((or (equal key-regexp "") (equal key-regexp "\\&"))
281: (setq key-regexp 0))
282: ((string-match "\\`\\\\[1-9]\\'" key-regexp)
283: (setq key-regexp (- (aref key-regexp 1) ?0))))
284: (save-restriction
285: (narrow-to-region beg end)
286: (goto-char (point-min))
287: (let (sort-regexp-record-end) ;isn't dynamic scoping wonderful?
288: (re-search-forward record-regexp)
289: (setq sort-regexp-record-end (point))
290: (goto-char (match-beginning 0))
291: (sort-subr reverse
292: (function (lambda ()
293: (and (re-search-forward record-regexp nil 'move)
294: (setq sort-regexp-record-end (match-end 0))
295: (goto-char (match-beginning 0)))))
296: (function (lambda ()
297: (goto-char sort-regexp-record-end)))
298: (function (lambda ()
299: (let ((n 0))
300: (cond ((numberp key-regexp)
301: (setq n key-regexp))
302: ((re-search-forward
303: key-regexp sort-regexp-record-end t)
304: (setq n 0))
305: (t (throw 'key nil)))
306: (condition-case ()
307: (if (fboundp 'buffer-substring-lessp)
308: (cons (match-beginning n)
309: (match-end n))
310: (buffer-substring (match-beginning n)
311: (match-end n)))
312: ;; if there was no such register
313: (error (throw 'key nil))))))))))
314:
315:
316: (defun sort-columns (reverse &optional beg end)
317: "Sort lines in region alphabetically by a certain range of columns.
318: For the purpose of this command, the region includes
319: the entire line that point is in and the entire line the mark is in.
320: The column positions of point and mark bound the range of columns to sort on.
321: A prefix argument means sort into reverse order.
322:
323: Note that sort-columns uses the sort utility program and therefore
324: cannot work on text containing TAB characters. Use M-x untabify
325: to convert tabs to spaces before sorting."
326: (interactive "P\nr")
327: (save-excursion
328: (let (beg1 end1 col-beg1 col-end1 col-start col-end)
329: (goto-char (min beg end))
330: (setq col-beg1 (current-column))
331: (beginning-of-line)
332: (setq beg1 (point))
333: (goto-char (max beg end))
334: (setq col-end1 (current-column))
335: (forward-line)
336: (setq end1 (point))
337: (setq col-start (min col-beg1 col-end1))
338: (setq col-end (max col-beg1 col-end1))
339: (if (search-backward "\t" beg1 t)
340: (error "sort-columns does not work with tabs. Use M-x untabify."))
341: (call-process-region beg1 end1 "sort" t t nil
342: (if reverse "-rt\n" "-t\n")
343: (concat "+0." col-start)
344: (concat "-0." col-end)))))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.