X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-util.el;h=8e5eb6aca959ec25d80fbbbd65b24af95c0a9b49;hb=8bee94245d027b46e8b93217dad7221ca12e48f2;hp=ec4f4900844a3987e7779fe57970b1f5d3483df7;hpb=1e294f2ccb951a4215cd3354cef17e0305433db4;p=gnus diff --git a/lisp/gnus-util.el b/lisp/gnus-util.el index ec4f49008..8e5eb6aca 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, 2001 +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen @@ -38,9 +38,11 @@ (defvar nnmail-pathname-coding-system)) (require 'nnheader) (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")) @@ -57,10 +59,15 @@ (let ((start 0) tail) (while (string-match regexp string start) (setq tail (- (length string) (match-end 0))) - (setq string (replace-match newtext t t string)) + (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) @@ -73,7 +80,7 @@ (buf (make-symbol "buf"))) `(let* ((,tempvar (selected-window)) (,buf ,buffer) - (,w (get-buffer-window ,buf 'visible))) + (,w (gnus-get-buffer-window ,buf 'visible))) (unwind-protect (progn (if ,w @@ -117,11 +124,6 @@ (funcall (if (stringp buffer) 'get-buffer 'buffer-name) buffer)))) -(defmacro gnus-kill-buffer (buffer) - `(let ((buf ,buffer)) - (when (gnus-buffer-exists-p buf) - (kill-buffer buf)))) - (defalias 'gnus-point-at-bol (if (fboundp 'point-at-bol) 'point-at-bol @@ -146,7 +148,7 @@ ;; Delete the current line (and the next N lines). (defmacro gnus-delete-line (&optional n) - `(delete-region (progn (beginning-of-line) (point)) + `(delete-region (gnus-point-at-bol) (progn (forward-line ,(or n 1)) (point)))) (defun gnus-byte-code (func) @@ -171,7 +173,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 @@ -196,6 +198,12 @@ (nnheader-narrow-to-headers) (message-fetch-field field))))) +(defun gnus-fetch-original-field (field) + "Fetch FIELD from the original version of the current article." + (with-current-buffer gnus-original-article-buffer + (gnus-fetch-field field))) + + (defun gnus-goto-colon () (beginning-of-line) (let ((eol (gnus-point-at-eol))) @@ -293,7 +301,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 ") ") @@ -327,14 +335,14 @@ (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 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) + (+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600) (* (- (string-to-number days) 1) 3600 24)))) (defvar gnus-user-date-format-alist @@ -342,16 +350,24 @@ (604800 . "%a %k:%M") ;;that's one week ((gnus-seconds-month) . "%a %d") ((gnus-seconds-year) . "%b %d") - (t . "%b %m '%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.") + (t . "%b %d '%y")) ;;this one is used when no + ;;other does match + "Specifies date format depending on age of article. +This is an alist of items (AGE . FORMAT). AGE can be a number (of +seconds) or a Lisp expression evaluating to a number. When the age of +the article is less than this number, then use `format-time-string' +with the corresponding FORMAT for displaying the date of the article. +If AGE is not a number or a Lisp expression evaluating to a +non-number, then the corresponding FORMAT is used as a default value. + +Note that the list is processed from the beginning, so it should be +sorted by ascending AGE. Also note that items following the first +non-number AGE will be ignored. + +You can use the functions `gnus-seconds-today', `gnus-seconds-month' +and `gnus-seconds-year' in the AGE spec. They return the number of +seconds passed since the start of today, of this month, of this year, +respectively.") (defun gnus-user-date (messy-date) "Format the messy-date acording to gnus-user-date-format-alist. @@ -361,11 +377,11 @@ Input should look like this: \"Sun, 14 Oct 2001 13:34:39 +0200\"." (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") + (my-format "%b %m '%y") (high (lsh (- (car now) (car messy-date)) 16))) - (if (and (> high -1) (= (logand high 65535) 0)) + (if (and (> high -1) (= (logand high 65535) 0)) ;;overflow and bad input - (let* ((difference (+ high (- (car (cdr now)) + (let* ((difference (+ high (- (car (cdr now)) (car (cdr messy-date))))) (templist gnus-user-date-format-alist) (top (eval (caar templist)))) @@ -467,7 +483,7 @@ jabbering all the time." "Return a list of Message-IDs in REFERENCES." (let ((beg 0) ids) - (while (string-match "<[^> \t]+>" references beg) + (while (string-match "<[^<]+[^< \t]" references beg) (push (substring references (match-beginning 0) (setq beg (match-end 0))) ids)) (nreverse ids))) @@ -475,11 +491,15 @@ 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)))) + (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." @@ -490,9 +510,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. @@ -506,15 +526,15 @@ 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 () +(defun gnus-read-event-char (&optional prompt) "Get the next event." - (let ((event (read-event))) + (let ((event (read-event prompt))) ;; should be gnus-characterp, but this can't be called in XEmacs anyway (cons (and (numberp event) event) event))) @@ -608,9 +628,13 @@ Bind `print-quoted' and `print-readably' to t while printing." (prin1 form (current-buffer)))) (defun gnus-prin1-to-string (form) - "The same as `prin1', but bind `print-quoted' and `print-readably' to t." + "The same as `prin1'. +Bind `print-quoted' and `print-readably' to t, and `print-length' +and `print-level' to nil." (let ((print-quoted t) - (print-readably t)) + (print-readably t) + (print-length nil) + (print-level nil)) (prin1-to-string form))) (defun gnus-make-directory (directory) @@ -652,6 +676,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." @@ -660,9 +697,23 @@ 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)))))) + +(defmacro gnus-faces-at (position) + "Return a list of faces at POSITION." + (if (featurep 'xemacs) + `(let ((pos ,position)) + (mapcar-extents 'extent-face + nil (current-buffer) pos pos nil 'face)) + `(let ((pos ,position)) + (delq nil (cons (get-text-property pos 'face) + (mapcar + (lambda (overlay) + (overlay-get overlay 'face)) + (overlays-at pos))))))) ;;; Protected and atomic operations. dmoore@ucsd.edu 21.11.1996 ;;; The primary idea here is to try to protect internal datastructures @@ -693,7 +744,7 @@ non-locally exits. The variables listed in PROTECT are updated atomically. It is safe to use gnus-atomic-progn-assign with long computations. Note that if any of the symbols in PROTECT were unbound, they will be -set to nil on a sucessful assignment. In case of an error or other +set to nil on a successful assignment. In case of an error or other non-local exit, it will still be unbound." (let* ((temp-sym-map (mapcar (lambda (x) (list (make-symbol (concat (symbol-name x) @@ -868,104 +919,14 @@ with potentially long computations." (defun gnus-map-function (funs arg) "Applies the result of the first function in FUNS to the second, and so on. ARG is passed to the first function." - (let ((myfuns funs)) - (while myfuns - (setq arg (funcall (pop myfuns) arg))) - arg)) + (while funs + (setq arg (funcall (pop funs) arg))) + arg) (defun gnus-run-hooks (&rest funcs) - "Does the same as `run-hooks', but saves excursion." - (let ((buf (current-buffer))) - (unwind-protect - (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))) + "Does the same as `run-hooks', but saves the current buffer." + (save-current-buffer + (apply 'run-hooks funcs))) ;;; Various @@ -979,20 +940,20 @@ Entries without port tokens default to DEFAULTPORT." (eq major-mode 'gnus-group-mode)))) (defun gnus-remove-duplicates (list) - (let (new (tail list)) - (while tail - (or (member (car tail) new) - (setq new (cons (car tail) new))) - (setq tail (cdr tail))) + (let (new) + (while list + (or (member (car list) new) + (setq new (cons (car list) new))) + (setq list (cdr list))) (nreverse new))) -(defun gnus-delete-if (predicate list) - "Delete elements from LIST that satisfy PREDICATE." +(defun gnus-remove-if (predicate list) + "Return a copy of LIST with all items satisfying PREDICATE removed." (let (out) (while list (unless (funcall predicate (car list)) (push (car list) out)) - (pop list)) + (setq list (cdr list))) (nreverse out))) (if (fboundp 'assq-delete-all) @@ -1020,7 +981,7 @@ Return the modified alist." (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)))))) @@ -1064,6 +1025,34 @@ Return the modified alist." (while (search-backward "\\." nil t) (delete-char 1))))) +(defmacro gnus-with-output-to-file (file &rest body) + (let ((buffer (make-symbol "output-buffer")) + (size (make-symbol "output-buffer-size")) + (leng (make-symbol "output-buffer-length"))) + `(let* ((print-quoted t) + (print-readably t) + (print-escape-multibyte nil) + print-level + print-length + (,size 131072) + (,buffer (make-string ,size 0)) + (,leng 0) + (append nil) + (standard-output + (lambda (c) + (aset ,buffer ,leng c) + (if (= ,size (setq ,leng (1+ ,leng))) + (progn (write-region ,buffer nil ,file append 'no-msg) + (setq ,leng 0 + append t)))))) + ,@body + (when (> ,leng 0) + (write-region (substring ,buffer 0 ,leng) nil ,file + append 'no-msg))))) + +(put 'gnus-with-output-to-file 'lisp-indent-function 1) +(put 'gnus-with-output-to-file 'edebug-form-spec '(form body)) + (if (fboundp 'union) (defalias 'gnus-union 'union) (defun gnus-union (l1 l2) @@ -1112,7 +1101,9 @@ Return the modified alist." (string-equal (downcase x) (downcase y))))) (defcustom gnus-use-byte-compile t - "If non-nil, byte-compile crucial run-time codes." + "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) @@ -1121,9 +1112,16 @@ Return the modified alist." "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)) + (defalias 'gnus-byte-compile + (lambda (form) + (let ((byte-compile-warnings '(unresolved callargs redefine))) + (byte-compile form)))) + (gnus-byte-compile form)) form)) (defun gnus-remassoc (key alist) @@ -1160,6 +1158,237 @@ sure of changing the value of `foo'." 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) +(defmacro gnus-mapcar (function seq1 &rest seqs2_n) + "Apply FUNCTION to each element of the sequences, and make a list of the results. +If there are several sequences, FUNCTION is called with that many arguments, +and mapping stops as soon as the shortest sequence runs out. With just one +sequence, this is like `mapcar'. With several, it is like the Common Lisp +`mapcar' function extended to arbitrary sequence types." + + (if seqs2_n + (let* ((seqs (cons seq1 seqs2_n)) + (cnt 0) + (heads (mapcar (lambda (seq) + (make-symbol (concat "head" + (int-to-string + (setq cnt (1+ cnt)))))) + seqs)) + (result (make-symbol "result")) + (result-tail (make-symbol "result-tail"))) + `(let* ,(let* ((bindings (cons nil nil)) + (heads heads)) + (nconc bindings (list (list result '(cons nil nil)))) + (nconc bindings (list (list result-tail result))) + (while heads + (nconc bindings (list (list (pop heads) (pop seqs))))) + (cdr bindings)) + (while (and ,@heads) + (setcdr ,result-tail (cons (funcall ,function + ,@(mapcar (lambda (h) (list 'car h)) + heads)) + nil)) + (setq ,result-tail (cdr ,result-tail) + ,@(apply 'nconc (mapcar (lambda (h) (list h (list 'cdr h))) heads)))) + (cdr ,result))) + `(mapcar ,function ,seq1))) + ;;; gnus-util.el ends here