Mercurial > emacs
annotate lisp/gnus/gnus-util.el @ 29462:3306af2e4f3d
(append_glyph): Revert change of 2000-06-06.
author | Gerd Moellmann <gerd@gnu.org> |
---|---|
date | Tue, 06 Jun 2000 12:26:35 +0000 |
parents | 15fc6acbae7a |
children | 9968f55ad26e |
rev | line source |
---|---|
17493 | 1 ;;; gnus-util.el --- utility functions for Gnus |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
2 ;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. |
17493 | 3 |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
17493 | 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) | |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
38 (eval-when-compile (require 'rmail)) |
17493 | 39 |
40 (eval-and-compile | |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
41 (autoload 'nnmail-date-to-time "nnmail") |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
42 (autoload 'rmail-insert-rmail-file-header "rmail") |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
43 (autoload 'rmail-count-new-messages "rmail") |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
44 (autoload 'rmail-show-message "rmail")) |
17493 | 45 |
46 (defun gnus-boundp (variable) | |
47 "Return non-nil if VARIABLE is bound and non-nil." | |
48 (and (boundp variable) | |
49 (symbol-value variable))) | |
50 | |
51 (defmacro gnus-eval-in-buffer-window (buffer &rest forms) | |
52 "Pop to BUFFER, evaluate FORMS, and then return to the original window." | |
53 (let ((tempvar (make-symbol "GnusStartBufferWindow")) | |
54 (w (make-symbol "w")) | |
55 (buf (make-symbol "buf"))) | |
56 `(let* ((,tempvar (selected-window)) | |
57 (,buf ,buffer) | |
58 (,w (get-buffer-window ,buf 'visible))) | |
59 (unwind-protect | |
60 (progn | |
61 (if ,w | |
62 (progn | |
63 (select-window ,w) | |
64 (set-buffer (window-buffer ,w))) | |
65 (pop-to-buffer ,buf)) | |
66 ,@forms) | |
67 (select-window ,tempvar))))) | |
68 | |
69 (put 'gnus-eval-in-buffer-window 'lisp-indent-function 1) | |
70 (put 'gnus-eval-in-buffer-window 'edebug-form-spec '(form body)) | |
71 | |
72 (defmacro gnus-intern-safe (string hashtable) | |
73 "Set hash value. Arguments are STRING, VALUE, and HASHTABLE." | |
74 `(let ((symbol (intern ,string ,hashtable))) | |
75 (or (boundp symbol) | |
76 (set symbol nil)) | |
77 symbol)) | |
78 | |
79 (defun gnus-truncate-string (str width) | |
80 (substring str 0 width)) | |
81 | |
82 ;; Added by Geoffrey T. Dairiki <dairiki@u.washington.edu>. A safe way | |
83 ;; to limit the length of a string. This function is necessary since | |
84 ;; `(substr "abc" 0 30)' pukes with "Args out of range". | |
85 (defsubst gnus-limit-string (str width) | |
86 (if (> (length str) width) | |
87 (substring str 0 width) | |
88 str)) | |
89 | |
90 (defsubst gnus-functionp (form) | |
91 "Return non-nil if FORM is funcallable." | |
92 (or (and (symbolp form) (fboundp form)) | |
93 (and (listp form) (eq (car form) 'lambda)) | |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
94 (byte-code-function-p form))) |
17493 | 95 |
96 (defsubst gnus-goto-char (point) | |
97 (and point (goto-char point))) | |
98 | |
99 (defmacro gnus-buffer-exists-p (buffer) | |
100 `(let ((buffer ,buffer)) | |
101 (when buffer | |
102 (funcall (if (stringp buffer) 'get-buffer 'buffer-name) | |
103 buffer)))) | |
104 | |
105 (defmacro gnus-kill-buffer (buffer) | |
106 `(let ((buf ,buffer)) | |
107 (when (gnus-buffer-exists-p buf) | |
108 (kill-buffer buf)))) | |
109 | |
110 (if (fboundp 'point-at-bol) | |
111 (fset 'gnus-point-at-bol 'point-at-bol) | |
112 (defun gnus-point-at-bol () | |
113 "Return point at the beginning of the line." | |
114 (let ((p (point))) | |
115 (beginning-of-line) | |
116 (prog1 | |
117 (point) | |
118 (goto-char p))))) | |
119 | |
120 (if (fboundp 'point-at-eol) | |
121 (fset 'gnus-point-at-eol 'point-at-eol) | |
122 (defun gnus-point-at-eol () | |
123 "Return point at the end of the line." | |
124 (let ((p (point))) | |
125 (end-of-line) | |
126 (prog1 | |
127 (point) | |
128 (goto-char p))))) | |
129 | |
130 (defun gnus-delete-first (elt list) | |
131 "Delete by side effect the first occurrence of ELT as a member of LIST." | |
132 (if (equal (car list) elt) | |
133 (cdr list) | |
134 (let ((total list)) | |
135 (while (and (cdr list) | |
136 (not (equal (cadr list) elt))) | |
137 (setq list (cdr list))) | |
138 (when (cdr list) | |
139 (setcdr list (cddr list))) | |
140 total))) | |
141 | |
142 ;; Delete the current line (and the next N lines). | |
143 (defmacro gnus-delete-line (&optional n) | |
144 `(delete-region (progn (beginning-of-line) (point)) | |
145 (progn (forward-line ,(or n 1)) (point)))) | |
146 | |
147 (defun gnus-byte-code (func) | |
148 "Return a form that can be `eval'ed based on FUNC." | |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
149 (let ((fval (indirect-function func))) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
150 (if (byte-code-function-p fval) |
17493 | 151 (let ((flist (append fval nil))) |
152 (setcar flist 'byte-code) | |
153 flist) | |
154 (cons 'progn (cddr fval))))) | |
155 | |
156 (defun gnus-extract-address-components (from) | |
157 (let (name address) | |
158 ;; First find the address - the thing with the @ in it. This may | |
159 ;; not be accurate in mail addresses, but does the trick most of | |
160 ;; the time in news messages. | |
161 (when (string-match "\\b[^@ \t<>]+[!@][^@ \t<>]+\\b" from) | |
162 (setq address (substring from (match-beginning 0) (match-end 0)))) | |
163 ;; Then we check whether the "name <address>" format is used. | |
164 (and address | |
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 ;; XOVER might not support folded From headers. | |
179 (and (string-match "(.*" from) | |
180 (setq name (substring from (1+ (match-beginning 0)) | |
181 (match-end 0))))) | |
182 ;; Fix by Hallvard B Furuseth <h.b.furuseth@usit.uio.no>. | |
183 (list (or name from) (or address from)))) | |
184 | |
185 (defun gnus-fetch-field (field) | |
186 "Return the value of the header FIELD of current article." | |
187 (save-excursion | |
188 (save-restriction | |
189 (let ((case-fold-search t) | |
190 (inhibit-point-motion-hooks t)) | |
191 (nnheader-narrow-to-headers) | |
192 (message-fetch-field field))))) | |
193 | |
194 (defun gnus-goto-colon () | |
195 (beginning-of-line) | |
196 (search-forward ":" (gnus-point-at-eol) t)) | |
197 | |
198 (defun gnus-remove-text-with-property (prop) | |
199 "Delete all text in the current buffer with text property PROP." | |
200 (save-excursion | |
201 (goto-char (point-min)) | |
202 (while (not (eobp)) | |
203 (while (get-text-property (point) prop) | |
204 (delete-char 1)) | |
205 (goto-char (next-single-property-change (point) prop nil (point-max)))))) | |
206 | |
207 (defun gnus-newsgroup-directory-form (newsgroup) | |
208 "Make hierarchical directory name from NEWSGROUP name." | |
209 (let ((newsgroup (gnus-newsgroup-savable-name newsgroup)) | |
210 (len (length newsgroup)) | |
211 idx) | |
212 ;; If this is a foreign group, we don't want to translate the | |
213 ;; entire name. | |
214 (if (setq idx (string-match ":" newsgroup)) | |
215 (aset newsgroup idx ?/) | |
216 (setq idx 0)) | |
217 ;; Replace all occurrences of `.' with `/'. | |
218 (while (< idx len) | |
219 (when (= (aref newsgroup idx) ?.) | |
220 (aset newsgroup idx ?/)) | |
221 (setq idx (1+ idx))) | |
222 newsgroup)) | |
223 | |
224 (defun gnus-newsgroup-savable-name (group) | |
225 ;; Replace any slashes in a group name (eg. an ange-ftp nndoc group) | |
226 ;; with dots. | |
227 (nnheader-replace-chars-in-string group ?/ ?.)) | |
228 | |
229 (defun gnus-string> (s1 s2) | |
230 (not (or (string< s1 s2) | |
231 (string= s1 s2)))) | |
232 | |
233 ;;; Time functions. | |
234 | |
235 (defun gnus-days-between (date1 date2) | |
236 ;; Return the number of days between date1 and date2. | |
237 (- (gnus-day-number date1) (gnus-day-number date2))) | |
238 | |
239 (defun gnus-day-number (date) | |
240 (let ((dat (mapcar (lambda (s) (and s (string-to-int s)) ) | |
241 (timezone-parse-date date)))) | |
242 (timezone-absolute-from-gregorian | |
243 (nth 1 dat) (nth 2 dat) (car dat)))) | |
244 | |
245 (defun gnus-time-to-day (time) | |
246 "Convert TIME to day number." | |
247 (let ((tim (decode-time time))) | |
248 (timezone-absolute-from-gregorian | |
249 (nth 4 tim) (nth 3 tim) (nth 5 tim)))) | |
250 | |
251 (defun gnus-encode-date (date) | |
252 "Convert DATE to internal time." | |
253 (let* ((parse (timezone-parse-date date)) | |
254 (date (mapcar (lambda (d) (and d (string-to-int d))) parse)) | |
255 (time (mapcar 'string-to-int (timezone-parse-time (aref parse 3))))) | |
256 (encode-time (caddr time) (cadr time) (car time) | |
19969
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19523
diff
changeset
|
257 (caddr date) (cadr date) (car date) |
5f1ab3dd344d
*** empty log message ***
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19523
diff
changeset
|
258 (* 60 (timezone-zone-to-minute (nth 4 date)))))) |
17493 | 259 |
260 (defun gnus-time-minus (t1 t2) | |
261 "Subtract two internal times." | |
262 (let ((borrow (< (cadr t1) (cadr t2)))) | |
263 (list (- (car t1) (car t2) (if borrow 1 0)) | |
264 (- (+ (if borrow 65536 0) (cadr t1)) (cadr t2))))) | |
265 | |
266 (defun gnus-time-less (t1 t2) | |
267 "Say whether time T1 is less than time T2." | |
268 (or (< (car t1) (car t2)) | |
269 (and (= (car t1) (car t2)) | |
270 (< (nth 1 t1) (nth 1 t2))))) | |
271 | |
272 (defun gnus-file-newer-than (file date) | |
273 (let ((fdate (nth 5 (file-attributes file)))) | |
274 (or (> (car fdate) (car date)) | |
275 (and (= (car fdate) (car date)) | |
276 (> (nth 1 fdate) (nth 1 date)))))) | |
277 | |
278 ;;; Keymap macros. | |
279 | |
280 (defmacro gnus-local-set-keys (&rest plist) | |
281 "Set the keys in PLIST in the current keymap." | |
282 `(gnus-define-keys-1 (current-local-map) ',plist)) | |
283 | |
284 (defmacro gnus-define-keys (keymap &rest plist) | |
285 "Define all keys in PLIST in KEYMAP." | |
286 `(gnus-define-keys-1 (quote ,keymap) (quote ,plist))) | |
287 | |
288 (defmacro gnus-define-keys-safe (keymap &rest plist) | |
289 "Define all keys in PLIST in KEYMAP without overwriting previous definitions." | |
290 `(gnus-define-keys-1 (quote ,keymap) (quote ,plist) t)) | |
291 | |
292 (put 'gnus-define-keys 'lisp-indent-function 1) | |
293 (put 'gnus-define-keys-safe 'lisp-indent-function 1) | |
294 (put 'gnus-local-set-keys 'lisp-indent-function 1) | |
295 | |
296 (defmacro gnus-define-keymap (keymap &rest plist) | |
297 "Define all keys in PLIST in KEYMAP." | |
298 `(gnus-define-keys-1 ,keymap (quote ,plist))) | |
299 | |
300 (put 'gnus-define-keymap 'lisp-indent-function 1) | |
301 | |
302 (defun gnus-define-keys-1 (keymap plist &optional safe) | |
303 (when (null keymap) | |
304 (error "Can't set keys in a null keymap")) | |
305 (cond ((symbolp keymap) | |
306 (setq keymap (symbol-value keymap))) | |
307 ((keymapp keymap)) | |
308 ((listp keymap) | |
309 (set (car keymap) nil) | |
310 (define-prefix-command (car keymap)) | |
311 (define-key (symbol-value (caddr keymap)) (cadr keymap) (car keymap)) | |
312 (setq keymap (symbol-value (car keymap))))) | |
313 (let (key) | |
314 (while plist | |
315 (when (symbolp (setq key (pop plist))) | |
316 (setq key (symbol-value key))) | |
317 (if (or (not safe) | |
318 (eq (lookup-key keymap key) 'undefined)) | |
319 (define-key keymap key (pop plist)) | |
320 (pop plist))))) | |
321 | |
322 (defun gnus-completing-read (default prompt &rest args) | |
323 ;; Like `completing-read', except that DEFAULT is the default argument. | |
324 (let* ((prompt (if default | |
325 (concat prompt " (default " default ") ") | |
326 (concat prompt " "))) | |
327 (answer (apply 'completing-read prompt args))) | |
328 (if (or (null answer) (zerop (length answer))) | |
329 default | |
330 answer))) | |
331 | |
332 ;; Two silly functions to ensure that all `y-or-n-p' questions clear | |
333 ;; the echo area. | |
334 (defun gnus-y-or-n-p (prompt) | |
335 (prog1 | |
336 (y-or-n-p prompt) | |
337 (message ""))) | |
338 | |
339 (defun gnus-yes-or-no-p (prompt) | |
340 (prog1 | |
341 (yes-or-no-p prompt) | |
342 (message ""))) | |
343 | |
344 (defun gnus-dd-mmm (messy-date) | |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
345 "Return a string like DD-MMM from a big messy string." |
17493 | 346 (let ((datevec (ignore-errors (timezone-parse-date messy-date)))) |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
347 (if (or (not datevec) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
348 (string-equal "0" (aref datevec 1))) |
17493 | 349 "??-???" |
350 (format "%2s-%s" | |
351 (condition-case () | |
352 ;; Make sure leading zeroes are stripped. | |
353 (number-to-string (string-to-number (aref datevec 2))) | |
354 (error "??")) | |
355 (capitalize | |
356 (or (car | |
357 (nth (1- (string-to-number (aref datevec 1))) | |
358 timezone-months-assoc)) | |
359 "???")))))) | |
360 | |
361 (defmacro gnus-date-get-time (date) | |
362 "Convert DATE string to Emacs time. | |
363 Cache the result as a text property stored in DATE." | |
364 ;; Either return the cached value... | |
365 `(let ((d ,date)) | |
366 (if (equal "" d) | |
367 '(0 0) | |
368 (or (get-text-property 0 'gnus-time d) | |
369 ;; or compute the value... | |
370 (let ((time (nnmail-date-to-time d))) | |
371 ;; and store it back in the string. | |
372 (put-text-property 0 1 'gnus-time time d) | |
373 time))))) | |
374 | |
375 (defsubst gnus-time-iso8601 (time) | |
376 "Return a string of TIME in YYMMDDTHHMMSS format." | |
377 (format-time-string "%Y%m%dT%H%M%S" time)) | |
378 | |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
379 (defun gnus-date-iso8601 (date) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
380 "Convert the DATE to YYMMDDTHHMMSS." |
17493 | 381 (condition-case () |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
382 (gnus-time-iso8601 (gnus-date-get-time date)) |
17493 | 383 (error ""))) |
384 | |
385 (defun gnus-mode-string-quote (string) | |
386 "Quote all \"%\"'s in STRING." | |
387 (save-excursion | |
388 (gnus-set-work-buffer) | |
389 (insert string) | |
390 (goto-char (point-min)) | |
391 (while (search-forward "%" nil t) | |
392 (insert "%")) | |
393 (buffer-string))) | |
394 | |
395 ;; Make a hash table (default and minimum size is 256). | |
396 ;; Optional argument HASHSIZE specifies the table size. | |
397 (defun gnus-make-hashtable (&optional hashsize) | |
398 (make-vector (if hashsize (max (gnus-create-hash-size hashsize) 256) 256) 0)) | |
399 | |
400 ;; Make a number that is suitable for hashing; bigger than MIN and | |
401 ;; equal to some 2^x. Many machines (such as sparcs) do not have a | |
402 ;; hardware modulo operation, so they implement it in software. On | |
403 ;; many sparcs over 50% of the time to intern is spent in the modulo. | |
404 ;; Yes, it's slower than actually computing the hash from the string! | |
405 ;; So we use powers of 2 so people can optimize the modulo to a mask. | |
406 (defun gnus-create-hash-size (min) | |
407 (let ((i 1)) | |
408 (while (< i min) | |
409 (setq i (* 2 i))) | |
410 i)) | |
411 | |
412 (defcustom gnus-verbose 7 | |
413 "*Integer that says how verbose Gnus should be. | |
414 The higher the number, the more messages Gnus will flash to say what | |
415 it's doing. At zero, Gnus will be totally mute; at five, Gnus will | |
416 display most important messages; and at ten, Gnus will keep on | |
417 jabbering all the time." | |
418 :group 'gnus-start | |
419 :type 'integer) | |
420 | |
421 ;; Show message if message has a lower level than `gnus-verbose'. | |
422 ;; Guideline for numbers: | |
423 ;; 1 - error messages, 3 - non-serious error messages, 5 - messages | |
424 ;; for things that take a long time, 7 - not very important messages | |
425 ;; on stuff, 9 - messages inside loops. | |
426 (defun gnus-message (level &rest args) | |
427 (if (<= level gnus-verbose) | |
428 (apply 'message args) | |
429 ;; We have to do this format thingy here even if the result isn't | |
430 ;; shown - the return value has to be the same as the return value | |
431 ;; from `message'. | |
432 (apply 'format args))) | |
433 | |
434 (defun gnus-error (level &rest args) | |
435 "Beep an error if LEVEL is equal to or less than `gnus-verbose'." | |
436 (when (<= (floor level) gnus-verbose) | |
437 (apply 'message args) | |
438 (ding) | |
439 (let (duration) | |
440 (when (and (floatp level) | |
441 (not (zerop (setq duration (* 10 (- level (floor level))))))) | |
442 (sit-for duration)))) | |
443 nil) | |
444 | |
445 (defun gnus-split-references (references) | |
446 "Return a list of Message-IDs in REFERENCES." | |
447 (let ((beg 0) | |
448 ids) | |
449 (while (string-match "<[^>]+>" references beg) | |
450 (push (substring references (match-beginning 0) (setq beg (match-end 0))) | |
451 ids)) | |
452 (nreverse ids))) | |
453 | |
454 (defun gnus-parent-id (references &optional n) | |
455 "Return the last Message-ID in REFERENCES. | |
456 If N, return the Nth ancestor instead." | |
457 (when references | |
458 (let ((ids (inline (gnus-split-references references)))) | |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
459 (car (last ids (or n 1)))))) |
17493 | 460 |
461 (defsubst gnus-buffer-live-p (buffer) | |
462 "Say whether BUFFER is alive or not." | |
463 (and buffer | |
464 (get-buffer buffer) | |
465 (buffer-name (get-buffer buffer)))) | |
466 | |
467 (defun gnus-horizontal-recenter () | |
468 "Recenter the current buffer horizontally." | |
469 (if (< (current-column) (/ (window-width) 2)) | |
470 (set-window-hscroll (get-buffer-window (current-buffer) t) 0) | |
471 (let* ((orig (point)) | |
472 (end (window-end (get-buffer-window (current-buffer) t))) | |
473 (max 0)) | |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
474 (when end |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
475 ;; Find the longest line currently displayed in the window. |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
476 (goto-char (window-start)) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
477 (while (and (not (eobp)) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
478 (< (point) end)) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
479 (end-of-line) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
480 (setq max (max max (current-column))) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
481 (forward-line 1)) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
482 (goto-char orig) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
483 ;; Scroll horizontally to center (sort of) the point. |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
484 (if (> max (window-width)) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
485 (set-window-hscroll |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
486 (get-buffer-window (current-buffer) t) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
487 (min (- (current-column) (/ (window-width) 3)) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
488 (+ 2 (- max (window-width))))) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
489 (set-window-hscroll (get-buffer-window (current-buffer) t) 0)) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
490 max)))) |
17493 | 491 |
492 (defun gnus-read-event-char () | |
493 "Get the next event." | |
494 (let ((event (read-event))) | |
495 ;; should be gnus-characterp, but this can't be called in XEmacs anyway | |
496 (cons (and (numberp event) event) event))) | |
497 | |
498 (defun gnus-sortable-date (date) | |
499 "Make sortable string by string-lessp from DATE. | |
500 Timezone package is used." | |
501 (condition-case () | |
502 (progn | |
503 (setq date (inline (timezone-fix-time | |
504 date nil | |
505 (aref (inline (timezone-parse-date date)) 4)))) | |
506 (inline | |
507 (timezone-make-sortable-date | |
508 (aref date 0) (aref date 1) (aref date 2) | |
509 (inline | |
510 (timezone-make-time-string | |
511 (aref date 3) (aref date 4) (aref date 5)))))) | |
512 (error ""))) | |
513 | |
514 (defun gnus-copy-file (file &optional to) | |
515 "Copy FILE to TO." | |
516 (interactive | |
517 (list (read-file-name "Copy file: " default-directory) | |
518 (read-file-name "Copy file to: " default-directory))) | |
519 (unless to | |
520 (setq to (read-file-name "Copy file to: " default-directory))) | |
521 (when (file-directory-p to) | |
522 (setq to (concat (file-name-as-directory to) | |
523 (file-name-nondirectory file)))) | |
524 (copy-file file to)) | |
525 | |
526 (defun gnus-kill-all-overlays () | |
527 "Delete all overlays in the current buffer." | |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
528 (let* ((overlayss (overlay-lists)) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
529 (buffer-read-only nil) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
530 (overlays (delq nil (nconc (car overlayss) (cdr overlayss))))) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
531 (while overlays |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
532 (delete-overlay (pop overlays))))) |
17493 | 533 |
534 (defvar gnus-work-buffer " *gnus work*") | |
535 | |
536 (defun gnus-set-work-buffer () | |
537 "Put point in the empty Gnus work buffer." | |
538 (if (get-buffer gnus-work-buffer) | |
539 (progn | |
540 (set-buffer gnus-work-buffer) | |
541 (erase-buffer)) | |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
542 (set-buffer (gnus-get-buffer-create gnus-work-buffer)) |
17493 | 543 (kill-all-local-variables) |
544 (buffer-disable-undo (current-buffer)))) | |
545 | |
546 (defmacro gnus-group-real-name (group) | |
547 "Find the real name of a foreign newsgroup." | |
548 `(let ((gname ,group)) | |
549 (if (string-match "^[^:]+:" gname) | |
550 (substring gname (match-end 0)) | |
551 gname))) | |
552 | |
553 (defun gnus-make-sort-function (funs) | |
554 "Return a composite sort condition based on the functions in FUNC." | |
555 (cond | |
556 ((not (listp funs)) funs) | |
557 ((null funs) funs) | |
558 ((cdr funs) | |
559 `(lambda (t1 t2) | |
560 ,(gnus-make-sort-function-1 (reverse funs)))) | |
561 (t | |
562 (car funs)))) | |
563 | |
564 (defun gnus-make-sort-function-1 (funs) | |
565 "Return a composite sort condition based on the functions in FUNC." | |
566 (if (cdr funs) | |
567 `(or (,(car funs) t1 t2) | |
568 (and (not (,(car funs) t2 t1)) | |
569 ,(gnus-make-sort-function-1 (cdr funs)))) | |
570 `(,(car funs) t1 t2))) | |
571 | |
572 (defun gnus-turn-off-edit-menu (type) | |
573 "Turn off edit menu in `gnus-TYPE-mode-map'." | |
574 (define-key (symbol-value (intern (format "gnus-%s-mode-map" type))) | |
575 [menu-bar edit] 'undefined)) | |
576 | |
577 (defun gnus-prin1 (form) | |
578 "Use `prin1' on FORM in the current buffer. | |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
579 Bind `print-quoted' and `print-readably' to t while printing." |
17493 | 580 (let ((print-quoted t) |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
581 (print-readably t) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
582 (print-escape-multibyte nil) |
17493 | 583 print-level print-length) |
584 (prin1 form (current-buffer)))) | |
585 | |
586 (defun gnus-prin1-to-string (form) | |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
587 "The same as `prin1', but bind `print-quoted' and `print-readably' to t." |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
588 (let ((print-quoted t) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
589 (print-readably t)) |
17493 | 590 (prin1-to-string form))) |
591 | |
592 (defun gnus-make-directory (directory) | |
593 "Make DIRECTORY (and all its parents) if it doesn't exist." | |
594 (when (and directory | |
595 (not (file-exists-p directory))) | |
596 (make-directory directory t)) | |
597 t) | |
598 | |
599 (defun gnus-write-buffer (file) | |
600 "Write the current buffer's contents to FILE." | |
601 ;; Make sure the directory exists. | |
602 (gnus-make-directory (file-name-directory file)) | |
603 ;; Write the buffer. | |
604 (write-region (point-min) (point-max) file nil 'quietly)) | |
605 | |
606 (defun gnus-delete-file (file) | |
607 "Delete FILE if it exists." | |
608 (when (file-exists-p file) | |
609 (delete-file file))) | |
610 | |
611 (defun gnus-strip-whitespace (string) | |
612 "Return STRING stripped of all whitespace." | |
613 (while (string-match "[\r\n\t ]+" string) | |
614 (setq string (replace-match "" t t string))) | |
615 string) | |
616 | |
617 (defun gnus-put-text-property-excluding-newlines (beg end prop val) | |
618 "The same as `put-text-property', but don't put this prop on any newlines in the region." | |
619 (save-match-data | |
620 (save-excursion | |
621 (save-restriction | |
622 (goto-char beg) | |
623 (while (re-search-forward "[ \t]*\n" end 'move) | |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
624 (gnus-put-text-property beg (match-beginning 0) prop val) |
17493 | 625 (setq beg (point))) |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
626 (gnus-put-text-property beg (point) prop val))))) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
627 |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
628 (defun gnus-put-text-property-excluding-characters-with-faces (beg end |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
629 prop val) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
630 "The same as `put-text-property', but don't put props on characters with the `gnus-face' property." |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
631 (let ((b beg)) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
632 (while (/= b end) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
633 (when (get-text-property b 'gnus-face) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
634 (setq b (next-single-property-change b 'gnus-face nil end))) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
635 (when (/= b end) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
636 (gnus-put-text-property |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
637 b (setq b (next-single-property-change b 'gnus-face nil end)) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
638 prop val))))) |
17493 | 639 |
640 ;;; Protected and atomic operations. dmoore@ucsd.edu 21.11.1996 | |
641 ;;; The primary idea here is to try to protect internal datastructures | |
642 ;;; from becoming corrupted when the user hits C-g, or if a hook or | |
643 ;;; similar blows up. Often in Gnus multiple tables/lists need to be | |
644 ;;; updated at the same time, or information can be lost. | |
645 | |
646 (defvar gnus-atomic-be-safe t | |
647 "If t, certain operations will be protected from interruption by C-g.") | |
648 | |
649 (defmacro gnus-atomic-progn (&rest forms) | |
650 "Evaluate FORMS atomically, which means to protect the evaluation | |
651 from being interrupted by the user. An error from the forms themselves | |
652 will return without finishing the operation. Since interrupts from | |
653 the user are disabled, it is recommended that only the most minimal | |
654 operations are performed by FORMS. If you wish to assign many | |
655 complicated values atomically, compute the results into temporary | |
656 variables and then do only the assignment atomically." | |
657 `(let ((inhibit-quit gnus-atomic-be-safe)) | |
658 ,@forms)) | |
659 | |
660 (put 'gnus-atomic-progn 'lisp-indent-function 0) | |
661 | |
662 (defmacro gnus-atomic-progn-assign (protect &rest forms) | |
663 "Evaluate FORMS, but insure that the variables listed in PROTECT | |
664 are not changed if anything in FORMS signals an error or otherwise | |
665 non-locally exits. The variables listed in PROTECT are updated atomically. | |
666 It is safe to use gnus-atomic-progn-assign with long computations. | |
667 | |
668 Note that if any of the symbols in PROTECT were unbound, they will be | |
669 set to nil on a sucessful assignment. In case of an error or other | |
670 non-local exit, it will still be unbound." | |
671 (let* ((temp-sym-map (mapcar (lambda (x) (list (make-symbol | |
672 (concat (symbol-name x) | |
673 "-tmp")) | |
674 x)) | |
675 protect)) | |
676 (sym-temp-map (mapcar (lambda (x) (list (cadr x) (car x))) | |
677 temp-sym-map)) | |
678 (temp-sym-let (mapcar (lambda (x) (list (car x) | |
679 `(and (boundp ',(cadr x)) | |
680 ,(cadr x)))) | |
681 temp-sym-map)) | |
682 (sym-temp-let sym-temp-map) | |
683 (temp-sym-assign (apply 'append temp-sym-map)) | |
684 (sym-temp-assign (apply 'append sym-temp-map)) | |
685 (result (make-symbol "result-tmp"))) | |
686 `(let (,@temp-sym-let | |
687 ,result) | |
688 (let ,sym-temp-let | |
689 (setq ,result (progn ,@forms)) | |
690 (setq ,@temp-sym-assign)) | |
691 (let ((inhibit-quit gnus-atomic-be-safe)) | |
692 (setq ,@sym-temp-assign)) | |
693 ,result))) | |
694 | |
695 (put 'gnus-atomic-progn-assign 'lisp-indent-function 1) | |
696 ;(put 'gnus-atomic-progn-assign 'edebug-form-spec '(sexp body)) | |
697 | |
698 (defmacro gnus-atomic-setq (&rest pairs) | |
699 "Similar to setq, except that the real symbols are only assigned when | |
700 there are no errors. And when the real symbols are assigned, they are | |
701 done so atomically. If other variables might be changed via side-effect, | |
702 see gnus-atomic-progn-assign. It is safe to use gnus-atomic-setq | |
703 with potentially long computations." | |
704 (let ((tpairs pairs) | |
705 syms) | |
706 (while tpairs | |
707 (push (car tpairs) syms) | |
708 (setq tpairs (cddr tpairs))) | |
709 `(gnus-atomic-progn-assign ,syms | |
710 (setq ,@pairs)))) | |
711 | |
712 ;(put 'gnus-atomic-setq 'edebug-form-spec '(body)) | |
713 | |
714 | |
715 ;;; Functions for saving to babyl/mail files. | |
716 | |
717 (defvar rmail-default-rmail-file) | |
718 (defun gnus-output-to-rmail (filename &optional ask) | |
719 "Append the current article to an Rmail file named FILENAME." | |
720 (require 'rmail) | |
721 ;; Most of these codes are borrowed from rmailout.el. | |
722 (setq filename (expand-file-name filename)) | |
723 (setq rmail-default-rmail-file filename) | |
724 (let ((artbuf (current-buffer)) | |
725 (tmpbuf (get-buffer-create " *Gnus-output*"))) | |
726 (save-excursion | |
727 (or (get-file-buffer filename) | |
728 (file-exists-p filename) | |
729 (if (or (not ask) | |
730 (gnus-yes-or-no-p | |
731 (concat "\"" filename "\" does not exist, create it? "))) | |
732 (let ((file-buffer (create-file-buffer filename))) | |
733 (save-excursion | |
734 (set-buffer file-buffer) | |
735 (rmail-insert-rmail-file-header) | |
736 (let ((require-final-newline nil)) | |
737 (gnus-write-buffer filename))) | |
738 (kill-buffer file-buffer)) | |
739 (error "Output file does not exist"))) | |
740 (set-buffer tmpbuf) | |
741 (erase-buffer) | |
742 (insert-buffer-substring artbuf) | |
743 (gnus-convert-article-to-rmail) | |
744 ;; Decide whether to append to a file or to an Emacs buffer. | |
745 (let ((outbuf (get-file-buffer filename))) | |
746 (if (not outbuf) | |
747 (append-to-file (point-min) (point-max) filename) | |
748 ;; File has been visited, in buffer OUTBUF. | |
749 (set-buffer outbuf) | |
750 (let ((buffer-read-only nil) | |
751 (msg (and (boundp 'rmail-current-message) | |
752 (symbol-value 'rmail-current-message)))) | |
753 ;; If MSG is non-nil, buffer is in RMAIL mode. | |
754 (when msg | |
755 (widen) | |
756 (narrow-to-region (point-max) (point-max))) | |
757 (insert-buffer-substring tmpbuf) | |
758 (when msg | |
759 (goto-char (point-min)) | |
760 (widen) | |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
761 (search-backward "\n\^_") |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
762 (narrow-to-region (point) (point-max)) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
763 (rmail-count-new-messages t) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
764 (when (rmail-summary-exists) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
765 (rmail-select-summary |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
766 (rmail-update-summary))) |
17493 | 767 (rmail-count-new-messages t) |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
768 (rmail-show-message msg)) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
769 (save-buffer))))) |
17493 | 770 (kill-buffer tmpbuf))) |
771 | |
772 (defun gnus-output-to-mail (filename &optional ask) | |
773 "Append the current article to a mail file named FILENAME." | |
774 (setq filename (expand-file-name filename)) | |
775 (let ((artbuf (current-buffer)) | |
776 (tmpbuf (get-buffer-create " *Gnus-output*"))) | |
777 (save-excursion | |
778 ;; Create the file, if it doesn't exist. | |
779 (when (and (not (get-file-buffer filename)) | |
780 (not (file-exists-p filename))) | |
781 (if (or (not ask) | |
782 (gnus-y-or-n-p | |
783 (concat "\"" filename "\" does not exist, create it? "))) | |
784 (let ((file-buffer (create-file-buffer filename))) | |
785 (save-excursion | |
786 (set-buffer file-buffer) | |
787 (let ((require-final-newline nil)) | |
788 (gnus-write-buffer filename))) | |
789 (kill-buffer file-buffer)) | |
790 (error "Output file does not exist"))) | |
791 (set-buffer tmpbuf) | |
792 (erase-buffer) | |
793 (insert-buffer-substring artbuf) | |
794 (goto-char (point-min)) | |
795 (if (looking-at "From ") | |
796 (forward-line 1) | |
797 (insert "From nobody " (current-time-string) "\n")) | |
798 (let (case-fold-search) | |
799 (while (re-search-forward "^From " nil t) | |
800 (beginning-of-line) | |
801 (insert ">"))) | |
802 ;; Decide whether to append to a file or to an Emacs buffer. | |
803 (let ((outbuf (get-file-buffer filename))) | |
804 (if (not outbuf) | |
805 (let ((buffer-read-only nil)) | |
806 (save-excursion | |
807 (goto-char (point-max)) | |
808 (forward-char -2) | |
809 (unless (looking-at "\n\n") | |
810 (goto-char (point-max)) | |
811 (unless (bolp) | |
812 (insert "\n")) | |
813 (insert "\n")) | |
814 (goto-char (point-max)) | |
815 (append-to-file (point-min) (point-max) filename))) | |
816 ;; File has been visited, in buffer OUTBUF. | |
817 (set-buffer outbuf) | |
818 (let ((buffer-read-only nil)) | |
819 (goto-char (point-max)) | |
820 (unless (eobp) | |
821 (insert "\n")) | |
822 (insert "\n") | |
823 (insert-buffer-substring tmpbuf))))) | |
824 (kill-buffer tmpbuf))) | |
825 | |
826 (defun gnus-convert-article-to-rmail () | |
827 "Convert article in current buffer to Rmail message format." | |
828 (let ((buffer-read-only nil)) | |
829 ;; Convert article directly into Babyl format. | |
830 (goto-char (point-min)) | |
831 (insert "\^L\n0, unseen,,\n*** EOOH ***\n") | |
832 (while (search-forward "\n\^_" nil t) ;single char | |
833 (replace-match "\n^_" t t)) ;2 chars: "^" and "_" | |
834 (goto-char (point-max)) | |
835 (insert "\^_"))) | |
836 | |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
837 (defun gnus-map-function (funs arg) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
838 "Applies the result of the first function in FUNS to the second, and so on. |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
839 ARG is passed to the first function." |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
840 (let ((myfuns funs)) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
841 (while myfuns |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
842 (setq arg (funcall (pop myfuns) arg))) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
843 arg)) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
844 |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
845 (defun gnus-run-hooks (&rest funcs) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
846 "Does the same as `run-hooks', but saves excursion." |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
847 (let ((buf (current-buffer))) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
848 (unwind-protect |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
849 (apply 'run-hooks funcs) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
850 (set-buffer buf)))) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
851 |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
852 ;;; |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
853 ;;; .netrc and .authinforc parsing |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
854 ;;; |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
855 |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
856 (defvar gnus-netrc-syntax-table |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
857 (let ((table (copy-syntax-table text-mode-syntax-table))) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
858 (modify-syntax-entry ?@ "w" table) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
859 (modify-syntax-entry ?- "w" table) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
860 (modify-syntax-entry ?_ "w" table) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
861 (modify-syntax-entry ?! "w" table) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
862 (modify-syntax-entry ?. "w" table) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
863 (modify-syntax-entry ?, "w" table) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
864 (modify-syntax-entry ?: "w" table) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
865 (modify-syntax-entry ?\; "w" table) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
866 (modify-syntax-entry ?% "w" table) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
867 (modify-syntax-entry ?) "w" table) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
868 (modify-syntax-entry ?( "w" table) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
869 table) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
870 "Syntax table when parsing .netrc files.") |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
871 |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
872 (defun gnus-parse-netrc (file) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
873 "Parse FILE and return an list of all entries in the file." |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
874 (if (not (file-exists-p file)) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
875 () |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
876 (save-excursion |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
877 (let ((tokens '("machine" "default" "login" |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
878 "password" "account" "macdef" "force")) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
879 alist elem result pair) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
880 (nnheader-set-temp-buffer " *netrc*") |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
881 (unwind-protect |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
882 (progn |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
883 (set-syntax-table gnus-netrc-syntax-table) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
884 (insert-file-contents file) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
885 (goto-char (point-min)) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
886 ;; Go through the file, line by line. |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
887 (while (not (eobp)) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
888 (narrow-to-region (point) (gnus-point-at-eol)) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
889 ;; For each line, get the tokens and values. |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
890 (while (not (eobp)) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
891 (skip-chars-forward "\t ") |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
892 (unless (eobp) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
893 (setq elem (buffer-substring |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
894 (point) (progn (forward-sexp 1) (point)))) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
895 (cond |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
896 ((equal elem "macdef") |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
897 ;; We skip past the macro definition. |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
898 (widen) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
899 (while (and (zerop (forward-line 1)) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
900 (looking-at "$"))) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
901 (narrow-to-region (point) (point))) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
902 ((member elem tokens) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
903 ;; Tokens that don't have a following value are ignored, |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
904 ;; except "default". |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
905 (when (and pair (or (cdr pair) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
906 (equal (car pair) "default"))) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
907 (push pair alist)) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
908 (setq pair (list elem))) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
909 (t |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
910 ;; Values that haven't got a preceding token are ignored. |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
911 (when pair |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
912 (setcdr pair elem) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
913 (push pair alist) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
914 (setq pair nil)))))) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
915 (if alist |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
916 (push (nreverse alist) result)) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
917 (setq alist nil |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
918 pair nil) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
919 (widen) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
920 (forward-line 1)) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
921 (nreverse result)) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
922 (kill-buffer " *netrc*")))))) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
923 |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
924 (defun gnus-netrc-machine (list machine) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
925 "Return the netrc values from LIST for MACHINE or for the default entry." |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
926 (let ((rest list)) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
927 (while (and list |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
928 (not (equal (cdr (assoc "machine" (car list))) machine))) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
929 (pop list)) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
930 (car (or list |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
931 (progn (while (and rest (not (assoc "default" (car rest)))) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
932 (pop rest)) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
933 rest))))) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
934 |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
935 (defun gnus-netrc-get (alist type) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
936 "Return the value of token TYPE from ALIST." |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
937 (cdr (assoc type alist))) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
938 |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
939 ;;; Various |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
940 |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
941 (defvar gnus-group-buffer) ; Compiler directive |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
942 (defun gnus-alive-p () |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
943 "Say whether Gnus is running or not." |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
944 (and (boundp 'gnus-group-buffer) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
945 (get-buffer gnus-group-buffer) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
946 (save-excursion |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
947 (set-buffer gnus-group-buffer) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
948 (eq major-mode 'gnus-group-mode)))) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
949 |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
950 (defun gnus-remove-duplicates (list) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
951 (let (new (tail list)) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
952 (while tail |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
953 (or (member (car tail) new) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
954 (setq new (cons (car tail) new))) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
955 (setq tail (cdr tail))) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
956 (nreverse new))) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
957 |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
958 (defun gnus-delete-if (predicate list) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
959 "Delete elements from LIST that satisfy PREDICATE." |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
960 (let (out) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
961 (while list |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
962 (unless (funcall predicate (car list)) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
963 (push (car list) out)) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
964 (pop list)) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
965 (nreverse out))) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
966 |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
967 (defun gnus-delete-alist (key alist) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
968 "Delete all entries in ALIST that have a key eq to KEY." |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
969 (let (entry) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
970 (while (setq entry (assq key alist)) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
971 (setq alist (delq entry alist))) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
972 alist)) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
973 |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
974 (defmacro gnus-pull (key alist) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
975 "Modify ALIST to be without KEY." |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
976 (unless (symbolp alist) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
977 (error "Not a symbol: %s" alist)) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
978 `(setq ,alist (delq (assq ,key ,alist) ,alist))) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
979 |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
980 (defun gnus-globalify-regexp (re) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
981 "Returns a regexp that matches a whole line, iff RE matches a part of it." |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
982 (concat (unless (string-match "^\\^" re) "^.*") |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
983 re |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
984 (unless (string-match "\\$$" re) ".*$"))) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
23319
diff
changeset
|
985 |
17493 | 986 (provide 'gnus-util) |
987 | |
988 ;;; gnus-util.el ends here |