1 |
;;; gnus-util.el --- utility functions for Gnus |
;;; gnus-util.el --- utility functions for Gnus |
2 |
;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2002 |
;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004 |
3 |
;; Free Software Foundation, Inc. |
;; Free Software Foundation, Inc. |
4 |
|
|
5 |
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
29 |
;; used by Gnus and may be used by any other package without loading |
;; used by Gnus and may be used by any other package without loading |
30 |
;; Gnus first. |
;; Gnus first. |
31 |
|
|
32 |
|
;; [Unfortunately, it does depend on other parts of Gnus, e.g. the |
33 |
|
;; autoloads below...] |
34 |
|
|
35 |
;;; Code: |
;;; Code: |
36 |
|
|
37 |
(require 'custom) |
(require 'custom) |
39 |
(require 'cl) |
(require 'cl) |
40 |
;; Fixme: this should be a gnus variable, not nnmail-. |
;; Fixme: this should be a gnus variable, not nnmail-. |
41 |
(defvar nnmail-pathname-coding-system)) |
(defvar nnmail-pathname-coding-system)) |
|
(require 'nnheader) |
|
42 |
(require 'time-date) |
(require 'time-date) |
43 |
|
(require 'netrc) |
44 |
|
|
45 |
(eval-and-compile |
(eval-and-compile |
46 |
(autoload 'message-fetch-field "message") |
(autoload 'message-fetch-field "message") |
47 |
|
(autoload 'gnus-get-buffer-window "gnus-win") |
48 |
(autoload 'rmail-insert-rmail-file-header "rmail") |
(autoload 'rmail-insert-rmail-file-header "rmail") |
49 |
(autoload 'rmail-count-new-messages "rmail") |
(autoload 'rmail-count-new-messages "rmail") |
50 |
(autoload 'rmail-show-message "rmail")) |
(autoload 'rmail-show-message "rmail") |
51 |
|
(autoload 'nnheader-narrow-to-headers "nnheader") |
52 |
|
(autoload 'nnheader-replace-chars-in-string "nnheader")) |
53 |
|
|
54 |
|
(eval-and-compile |
55 |
|
(cond |
56 |
|
((fboundp 'replace-in-string) |
57 |
|
(defalias 'gnus-replace-in-string 'replace-in-string)) |
58 |
|
((fboundp 'replace-regexp-in-string) |
59 |
|
(defun gnus-replace-in-string (string regexp newtext &optional literal) |
60 |
|
(replace-regexp-in-string regexp newtext string nil literal))) |
61 |
|
(t |
62 |
|
(defun gnus-replace-in-string (string regexp newtext &optional literal) |
63 |
|
(let ((start 0) tail) |
64 |
|
(while (string-match regexp string start) |
65 |
|
(setq tail (- (length string) (match-end 0))) |
66 |
|
(setq string (replace-match newtext nil literal string)) |
67 |
|
(setq start (- (length string) tail)))) |
68 |
|
string)))) |
69 |
|
|
70 |
|
;;; bring in the netrc functions as aliases |
71 |
|
(defalias 'gnus-netrc-get 'netrc-get) |
72 |
|
(defalias 'gnus-netrc-machine 'netrc-machine) |
73 |
|
(defalias 'gnus-parse-netrc 'netrc-parse) |
74 |
|
|
75 |
(defun gnus-boundp (variable) |
(defun gnus-boundp (variable) |
76 |
"Return non-nil if VARIABLE is bound and non-nil." |
"Return non-nil if VARIABLE is bound and non-nil." |
80 |
(defmacro gnus-eval-in-buffer-window (buffer &rest forms) |
(defmacro gnus-eval-in-buffer-window (buffer &rest forms) |
81 |
"Pop to BUFFER, evaluate FORMS, and then return to the original window." |
"Pop to BUFFER, evaluate FORMS, and then return to the original window." |
82 |
(let ((tempvar (make-symbol "GnusStartBufferWindow")) |
(let ((tempvar (make-symbol "GnusStartBufferWindow")) |
83 |
(w (make-symbol "w")) |
(w (make-symbol "w")) |
84 |
(buf (make-symbol "buf"))) |
(buf (make-symbol "buf"))) |
85 |
`(let* ((,tempvar (selected-window)) |
`(let* ((,tempvar (selected-window)) |
86 |
(,buf ,buffer) |
(,buf ,buffer) |
87 |
(,w (get-buffer-window ,buf 'visible))) |
(,w (gnus-get-buffer-window ,buf 'visible))) |
88 |
(unwind-protect |
(unwind-protect |
89 |
(progn |
(progn |
90 |
(if ,w |
(if ,w |
91 |
(progn |
(progn |
92 |
(select-window ,w) |
(select-window ,w) |
93 |
(set-buffer (window-buffer ,w))) |
(set-buffer (window-buffer ,w))) |
94 |
(pop-to-buffer ,buf)) |
(pop-to-buffer ,buf)) |
95 |
,@forms) |
,@forms) |
96 |
(select-window ,tempvar))))) |
(select-window ,tempvar))))) |
97 |
|
|
98 |
(put 'gnus-eval-in-buffer-window 'lisp-indent-function 1) |
(put 'gnus-eval-in-buffer-window 'lisp-indent-function 1) |
99 |
(put 'gnus-eval-in-buffer-window 'edebug-form-spec '(form body)) |
(put 'gnus-eval-in-buffer-window 'edebug-form-spec '(form body)) |
108 |
;; Added by Geoffrey T. Dairiki <dairiki@u.washington.edu>. A safe way |
;; Added by Geoffrey T. Dairiki <dairiki@u.washington.edu>. A safe way |
109 |
;; to limit the length of a string. This function is necessary since |
;; to limit the length of a string. This function is necessary since |
110 |
;; `(substr "abc" 0 30)' pukes with "Args out of range". |
;; `(substr "abc" 0 30)' pukes with "Args out of range". |
111 |
|
;; Fixme: Why not `truncate-string-to-width'? |
112 |
(defsubst gnus-limit-string (str width) |
(defsubst gnus-limit-string (str width) |
113 |
(if (> (length str) width) |
(if (> (length str) width) |
114 |
(substring str 0 width) |
(substring str 0 width) |
115 |
str)) |
str)) |
116 |
|
|
|
(defsubst gnus-functionp (form) |
|
|
"Return non-nil if FORM is funcallable." |
|
|
(or (and (symbolp form) (fboundp form)) |
|
|
(and (listp form) (eq (car form) 'lambda)) |
|
|
(byte-code-function-p form))) |
|
|
|
|
117 |
(defsubst gnus-goto-char (point) |
(defsubst gnus-goto-char (point) |
118 |
(and point (goto-char point))) |
(and point (goto-char point))) |
119 |
|
|
123 |
(funcall (if (stringp buffer) 'get-buffer 'buffer-name) |
(funcall (if (stringp buffer) 'get-buffer 'buffer-name) |
124 |
buffer)))) |
buffer)))) |
125 |
|
|
|
(defmacro gnus-kill-buffer (buffer) |
|
|
`(let ((buf ,buffer)) |
|
|
(when (gnus-buffer-exists-p buf) |
|
|
(kill-buffer buf)))) |
|
|
|
|
126 |
(defalias 'gnus-point-at-bol |
(defalias 'gnus-point-at-bol |
127 |
(if (fboundp 'point-at-bol) |
(if (fboundp 'point-at-bol) |
128 |
'point-at-bol |
'point-at-bol |
133 |
'point-at-eol |
'point-at-eol |
134 |
'line-end-position)) |
'line-end-position)) |
135 |
|
|
136 |
|
;; The LOCAL arg to `add-hook' is interpreted differently in Emacs and |
137 |
|
;; XEmacs. In Emacs we don't need to call `make-local-hook' first. |
138 |
|
;; It's harmless, though, so the main purpose of this alias is to shut |
139 |
|
;; up the byte compiler. |
140 |
|
(defalias 'gnus-make-local-hook |
141 |
|
(if (eq (get 'make-local-hook 'byte-compile) |
142 |
|
'byte-compile-obsolete) |
143 |
|
'ignore ; Emacs |
144 |
|
'make-local-hook)) ; XEmacs |
145 |
|
|
146 |
(defun gnus-delete-first (elt list) |
(defun gnus-delete-first (elt list) |
147 |
"Delete by side effect the first occurrence of ELT as a member of LIST." |
"Delete by side effect the first occurrence of ELT as a member of LIST." |
148 |
(if (equal (car list) elt) |
(if (equal (car list) elt) |
157 |
|
|
158 |
;; Delete the current line (and the next N lines). |
;; Delete the current line (and the next N lines). |
159 |
(defmacro gnus-delete-line (&optional n) |
(defmacro gnus-delete-line (&optional n) |
160 |
`(delete-region (progn (beginning-of-line) (point)) |
`(delete-region (gnus-point-at-bol) |
161 |
(progn (forward-line ,(or n 1)) (point)))) |
(progn (forward-line ,(or n 1)) (point)))) |
162 |
|
|
163 |
(defun gnus-byte-code (func) |
(defun gnus-byte-code (func) |
170 |
(cons 'progn (cddr fval))))) |
(cons 'progn (cddr fval))))) |
171 |
|
|
172 |
(defun gnus-extract-address-components (from) |
(defun gnus-extract-address-components (from) |
173 |
|
"Extract address components from a From header. |
174 |
|
Given an RFC-822 address FROM, extract full name and canonical address. |
175 |
|
Returns a list of the form (FULL-NAME CANONICAL-ADDRESS). Much more simple |
176 |
|
solution than `mail-extract-address-components', which works much better, but |
177 |
|
is slower." |
178 |
(let (name address) |
(let (name address) |
179 |
;; First find the address - the thing with the @ in it. This may |
;; First find the address - the thing with the @ in it. This may |
180 |
;; not be accurate in mail addresses, but does the trick most of |
;; not be accurate in mail addresses, but does the trick most of |
187 |
(string-match (concat "[ \t]*<" (regexp-quote address) ">") from) |
(string-match (concat "[ \t]*<" (regexp-quote address) ">") from) |
188 |
(and (setq name (substring from 0 (match-beginning 0))) |
(and (setq name (substring from 0 (match-beginning 0))) |
189 |
;; Strip any quotes from the name. |
;; Strip any quotes from the name. |
190 |
(string-match "\".*\"" name) |
(string-match "^\".*\"$" name) |
191 |
(setq name (substring name 1 (1- (match-end 0)))))) |
(setq name (substring name 1 (1- (match-end 0)))))) |
192 |
;; If not, then "address (name)" is used. |
;; If not, then "address (name)" is used. |
193 |
(or name |
(or name |
212 |
(nnheader-narrow-to-headers) |
(nnheader-narrow-to-headers) |
213 |
(message-fetch-field field))))) |
(message-fetch-field field))))) |
214 |
|
|
215 |
|
(defun gnus-fetch-original-field (field) |
216 |
|
"Fetch FIELD from the original version of the current article." |
217 |
|
(with-current-buffer gnus-original-article-buffer |
218 |
|
(gnus-fetch-field field))) |
219 |
|
|
220 |
|
|
221 |
(defun gnus-goto-colon () |
(defun gnus-goto-colon () |
222 |
(beginning-of-line) |
(beginning-of-line) |
223 |
(search-forward ":" (gnus-point-at-eol) t)) |
(let ((eol (gnus-point-at-eol))) |
224 |
|
(goto-char (or (text-property-any (point) eol 'gnus-position t) |
225 |
|
(search-forward ":" eol t) |
226 |
|
(point))))) |
227 |
|
|
228 |
|
(defun gnus-decode-newsgroups (newsgroups group &optional method) |
229 |
|
(let ((method (or method (gnus-find-method-for-group group)))) |
230 |
|
(mapconcat (lambda (group) |
231 |
|
(gnus-group-name-decode group (gnus-group-name-charset |
232 |
|
method group))) |
233 |
|
(message-tokenize-header newsgroups) |
234 |
|
","))) |
235 |
|
|
236 |
(defun gnus-remove-text-with-property (prop) |
(defun gnus-remove-text-with-property (prop) |
237 |
"Delete all text in the current buffer with text property PROP." |
"Delete all text in the current buffer with text property PROP." |
244 |
|
|
245 |
(defun gnus-newsgroup-directory-form (newsgroup) |
(defun gnus-newsgroup-directory-form (newsgroup) |
246 |
"Make hierarchical directory name from NEWSGROUP name." |
"Make hierarchical directory name from NEWSGROUP name." |
247 |
(let ((newsgroup (gnus-newsgroup-savable-name newsgroup)) |
(let* ((newsgroup (gnus-newsgroup-savable-name newsgroup)) |
248 |
(len (length newsgroup)) |
(idx (string-match ":" newsgroup))) |
249 |
idx) |
(concat |
250 |
;; If this is a foreign group, we don't want to translate the |
(if idx (substring newsgroup 0 idx)) |
251 |
;; entire name. |
(if idx "/") |
252 |
(if (setq idx (string-match ":" newsgroup)) |
(nnheader-replace-chars-in-string |
253 |
(aset newsgroup idx ?/) |
(if idx (substring newsgroup (1+ idx)) newsgroup) |
254 |
(setq idx 0)) |
?. ?/)))) |
|
;; Replace all occurrences of `.' with `/'. |
|
|
(while (< idx len) |
|
|
(when (= (aref newsgroup idx) ?.) |
|
|
(aset newsgroup idx ?/)) |
|
|
(setq idx (1+ idx))) |
|
|
newsgroup)) |
|
255 |
|
|
256 |
(defun gnus-newsgroup-savable-name (group) |
(defun gnus-newsgroup-savable-name (group) |
257 |
;; Replace any slashes in a group name (eg. an ange-ftp nndoc group) |
;; Replace any slashes in a group name (eg. an ange-ftp nndoc group) |
314 |
(define-key keymap key (pop plist)) |
(define-key keymap key (pop plist)) |
315 |
(pop plist))))) |
(pop plist))))) |
316 |
|
|
317 |
(defun gnus-completing-read (default prompt &rest args) |
(defun gnus-completing-read-with-default (default prompt &rest args) |
318 |
;; Like `completing-read', except that DEFAULT is the default argument. |
;; Like `completing-read', except that DEFAULT is the default argument. |
319 |
(let* ((prompt (if default |
(let* ((prompt (if default |
320 |
(concat prompt " (default " default ") ") |
(concat prompt " (default " default ") ") |
336 |
(yes-or-no-p prompt) |
(yes-or-no-p prompt) |
337 |
(message ""))) |
(message ""))) |
338 |
|
|
339 |
|
;; By Frank Schmitt <ich@Frank-Schmitt.net>. Allows to have |
340 |
|
;; age-depending date representations. (e.g. just the time if it's |
341 |
|
;; from today, the day of the week if it's within the last 7 days and |
342 |
|
;; the full date if it's older) |
343 |
|
|
344 |
|
(defun gnus-seconds-today () |
345 |
|
"Return the number of seconds passed today." |
346 |
|
(let ((now (decode-time (current-time)))) |
347 |
|
(+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600)))) |
348 |
|
|
349 |
|
(defun gnus-seconds-month () |
350 |
|
"Return the number of seconds passed this month." |
351 |
|
(let ((now (decode-time (current-time)))) |
352 |
|
(+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600) |
353 |
|
(* (- (car (nthcdr 3 now)) 1) 3600 24)))) |
354 |
|
|
355 |
|
(defun gnus-seconds-year () |
356 |
|
"Return the number of seconds passed this year." |
357 |
|
(let ((now (decode-time (current-time))) |
358 |
|
(days (format-time-string "%j" (current-time)))) |
359 |
|
(+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600) |
360 |
|
(* (- (string-to-number days) 1) 3600 24)))) |
361 |
|
|
362 |
|
(defvar gnus-user-date-format-alist |
363 |
|
'(((gnus-seconds-today) . "%k:%M") |
364 |
|
(604800 . "%a %k:%M") ;;that's one week |
365 |
|
((gnus-seconds-month) . "%a %d") |
366 |
|
((gnus-seconds-year) . "%b %d") |
367 |
|
(t . "%b %d '%y")) ;;this one is used when no |
368 |
|
;;other does match |
369 |
|
"Specifies date format depending on age of article. |
370 |
|
This is an alist of items (AGE . FORMAT). AGE can be a number (of |
371 |
|
seconds) or a Lisp expression evaluating to a number. When the age of |
372 |
|
the article is less than this number, then use `format-time-string' |
373 |
|
with the corresponding FORMAT for displaying the date of the article. |
374 |
|
If AGE is not a number or a Lisp expression evaluating to a |
375 |
|
non-number, then the corresponding FORMAT is used as a default value. |
376 |
|
|
377 |
|
Note that the list is processed from the beginning, so it should be |
378 |
|
sorted by ascending AGE. Also note that items following the first |
379 |
|
non-number AGE will be ignored. |
380 |
|
|
381 |
|
You can use the functions `gnus-seconds-today', `gnus-seconds-month' |
382 |
|
and `gnus-seconds-year' in the AGE spec. They return the number of |
383 |
|
seconds passed since the start of today, of this month, of this year, |
384 |
|
respectively.") |
385 |
|
|
386 |
|
(defun gnus-user-date (messy-date) |
387 |
|
"Format the messy-date according to gnus-user-date-format-alist. |
388 |
|
Returns \" ? \" if there's bad input or if an other error occurs. |
389 |
|
Input should look like this: \"Sun, 14 Oct 2001 13:34:39 +0200\"." |
390 |
|
(condition-case () |
391 |
|
(let* ((messy-date (time-to-seconds (safe-date-to-time messy-date))) |
392 |
|
(now (time-to-seconds (current-time))) |
393 |
|
;;If we don't find something suitable we'll use this one |
394 |
|
(my-format "%b %d '%y")) |
395 |
|
(let* ((difference (- now messy-date)) |
396 |
|
(templist gnus-user-date-format-alist) |
397 |
|
(top (eval (caar templist)))) |
398 |
|
(while (if (numberp top) (< top difference) (not top)) |
399 |
|
(progn |
400 |
|
(setq templist (cdr templist)) |
401 |
|
(setq top (eval (caar templist))))) |
402 |
|
(if (stringp (cdr (car templist))) |
403 |
|
(setq my-format (cdr (car templist))))) |
404 |
|
(format-time-string (eval my-format) (seconds-to-time messy-date))) |
405 |
|
(error " ? "))) |
406 |
|
|
407 |
(defun gnus-dd-mmm (messy-date) |
(defun gnus-dd-mmm (messy-date) |
408 |
"Return a string like DD-MMM from a big messy string." |
"Return a string like DD-MMM from a big messy string." |
409 |
(condition-case () |
(condition-case () |
436 |
|
|
437 |
(defun gnus-mode-string-quote (string) |
(defun gnus-mode-string-quote (string) |
438 |
"Quote all \"%\"'s in STRING." |
"Quote all \"%\"'s in STRING." |
439 |
(save-excursion |
(gnus-replace-in-string string "%" "%%")) |
|
(gnus-set-work-buffer) |
|
|
(insert string) |
|
|
(goto-char (point-min)) |
|
|
(while (search-forward "%" nil t) |
|
|
(insert "%")) |
|
|
(buffer-string))) |
|
440 |
|
|
441 |
;; Make a hash table (default and minimum size is 256). |
;; Make a hash table (default and minimum size is 256). |
442 |
;; Optional argument HASHSIZE specifies the table size. |
;; Optional argument HASHSIZE specifies the table size. |
464 |
:group 'gnus-start |
:group 'gnus-start |
465 |
:type 'integer) |
:type 'integer) |
466 |
|
|
|
;; Show message if message has a lower level than `gnus-verbose'. |
|
|
;; Guideline for numbers: |
|
|
;; 1 - error messages, 3 - non-serious error messages, 5 - messages |
|
|
;; for things that take a long time, 7 - not very important messages |
|
|
;; on stuff, 9 - messages inside loops. |
|
467 |
(defun gnus-message (level &rest args) |
(defun gnus-message (level &rest args) |
468 |
|
"If LEVEL is lower than `gnus-verbose' print ARGS using `message'. |
469 |
|
|
470 |
|
Guideline for numbers: |
471 |
|
1 - error messages, 3 - non-serious error messages, 5 - messages for things |
472 |
|
that take a long time, 7 - not very important messages on stuff, 9 - messages |
473 |
|
inside loops." |
474 |
(if (<= level gnus-verbose) |
(if (<= level gnus-verbose) |
475 |
(apply 'message args) |
(apply 'message args) |
476 |
;; We have to do this format thingy here even if the result isn't |
;; We have to do this format thingy here even if the result isn't |
493 |
"Return a list of Message-IDs in REFERENCES." |
"Return a list of Message-IDs in REFERENCES." |
494 |
(let ((beg 0) |
(let ((beg 0) |
495 |
ids) |
ids) |
496 |
(while (string-match "<[^>]+>" references beg) |
(while (string-match "<[^<]+[^< \t]" references beg) |
497 |
(push (substring references (match-beginning 0) (setq beg (match-end 0))) |
(push (substring references (match-beginning 0) (setq beg (match-end 0))) |
498 |
ids)) |
ids)) |
499 |
(nreverse ids))) |
(nreverse ids))) |
501 |
(defsubst gnus-parent-id (references &optional n) |
(defsubst gnus-parent-id (references &optional n) |
502 |
"Return the last Message-ID in REFERENCES. |
"Return the last Message-ID in REFERENCES. |
503 |
If N, return the Nth ancestor instead." |
If N, return the Nth ancestor instead." |
504 |
(when references |
(when (and references |
505 |
(let ((ids (inline (gnus-split-references references)))) |
(not (zerop (length references)))) |
506 |
(while (nthcdr (or n 1) ids) |
(if n |
507 |
(setq ids (cdr ids))) |
(let ((ids (inline (gnus-split-references references)))) |
508 |
(car ids)))) |
(while (nthcdr n ids) |
509 |
|
(setq ids (cdr ids))) |
510 |
|
(car ids)) |
511 |
|
(when (string-match "\\(<[^<]+>\\)[ \t]*\\'" references) |
512 |
|
(match-string 1 references))))) |
513 |
|
|
514 |
(defsubst gnus-buffer-live-p (buffer) |
(defun gnus-buffer-live-p (buffer) |
515 |
"Say whether BUFFER is alive or not." |
"Say whether BUFFER is alive or not." |
516 |
(and buffer |
(and buffer |
517 |
(get-buffer buffer) |
(get-buffer buffer) |
520 |
(defun gnus-horizontal-recenter () |
(defun gnus-horizontal-recenter () |
521 |
"Recenter the current buffer horizontally." |
"Recenter the current buffer horizontally." |
522 |
(if (< (current-column) (/ (window-width) 2)) |
(if (< (current-column) (/ (window-width) 2)) |
523 |
(set-window-hscroll (get-buffer-window (current-buffer) t) 0) |
(set-window-hscroll (gnus-get-buffer-window (current-buffer) t) 0) |
524 |
(let* ((orig (point)) |
(let* ((orig (point)) |
525 |
(end (window-end (get-buffer-window (current-buffer) t))) |
(end (window-end (gnus-get-buffer-window (current-buffer) t))) |
526 |
(max 0)) |
(max 0)) |
527 |
(when end |
(when end |
528 |
;; Find the longest line currently displayed in the window. |
;; Find the longest line currently displayed in the window. |
536 |
;; Scroll horizontally to center (sort of) the point. |
;; Scroll horizontally to center (sort of) the point. |
537 |
(if (> max (window-width)) |
(if (> max (window-width)) |
538 |
(set-window-hscroll |
(set-window-hscroll |
539 |
(get-buffer-window (current-buffer) t) |
(gnus-get-buffer-window (current-buffer) t) |
540 |
(min (- (current-column) (/ (window-width) 3)) |
(min (- (current-column) (/ (window-width) 3)) |
541 |
(+ 2 (- max (window-width))))) |
(+ 2 (- max (window-width))))) |
542 |
(set-window-hscroll (get-buffer-window (current-buffer) t) 0)) |
(set-window-hscroll (gnus-get-buffer-window (current-buffer) t) 0)) |
543 |
max)))) |
max)))) |
544 |
|
|
545 |
(defun gnus-read-event-char () |
(defun gnus-read-event-char (&optional prompt) |
546 |
"Get the next event." |
"Get the next event." |
547 |
(let ((event (read-event))) |
(let ((event (read-event prompt))) |
548 |
;; should be gnus-characterp, but this can't be called in XEmacs anyway |
;; should be gnus-characterp, but this can't be called in XEmacs anyway |
549 |
(cons (and (numberp event) event) event))) |
(cons (and (numberp event) event) event))) |
550 |
|
|
584 |
gname))) |
gname))) |
585 |
|
|
586 |
(defun gnus-make-sort-function (funs) |
(defun gnus-make-sort-function (funs) |
587 |
"Return a composite sort condition based on the functions in FUNC." |
"Return a composite sort condition based on the functions in FUNS." |
588 |
(cond |
(cond |
589 |
;; Just a simple function. |
;; Just a simple function. |
590 |
((gnus-functionp funs) funs) |
((functionp funs) funs) |
591 |
;; No functions at all. |
;; No functions at all. |
592 |
((null funs) funs) |
((null funs) funs) |
593 |
;; A list of functions. |
;; A list of functions. |
594 |
((or (cdr funs) |
((or (cdr funs) |
595 |
(listp (car funs))) |
(listp (car funs))) |
596 |
`(lambda (t1 t2) |
(gnus-byte-compile |
597 |
,(gnus-make-sort-function-1 (reverse funs)))) |
`(lambda (t1 t2) |
598 |
|
,(gnus-make-sort-function-1 (reverse funs))))) |
599 |
;; A list containing just one function. |
;; A list containing just one function. |
600 |
(t |
(t |
601 |
(car funs)))) |
(car funs)))) |
602 |
|
|
603 |
(defun gnus-make-sort-function-1 (funs) |
(defun gnus-make-sort-function-1 (funs) |
604 |
"Return a composite sort condition based on the functions in FUNC." |
"Return a composite sort condition based on the functions in FUNS." |
605 |
(let ((function (car funs)) |
(let ((function (car funs)) |
606 |
(first 't1) |
(first 't1) |
607 |
(last 't2)) |
(last 't2)) |
612 |
(setq function (cadr function) |
(setq function (cadr function) |
613 |
first 't2 |
first 't2 |
614 |
last 't1)) |
last 't1)) |
615 |
((gnus-functionp function) |
((functionp function) |
616 |
;; Do nothing. |
;; Do nothing. |
617 |
) |
) |
618 |
(t |
(t |
628 |
(define-key (symbol-value (intern (format "gnus-%s-mode-map" type))) |
(define-key (symbol-value (intern (format "gnus-%s-mode-map" type))) |
629 |
[menu-bar edit] 'undefined)) |
[menu-bar edit] 'undefined)) |
630 |
|
|
631 |
|
(defmacro gnus-bind-print-variables (&rest forms) |
632 |
|
"Bind print-* variables and evaluate FORMS. |
633 |
|
This macro is used with `prin1', `pp', etc. in order to ensure printed |
634 |
|
Lisp objects are loadable. Bind `print-quoted' and `print-readably' |
635 |
|
to t, and `print-escape-multibyte', `print-escape-newlines', |
636 |
|
`print-escape-nonascii', `print-length', `print-level' and |
637 |
|
`print-string-length' to nil." |
638 |
|
`(let ((print-quoted t) |
639 |
|
(print-readably t) |
640 |
|
;;print-circle |
641 |
|
;;print-continuous-numbering |
642 |
|
print-escape-multibyte |
643 |
|
print-escape-newlines |
644 |
|
print-escape-nonascii |
645 |
|
;;print-gensym |
646 |
|
print-length |
647 |
|
print-level |
648 |
|
print-string-length) |
649 |
|
,@forms)) |
650 |
|
|
651 |
(defun gnus-prin1 (form) |
(defun gnus-prin1 (form) |
652 |
"Use `prin1' on FORM in the current buffer. |
"Use `prin1' on FORM in the current buffer. |
653 |
Bind `print-quoted' and `print-readably' to t while printing." |
Bind `print-quoted' and `print-readably' to t, and `print-length' and |
654 |
(let ((print-quoted t) |
`print-level' to nil. See also `gnus-bind-print-variables'." |
655 |
(print-readably t) |
(gnus-bind-print-variables (prin1 form (current-buffer)))) |
|
(print-escape-multibyte nil) |
|
|
print-level print-length) |
|
|
(prin1 form (current-buffer)))) |
|
656 |
|
|
657 |
(defun gnus-prin1-to-string (form) |
(defun gnus-prin1-to-string (form) |
658 |
"The same as `prin1', but bind `print-quoted' and `print-readably' to t." |
"The same as `prin1'. |
659 |
(let ((print-quoted t) |
Bind `print-quoted' and `print-readably' to t, and `print-length' and |
660 |
(print-readably t)) |
`print-level' to nil. See also `gnus-bind-print-variables'." |
661 |
(prin1-to-string form))) |
(gnus-bind-print-variables (prin1-to-string form))) |
662 |
|
|
663 |
|
(defun gnus-pp (form) |
664 |
|
"Use `pp' on FORM in the current buffer. |
665 |
|
Bind `print-quoted' and `print-readably' to t, and `print-length' and |
666 |
|
`print-level' to nil. See also `gnus-bind-print-variables'." |
667 |
|
(gnus-bind-print-variables (pp form (current-buffer)))) |
668 |
|
|
669 |
|
(defun gnus-pp-to-string (form) |
670 |
|
"The same as `pp-to-string'. |
671 |
|
Bind `print-quoted' and `print-readably' to t, and `print-length' and |
672 |
|
`print-level' to nil. See also `gnus-bind-print-variables'." |
673 |
|
(gnus-bind-print-variables (pp-to-string form))) |
674 |
|
|
675 |
(defun gnus-make-directory (directory) |
(defun gnus-make-directory (directory) |
676 |
"Make DIRECTORY (and all its parents) if it doesn't exist." |
"Make DIRECTORY (and all its parents) if it doesn't exist." |
711 |
(setq beg (point))) |
(setq beg (point))) |
712 |
(gnus-put-text-property beg (point) prop val))))) |
(gnus-put-text-property beg (point) prop val))))) |
713 |
|
|
714 |
|
(defsubst gnus-put-overlay-excluding-newlines (beg end prop val) |
715 |
|
"The same as `put-text-property', but don't put this prop on any newlines in the region." |
716 |
|
(save-match-data |
717 |
|
(save-excursion |
718 |
|
(save-restriction |
719 |
|
(goto-char beg) |
720 |
|
(while (re-search-forward gnus-emphasize-whitespace-regexp end 'move) |
721 |
|
(gnus-overlay-put |
722 |
|
(gnus-make-overlay beg (match-beginning 0)) |
723 |
|
prop val) |
724 |
|
(setq beg (point))) |
725 |
|
(gnus-overlay-put (gnus-make-overlay beg (point)) prop val))))) |
726 |
|
|
727 |
(defun gnus-put-text-property-excluding-characters-with-faces (beg end |
(defun gnus-put-text-property-excluding-characters-with-faces (beg end |
728 |
prop val) |
prop val) |
729 |
"The same as `put-text-property', but don't put props on characters with the `gnus-face' property." |
"The same as `put-text-property', but don't put props on characters with the `gnus-face' property." |
732 |
(when (get-text-property b 'gnus-face) |
(when (get-text-property b 'gnus-face) |
733 |
(setq b (next-single-property-change b 'gnus-face nil end))) |
(setq b (next-single-property-change b 'gnus-face nil end))) |
734 |
(when (/= b end) |
(when (/= b end) |
735 |
(gnus-put-text-property |
(inline |
736 |
b (setq b (next-single-property-change b 'gnus-face nil end)) |
(gnus-put-text-property |
737 |
prop val))))) |
b (setq b (next-single-property-change b 'gnus-face nil end)) |
738 |
|
prop val)))))) |
739 |
|
|
740 |
|
(defmacro gnus-faces-at (position) |
741 |
|
"Return a list of faces at POSITION." |
742 |
|
(if (featurep 'xemacs) |
743 |
|
`(let ((pos ,position)) |
744 |
|
(mapcar-extents 'extent-face |
745 |
|
nil (current-buffer) pos pos nil 'face)) |
746 |
|
`(let ((pos ,position)) |
747 |
|
(delq nil (cons (get-text-property pos 'face) |
748 |
|
(mapcar |
749 |
|
(lambda (overlay) |
750 |
|
(overlay-get overlay 'face)) |
751 |
|
(overlays-at pos))))))) |
752 |
|
|
753 |
;;; Protected and atomic operations. dmoore@ucsd.edu 21.11.1996 |
;;; Protected and atomic operations. dmoore@ucsd.edu 21.11.1996 |
754 |
;;; The primary idea here is to try to protect internal datastructures |
;;; The primary idea here is to try to protect internal datastructures |
827 |
|
|
828 |
;;; Functions for saving to babyl/mail files. |
;;; Functions for saving to babyl/mail files. |
829 |
|
|
830 |
(defvar rmail-default-rmail-file) |
(eval-when-compile |
831 |
|
(condition-case nil |
832 |
|
(progn |
833 |
|
(require 'rmail) |
834 |
|
(autoload 'rmail-update-summary "rmailsum")) |
835 |
|
(error |
836 |
|
(define-compiler-macro rmail-select-summary (&rest body) |
837 |
|
;; Rmail of the XEmacs version is supplied by the package, and |
838 |
|
;; requires tm and apel packages. However, there may be those |
839 |
|
;; who haven't installed those packages. This macro helps such |
840 |
|
;; people even if they install those packages later. |
841 |
|
`(eval '(rmail-select-summary ,@body))) |
842 |
|
;; If there's rmail but there's no tm (or there's apel of the |
843 |
|
;; mainstream, not the XEmacs version), loading rmail of the XEmacs |
844 |
|
;; version fails halfway, however it provides the rmail-select-summary |
845 |
|
;; macro which uses the following functions: |
846 |
|
(autoload 'rmail-summary-displayed "rmail") |
847 |
|
(autoload 'rmail-maybe-display-summary "rmail"))) |
848 |
|
(defvar rmail-default-rmail-file) |
849 |
|
(defvar mm-text-coding-system)) |
850 |
|
|
851 |
(defun gnus-output-to-rmail (filename &optional ask) |
(defun gnus-output-to-rmail (filename &optional ask) |
852 |
"Append the current article to an Rmail file named FILENAME." |
"Append the current article to an Rmail file named FILENAME." |
853 |
(require 'rmail) |
(require 'rmail) |
854 |
|
(require 'mm-util) |
855 |
;; Most of these codes are borrowed from rmailout.el. |
;; Most of these codes are borrowed from rmailout.el. |
856 |
(setq filename (expand-file-name filename)) |
(setq filename (expand-file-name filename)) |
857 |
(setq rmail-default-rmail-file filename) |
(setq rmail-default-rmail-file filename) |
894 |
(when msg |
(when msg |
895 |
(goto-char (point-min)) |
(goto-char (point-min)) |
896 |
(widen) |
(widen) |
897 |
(search-backward "\n\^_") |
(search-backward "\n\^_") |
898 |
(narrow-to-region (point) (point-max)) |
(narrow-to-region (point) (point-max)) |
899 |
(rmail-count-new-messages t) |
(rmail-count-new-messages t) |
900 |
(when (rmail-summary-exists) |
(when (rmail-summary-exists) |
901 |
(rmail-select-summary |
(rmail-select-summary |
902 |
(rmail-update-summary))) |
(rmail-update-summary))) |
903 |
(rmail-count-new-messages t) |
(rmail-count-new-messages t) |
973 |
(insert "\^_"))) |
(insert "\^_"))) |
974 |
|
|
975 |
(defun gnus-map-function (funs arg) |
(defun gnus-map-function (funs arg) |
976 |
"Applies the result of the first function in FUNS to the second, and so on. |
"Apply the result of the first function in FUNS to the second, and so on. |
977 |
ARG is passed to the first function." |
ARG is passed to the first function." |
978 |
(let ((myfuns funs)) |
(while funs |
979 |
(while myfuns |
(setq arg (funcall (pop funs) arg))) |
980 |
(setq arg (funcall (pop myfuns) arg))) |
arg) |
|
arg)) |
|
981 |
|
|
982 |
(defun gnus-run-hooks (&rest funcs) |
(defun gnus-run-hooks (&rest funcs) |
983 |
"Does the same as `run-hooks', but saves excursion." |
"Does the same as `run-hooks', but saves the current buffer." |
984 |
(let ((buf (current-buffer))) |
(save-current-buffer |
985 |
(unwind-protect |
(apply 'run-hooks funcs))) |
|
(apply 'run-hooks funcs) |
|
|
(set-buffer buf)))) |
|
|
|
|
|
;;; |
|
|
;;; .netrc and .authinforc parsing |
|
|
;;; |
|
|
|
|
|
(defun gnus-parse-netrc (file) |
|
|
"Parse FILE and return a list of all entries in the file." |
|
|
(when (file-exists-p file) |
|
|
(with-temp-buffer |
|
|
(let ((tokens '("machine" "default" "login" |
|
|
"password" "account" "macdef" "force" |
|
|
"port")) |
|
|
alist elem result pair) |
|
|
(insert-file-contents file) |
|
|
(goto-char (point-min)) |
|
|
;; Go through the file, line by line. |
|
|
(while (not (eobp)) |
|
|
(narrow-to-region (point) (gnus-point-at-eol)) |
|
|
;; For each line, get the tokens and values. |
|
|
(while (not (eobp)) |
|
|
(skip-chars-forward "\t ") |
|
|
;; Skip lines that begin with a "#". |
|
|
(if (eq (char-after) ?#) |
|
|
(goto-char (point-max)) |
|
|
(unless (eobp) |
|
|
(setq elem |
|
|
(if (= (following-char) ?\") |
|
|
(read (current-buffer)) |
|
|
(buffer-substring |
|
|
(point) (progn (skip-chars-forward "^\t ") |
|
|
(point))))) |
|
|
(cond |
|
|
((equal elem "macdef") |
|
|
;; We skip past the macro definition. |
|
|
(widen) |
|
|
(while (and (zerop (forward-line 1)) |
|
|
(looking-at "$"))) |
|
|
(narrow-to-region (point) (point))) |
|
|
((member elem tokens) |
|
|
;; Tokens that don't have a following value are ignored, |
|
|
;; except "default". |
|
|
(when (and pair (or (cdr pair) |
|
|
(equal (car pair) "default"))) |
|
|
(push pair alist)) |
|
|
(setq pair (list elem))) |
|
|
(t |
|
|
;; Values that haven't got a preceding token are ignored. |
|
|
(when pair |
|
|
(setcdr pair elem) |
|
|
(push pair alist) |
|
|
(setq pair nil))))))) |
|
|
(when alist |
|
|
(push (nreverse alist) result)) |
|
|
(setq alist nil |
|
|
pair nil) |
|
|
(widen) |
|
|
(forward-line 1)) |
|
|
(nreverse result))))) |
|
|
|
|
|
(defun gnus-netrc-machine (list machine &optional port defaultport) |
|
|
"Return the netrc values from LIST for MACHINE or for the default entry. |
|
|
If PORT specified, only return entries with matching port tokens. |
|
|
Entries without port tokens default to DEFAULTPORT." |
|
|
(let ((rest list) |
|
|
result) |
|
|
(while list |
|
|
(when (equal (cdr (assoc "machine" (car list))) machine) |
|
|
(push (car list) result)) |
|
|
(pop list)) |
|
|
(unless result |
|
|
;; No machine name matches, so we look for default entries. |
|
|
(while rest |
|
|
(when (assoc "default" (car rest)) |
|
|
(push (car rest) result)) |
|
|
(pop rest))) |
|
|
(when result |
|
|
(setq result (nreverse result)) |
|
|
(while (and result |
|
|
(not (equal (or port defaultport "nntp") |
|
|
(or (gnus-netrc-get (car result) "port") |
|
|
defaultport "nntp")))) |
|
|
(pop result)) |
|
|
(car result)))) |
|
|
|
|
|
(defun gnus-netrc-get (alist type) |
|
|
"Return the value of token TYPE from ALIST." |
|
|
(cdr (assoc type alist))) |
|
986 |
|
|
987 |
;;; Various |
;;; Various |
988 |
|
|
996 |
(eq major-mode 'gnus-group-mode)))) |
(eq major-mode 'gnus-group-mode)))) |
997 |
|
|
998 |
(defun gnus-remove-duplicates (list) |
(defun gnus-remove-duplicates (list) |
999 |
(let (new (tail list)) |
(let (new) |
1000 |
(while tail |
(while list |
1001 |
(or (member (car tail) new) |
(or (member (car list) new) |
1002 |
(setq new (cons (car tail) new))) |
(setq new (cons (car list) new))) |
1003 |
(setq tail (cdr tail))) |
(setq list (cdr list))) |
1004 |
(nreverse new))) |
(nreverse new))) |
1005 |
|
|
1006 |
(defun gnus-delete-if (predicate list) |
(defun gnus-remove-if (predicate list) |
1007 |
"Delete elements from LIST that satisfy PREDICATE." |
"Return a copy of LIST with all items satisfying PREDICATE removed." |
1008 |
(let (out) |
(let (out) |
1009 |
(while list |
(while list |
1010 |
(unless (funcall predicate (car list)) |
(unless (funcall predicate (car list)) |
1011 |
(push (car list) out)) |
(push (car list) out)) |
1012 |
(pop list)) |
(setq list (cdr list))) |
1013 |
(nreverse out))) |
(nreverse out))) |
1014 |
|
|
1015 |
(defun gnus-delete-alist (key alist) |
(if (fboundp 'assq-delete-all) |
1016 |
"Delete all entries in ALIST that have a key eq to KEY." |
(defalias 'gnus-delete-alist 'assq-delete-all) |
1017 |
(let (entry) |
(defun gnus-delete-alist (key alist) |
1018 |
(while (setq entry (assq key alist)) |
"Delete from ALIST all elements whose car is KEY. |
1019 |
(setq alist (delq entry alist))) |
Return the modified alist." |
1020 |
alist)) |
(let (entry) |
1021 |
|
(while (setq entry (assq key alist)) |
1022 |
|
(setq alist (delq entry alist))) |
1023 |
|
alist))) |
1024 |
|
|
1025 |
(defmacro gnus-pull (key alist &optional assoc-p) |
(defmacro gnus-pull (key alist &optional assoc-p) |
1026 |
"Modify ALIST to be without KEY." |
"Modify ALIST to be without KEY." |
1030 |
`(setq ,alist (delq (,fun ,key ,alist) ,alist)))) |
`(setq ,alist (delq (,fun ,key ,alist) ,alist)))) |
1031 |
|
|
1032 |
(defun gnus-globalify-regexp (re) |
(defun gnus-globalify-regexp (re) |
1033 |
"Returns a regexp that matches a whole line, iff RE matches a part of it." |
"Return a regexp that matches a whole line, iff RE matches a part of it." |
1034 |
(concat (unless (string-match "^\\^" re) "^.*") |
(concat (unless (string-match "^\\^" re) "^.*") |
1035 |
re |
re |
1036 |
(unless (string-match "\\$$" re) ".*$"))) |
(unless (string-match "\\$$" re) ".*$"))) |
1037 |
|
|
1038 |
(defun gnus-set-window-start (&optional point) |
(defun gnus-set-window-start (&optional point) |
1039 |
"Set the window start to POINT, or (point) if nil." |
"Set the window start to POINT, or (point) if nil." |
1040 |
(let ((win (get-buffer-window (current-buffer) t))) |
(let ((win (gnus-get-buffer-window (current-buffer) t))) |
1041 |
(when win |
(when win |
1042 |
(set-window-start win (or point (point)))))) |
(set-window-start win (or point (point)))))) |
1043 |
|
|
1081 |
(while (search-backward "\\." nil t) |
(while (search-backward "\\." nil t) |
1082 |
(delete-char 1))))) |
(delete-char 1))))) |
1083 |
|
|
1084 |
|
;; Fixme: Why not use `with-output-to-temp-buffer'? |
1085 |
|
(defmacro gnus-with-output-to-file (file &rest body) |
1086 |
|
(let ((buffer (make-symbol "output-buffer")) |
1087 |
|
(size (make-symbol "output-buffer-size")) |
1088 |
|
(leng (make-symbol "output-buffer-length")) |
1089 |
|
(append (make-symbol "output-buffer-append"))) |
1090 |
|
`(let* ((,size 131072) |
1091 |
|
(,buffer (make-string ,size 0)) |
1092 |
|
(,leng 0) |
1093 |
|
(,append nil) |
1094 |
|
(standard-output |
1095 |
|
(lambda (c) |
1096 |
|
(aset ,buffer ,leng c) |
1097 |
|
|
1098 |
|
(if (= ,size (setq ,leng (1+ ,leng))) |
1099 |
|
(progn (write-region ,buffer nil ,file ,append 'no-msg) |
1100 |
|
(setq ,leng 0 |
1101 |
|
,append t)))))) |
1102 |
|
,@body |
1103 |
|
(when (> ,leng 0) |
1104 |
|
(let ((coding-system-for-write 'no-conversion)) |
1105 |
|
(write-region (substring ,buffer 0 ,leng) nil ,file |
1106 |
|
,append 'no-msg)))))) |
1107 |
|
|
1108 |
|
(put 'gnus-with-output-to-file 'lisp-indent-function 1) |
1109 |
|
(put 'gnus-with-output-to-file 'edebug-form-spec '(form body)) |
1110 |
|
|
1111 |
|
(if (fboundp 'union) |
1112 |
|
(defalias 'gnus-union 'union) |
1113 |
|
(defun gnus-union (l1 l2) |
1114 |
|
"Set union of lists L1 and L2." |
1115 |
|
(cond ((null l1) l2) |
1116 |
|
((null l2) l1) |
1117 |
|
((equal l1 l2) l1) |
1118 |
|
(t |
1119 |
|
(or (>= (length l1) (length l2)) |
1120 |
|
(setq l1 (prog1 l2 (setq l2 l1)))) |
1121 |
|
(while l2 |
1122 |
|
(or (member (car l2) l1) |
1123 |
|
(push (car l2) l1)) |
1124 |
|
(pop l2)) |
1125 |
|
l1)))) |
1126 |
|
|
1127 |
(defun gnus-add-text-properties-when |
(defun gnus-add-text-properties-when |
1128 |
(property value start end properties &optional object) |
(property value start end properties &optional object) |
1129 |
"Like `gnus-add-text-properties', only applied on where PROPERTY is VALUE." |
"Like `gnus-add-text-properties', only applied on where PROPERTY is VALUE." |
1130 |
(let (point) |
(let (point) |
1131 |
(while (and start |
(while (and start |
1132 |
|
(< start end) ;; XEmacs will loop for every when start=end. |
1133 |
(setq point (text-property-not-all start end property value))) |
(setq point (text-property-not-all start end property value))) |
1134 |
(gnus-add-text-properties start point properties object) |
(gnus-add-text-properties start point properties object) |
1135 |
(setq start (text-property-any point end property value))) |
(setq start (text-property-any point end property value))) |
1141 |
"Like `remove-text-properties', only applied on where PROPERTY is VALUE." |
"Like `remove-text-properties', only applied on where PROPERTY is VALUE." |
1142 |
(let (point) |
(let (point) |
1143 |
(while (and start |
(while (and start |
1144 |
|
(< start end) |
1145 |
(setq point (text-property-not-all start end property value))) |
(setq point (text-property-not-all start end property value))) |
1146 |
(remove-text-properties start point properties object) |
(remove-text-properties start point properties object) |
1147 |
(setq start (text-property-any point end property value))) |
(setq start (text-property-any point end property value))) |
1149 |
(remove-text-properties start end properties object)) |
(remove-text-properties start end properties object)) |
1150 |
t)) |
t)) |
1151 |
|
|
1152 |
|
;; This might use `compare-strings' to reduce consing in the |
1153 |
|
;; case-insensitive case, but it has to cope with null args. |
1154 |
|
;; (`string-equal' uses symbol print names.) |
1155 |
|
(defun gnus-string-equal (x y) |
1156 |
|
"Like `string-equal', except it compares case-insensitively." |
1157 |
|
(and (= (length x) (length y)) |
1158 |
|
(or (string-equal x y) |
1159 |
|
(string-equal (downcase x) (downcase y))))) |
1160 |
|
|
1161 |
|
(defcustom gnus-use-byte-compile t |
1162 |
|
"If non-nil, byte-compile crucial run-time code. |
1163 |
|
Setting it to nil has no effect after the first time `gnus-byte-compile' |
1164 |
|
is run." |
1165 |
|
:type 'boolean |
1166 |
|
:version "21.1" |
1167 |
|
:group 'gnus-various) |
1168 |
|
|
1169 |
|
(defun gnus-byte-compile (form) |
1170 |
|
"Byte-compile FORM if `gnus-use-byte-compile' is non-nil." |
1171 |
|
(if gnus-use-byte-compile |
1172 |
|
(progn |
1173 |
|
(condition-case nil |
1174 |
|
;; Work around a bug in XEmacs 21.4 |
1175 |
|
(require 'byte-optimize) |
1176 |
|
(error)) |
1177 |
|
(require 'bytecomp) |
1178 |
|
(defalias 'gnus-byte-compile |
1179 |
|
(lambda (form) |
1180 |
|
(let ((byte-compile-warnings '(unresolved callargs redefine))) |
1181 |
|
(byte-compile form)))) |
1182 |
|
(gnus-byte-compile form)) |
1183 |
|
form)) |
1184 |
|
|
1185 |
|
(defun gnus-remassoc (key alist) |
1186 |
|
"Delete by side effect any elements of LIST whose car is `equal' to KEY. |
1187 |
|
The modified LIST is returned. If the first member |
1188 |
|
of LIST has a car that is `equal' to KEY, there is no way to remove it |
1189 |
|
by side effect; therefore, write `(setq foo (remassoc key foo))' to be |
1190 |
|
sure of changing the value of `foo'." |
1191 |
|
(when alist |
1192 |
|
(if (equal key (caar alist)) |
1193 |
|
(cdr alist) |
1194 |
|
(setcdr alist (gnus-remassoc key (cdr alist))) |
1195 |
|
alist))) |
1196 |
|
|
1197 |
|
(defun gnus-update-alist-soft (key value alist) |
1198 |
|
(if value |
1199 |
|
(cons (cons key value) (gnus-remassoc key alist)) |
1200 |
|
(gnus-remassoc key alist))) |
1201 |
|
|
1202 |
|
(defun gnus-create-info-command (node) |
1203 |
|
"Create a command that will go to info NODE." |
1204 |
|
`(lambda () |
1205 |
|
(interactive) |
1206 |
|
,(concat "Enter the info system at node " node) |
1207 |
|
(Info-goto-node ,node) |
1208 |
|
(setq gnus-info-buffer (current-buffer)) |
1209 |
|
(gnus-configure-windows 'info))) |
1210 |
|
|
1211 |
|
(defun gnus-not-ignore (&rest args) |
1212 |
|
t) |
1213 |
|
|
1214 |
(defvar gnus-directory-sep-char-regexp "/" |
(defvar gnus-directory-sep-char-regexp "/" |
1215 |
"The regexp of directory separator character. |
"The regexp of directory separator character. |
1216 |
If you find some problem with the directory separator character, try |
If you find some problem with the directory separator character, try |
1217 |
\"[/\\\\\]\" for some systems.") |
\"[/\\\\\]\" for some systems.") |
1218 |
|
|
1219 |
|
(defun gnus-url-unhex (x) |
1220 |
|
(if (> x ?9) |
1221 |
|
(if (>= x ?a) |
1222 |
|
(+ 10 (- x ?a)) |
1223 |
|
(+ 10 (- x ?A))) |
1224 |
|
(- x ?0))) |
1225 |
|
|
1226 |
|
;; Fixme: Do it like QP. |
1227 |
|
(defun gnus-url-unhex-string (str &optional allow-newlines) |
1228 |
|
"Remove %XX, embedded spaces, etc in a url. |
1229 |
|
If optional second argument ALLOW-NEWLINES is non-nil, then allow the |
1230 |
|
decoding of carriage returns and line feeds in the string, which is normally |
1231 |
|
forbidden in URL encoding." |
1232 |
|
(let ((tmp "") |
1233 |
|
(case-fold-search t)) |
1234 |
|
(while (string-match "%[0-9a-f][0-9a-f]" str) |
1235 |
|
(let* ((start (match-beginning 0)) |
1236 |
|
(ch1 (gnus-url-unhex (elt str (+ start 1)))) |
1237 |
|
(code (+ (* 16 ch1) |
1238 |
|
(gnus-url-unhex (elt str (+ start 2)))))) |
1239 |
|
(setq tmp (concat |
1240 |
|
tmp (substring str 0 start) |
1241 |
|
(cond |
1242 |
|
(allow-newlines |
1243 |
|
(char-to-string code)) |
1244 |
|
((or (= code ?\n) (= code ?\r)) |
1245 |
|
" ") |
1246 |
|
(t (char-to-string code)))) |
1247 |
|
str (substring str (match-end 0))))) |
1248 |
|
(setq tmp (concat tmp str)) |
1249 |
|
tmp)) |
1250 |
|
|
1251 |
|
(defun gnus-make-predicate (spec) |
1252 |
|
"Transform SPEC into a function that can be called. |
1253 |
|
SPEC is a predicate specifier that contains stuff like `or', `and', |
1254 |
|
`not', lists and functions. The functions all take one parameter." |
1255 |
|
`(lambda (elem) ,(gnus-make-predicate-1 spec))) |
1256 |
|
|
1257 |
|
(defun gnus-make-predicate-1 (spec) |
1258 |
|
(cond |
1259 |
|
((symbolp spec) |
1260 |
|
`(,spec elem)) |
1261 |
|
((listp spec) |
1262 |
|
(if (memq (car spec) '(or and not)) |
1263 |
|
`(,(car spec) ,@(mapcar 'gnus-make-predicate-1 (cdr spec))) |
1264 |
|
(error "Invalid predicate specifier: %s" spec))))) |
1265 |
|
|
1266 |
|
(defun gnus-local-map-property (map) |
1267 |
|
"Return a list suitable for a text property list specifying keymap MAP." |
1268 |
|
(cond |
1269 |
|
((featurep 'xemacs) |
1270 |
|
(list 'keymap map)) |
1271 |
|
((>= emacs-major-version 21) |
1272 |
|
(list 'keymap map)) |
1273 |
|
(t |
1274 |
|
(list 'local-map map)))) |
1275 |
|
|
1276 |
|
(defmacro gnus-completing-read-maybe-default (prompt table &optional predicate |
1277 |
|
require-match initial-contents |
1278 |
|
history default) |
1279 |
|
"Like `completing-read', allowing for non-existent 7th arg in older XEmacsen." |
1280 |
|
`(completing-read ,prompt ,table ,predicate ,require-match |
1281 |
|
,initial-contents ,history |
1282 |
|
,@(if (and (featurep 'xemacs) (< emacs-minor-version 2)) |
1283 |
|
() |
1284 |
|
(list default)))) |
1285 |
|
|
1286 |
|
(defun gnus-completing-read (prompt table &optional predicate require-match |
1287 |
|
history) |
1288 |
|
(when (and history |
1289 |
|
(not (boundp history))) |
1290 |
|
(set history nil)) |
1291 |
|
(gnus-completing-read-maybe-default |
1292 |
|
(if (symbol-value history) |
1293 |
|
(concat prompt " (" (car (symbol-value history)) "): ") |
1294 |
|
(concat prompt ": ")) |
1295 |
|
table |
1296 |
|
predicate |
1297 |
|
require-match |
1298 |
|
nil |
1299 |
|
history |
1300 |
|
(car (symbol-value history)))) |
1301 |
|
|
1302 |
|
(defun gnus-graphic-display-p () |
1303 |
|
(or (and (fboundp 'display-graphic-p) |
1304 |
|
(display-graphic-p)) |
1305 |
|
;;;!!!This is bogus. Fixme! |
1306 |
|
(and (featurep 'xemacs) |
1307 |
|
t))) |
1308 |
|
|
1309 |
|
(put 'gnus-parse-without-error 'lisp-indent-function 0) |
1310 |
|
(put 'gnus-parse-without-error 'edebug-form-spec '(body)) |
1311 |
|
|
1312 |
|
(defmacro gnus-parse-without-error (&rest body) |
1313 |
|
"Allow continuing onto the next line even if an error occurs." |
1314 |
|
`(while (not (eobp)) |
1315 |
|
(condition-case () |
1316 |
|
(progn |
1317 |
|
,@body |
1318 |
|
(goto-char (point-max))) |
1319 |
|
(error |
1320 |
|
(gnus-error 4 "Invalid data on line %d" |
1321 |
|
(count-lines (point-min) (point))) |
1322 |
|
(forward-line 1))))) |
1323 |
|
|
1324 |
|
(defun gnus-cache-file-contents (file variable function) |
1325 |
|
"Cache the contents of FILE in VARIABLE. The contents come from FUNCTION." |
1326 |
|
(let ((time (nth 5 (file-attributes file))) |
1327 |
|
contents value) |
1328 |
|
(if (or (null (setq value (symbol-value variable))) |
1329 |
|
(not (equal (car value) file)) |
1330 |
|
(not (equal (nth 1 value) time))) |
1331 |
|
(progn |
1332 |
|
(setq contents (funcall function file)) |
1333 |
|
(set variable (list file time contents)) |
1334 |
|
contents) |
1335 |
|
(nth 2 value)))) |
1336 |
|
|
1337 |
|
(defun gnus-multiple-choice (prompt choice &optional idx) |
1338 |
|
"Ask user a multiple choice question. |
1339 |
|
CHOICE is a list of the choice char and help message at IDX." |
1340 |
|
(let (tchar buf) |
1341 |
|
(save-window-excursion |
1342 |
|
(save-excursion |
1343 |
|
(while (not tchar) |
1344 |
|
(message "%s (%s): " |
1345 |
|
prompt |
1346 |
|
(concat |
1347 |
|
(mapconcat (lambda (s) (char-to-string (car s))) |
1348 |
|
choice ", ") ", ?")) |
1349 |
|
(setq tchar (read-char)) |
1350 |
|
(when (not (assq tchar choice)) |
1351 |
|
(setq tchar nil) |
1352 |
|
(setq buf (get-buffer-create "*Gnus Help*")) |
1353 |
|
(pop-to-buffer buf) |
1354 |
|
(fundamental-mode) ; for Emacs 20.4+ |
1355 |
|
(buffer-disable-undo) |
1356 |
|
(erase-buffer) |
1357 |
|
(insert prompt ":\n\n") |
1358 |
|
(let ((max -1) |
1359 |
|
(list choice) |
1360 |
|
(alist choice) |
1361 |
|
(idx (or idx 1)) |
1362 |
|
(i 0) |
1363 |
|
n width pad format) |
1364 |
|
;; find the longest string to display |
1365 |
|
(while list |
1366 |
|
(setq n (length (nth idx (car list)))) |
1367 |
|
(unless (> max n) |
1368 |
|
(setq max n)) |
1369 |
|
(setq list (cdr list))) |
1370 |
|
(setq max (+ max 4)) ; %c, `:', SPACE, a SPACE at end |
1371 |
|
(setq n (/ (1- (window-width)) max)) ; items per line |
1372 |
|
(setq width (/ (1- (window-width)) n)) ; width of each item |
1373 |
|
;; insert `n' items, each in a field of width `width' |
1374 |
|
(while alist |
1375 |
|
(if (< i n) |
1376 |
|
() |
1377 |
|
(setq i 0) |
1378 |
|
(delete-char -1) ; the `\n' takes a char |
1379 |
|
(insert "\n")) |
1380 |
|
(setq pad (- width 3)) |
1381 |
|
(setq format (concat "%c: %-" (int-to-string pad) "s")) |
1382 |
|
(insert (format format (caar alist) (nth idx (car alist)))) |
1383 |
|
(setq alist (cdr alist)) |
1384 |
|
(setq i (1+ i)))))))) |
1385 |
|
(if (buffer-live-p buf) |
1386 |
|
(kill-buffer buf)) |
1387 |
|
tchar)) |
1388 |
|
|
1389 |
|
(defun gnus-select-frame-set-input-focus (frame) |
1390 |
|
"Select FRAME, raise it, and set input focus, if possible." |
1391 |
|
(cond ((featurep 'xemacs) |
1392 |
|
(raise-frame frame) |
1393 |
|
(select-frame frame) |
1394 |
|
(focus-frame frame)) |
1395 |
|
;; The function `select-frame-set-input-focus' won't set |
1396 |
|
;; the input focus under Emacs 21.2 and X window system. |
1397 |
|
;;((fboundp 'select-frame-set-input-focus) |
1398 |
|
;; (defalias 'gnus-select-frame-set-input-focus |
1399 |
|
;; 'select-frame-set-input-focus) |
1400 |
|
;; (select-frame-set-input-focus frame)) |
1401 |
|
(t |
1402 |
|
(raise-frame frame) |
1403 |
|
(select-frame frame) |
1404 |
|
(cond ((and (eq window-system 'x) |
1405 |
|
(fboundp 'x-focus-frame)) |
1406 |
|
(x-focus-frame frame)) |
1407 |
|
((eq window-system 'w32) |
1408 |
|
(w32-focus-frame frame))) |
1409 |
|
(when focus-follows-mouse |
1410 |
|
(set-mouse-position frame (1- (frame-width frame)) 0))))) |
1411 |
|
|
1412 |
|
(defun gnus-frame-or-window-display-name (object) |
1413 |
|
"Given a frame or window, return the associated display name. |
1414 |
|
Return nil otherwise." |
1415 |
|
(if (featurep 'xemacs) |
1416 |
|
(device-connection (dfw-device object)) |
1417 |
|
(if (or (framep object) |
1418 |
|
(and (windowp object) |
1419 |
|
(setq object (window-frame object)))) |
1420 |
|
(let ((display (frame-parameter object 'display))) |
1421 |
|
(if (and (stringp display) |
1422 |
|
;; Exclude invalid display names. |
1423 |
|
(string-match "\\`[^:]*:[0-9]+\\(\\.[0-9]+\\)?\\'" |
1424 |
|
display)) |
1425 |
|
display))))) |
1426 |
|
|
1427 |
|
;; Fixme: This has only one use (in gnus-agent), which isn't worthwhile. |
1428 |
|
(defmacro gnus-mapcar (function seq1 &rest seqs2_n) |
1429 |
|
"Apply FUNCTION to each element of the sequences, and make a list of the results. |
1430 |
|
If there are several sequences, FUNCTION is called with that many arguments, |
1431 |
|
and mapping stops as soon as the shortest sequence runs out. With just one |
1432 |
|
sequence, this is like `mapcar'. With several, it is like the Common Lisp |
1433 |
|
`mapcar' function extended to arbitrary sequence types." |
1434 |
|
|
1435 |
|
(if seqs2_n |
1436 |
|
(let* ((seqs (cons seq1 seqs2_n)) |
1437 |
|
(cnt 0) |
1438 |
|
(heads (mapcar (lambda (seq) |
1439 |
|
(make-symbol (concat "head" |
1440 |
|
(int-to-string |
1441 |
|
(setq cnt (1+ cnt)))))) |
1442 |
|
seqs)) |
1443 |
|
(result (make-symbol "result")) |
1444 |
|
(result-tail (make-symbol "result-tail"))) |
1445 |
|
`(let* ,(let* ((bindings (cons nil nil)) |
1446 |
|
(heads heads)) |
1447 |
|
(nconc bindings (list (list result '(cons nil nil)))) |
1448 |
|
(nconc bindings (list (list result-tail result))) |
1449 |
|
(while heads |
1450 |
|
(nconc bindings (list (list (pop heads) (pop seqs))))) |
1451 |
|
(cdr bindings)) |
1452 |
|
(while (and ,@heads) |
1453 |
|
(setcdr ,result-tail (cons (funcall ,function |
1454 |
|
,@(mapcar (lambda (h) (list 'car h)) |
1455 |
|
heads)) |
1456 |
|
nil)) |
1457 |
|
(setq ,result-tail (cdr ,result-tail) |
1458 |
|
,@(apply 'nconc (mapcar (lambda (h) (list h (list 'cdr h))) heads)))) |
1459 |
|
(cdr ,result))) |
1460 |
|
`(mapcar ,function ,seq1))) |
1461 |
|
|
1462 |
|
(if (fboundp 'merge) |
1463 |
|
(defalias 'gnus-merge 'merge) |
1464 |
|
;; Adapted from cl-seq.el |
1465 |
|
(defun gnus-merge (type list1 list2 pred) |
1466 |
|
"Destructively merge lists LIST1 and LIST2 to produce a new list. |
1467 |
|
Argument TYPE is for compatibility and ignored. |
1468 |
|
Ordering of the elements is preserved according to PRED, a `less-than' |
1469 |
|
predicate on the elements." |
1470 |
|
(let ((res nil)) |
1471 |
|
(while (and list1 list2) |
1472 |
|
(if (funcall pred (car list2) (car list1)) |
1473 |
|
(push (pop list2) res) |
1474 |
|
(push (pop list1) res))) |
1475 |
|
(nconc (nreverse res) list1 list2)))) |
1476 |
|
|
1477 |
|
(eval-when-compile |
1478 |
|
(defvar xemacs-codename)) |
1479 |
|
|
1480 |
|
(defun gnus-emacs-version () |
1481 |
|
"Stringified Emacs version." |
1482 |
|
(let ((system-v |
1483 |
|
(cond |
1484 |
|
((eq gnus-user-agent 'emacs-gnus-config) |
1485 |
|
system-configuration) |
1486 |
|
((eq gnus-user-agent 'emacs-gnus-type) |
1487 |
|
(symbol-name system-type)) |
1488 |
|
(t nil)))) |
1489 |
|
(cond |
1490 |
|
((eq gnus-user-agent 'gnus) |
1491 |
|
nil) |
1492 |
|
((string-match "^\\(\\([.0-9]+\\)*\\)\\.[0-9]+$" emacs-version) |
1493 |
|
(concat "Emacs/" (match-string 1 emacs-version) |
1494 |
|
(if system-v |
1495 |
|
(concat " (" system-v ")") |
1496 |
|
""))) |
1497 |
|
((string-match |
1498 |
|
"\\([A-Z]*[Mm][Aa][Cc][Ss]\\)[^(]*\\(\\((beta.*)\\|'\\)\\)?" |
1499 |
|
emacs-version) |
1500 |
|
(concat |
1501 |
|
(match-string 1 emacs-version) |
1502 |
|
(format "/%d.%d" emacs-major-version emacs-minor-version) |
1503 |
|
(if (match-beginning 3) |
1504 |
|
(match-string 3 emacs-version) |
1505 |
|
"") |
1506 |
|
(if (boundp 'xemacs-codename) |
1507 |
|
(concat |
1508 |
|
" (" xemacs-codename |
1509 |
|
(if system-v |
1510 |
|
(concat ", " system-v ")") |
1511 |
|
")")) |
1512 |
|
""))) |
1513 |
|
(t emacs-version)))) |
1514 |
|
|
1515 |
(provide 'gnus-util) |
(provide 'gnus-util) |
1516 |
|
|
1517 |
;;; arch-tag: f94991af-d32b-4c97-8c26-ca12a934de49 |
;;; arch-tag: f94991af-d32b-4c97-8c26-ca12a934de49 |