X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-util.el;h=dddac9287cdfe01f0c5048d72e0534178912a124;hb=78f0141d5935046c88037606149c1b9389d71186;hp=c58e4da60f3a18c32aec9b24ef95b7e0443381d1;hpb=edd853294e9c6133a454654f4e6e23a37f3c3569;p=gnus diff --git a/lisp/gnus-util.el b/lisp/gnus-util.el index c58e4da60..dddac9287 100644 --- a/lisp/gnus-util.el +++ b/lisp/gnus-util.el @@ -1,5 +1,5 @@ ;;; gnus-util.el --- utility functions for Gnus -;; Copyright (C) 1996, 1997, 1998, 1999, 2000 +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen @@ -32,16 +32,42 @@ ;;; Code: (require 'custom) -(eval-when-compile (require 'cl)) +(eval-when-compile + (require 'cl) + ;; Fixme: this should be a gnus variable, not nnmail-. + (defvar nnmail-pathname-coding-system)) (require 'nnheader) -(require 'message) (require 'time-date) +(require 'netrc) (eval-and-compile + (autoload 'message-fetch-field "message") + (autoload 'gnus-get-buffer-window "gnus-win") (autoload 'rmail-insert-rmail-file-header "rmail") (autoload 'rmail-count-new-messages "rmail") (autoload 'rmail-show-message "rmail")) +(eval-and-compile + (cond + ((fboundp 'replace-in-string) + (defalias 'gnus-replace-in-string 'replace-in-string)) + ((fboundp 'replace-regexp-in-string) + (defun gnus-replace-in-string (string regexp newtext &optional literal) + (replace-regexp-in-string regexp newtext string nil literal))) + (t + (defun gnus-replace-in-string (string regexp newtext &optional literal) + (let ((start 0) tail) + (while (string-match regexp string start) + (setq tail (- (length string) (match-end 0))) + (setq string (replace-match newtext nil literal string)) + (setq start (- (length string) tail)))) + string)))) + +;;; bring in the netrc functions as aliases +(defalias 'gnus-netrc-get 'netrc-get) +(defalias 'gnus-netrc-machine 'netrc-machine) +(defalias 'gnus-parse-netrc 'netrc-parse) + (defun gnus-boundp (variable) "Return non-nil if VARIABLE is bound and non-nil." (and (boundp variable) @@ -50,20 +76,20 @@ (defmacro gnus-eval-in-buffer-window (buffer &rest forms) "Pop to BUFFER, evaluate FORMS, and then return to the original window." (let ((tempvar (make-symbol "GnusStartBufferWindow")) - (w (make-symbol "w")) - (buf (make-symbol "buf"))) + (w (make-symbol "w")) + (buf (make-symbol "buf"))) `(let* ((,tempvar (selected-window)) - (,buf ,buffer) - (,w (get-buffer-window ,buf 'visible))) + (,buf ,buffer) + (,w (gnus-get-buffer-window ,buf 'visible))) (unwind-protect - (progn - (if ,w - (progn - (select-window ,w) - (set-buffer (window-buffer ,w))) - (pop-to-buffer ,buf)) - ,@forms) - (select-window ,tempvar))))) + (progn + (if ,w + (progn + (select-window ,w) + (set-buffer (window-buffer ,w))) + (pop-to-buffer ,buf)) + ,@forms) + (select-window ,tempvar))))) (put 'gnus-eval-in-buffer-window 'lisp-indent-function 1) (put 'gnus-eval-in-buffer-window 'edebug-form-spec '(form body)) @@ -152,7 +178,7 @@ (string-match (concat "[ \t]*<" (regexp-quote address) ">") from) (and (setq name (substring from 0 (match-beginning 0))) ;; Strip any quotes from the name. - (string-match "\".*\"" name) + (string-match "^\".*\"$" name) (setq name (substring name 1 (1- (match-end 0)))))) ;; If not, then "address (name)" is used. (or name @@ -179,7 +205,18 @@ (defun gnus-goto-colon () (beginning-of-line) - (search-forward ":" (gnus-point-at-eol) t)) + (let ((eol (gnus-point-at-eol))) + (goto-char (or (text-property-any (point) eol 'gnus-position t) + (search-forward ":" eol t) + (point))))) + +(defun gnus-decode-newsgroups (newsgroups group &optional method) + (let ((method (or method (gnus-find-method-for-group group)))) + (mapconcat (lambda (group) + (gnus-group-name-decode group (gnus-group-name-charset + method group))) + (message-tokenize-header newsgroups) + ","))) (defun gnus-remove-text-with-property (prop) "Delete all text in the current buffer with text property PROP." @@ -190,22 +227,17 @@ (delete-char 1)) (goto-char (next-single-property-change (point) prop nil (point-max)))))) +(require 'nnheader) (defun gnus-newsgroup-directory-form (newsgroup) "Make hierarchical directory name from NEWSGROUP name." - (let ((newsgroup (gnus-newsgroup-savable-name newsgroup)) - (len (length newsgroup)) - idx) - ;; If this is a foreign group, we don't want to translate the - ;; entire name. - (if (setq idx (string-match ":" newsgroup)) - (aset newsgroup idx ?/) - (setq idx 0)) - ;; Replace all occurrences of `.' with `/'. - (while (< idx len) - (when (= (aref newsgroup idx) ?.) - (aset newsgroup idx ?/)) - (setq idx (1+ idx))) - newsgroup)) + (let* ((newsgroup (gnus-newsgroup-savable-name newsgroup)) + (idx (string-match ":" newsgroup))) + (concat + (if idx (substring newsgroup 0 idx)) + (if idx "/") + (nnheader-replace-chars-in-string + (if idx (substring newsgroup (1+ idx)) newsgroup) + ?. ?/)))) (defun gnus-newsgroup-savable-name (group) ;; Replace any slashes in a group name (eg. an ange-ftp nndoc group) @@ -268,7 +300,7 @@ (define-key keymap key (pop plist)) (pop plist))))) -(defun gnus-completing-read (default prompt &rest args) +(defun gnus-completing-read-with-default (default prompt &rest args) ;; Like `completing-read', except that DEFAULT is the default argument. (let* ((prompt (if default (concat prompt " (default " default ") ") @@ -290,6 +322,71 @@ (yes-or-no-p prompt) (message ""))) +;; By Frank Schmitt . Allows to have +;; age-depending date representations. (e.g. just the time if it's +;; from today, the day of the week if it's within the last 7 days and +;; the full date if it's older) +(defun gnus-seconds-today () + "Returns the number of seconds passed today" + (let ((now (decode-time (current-time)))) + (+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600)))) + +(defun gnus-seconds-month () + "Returns the number of seconds passed this month" + (let ((now (decode-time (current-time)))) + (+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600) + (* (- (car (nthcdr 3 now)) 1) 3600 24)))) + +(defun gnus-seconds-year () + "Returns the number of seconds passed this year" + (let ((now (decode-time (current-time))) + (days (format-time-string "%j" (current-time)))) + (+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600) + (* (- (string-to-number days) 1) 3600 24)))) + +(defvar gnus-user-date-format-alist + '(((gnus-seconds-today) . "%k:%M") + (604800 . "%a %k:%M") ;;that's one week + ((gnus-seconds-month) . "%a %d") + ((gnus-seconds-year) . "%b %d") + (t . "%b %d '%y")) ;;this one is used when no + ;;other does match + "Alist of time in seconds and format specification used to display dates not older. +The first element must be a number or a function returning a +number. The second element is a format-specification as described in +the documentation for format-time-string. The list must be ordered +smallest number up. When there is an element, which is not a number, +the corresponding format-specification will be used, disregarding any +following elements. You can use the functions gnus-seconds-today, +gnus-seconds-month, gnus-seconds-year which will return the number of +seconds which passed today/this month/this year.") + +(defun gnus-user-date (messy-date) + "Format the messy-date acording to gnus-user-date-format-alist. +Returns \" ? \" if there's bad input or if an other error occurs. +Input should look like this: \"Sun, 14 Oct 2001 13:34:39 +0200\"." + (condition-case () + (let* ((messy-date (safe-date-to-time messy-date)) + (now (current-time)) + ;;If we don't find something suitable we'll use this one + (my-format "%b %m '%y") + (high (lsh (- (car now) (car messy-date)) 16))) + (if (and (> high -1) (= (logand high 65535) 0)) + ;;overflow and bad input + (let* ((difference (+ high (- (car (cdr now)) + (car (cdr messy-date))))) + (templist gnus-user-date-format-alist) + (top (eval (caar templist)))) + (while (if (numberp top) (< top difference) (not top)) + (progn + (setq templist (cdr templist)) + (setq top (eval (caar templist))))) + (if (stringp (cdr (car templist))) + (setq my-format (cdr (car templist)))))) + (format-time-string (eval my-format) messy-date)) + (error " ? "))) +;;end of Frank's code + (defun gnus-dd-mmm (messy-date) "Return a string like DD-MMM from a big messy string." (condition-case () @@ -322,13 +419,7 @@ Cache the result as a text property stored in DATE." (defun gnus-mode-string-quote (string) "Quote all \"%\"'s in STRING." - (save-excursion - (gnus-set-work-buffer) - (insert string) - (goto-char (point-min)) - (while (search-forward "%" nil t) - (insert "%")) - (buffer-string))) + (gnus-replace-in-string string "%" "%%")) ;; Make a hash table (default and minimum size is 256). ;; Optional argument HASHSIZE specifies the table size. @@ -384,7 +475,7 @@ jabbering all the time." "Return a list of Message-IDs in REFERENCES." (let ((beg 0) ids) - (while (string-match "<[^>]+>" references beg) + (while (string-match "<[^<]+[^< \t]" references beg) (push (substring references (match-beginning 0) (setq beg (match-end 0))) ids)) (nreverse ids))) @@ -392,13 +483,17 @@ jabbering all the time." (defsubst gnus-parent-id (references &optional n) "Return the last Message-ID in REFERENCES. If N, return the Nth ancestor instead." - (when references - (let ((ids (inline (gnus-split-references references)))) - (while (nthcdr (or n 1) ids) - (setq ids (cdr ids))) - (car ids)))) - -(defsubst gnus-buffer-live-p (buffer) + (when (and references + (not (zerop (length references)))) + (if n + (let ((ids (inline (gnus-split-references references)))) + (while (nthcdr n ids) + (setq ids (cdr ids))) + (car ids)) + (when (string-match "\\(<[^<]+>\\)[ \t]*\\'" references) + (match-string 1 references))))) + +(defun gnus-buffer-live-p (buffer) "Say whether BUFFER is alive or not." (and buffer (get-buffer buffer) @@ -407,9 +502,9 @@ If N, return the Nth ancestor instead." (defun gnus-horizontal-recenter () "Recenter the current buffer horizontally." (if (< (current-column) (/ (window-width) 2)) - (set-window-hscroll (get-buffer-window (current-buffer) t) 0) + (set-window-hscroll (gnus-get-buffer-window (current-buffer) t) 0) (let* ((orig (point)) - (end (window-end (get-buffer-window (current-buffer) t))) + (end (window-end (gnus-get-buffer-window (current-buffer) t))) (max 0)) (when end ;; Find the longest line currently displayed in the window. @@ -423,10 +518,10 @@ If N, return the Nth ancestor instead." ;; Scroll horizontally to center (sort of) the point. (if (> max (window-width)) (set-window-hscroll - (get-buffer-window (current-buffer) t) + (gnus-get-buffer-window (current-buffer) t) (min (- (current-column) (/ (window-width) 3)) (+ 2 (- max (window-width))))) - (set-window-hscroll (get-buffer-window (current-buffer) t) 0)) + (set-window-hscroll (gnus-get-buffer-window (current-buffer) t) 0)) max)))) (defun gnus-read-event-char () @@ -480,8 +575,9 @@ If N, return the Nth ancestor instead." ;; A list of functions. ((or (cdr funs) (listp (car funs))) - `(lambda (t1 t2) - ,(gnus-make-sort-function-1 (reverse funs)))) + (gnus-byte-compile + `(lambda (t1 t2) + ,(gnus-make-sort-function-1 (reverse funs))))) ;; A list containing just one function. (t (car funs)))) @@ -531,6 +627,7 @@ Bind `print-quoted' and `print-readably' to t while printing." (defun gnus-make-directory (directory) "Make DIRECTORY (and all its parents) if it doesn't exist." + (require 'nnmail) (let ((file-name-coding-system nnmail-pathname-coding-system)) (when (and directory (not (file-exists-p directory))) @@ -567,6 +664,19 @@ Bind `print-quoted' and `print-readably' to t while printing." (setq beg (point))) (gnus-put-text-property beg (point) prop val))))) +(defsubst gnus-put-overlay-excluding-newlines (beg end prop val) + "The same as `put-text-property', but don't put this prop on any newlines in the region." + (save-match-data + (save-excursion + (save-restriction + (goto-char beg) + (while (re-search-forward gnus-emphasize-whitespace-regexp end 'move) + (gnus-overlay-put + (gnus-make-overlay beg (match-beginning 0)) + prop val) + (setq beg (point))) + (gnus-overlay-put (gnus-make-overlay beg (point)) prop val))))) + (defun gnus-put-text-property-excluding-characters-with-faces (beg end prop val) "The same as `put-text-property', but don't put props on characters with the `gnus-face' property." @@ -575,9 +685,10 @@ Bind `print-quoted' and `print-readably' to t while printing." (when (get-text-property b 'gnus-face) (setq b (next-single-property-change b 'gnus-face nil end))) (when (/= b end) - (gnus-put-text-property - b (setq b (next-single-property-change b 'gnus-face nil end)) - prop val))))) + (inline + (gnus-put-text-property + b (setq b (next-single-property-change b 'gnus-face nil end)) + prop val)))))) ;;; Protected and atomic operations. dmoore@ucsd.edu 21.11.1996 ;;; The primary idea here is to try to protect internal datastructures @@ -687,7 +798,8 @@ with potentially long computations." ;; Decide whether to append to a file or to an Emacs buffer. (let ((outbuf (get-file-buffer filename))) (if (not outbuf) - (mm-append-to-file (point-min) (point-max) filename) + (let ((file-name-coding-system nnmail-pathname-coding-system)) + (mm-append-to-file (point-min) (point-max) filename)) ;; File has been visited, in buffer OUTBUF. (set-buffer outbuf) (let ((buffer-read-only nil) @@ -701,10 +813,10 @@ with potentially long computations." (when msg (goto-char (point-min)) (widen) - (search-backward "\n\^_") - (narrow-to-region (point) (point-max)) - (rmail-count-new-messages t) - (when (rmail-summary-exists) + (search-backward "\n\^_") + (narrow-to-region (point) (point-max)) + (rmail-count-new-messages t) + (when (rmail-summary-exists) (rmail-select-summary (rmail-update-summary))) (rmail-count-new-messages t) @@ -756,7 +868,8 @@ with potentially long computations." (insert "\n")) (insert "\n")) (goto-char (point-max)) - (mm-append-to-file (point-min) (point-max) filename))) + (let ((file-name-coding-system nnmail-pathname-coding-system)) + (mm-append-to-file (point-min) (point-max) filename)))) ;; File has been visited, in buffer OUTBUF. (set-buffer outbuf) (let ((buffer-read-only nil)) @@ -793,93 +906,6 @@ ARG is passed to the first function." (apply 'run-hooks funcs) (set-buffer buf)))) -;;; -;;; .netrc and .authinforc parsing -;;; - -(defun gnus-parse-netrc (file) - "Parse FILE and return an 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))) - ;;; Various (defvar gnus-group-buffer) ; Compiler directive @@ -908,12 +934,15 @@ Entries without port tokens default to DEFAULTPORT." (pop list)) (nreverse out))) -(defun gnus-delete-alist (key alist) - "Delete all entries in ALIST that have a key eq to KEY." - (let (entry) - (while (setq entry (assq key alist)) - (setq alist (delq entry alist))) - alist)) +(if (fboundp 'assq-delete-all) + (defalias 'gnus-delete-alist 'assq-delete-all) + (defun gnus-delete-alist (key alist) + "Delete from ALIST all elements whose car is KEY. +Return the modified alist." + (let (entry) + (while (setq entry (assq key alist)) + (setq alist (delq entry alist))) + alist))) (defmacro gnus-pull (key alist &optional assoc-p) "Modify ALIST to be without KEY." @@ -930,7 +959,7 @@ Entries without port tokens default to DEFAULTPORT." (defun gnus-set-window-start (&optional point) "Set the window start to POINT, or (point) if nil." - (let ((win (get-buffer-window (current-buffer) t))) + (let ((win (gnus-get-buffer-window (current-buffer) t))) (when win (set-window-start win (or point (point)))))) @@ -994,7 +1023,8 @@ Entries without port tokens default to DEFAULTPORT." (property value start end properties &optional object) "Like `gnus-add-text-properties', only applied on where PROPERTY is VALUE." (let (point) - (while (and start + (while (and start + (< start end) ;; XEmacs will loop for every when start=end. (setq point (text-property-not-all start end property value))) (gnus-add-text-properties start point properties object) (setq start (text-property-any point end property value))) @@ -1005,12 +1035,272 @@ Entries without port tokens default to DEFAULTPORT." (property value start end properties &optional object) "Like `remove-text-properties', only applied on where PROPERTY is VALUE." (let (point) - (while (and start + (while (and start + (< start end) (setq point (text-property-not-all start end property value))) (remove-text-properties start point properties object) (setq start (text-property-any point end property value))) (if start - (remove-text-properties start end properties object)))) + (remove-text-properties start end properties object)) + t)) + +(defun gnus-string-equal (x y) + "Like `string-equal', except it compares case-insensitively." + (and (= (length x) (length y)) + (or (string-equal x y) + (string-equal (downcase x) (downcase y))))) + +(defcustom gnus-use-byte-compile t + "If non-nil, byte-compile crucial run-time codes. +Setting it to `nil' has no effect after first time running +`gnus-byte-compile'." + :type 'boolean + :version "21.1" + :group 'gnus-various) + +(defun gnus-byte-compile (form) + "Byte-compile FORM if `gnus-use-byte-compile' is non-nil." + (if gnus-use-byte-compile + (progn + (condition-case nil + ;; Work around a bug in XEmacs 21.4 + (require 'byte-optimize) + (error)) + (require 'bytecomp) + (defalias 'gnus-byte-compile 'byte-compile) + (byte-compile form)) + form)) + +(defun gnus-remassoc (key alist) + "Delete by side effect any elements of LIST whose car is `equal' to KEY. +The modified LIST is returned. If the first member +of LIST has a car that is `equal' to KEY, there is no way to remove it +by side effect; therefore, write `(setq foo (remassoc key foo))' to be +sure of changing the value of `foo'." + (when alist + (if (equal key (caar alist)) + (cdr alist) + (setcdr alist (gnus-remassoc key (cdr alist))) + alist))) + +(defun gnus-update-alist-soft (key value alist) + (if value + (cons (cons key value) (gnus-remassoc key alist)) + (gnus-remassoc key alist))) + +(defun gnus-create-info-command (node) + "Create a command that will go to info NODE." + `(lambda () + (interactive) + ,(concat "Enter the info system at node " node) + (Info-goto-node ,node) + (setq gnus-info-buffer (current-buffer)) + (gnus-configure-windows 'info))) + +(defun gnus-not-ignore (&rest args) + t) + +(defvar gnus-directory-sep-char-regexp "/" + "The regexp of directory separator character. +If you find some problem with the directory separator character, try +\"[/\\\\\]\" for some systems.") + +(defun gnus-url-unhex (x) + (if (> x ?9) + (if (>= x ?a) + (+ 10 (- x ?a)) + (+ 10 (- x ?A))) + (- x ?0))) + +(defun gnus-url-unhex-string (str &optional allow-newlines) + "Remove %XXX embedded spaces, etc in a url. +If optional second argument ALLOW-NEWLINES is non-nil, then allow the +decoding of carriage returns and line feeds in the string, which is normally +forbidden in URL encoding." + (setq str (or (mm-subst-char-in-string ?+ ? str) "")) + (let ((tmp "") + (case-fold-search t)) + (while (string-match "%[0-9a-f][0-9a-f]" str) + (let* ((start (match-beginning 0)) + (ch1 (gnus-url-unhex (elt str (+ start 1)))) + (code (+ (* 16 ch1) + (gnus-url-unhex (elt str (+ start 2)))))) + (setq tmp (concat + tmp (substring str 0 start) + (cond + (allow-newlines + (char-to-string code)) + ((or (= code ?\n) (= code ?\r)) + " ") + (t (char-to-string code)))) + str (substring str (match-end 0))))) + (setq tmp (concat tmp str)) + tmp)) + +(defun gnus-make-predicate (spec) + "Transform SPEC into a function that can be called. +SPEC is a predicate specifier that contains stuff like `or', `and', +`not', lists and functions. The functions all take one parameter." + `(lambda (elem) ,(gnus-make-predicate-1 spec))) + +(defun gnus-make-predicate-1 (spec) + (cond + ((symbolp spec) + `(,spec elem)) + ((listp spec) + (if (memq (car spec) '(or and not)) + `(,(car spec) ,@(mapcar 'gnus-make-predicate-1 (cdr spec))) + (error "Invalid predicate specifier: %s" spec))))) + +(defun gnus-local-map-property (map) + "Return a list suitable for a text property list specifying keymap MAP." + (cond + ((featurep 'xemacs) + (list 'keymap map)) + ((>= emacs-major-version 21) + (list 'keymap map)) + (t + (list 'local-map map)))) + +(defun gnus-completing-read (prompt table &optional predicate require-match + history) + (when (and history + (not (boundp history))) + (set history nil)) + (completing-read + (if (symbol-value history) + (concat prompt " (" (car (symbol-value history)) "): ") + (concat prompt ": ")) + table + predicate + require-match + nil + history + (car (symbol-value history)))) + +(defun gnus-graphic-display-p () + (or (and (fboundp 'display-graphic-p) + (display-graphic-p)) + ;;;!!!This is bogus. Fixme! + (and (featurep 'xemacs) + t))) + +(put 'gnus-parse-without-error 'lisp-indent-function 0) +(put 'gnus-parse-without-error 'edebug-form-spec '(body)) + +(defmacro gnus-parse-without-error (&rest body) + "Allow continuing onto the next line even if an error occurs." + `(while (not (eobp)) + (condition-case () + (progn + ,@body + (goto-char (point-max))) + (error + (gnus-error 4 "Invalid data on line %d" + (count-lines (point-min) (point))) + (forward-line 1))))) + +(defun gnus-cache-file-contents (file variable function) + "Cache the contents of FILE in VARIABLE. The contents come from FUNCTION." + (let ((time (nth 5 (file-attributes file))) + contents value) + (if (or (null (setq value (symbol-value variable))) + (not (equal (car value) file)) + (not (equal (nth 1 value) time))) + (progn + (setq contents (funcall function file)) + (set variable (list file time contents)) + contents) + (nth 2 value)))) + +(defun gnus-multiple-choice (prompt choice &optional idx) + "Ask user a multiple choice question. +CHOICE is a list of the choice char and help message at IDX." + (let (tchar buf) + (save-window-excursion + (save-excursion + (while (not tchar) + (message "%s (%s?): " + prompt + (mapconcat (lambda (s) (char-to-string (car s))) + choice "")) + (setq tchar (read-char)) + (when (not (assq tchar choice)) + (setq tchar nil) + (setq buf (get-buffer-create "*Gnus Help*")) + (pop-to-buffer buf) + (fundamental-mode) ; for Emacs 20.4+ + (buffer-disable-undo) + (erase-buffer) + (insert prompt ":\n\n") + (let ((max -1) + (list choice) + (alist choice) + (idx (or idx 1)) + (i 0) + n width pad format) + ;; find the longest string to display + (while list + (setq n (length (nth idx (car list)))) + (unless (> max n) + (setq max n)) + (setq list (cdr list))) + (setq max (+ max 4)) ; %c, `:', SPACE, a SPACE at end + (setq n (/ (1- (window-width)) max)) ; items per line + (setq width (/ (1- (window-width)) n)) ; width of each item + ;; insert `n' items, each in a field of width `width' + (while alist + (if (< i n) + () + (setq i 0) + (delete-char -1) ; the `\n' takes a char + (insert "\n")) + (setq pad (- width 3)) + (setq format (concat "%c: %-" (int-to-string pad) "s")) + (insert (format format (caar alist) (nth idx (car alist)))) + (setq alist (cdr alist)) + (setq i (1+ i)))))))) + (if (buffer-live-p buf) + (kill-buffer buf)) + tchar)) + +(defun gnus-select-frame-set-input-focus (frame) + "Select FRAME, raise it, and set input focus, if possible." + (cond ((featurep 'xemacs) + (raise-frame frame) + (select-frame frame) + (focus-frame frame)) + ;; The function `select-frame-set-input-focus' won't set + ;; the input focus under Emacs 21.2 and X window system. + ;;((fboundp 'select-frame-set-input-focus) + ;; (defalias 'gnus-select-frame-set-input-focus + ;; 'select-frame-set-input-focus) + ;; (select-frame-set-input-focus frame)) + (t + (raise-frame frame) + (select-frame frame) + (cond ((and (eq window-system 'x) + (fboundp 'x-focus-frame)) + (x-focus-frame frame)) + ((eq window-system 'w32) + (w32-focus-frame frame))) + (when focus-follows-mouse + (set-mouse-position frame (1- (frame-width frame)) 0))))) + +(defun gnus-frame-or-window-display-name (object) + "Given a frame or window, return the associated display name. +Return nil otherwise." + (if (featurep 'xemacs) + (device-connection (dfw-device object)) + (if (or (framep object) + (and (windowp object) + (setq object (window-frame object)))) + (let ((display (frame-parameter object 'display))) + (if (and (stringp display) + ;; Exclude invalid display names. + (string-match "\\`[^:]*:[0-9]+\\(\\.[0-9]+\\)?\\'" + display)) + display))))) (provide 'gnus-util)