;;; 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 <larsi@gnus.org>
(require 'custom)
(require 'nnheader)
(require 'time-date)
+(require 'netrc)
(eval-and-compile
(autoload 'message-fetch-field "message")
(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)
(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))
;; 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)
(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)))
((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.
(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)))
(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)
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
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)
(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
(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)
(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)
(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"
(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)
(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
projects / elisp / gnus.git- / blobdiff