Mercurial > emacs
annotate lisp/gnus/gnus-util.el @ 23192:1ea9db09a678
(checkdoc-buffer-label): New function.
(checkdoc-start-section, checkdoc-error): Use `checkdoc-buffer-label'.
(checkdoc-this-string-valid-engine): Permit ? as terminating
punctuation for first line sentence breaking.
(checkdoc-this-string-valid): When converting a comment into a doc
string, make sure " chars are \".
(checkdoc-sentencespace-region-engine): Only do double space check
if based on the variable `sentence-end-double-space'
author | Eric M. Ludlam <zappo@gnu.org> |
---|---|
date | Sat, 05 Sep 1998 13:46:23 +0000 |
parents | 5f1ab3dd344d |
children | 6d8f2c66943f |
rev | line source |
---|---|
17493 | 1 ;;; gnus-util.el --- utility functions for Gnus |
2 ;; Copyright (C) 1996,97 Free Software Foundation, Inc. | |
3 | |
4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> | |
5 ;; Keywords: news | |
6 | |
7 ;; This file is part of GNU Emacs. | |
8 | |
9 ;; GNU Emacs is free software; you can redistribute it and/or modify | |
10 ;; it under the terms of the GNU General Public License as published by | |
11 ;; the Free Software Foundation; either version 2, or (at your option) | |
12 ;; any later version. | |
13 | |
14 ;; GNU Emacs is distributed in the hope that it will be useful, | |
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
17 ;; GNU General Public License for more details. | |
18 | |
19 ;; You should have received a copy of the GNU General Public License | |
20 ;; along with GNU Emacs; see the file COPYING. If not, write to the | |
21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
22 ;; Boston, MA 02111-1307, USA. | |
23 | |
24 ;;; Commentary: | |
25 | |
26 ;; Nothing in this file depends on any other parts of Gnus -- all | |
27 ;; functions and macros in this file are utility functions that are | |
28 ;; used by Gnus and may be used by any other package without loading | |
29 ;; Gnus first. | |
30 | |
31 ;;; Code: | |
32 | |
33 (require 'custom) | |
19523
6713d6efcfde
Require cl only at compile time.
Richard M. Stallman <rms@gnu.org>
parents:
17493
diff
changeset
|
34 (eval-when-compile (require 'cl)) |
17493 | 35 (require 'nnheader) |
36 (require 'timezone) | |
37 (require 'message) | |
38 | |
39 (eval-and-compile | |
40 (autoload 'nnmail-date-to-time "nnmail")) | |
41 | |
42 (defun gnus-boundp (variable) | |
43 "Return non-nil if VARIABLE is bound and non-nil." | |
44 (and (boundp variable) | |
45 (symbol-value variable))) | |
46 | |
47 (defmacro gnus-eval-in-buffer-window (buffer &rest forms) | |
48 "Pop to BUFFER, evaluate FORMS, and then return to the original window." | |
49 (let ((tempvar (make-symbol "GnusStartBufferWindow")) | |
50 (w (make-symbol "w")) | |
51 (buf (make-symbol "buf"))) | |
52 `(let* ((,tempvar (selected-window)) | |
53 (,buf ,buffer) | |
54 (,w (get-buffer-window ,buf 'visible))) | |
55 (unwind-protect | |
56 (progn | |
57 (if ,w | |
58 (progn | |
59 (select-window ,w) | |
60 (set-buffer (window-buffer ,w))) | |
61 (pop-to-buffer ,buf)) | |
62 ,@forms) | |
63 (select-window ,tempvar))))) | |
64 | |
65 (put 'gnus-eval-in-buffer-window 'lisp-indent-function 1) | |
66 (put 'gnus-eval-in-buffer-window 'edebug-form-spec '(form body)) | |
67 | |
68 (defmacro gnus-intern-safe (string hashtable) | |
69 "Set hash value. Arguments are STRING, VALUE, and HASHTABLE." | |
70 `(let ((symbol (intern ,string ,hashtable))) | |
71 (or (boundp symbol) | |
72 (set symbol nil)) | |
73 symbol)) | |
74 | |
75 ;; modified by MORIOKA Tomohiko <morioka@jaist.ac.jp> | |
76 ;; function `substring' might cut on a middle of multi-octet | |
77 ;; character. | |
78 (defun gnus-truncate-string (str width) | |
79 (substring str 0 width)) | |
80 | |
81 ;; Added by Geoffrey T. Dairiki <dairiki@u.washington.edu>. A safe way | |
82 ;; to limit the length of a string. This function is necessary since | |
83 ;; `(substr "abc" 0 30)' pukes with "Args out of range". | |
84 (defsubst gnus-limit-string (str width) | |
85 (if (> (length str) width) | |
86 (substring str 0 width) | |
87 str)) | |
88 | |
89 (defsubst gnus-functionp (form) | |
90 "Return non-nil if FORM is funcallable." | |
91 (or (and (symbolp form) (fboundp form)) | |
92 (and (listp form) (eq (car form) 'lambda)) | |
93 (compiled-function-p form))) | |
94 | |
95 (defsubst gnus-goto-char (point) | |
96 (and point (goto-char point))) | |
97 | |
98 (defmacro gnus-buffer-exists-p (buffer) | |
99 `(let ((buffer ,buffer)) | |
100 (when buffer | |
101 (funcall (if (stringp buffer) 'get-buffer 'buffer-name) | |
102 buffer)))) | |
103 | |
104 (defmacro gnus-kill-buffer (buffer) | |
105 `(let ((buf ,buffer)) | |
106 (when (gnus-buffer-exists-p buf) | |
107 (kill-buffer buf)))) | |
108 | |
109 (if (fboundp 'point-at-bol) | |
110 (fset 'gnus-point-at-bol 'point-at-bol) | |
111 (defun gnus-point-at-bol () | |
112 "Return point at the beginning of the line." | |
113 (let ((p (point))) | |
114 (beginning-of-line) | |
115 (prog1 | |
116 (point) | |
117 (goto-char p))))) | |
118 | |
119 (if (fboundp 'point-at-eol) | |
120 (fset 'gnus-point-at-eol 'point-at-eol) | |
121 (defun gnus-point-at-eol () | |
122 "Return point at the end of the line." | |
123 (let ((p (point))) | |
124 (end-of-line) | |
125 (prog1 | |
126 (point) | |
127 (goto-char p))))) | |
128 | |
129 (defun gnus-delete-first (elt list) | |
130 "Delete by side effect the first occurrence of ELT as a member of LIST." | |
131 (if (equal (car list) elt) | |
132 (cdr list) | |
133 (let ((total list)) | |
134 (while (and (cdr list) | |
135 (not (equal (cadr list) elt))) | |
136 (setq list (cdr list))) | |
137 (when (cdr list) | |
138 (setcdr list (cddr list))) | |
139 total))) | |
140 | |
141 ;; Delete the current line (and the next N lines). | |
142 (defmacro gnus-delete-line (&optional n) | |
143 `(delete-region (progn (beginning-of-line) (point)) | |
144 (progn (forward-line ,(or n 1)) (point)))) | |
145 | |
146 (defun gnus-byte-code (func) | |
147 "Return a form that can be `eval'ed based on FUNC." | |
148 (let ((fval (symbol-function func))) | |
149 (if (compiled-function-p fval) | |
150 (let ((flist (append fval nil))) | |
151 (setcar flist 'byte-code) | |
152 flist) | |
153 (cons 'progn (cddr fval))))) | |
154 | |
155 (defun gnus-extract-address-components (from) | |
156 (let (name address) | |
157 ;; First find the address - the thing with the @ in it. This may | |
158 ;; not be accurate in mail addresses, but does the trick most of | |
159 ;; the time in news messages. | |
160 (when (string-match "\\b[^@ \t<>]+[!@][^@ \t<>]+\\b" from) | |
161 (setq address (substring from (match-beginning 0) (match-end 0)))) | |
162 ;; Then we check whether the "name <address>" format is used. | |
163 (and address | |
164 ;; Fix by MORIOKA Tomohiko <morioka@jaist.ac.jp> | |
165 ;; Linear white space is not required. | |
166 (string-match (concat "[ \t]*<" (regexp-quote address) ">") from) | |
167 (and (setq name (substring from 0 (match-beginning 0))) | |
168 ;; Strip any quotes from the name. | |
169 (string-match "\".*\"" name) | |
170 (setq name (substring name 1 (1- (match-end 0)))))) | |
171 ;; If not, then "address (name)" is used. | |
172 (or name | |
173 (and (string-match "(.+)" from) | |
174 (setq name (substring from (1+ (match-beginning 0)) | |
175 (1- (match-end 0))))) | |
176 (and (string-match "()" from) | |
177 (setq name address)) | |
178 ;; Fix by MORIOKA Tomohiko <morioka@jaist.ac.jp>. | |
179 ;; XOVER might not support folded From headers. | |
180 (and (string-match "(.*" from) | |
181 (setq name (substring from (1+ (match-beginning 0)) | |
182 (match-end 0))))) | |
183 ;; Fix by Hallvard B Furuseth <h.b.furuseth@usit.uio.no>. | |
184 (list (or name from) (or address from)))) | |
185 | |
186 (defun gnus-fetch-field (field) | |
187 "Return the value of the header FIELD of current article." | |
188 (save-excursion | |
189 (save-restriction | |
190 (let ((case-fold-search t) | |
191 (inhibit-point-motion-hooks t)) | |
192 (nnheader-narrow-to-headers) | |
193 (message-fetch-field field))))) | |
194 | |
195 (defun gnus-goto-colon () | |
196 (beginning-of-line) | |
197 (search-forward ":" (gnus-point-at-eol) t)) | |
198 | |
199 (defun gnus-remove-text-with-property (prop) | |
200 "Delete all text in the current buffer with text property PROP." | |
201 (save-excursion | |
202 (goto-char (point-min)) | |
203 (while (not (eobp)) | |
204 (while (get-text-property (point) prop) | |
205 (delete-char 1)) | |
206 (goto-char (next-single-property-change (point) prop nil (point-max)))))) | |
207 | |
208 (defun gnus-newsgroup-directory-form (newsgroup) | |
209 "Make hierarchical directory name from NEWSGROUP name." | |
210 (let ((newsgroup (gnus-newsgroup-savable-name newsgroup)) | |
211 (len (length newsgroup)) | |
212 idx) | |
213 ;; If this is a foreign group, we don't want to translate the | |
214 ;; entire name. | |
215 (if (setq idx (string-match ":" newsgroup)) | |
216 (aset newsgroup idx ?/) | |
217 (setq idx 0)) | |
218 ;; Replace all occurrences of `.' with `/'. | |
219 (while (< idx len) | |
220 (when (= (aref newsgroup idx) ?.) | |
221 (aset newsgroup idx ?/)) | |
222 (setq idx (1+ idx))) | |
223 newsgroup)) | |
224 | |
225 (defun gnus-newsgroup-savable-name (group) | |
226 ;; Replace any slashes in a group name (eg. an ange-ftp nndoc group) | |
227 ;; with dots. | |
228 (nnheader-replace-chars-in-string group ?/ ?.)) | |
229 | |
230 (defun gnus-string> (s1 s2) | |
231 (not (or (string< s1 s2) | |
232 (string= s1 s2)))) | |
233 | |
234 ;;; Time functions. | |
235 | |
236 (defun gnus-days-between (date1 date2) | |
237 ;; Return the number of days between date1 and date2. | |
238 (- (gnus-day-number date1) (gnus-day-number date2))) | |
239 | |
240 (defun gnus-day-number (date) | |
241 (let ((dat (mapcar (lambda (s) (and s (string-to-int s)) ) | |
242 (timezone-parse-date date)))) | |
243 (timezone-absolute-from-gregorian | |
244 (nth 1 dat) (nth 2 dat) (car dat)))) | |
245 | |
246 (defun gnus-time-to-day (time) | |
247 "Convert TIME to day number." | |
248 (let ((tim (decode-time time))) | |
249 (timezone-absolute-from-gregorian | |
250 (nth 4 tim) (nth 3 tim) (nth 5 tim)))) | |
251 | |
252 (defun gnus-encode-date (date) | |
253 "Convert DATE to internal time." | |
254 (let* ((parse (timezone-parse-date date)) | |
255 (date (mapcar (lambda (d) (and d (string-to-int d))) parse)) | |
256 (time (mapcar 'string-to-int (timezone-parse-time (aref parse 3))))) | |
257 (encode-time (caddr time) (cadr time) (car time) | |
19969
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19523
diff
changeset
|
258 (caddr date) (cadr date) (car date) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19523
diff
changeset
|
259 (* 60 (timezone-zone-to-minute (nth 4 date)))))) |
17493 | 260 |
261 (defun gnus-time-minus (t1 t2) | |
262 "Subtract two internal times." | |
263 (let ((borrow (< (cadr t1) (cadr t2)))) | |
264 (list (- (car t1) (car t2) (if borrow 1 0)) | |
265 (- (+ (if borrow 65536 0) (cadr t1)) (cadr t2))))) | |
266 | |
267 (defun gnus-time-less (t1 t2) | |
268 "Say whether time T1 is less than time T2." | |
269 (or (< (car t1) (car t2)) | |
270 (and (= (car t1) (car t2)) | |
271 (< (nth 1 t1) (nth 1 t2))))) | |
272 | |
273 (defun gnus-file-newer-than (file date) | |
274 (let ((fdate (nth 5 (file-attributes file)))) | |
275 (or (> (car fdate) (car date)) | |
276 (and (= (car fdate) (car date)) | |
277 (> (nth 1 fdate) (nth 1 date)))))) | |
278 | |
279 ;;; Keymap macros. | |
280 | |
281 (defmacro gnus-local-set-keys (&rest plist) | |
282 "Set the keys in PLIST in the current keymap." | |
283 `(gnus-define-keys-1 (current-local-map) ',plist)) | |
284 | |
285 (defmacro gnus-define-keys (keymap &rest plist) | |
286 "Define all keys in PLIST in KEYMAP." | |
287 `(gnus-define-keys-1 (quote ,keymap) (quote ,plist))) | |
288 | |
289 (defmacro gnus-define-keys-safe (keymap &rest plist) | |
290 "Define all keys in PLIST in KEYMAP without overwriting previous definitions." | |
291 `(gnus-define-keys-1 (quote ,keymap) (quote ,plist) t)) | |
292 | |
293 (put 'gnus-define-keys 'lisp-indent-function 1) | |
294 (put 'gnus-define-keys-safe 'lisp-indent-function 1) | |
295 (put 'gnus-local-set-keys 'lisp-indent-function 1) | |
296 | |
297 (defmacro gnus-define-keymap (keymap &rest plist) | |
298 "Define all keys in PLIST in KEYMAP." | |
299 `(gnus-define-keys-1 ,keymap (quote ,plist))) | |
300 | |
301 (put 'gnus-define-keymap 'lisp-indent-function 1) | |
302 | |
303 (defun gnus-define-keys-1 (keymap plist &optional safe) | |
304 (when (null keymap) | |
305 (error "Can't set keys in a null keymap")) | |
306 (cond ((symbolp keymap) | |
307 (setq keymap (symbol-value keymap))) | |
308 ((keymapp keymap)) | |
309 ((listp keymap) | |
310 (set (car keymap) nil) | |
311 (define-prefix-command (car keymap)) | |
312 (define-key (symbol-value (caddr keymap)) (cadr keymap) (car keymap)) | |
313 (setq keymap (symbol-value (car keymap))))) | |
314 (let (key) | |
315 (while plist | |
316 (when (symbolp (setq key (pop plist))) | |
317 (setq key (symbol-value key))) | |
318 (if (or (not safe) | |
319 (eq (lookup-key keymap key) 'undefined)) | |
320 (define-key keymap key (pop plist)) | |
321 (pop plist))))) | |
322 | |
323 (defun gnus-completing-read (default prompt &rest args) | |
324 ;; Like `completing-read', except that DEFAULT is the default argument. | |
325 (let* ((prompt (if default | |
326 (concat prompt " (default " default ") ") | |
327 (concat prompt " "))) | |
328 (answer (apply 'completing-read prompt args))) | |
329 (if (or (null answer) (zerop (length answer))) | |
330 default | |
331 answer))) | |
332 | |
333 ;; Two silly functions to ensure that all `y-or-n-p' questions clear | |
334 ;; the echo area. | |
335 (defun gnus-y-or-n-p (prompt) | |
336 (prog1 | |
337 (y-or-n-p prompt) | |
338 (message ""))) | |
339 | |
340 (defun gnus-yes-or-no-p (prompt) | |
341 (prog1 | |
342 (yes-or-no-p prompt) | |
343 (message ""))) | |
344 | |
345 ;; I suspect there's a better way, but I haven't taken the time to do | |
346 ;; it yet. -erik selberg@cs.washington.edu | |
347 (defun gnus-dd-mmm (messy-date) | |
348 "Return a string like DD-MMM from a big messy string" | |
349 (let ((datevec (ignore-errors (timezone-parse-date messy-date)))) | |
350 (if (not datevec) | |
351 "??-???" | |
352 (format "%2s-%s" | |
353 (condition-case () | |
354 ;; Make sure leading zeroes are stripped. | |
355 (number-to-string (string-to-number (aref datevec 2))) | |
356 (error "??")) | |
357 (capitalize | |
358 (or (car | |
359 (nth (1- (string-to-number (aref datevec 1))) | |
360 timezone-months-assoc)) | |
361 "???")))))) | |
362 | |
363 (defmacro gnus-date-get-time (date) | |
364 "Convert DATE string to Emacs time. | |
365 Cache the result as a text property stored in DATE." | |
366 ;; Either return the cached value... | |
367 `(let ((d ,date)) | |
368 (if (equal "" d) | |
369 '(0 0) | |
370 (or (get-text-property 0 'gnus-time d) | |
371 ;; or compute the value... | |
372 (let ((time (nnmail-date-to-time d))) | |
373 ;; and store it back in the string. | |
374 (put-text-property 0 1 'gnus-time time d) | |
375 time))))) | |
376 | |
377 (defsubst gnus-time-iso8601 (time) | |
378 "Return a string of TIME in YYMMDDTHHMMSS format." | |
379 (format-time-string "%Y%m%dT%H%M%S" time)) | |
380 | |
381 (defun gnus-date-iso8601 (header) | |
382 "Convert the date field in HEADER to YYMMDDTHHMMSS" | |
383 (condition-case () | |
384 (gnus-time-iso8601 (gnus-date-get-time (mail-header-date header))) | |
385 (error ""))) | |
386 | |
387 (defun gnus-mode-string-quote (string) | |
388 "Quote all \"%\"'s in STRING." | |
389 (save-excursion | |
390 (gnus-set-work-buffer) | |
391 (insert string) | |
392 (goto-char (point-min)) | |
393 (while (search-forward "%" nil t) | |
394 (insert "%")) | |
395 (buffer-string))) | |
396 | |
397 ;; Make a hash table (default and minimum size is 256). | |
398 ;; Optional argument HASHSIZE specifies the table size. | |
399 (defun gnus-make-hashtable (&optional hashsize) | |
400 (make-vector (if hashsize (max (gnus-create-hash-size hashsize) 256) 256) 0)) | |
401 | |
402 ;; Make a number that is suitable for hashing; bigger than MIN and | |
403 ;; equal to some 2^x. Many machines (such as sparcs) do not have a | |
404 ;; hardware modulo operation, so they implement it in software. On | |
405 ;; many sparcs over 50% of the time to intern is spent in the modulo. | |
406 ;; Yes, it's slower than actually computing the hash from the string! | |
407 ;; So we use powers of 2 so people can optimize the modulo to a mask. | |
408 (defun gnus-create-hash-size (min) | |
409 (let ((i 1)) | |
410 (while (< i min) | |
411 (setq i (* 2 i))) | |
412 i)) | |
413 | |
414 (defcustom gnus-verbose 7 | |
415 "*Integer that says how verbose Gnus should be. | |
416 The higher the number, the more messages Gnus will flash to say what | |
417 it's doing. At zero, Gnus will be totally mute; at five, Gnus will | |
418 display most important messages; and at ten, Gnus will keep on | |
419 jabbering all the time." | |
420 :group 'gnus-start | |
421 :type 'integer) | |
422 | |
423 ;; Show message if message has a lower level than `gnus-verbose'. | |
424 ;; Guideline for numbers: | |
425 ;; 1 - error messages, 3 - non-serious error messages, 5 - messages | |
426 ;; for things that take a long time, 7 - not very important messages | |
427 ;; on stuff, 9 - messages inside loops. | |
428 (defun gnus-message (level &rest args) | |
429 (if (<= level gnus-verbose) | |
430 (apply 'message args) | |
431 ;; We have to do this format thingy here even if the result isn't | |
432 ;; shown - the return value has to be the same as the return value | |
433 ;; from `message'. | |
434 (apply 'format args))) | |
435 | |
436 (defun gnus-error (level &rest args) | |
437 "Beep an error if LEVEL is equal to or less than `gnus-verbose'." | |
438 (when (<= (floor level) gnus-verbose) | |
439 (apply 'message args) | |
440 (ding) | |
441 (let (duration) | |
442 (when (and (floatp level) | |
443 (not (zerop (setq duration (* 10 (- level (floor level))))))) | |
444 (sit-for duration)))) | |
445 nil) | |
446 | |
447 (defun gnus-split-references (references) | |
448 "Return a list of Message-IDs in REFERENCES." | |
449 (let ((beg 0) | |
450 ids) | |
451 (while (string-match "<[^>]+>" references beg) | |
452 (push (substring references (match-beginning 0) (setq beg (match-end 0))) | |
453 ids)) | |
454 (nreverse ids))) | |
455 | |
456 (defun gnus-parent-id (references &optional n) | |
457 "Return the last Message-ID in REFERENCES. | |
458 If N, return the Nth ancestor instead." | |
459 (when references | |
460 (let ((ids (inline (gnus-split-references references)))) | |
19523
6713d6efcfde
Require cl only at compile time.
Richard M. Stallman <rms@gnu.org>
parents:
17493
diff
changeset
|
461 (while (nthcdr (or n 1) ids) |
6713d6efcfde
Require cl only at compile time.
Richard M. Stallman <rms@gnu.org>
parents:
17493
diff
changeset
|
462 (setq ids (cdr ids))) |
6713d6efcfde
Require cl only at compile time.
Richard M. Stallman <rms@gnu.org>
parents:
17493
diff
changeset
|
463 (car ids)))) |
17493 | 464 |
465 (defsubst gnus-buffer-live-p (buffer) | |
466 "Say whether BUFFER is alive or not." | |
467 (and buffer | |
468 (get-buffer buffer) | |
469 (buffer-name (get-buffer buffer)))) | |
470 | |
471 (defun gnus-horizontal-recenter () | |
472 "Recenter the current buffer horizontally." | |
473 (if (< (current-column) (/ (window-width) 2)) | |
474 (set-window-hscroll (get-buffer-window (current-buffer) t) 0) | |
475 (let* ((orig (point)) | |
476 (end (window-end (get-buffer-window (current-buffer) t))) | |
477 (max 0)) | |
478 ;; Find the longest line currently displayed in the window. | |
479 (goto-char (window-start)) | |
480 (while (and (not (eobp)) | |
481 (< (point) end)) | |
482 (end-of-line) | |
483 (setq max (max max (current-column))) | |
484 (forward-line 1)) | |
485 (goto-char orig) | |
486 ;; Scroll horizontally to center (sort of) the point. | |
487 (if (> max (window-width)) | |
488 (set-window-hscroll | |
489 (get-buffer-window (current-buffer) t) | |
490 (min (- (current-column) (/ (window-width) 3)) | |
491 (+ 2 (- max (window-width))))) | |
492 (set-window-hscroll (get-buffer-window (current-buffer) t) 0)) | |
493 max))) | |
494 | |
495 (defun gnus-read-event-char () | |
496 "Get the next event." | |
497 (let ((event (read-event))) | |
498 ;; should be gnus-characterp, but this can't be called in XEmacs anyway | |
499 (cons (and (numberp event) event) event))) | |
500 | |
501 (defun gnus-sortable-date (date) | |
502 "Make sortable string by string-lessp from DATE. | |
503 Timezone package is used." | |
504 (condition-case () | |
505 (progn | |
506 (setq date (inline (timezone-fix-time | |
507 date nil | |
508 (aref (inline (timezone-parse-date date)) 4)))) | |
509 (inline | |
510 (timezone-make-sortable-date | |
511 (aref date 0) (aref date 1) (aref date 2) | |
512 (inline | |
513 (timezone-make-time-string | |
514 (aref date 3) (aref date 4) (aref date 5)))))) | |
515 (error ""))) | |
516 | |
517 (defun gnus-copy-file (file &optional to) | |
518 "Copy FILE to TO." | |
519 (interactive | |
520 (list (read-file-name "Copy file: " default-directory) | |
521 (read-file-name "Copy file to: " default-directory))) | |
522 (unless to | |
523 (setq to (read-file-name "Copy file to: " default-directory))) | |
524 (when (file-directory-p to) | |
525 (setq to (concat (file-name-as-directory to) | |
526 (file-name-nondirectory file)))) | |
527 (copy-file file to)) | |
528 | |
529 (defun gnus-kill-all-overlays () | |
530 "Delete all overlays in the current buffer." | |
531 (unless gnus-xemacs | |
532 (let* ((overlayss (overlay-lists)) | |
533 (buffer-read-only nil) | |
19969
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19523
diff
changeset
|
534 (overlays (delq nil (nconc (car overlayss) (cdr overlayss))))) |
17493 | 535 (while overlays |
536 (delete-overlay (pop overlays)))))) | |
537 | |
538 (defvar gnus-work-buffer " *gnus work*") | |
539 | |
540 (defun gnus-set-work-buffer () | |
541 "Put point in the empty Gnus work buffer." | |
542 (if (get-buffer gnus-work-buffer) | |
543 (progn | |
544 (set-buffer gnus-work-buffer) | |
545 (erase-buffer)) | |
546 (set-buffer (get-buffer-create gnus-work-buffer)) | |
547 (kill-all-local-variables) | |
548 (buffer-disable-undo (current-buffer)))) | |
549 | |
550 (defmacro gnus-group-real-name (group) | |
551 "Find the real name of a foreign newsgroup." | |
552 `(let ((gname ,group)) | |
553 (if (string-match "^[^:]+:" gname) | |
554 (substring gname (match-end 0)) | |
555 gname))) | |
556 | |
557 (defun gnus-make-sort-function (funs) | |
558 "Return a composite sort condition based on the functions in FUNC." | |
559 (cond | |
560 ((not (listp funs)) funs) | |
561 ((null funs) funs) | |
562 ((cdr funs) | |
563 `(lambda (t1 t2) | |
564 ,(gnus-make-sort-function-1 (reverse funs)))) | |
565 (t | |
566 (car funs)))) | |
567 | |
568 (defun gnus-make-sort-function-1 (funs) | |
569 "Return a composite sort condition based on the functions in FUNC." | |
570 (if (cdr funs) | |
571 `(or (,(car funs) t1 t2) | |
572 (and (not (,(car funs) t2 t1)) | |
573 ,(gnus-make-sort-function-1 (cdr funs)))) | |
574 `(,(car funs) t1 t2))) | |
575 | |
576 (defun gnus-turn-off-edit-menu (type) | |
577 "Turn off edit menu in `gnus-TYPE-mode-map'." | |
578 (define-key (symbol-value (intern (format "gnus-%s-mode-map" type))) | |
579 [menu-bar edit] 'undefined)) | |
580 | |
581 (defun gnus-prin1 (form) | |
582 "Use `prin1' on FORM in the current buffer. | |
583 Bind `print-quoted' to t while printing." | |
584 (let ((print-quoted t) | |
585 print-level print-length) | |
586 (prin1 form (current-buffer)))) | |
587 | |
588 (defun gnus-prin1-to-string (form) | |
589 "The same as `prin1', but but `print-quoted' to t." | |
590 (let ((print-quoted t)) | |
591 (prin1-to-string form))) | |
592 | |
593 (defun gnus-make-directory (directory) | |
594 "Make DIRECTORY (and all its parents) if it doesn't exist." | |
595 (when (and directory | |
596 (not (file-exists-p directory))) | |
597 (make-directory directory t)) | |
598 t) | |
599 | |
600 (defun gnus-write-buffer (file) | |
601 "Write the current buffer's contents to FILE." | |
602 ;; Make sure the directory exists. | |
603 (gnus-make-directory (file-name-directory file)) | |
604 ;; Write the buffer. | |
605 (write-region (point-min) (point-max) file nil 'quietly)) | |
606 | |
607 (defmacro gnus-delete-assq (key list) | |
608 `(let ((listval (eval ,list))) | |
609 (setq ,list (delq (assq ,key listval) listval)))) | |
610 | |
611 (defmacro gnus-delete-assoc (key list) | |
612 `(let ((listval ,list)) | |
613 (setq ,list (delq (assoc ,key listval) listval)))) | |
614 | |
615 (defun gnus-delete-file (file) | |
616 "Delete FILE if it exists." | |
617 (when (file-exists-p file) | |
618 (delete-file file))) | |
619 | |
620 (defun gnus-strip-whitespace (string) | |
621 "Return STRING stripped of all whitespace." | |
622 (while (string-match "[\r\n\t ]+" string) | |
623 (setq string (replace-match "" t t string))) | |
624 string) | |
625 | |
626 (defun gnus-put-text-property-excluding-newlines (beg end prop val) | |
627 "The same as `put-text-property', but don't put this prop on any newlines in the region." | |
628 (save-match-data | |
629 (save-excursion | |
630 (save-restriction | |
631 (goto-char beg) | |
632 (while (re-search-forward "[ \t]*\n" end 'move) | |
633 (put-text-property beg (match-beginning 0) prop val) | |
634 (setq beg (point))) | |
635 (put-text-property beg (point) prop val))))) | |
636 | |
637 ;;; Protected and atomic operations. dmoore@ucsd.edu 21.11.1996 | |
638 ;;; The primary idea here is to try to protect internal datastructures | |
639 ;;; from becoming corrupted when the user hits C-g, or if a hook or | |
640 ;;; similar blows up. Often in Gnus multiple tables/lists need to be | |
641 ;;; updated at the same time, or information can be lost. | |
642 | |
643 (defvar gnus-atomic-be-safe t | |
644 "If t, certain operations will be protected from interruption by C-g.") | |
645 | |
646 (defmacro gnus-atomic-progn (&rest forms) | |
647 "Evaluate FORMS atomically, which means to protect the evaluation | |
648 from being interrupted by the user. An error from the forms themselves | |
649 will return without finishing the operation. Since interrupts from | |
650 the user are disabled, it is recommended that only the most minimal | |
651 operations are performed by FORMS. If you wish to assign many | |
652 complicated values atomically, compute the results into temporary | |
653 variables and then do only the assignment atomically." | |
654 `(let ((inhibit-quit gnus-atomic-be-safe)) | |
655 ,@forms)) | |
656 | |
657 (put 'gnus-atomic-progn 'lisp-indent-function 0) | |
658 | |
659 (defmacro gnus-atomic-progn-assign (protect &rest forms) | |
660 "Evaluate FORMS, but insure that the variables listed in PROTECT | |
661 are not changed if anything in FORMS signals an error or otherwise | |
662 non-locally exits. The variables listed in PROTECT are updated atomically. | |
663 It is safe to use gnus-atomic-progn-assign with long computations. | |
664 | |
665 Note that if any of the symbols in PROTECT were unbound, they will be | |
666 set to nil on a sucessful assignment. In case of an error or other | |
667 non-local exit, it will still be unbound." | |
668 (let* ((temp-sym-map (mapcar (lambda (x) (list (make-symbol | |
669 (concat (symbol-name x) | |
670 "-tmp")) | |
671 x)) | |
672 protect)) | |
673 (sym-temp-map (mapcar (lambda (x) (list (cadr x) (car x))) | |
674 temp-sym-map)) | |
675 (temp-sym-let (mapcar (lambda (x) (list (car x) | |
676 `(and (boundp ',(cadr x)) | |
677 ,(cadr x)))) | |
678 temp-sym-map)) | |
679 (sym-temp-let sym-temp-map) | |
680 (temp-sym-assign (apply 'append temp-sym-map)) | |
681 (sym-temp-assign (apply 'append sym-temp-map)) | |
682 (result (make-symbol "result-tmp"))) | |
683 `(let (,@temp-sym-let | |
684 ,result) | |
685 (let ,sym-temp-let | |
686 (setq ,result (progn ,@forms)) | |
687 (setq ,@temp-sym-assign)) | |
688 (let ((inhibit-quit gnus-atomic-be-safe)) | |
689 (setq ,@sym-temp-assign)) | |
690 ,result))) | |
691 | |
692 (put 'gnus-atomic-progn-assign 'lisp-indent-function 1) | |
693 ;(put 'gnus-atomic-progn-assign 'edebug-form-spec '(sexp body)) | |
694 | |
695 (defmacro gnus-atomic-setq (&rest pairs) | |
696 "Similar to setq, except that the real symbols are only assigned when | |
697 there are no errors. And when the real symbols are assigned, they are | |
698 done so atomically. If other variables might be changed via side-effect, | |
699 see gnus-atomic-progn-assign. It is safe to use gnus-atomic-setq | |
700 with potentially long computations." | |
701 (let ((tpairs pairs) | |
702 syms) | |
703 (while tpairs | |
704 (push (car tpairs) syms) | |
705 (setq tpairs (cddr tpairs))) | |
706 `(gnus-atomic-progn-assign ,syms | |
707 (setq ,@pairs)))) | |
708 | |
709 ;(put 'gnus-atomic-setq 'edebug-form-spec '(body)) | |
710 | |
711 | |
712 ;;; Functions for saving to babyl/mail files. | |
713 | |
714 (defvar rmail-default-rmail-file) | |
715 (defun gnus-output-to-rmail (filename &optional ask) | |
716 "Append the current article to an Rmail file named FILENAME." | |
717 (require 'rmail) | |
718 ;; Most of these codes are borrowed from rmailout.el. | |
719 (setq filename (expand-file-name filename)) | |
720 (setq rmail-default-rmail-file filename) | |
721 (let ((artbuf (current-buffer)) | |
722 (tmpbuf (get-buffer-create " *Gnus-output*"))) | |
723 (save-excursion | |
724 (or (get-file-buffer filename) | |
725 (file-exists-p filename) | |
726 (if (or (not ask) | |
727 (gnus-yes-or-no-p | |
728 (concat "\"" filename "\" does not exist, create it? "))) | |
729 (let ((file-buffer (create-file-buffer filename))) | |
730 (save-excursion | |
731 (set-buffer file-buffer) | |
732 (rmail-insert-rmail-file-header) | |
733 (let ((require-final-newline nil)) | |
734 (gnus-write-buffer filename))) | |
735 (kill-buffer file-buffer)) | |
736 (error "Output file does not exist"))) | |
737 (set-buffer tmpbuf) | |
738 (erase-buffer) | |
739 (insert-buffer-substring artbuf) | |
740 (gnus-convert-article-to-rmail) | |
741 ;; Decide whether to append to a file or to an Emacs buffer. | |
742 (let ((outbuf (get-file-buffer filename))) | |
743 (if (not outbuf) | |
744 (append-to-file (point-min) (point-max) filename) | |
745 ;; File has been visited, in buffer OUTBUF. | |
746 (set-buffer outbuf) | |
747 (let ((buffer-read-only nil) | |
748 (msg (and (boundp 'rmail-current-message) | |
749 (symbol-value 'rmail-current-message)))) | |
750 ;; If MSG is non-nil, buffer is in RMAIL mode. | |
751 (when msg | |
752 (widen) | |
753 (narrow-to-region (point-max) (point-max))) | |
754 (insert-buffer-substring tmpbuf) | |
755 (when msg | |
756 (goto-char (point-min)) | |
757 (widen) | |
758 (search-backward "\^_") | |
759 (narrow-to-region (point) (point-max)) | |
760 (goto-char (1+ (point-min))) | |
761 (rmail-count-new-messages t) | |
762 (rmail-show-message msg)))))) | |
763 (kill-buffer tmpbuf))) | |
764 | |
765 (defun gnus-output-to-mail (filename &optional ask) | |
766 "Append the current article to a mail file named FILENAME." | |
767 (setq filename (expand-file-name filename)) | |
768 (let ((artbuf (current-buffer)) | |
769 (tmpbuf (get-buffer-create " *Gnus-output*"))) | |
770 (save-excursion | |
771 ;; Create the file, if it doesn't exist. | |
772 (when (and (not (get-file-buffer filename)) | |
773 (not (file-exists-p filename))) | |
774 (if (or (not ask) | |
775 (gnus-y-or-n-p | |
776 (concat "\"" filename "\" does not exist, create it? "))) | |
777 (let ((file-buffer (create-file-buffer filename))) | |
778 (save-excursion | |
779 (set-buffer file-buffer) | |
780 (let ((require-final-newline nil)) | |
781 (gnus-write-buffer filename))) | |
782 (kill-buffer file-buffer)) | |
783 (error "Output file does not exist"))) | |
784 (set-buffer tmpbuf) | |
785 (erase-buffer) | |
786 (insert-buffer-substring artbuf) | |
787 (goto-char (point-min)) | |
788 (if (looking-at "From ") | |
789 (forward-line 1) | |
790 (insert "From nobody " (current-time-string) "\n")) | |
791 (let (case-fold-search) | |
792 (while (re-search-forward "^From " nil t) | |
793 (beginning-of-line) | |
794 (insert ">"))) | |
795 ;; Decide whether to append to a file or to an Emacs buffer. | |
796 (let ((outbuf (get-file-buffer filename))) | |
797 (if (not outbuf) | |
798 (let ((buffer-read-only nil)) | |
799 (save-excursion | |
800 (goto-char (point-max)) | |
801 (forward-char -2) | |
802 (unless (looking-at "\n\n") | |
803 (goto-char (point-max)) | |
804 (unless (bolp) | |
805 (insert "\n")) | |
806 (insert "\n")) | |
807 (goto-char (point-max)) | |
808 (append-to-file (point-min) (point-max) filename))) | |
809 ;; File has been visited, in buffer OUTBUF. | |
810 (set-buffer outbuf) | |
811 (let ((buffer-read-only nil)) | |
812 (goto-char (point-max)) | |
813 (unless (eobp) | |
814 (insert "\n")) | |
815 (insert "\n") | |
816 (insert-buffer-substring tmpbuf))))) | |
817 (kill-buffer tmpbuf))) | |
818 | |
819 (defun gnus-convert-article-to-rmail () | |
820 "Convert article in current buffer to Rmail message format." | |
821 (let ((buffer-read-only nil)) | |
822 ;; Convert article directly into Babyl format. | |
823 (goto-char (point-min)) | |
824 (insert "\^L\n0, unseen,,\n*** EOOH ***\n") | |
825 (while (search-forward "\n\^_" nil t) ;single char | |
826 (replace-match "\n^_" t t)) ;2 chars: "^" and "_" | |
827 (goto-char (point-max)) | |
828 (insert "\^_"))) | |
829 | |
830 (provide 'gnus-util) | |
831 | |
832 ;;; gnus-util.el ends here |