/[emacs]/emacs/lisp/gnus/gnus-util.el
ViewVC logotype

Diff of /emacs/lisp/gnus/gnus-util.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.16.4.2 by miles, Tue Oct 14 23:34:50 2003 UTC revision 1.16.4.3 by miles, Thu Sep 16 00:12:16 2004 UTC
# Line 1  Line 1 
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>
# Line 29  Line 29 
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)
# Line 36  Line 39 
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."
# Line 53  Line 80 
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))
# Line 81  Line 108 
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    
# Line 101  Line 123 
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
# Line 116  Line 133 
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)
# Line 130  Line 157 
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)
# Line 143  Line 170 
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
# Line 155  Line 187 
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
# Line 180  Line 212 
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."
# Line 195  Line 244 
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)
# Line 271  Line 314 
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 ") ")
# Line 293  Line 336 
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 ()
# Line 325  Cache the result as a text property stor Line 436  Cache the result as a text property stor
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.
# Line 359  jabbering all the time." Line 464  jabbering all the time."
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
# Line 387  jabbering all the time." Line 493  jabbering all the time."
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)))
# Line 395  jabbering all the time." Line 501  jabbering all the time."
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)
# Line 410  If N, return the Nth ancestor instead." Line 520  If N, return the Nth ancestor instead."
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.
# Line 426  If N, return the Nth ancestor instead." Line 536  If N, return the Nth ancestor instead."
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    
# Line 474  If N, return the Nth ancestor instead." Line 584  If N, return the Nth ancestor instead."
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))
# Line 501  If N, return the Nth ancestor instead." Line 612  If N, return the Nth ancestor instead."
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
# Line 517  If N, return the Nth ancestor instead." Line 628  If N, return the Nth ancestor instead."
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."
# Line 571  Bind `print-quoted' and `print-readably' Line 711  Bind `print-quoted' and `print-readably'
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."
# Line 579  Bind `print-quoted' and `print-readably' Line 732  Bind `print-quoted' and `print-readably'
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
# Line 660  with potentially long computations." Line 827  with potentially long computations."
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)
# Line 706  with potentially long computations." Line 894  with potentially long computations."
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)
# Line 785  with potentially long computations." Line 973  with potentially long computations."
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    
# Line 898  Entries without port tokens default to D Line 996  Entries without port tokens default to D
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."
# Line 929  Entries without port tokens default to D Line 1030  Entries without port tokens default to D
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    
# Line 980  Entries without port tokens default to D Line 1081  Entries without port tokens default to D
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)))
# Line 996  Entries without port tokens default to D Line 1141  Entries without port tokens default to D
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)))
# Line 1003  Entries without port tokens default to D Line 1149  Entries without port tokens default to D
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

Legend:
Removed from v.1.16.4.2  
changed lines
  Added in v.1.16.4.3

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26