X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;ds=sidebyside;f=lisp%2Fgnus-util.el;h=df890d1057ae8426cf0348a319224f8adf83622d;hb=47bc3a7ccbdea93f85546cfac45ee9ebdb32d310;hp=fd4a0bd48c20445dc25e6591381aff8675fc5d57;hpb=e3da950cc63d9e2d41246b84b7cb68f30c5156b0;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-util.el b/lisp/gnus-util.el index fd4a0bd..df890d1 100644 --- a/lisp/gnus-util.el +++ b/lisp/gnus-util.el @@ -1,5 +1,5 @@ ;;; gnus-util.el --- utility functions for Semi-gnus -;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002 +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen @@ -41,6 +41,7 @@ (require 'custom) (require 'nnheader) (require 'time-date) +(require 'netrc) (eval-and-compile (autoload 'message-fetch-field "message") @@ -65,6 +66,11 @@ (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) @@ -125,11 +131,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)))) - (static-cond ((fboundp 'point-at-bol) (defalias 'gnus-point-at-bol 'point-at-bol)) @@ -173,7 +174,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) @@ -223,6 +224,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))) @@ -371,15 +378,22 @@ ((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.") + "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. @@ -544,9 +558,15 @@ If N, return the Nth ancestor instead." (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 (condition-case nil + (read-event prompt) + ;; `read-event' doesn't allow arguments in Mule 2.3 + (wrong-number-of-arguments + (when prompt + (message "%s" prompt)) + (read-event))))) ;; should be gnus-characterp, but this can't be called in XEmacs anyway (cons (and (numberp event) event) event))) @@ -639,9 +659,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) @@ -726,6 +750,19 @@ Bind `print-quoted' and `print-readably' to t while printing." 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 ;;; from becoming corrupted when the user hits C-g, or if a hook or @@ -755,7 +792,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) @@ -934,104 +971,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 @@ -1045,20 +992,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) @@ -1131,6 +1078,32 @@ 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 + (if (> ,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) @@ -1180,7 +1153,7 @@ Return the modified alist." (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 +Setting it to nil has no effect after first time running `gnus-byte-compile'." :type 'boolean :version "21.1" @@ -1348,10 +1321,10 @@ CHOICE is a list of the choice char and help message at IDX." (save-window-excursion (save-excursion (while (not tchar) - (message "%s (%s?): " + (message "%s (%s): " prompt (mapconcat (lambda (s) (char-to-string (car s))) - choice "")) + choice ", ")) (setq tchar (read-char)) (when (not (assq tchar choice)) (setq tchar nil) @@ -1392,6 +1365,86 @@ CHOICE is a list of the choice char and help message at IDX." (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 (or (not (boundp 'focus-follows-mouse)) + (symbol-value 'focus-follows-mouse)) + (set-mouse-position frame (1- (frame-width frame)) 0))))) + +(unless (fboundp 'frame-parameter) + (defalias 'frame-parameter + (lambda (frame parameter) + "Return FRAME's value for parameter PARAMETER. +If FRAME is nil, describe the currently selected frame." + (cdr (assq parameter (frame-parameters frame)))))) + +(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