;; used by Gnus and may be used by any other package without loading
;; Gnus first.
+;; [Unfortunately, it does depend on other parts of Gnus, e.g. the
+;; autoloads below...]
+
;;; Code:
(require 'custom)
(require 'cl)
;; Fixme: this should be a gnus variable, not nnmail-.
(defvar nnmail-pathname-coding-system))
-(require 'nnheader)
(require 'time-date)
(require 'netrc)
(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"))
+ (autoload 'rmail-show-message "rmail")
+ (autoload 'nnheader-narrow-to-headers "nnheader")
+ (autoload 'nnheader-replace-chars-in-string "nnheader"))
(eval-and-compile
(cond
;; Added by Geoffrey T. Dairiki <dairiki@u.washington.edu>. A safe way
;; to limit the length of a string. This function is necessary since
;; `(substr "abc" 0 30)' pukes with "Args out of range".
+;; Fixme: Why not `truncate-string-to-width'?
(defsubst gnus-limit-string (str width)
(if (> (length str) width)
(substring str 0 width)
str))
-(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)))
-
(defsubst gnus-goto-char (point)
(and point (goto-char point)))
'point-at-eol
'line-end-position))
+;; The LOCAL arg to `add-hook' is interpreted differently in Emacs and
+;; XEmacs. In Emacs we don't need to call `make-local-hook' first.
+;; It's harmless, though, so the main purpose of this alias is to shut
+;; up the byte compiler.
+(defalias 'gnus-make-local-hook
+ (if (eq (get 'make-local-hook 'byte-compile)
+ 'byte-compile-obsolete)
+ 'ignore ; Emacs
+ 'make-local-hook)) ; XEmacs
+
(defun gnus-delete-first (elt list)
"Delete by side effect the first occurrence of ELT as a member of LIST."
(if (equal (car list) elt)
;; 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)
(cons 'progn (cddr fval)))))
(defun gnus-extract-address-components (from)
+ "Extract address components from a From header.
+Given an RFC-822 address FROM, extract full name and canonical address.
+Returns a list of the form (FULL-NAME CANONICAL-ADDRESS). Much more simple
+solution than `mail-extract-address-components', which works much better, but
+is slower."
(let (name address)
;; First find the address - the thing with the @ in it. This may
;; not be accurate in mail addresses, but does the trick most of
(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)))
(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))
;; 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"
+ "Return 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"
+ "Return 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"
+ "Return 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)
respectively.")
(defun gnus-user-date (messy-date)
- "Format the messy-date acording to gnus-user-date-format-alist.
+ "Format the messy-date according 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))
+ (let* ((messy-date (time-to-seconds (safe-date-to-time messy-date)))
+ (now (time-to-seconds (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))
+ (my-format "%b %d '%y"))
+ (let* ((difference (- now 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) (seconds-to-time 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."
:group 'gnus-start
:type 'integer)
-;; 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.
(defun gnus-message (level &rest args)
+ "If LEVEL is lower than `gnus-verbose' print ARGS using `message'.
+
+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."
(if (<= level gnus-verbose)
(apply 'message args)
;; We have to do this format thingy here even if the result isn't
gname)))
(defun gnus-make-sort-function (funs)
- "Return a composite sort condition based on the functions in FUNC."
+ "Return a composite sort condition based on the functions in FUNS."
(cond
;; Just a simple function.
- ((gnus-functionp funs) funs)
+ ((functionp funs) funs)
;; No functions at all.
((null funs) funs)
;; A list of functions.
(car funs))))
(defun gnus-make-sort-function-1 (funs)
- "Return a composite sort condition based on the functions in FUNC."
+ "Return a composite sort condition based on the functions in FUNS."
(let ((function (car funs))
(first 't1)
(last 't2))
(setq function (cadr function)
first 't2
last 't1))
- ((gnus-functionp function)
+ ((functionp function)
;; Do nothing.
)
(t
;;; Functions for saving to babyl/mail files.
-(defvar rmail-default-rmail-file)
+(eval-when-compile
+ (defvar rmail-default-rmail-file)
+ (defvar mm-text-coding-system))
+
(defun gnus-output-to-rmail (filename &optional ask)
"Append the current article to an Rmail file named FILENAME."
(require 'rmail)
+ (require 'mm-util)
;; Most of these codes are borrowed from rmailout.el.
(setq filename (expand-file-name filename))
(setq rmail-default-rmail-file filename)
(insert "\^_")))
(defun gnus-map-function (funs arg)
- "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.
ARG is passed to the first function."
(while funs
(setq arg (funcall (pop funs) arg)))
`(setq ,alist (delq (,fun ,key ,alist) ,alist))))
(defun gnus-globalify-regexp (re)
- "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."
(concat (unless (string-match "^\\^" re) "^.*")
re
(unless (string-match "\\$$" re) ".*$")))
(while (search-backward "\\." nil t)
(delete-char 1)))))
+;; Fixme: Why not use `with-output-to-temp-buffer'?
+(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"))
+ (append (make-symbol "output-buffer-append")))
+ `(let* ((,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)
+ (let ((coding-system-for-write 'no-conversion))
+ (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)
(remove-text-properties start end properties object))
t))
+;; This might use `compare-strings' to reduce consing in the
+;; case-insensitive case, but it has to cope with null args.
+;; (`string-equal' uses symbol print names.)
(defun gnus-string-equal (x y)
"Like `string-equal', except it compares case-insensitively."
(and (= (length x) (length 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'."
+ "If non-nil, byte-compile crucial run-time code.
+Setting it to nil has no effect after the first time `gnus-byte-compile'
+is run."
:type 'boolean
:version "21.1"
:group 'gnus-various)
(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)
(+ 10 (- x ?A)))
(- x ?0)))
+;; Fixme: Do it like QP.
(defun gnus-url-unhex-string (str &optional allow-newlines)
- "Remove %XXX embedded spaces, etc in a url.
+ "Remove %XX, 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)
(t
(list 'local-map map))))
+(defmacro gnus-completing-read-maybe-default (prompt table &optional predicate
+ require-match initial-contents
+ history default)
+ "Like `completing-read', allowing for non-existent 7th arg in older XEmacsen."
+ `(completing-read ,prompt ,table ,predicate ,require-match
+ ,initial-contents ,history
+ ,@(if (and (featurep 'xemacs) (< emacs-minor-version 2))
+ ()
+ (list default))))
+
(defun gnus-completing-read (prompt table &optional predicate require-match
history)
(when (and history
(not (boundp history)))
(set history nil))
- (completing-read
+ (gnus-completing-read-maybe-default
(if (symbol-value history)
(concat prompt " (" (car (symbol-value history)) "): ")
(concat prompt ": "))
(while (not tchar)
(message "%s (%s): "
prompt
- (mapconcat (lambda (s) (char-to-string (car s)))
- choice ", "))
+ (concat
+ (mapconcat (lambda (s) (char-to-string (car s)))
+ choice ", ") ", ?"))
(setq tchar (read-char))
(when (not (assq tchar choice))
(setq tchar nil)
display))
display)))))
+;; Fixme: This has only one use (in gnus-agent), which isn't worthwhile.
+(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)))
+
+(if (fboundp 'merge)
+ (defalias 'gnus-merge 'merge)
+ ;; Adapted from cl-seq.el
+ (defun gnus-merge (type list1 list2 pred)
+ "Destructively merge lists LIST1 and LIST2 to produce a new list.
+Argument TYPE is for compatibility and ignored.
+Ordering of the elements is preserved according to PRED, a `less-than'
+predicate on the elements."
+ (let ((res nil))
+ (while (and list1 list2)
+ (if (funcall pred (car list2) (car list1))
+ (push (pop list2) res)
+ (push (pop list1) res)))
+ (nconc (nreverse res) list1 list2))))
+
+(eval-when-compile
+ (defvar xemacs-codename))
+
+(defun gnus-emacs-version ()
+ (let ((system-v
+ (cond
+ ((eq gnus-user-agent 'emacs-gnus-config)
+ system-configuration)
+ ((eq gnus-user-agent 'emacs-gnus-type)
+ (symbol-name system-type))
+ (t nil))))
+ (cond
+ ((eq gnus-user-agent 'gnus)
+ nil)
+ ((string-match "^\\(\\([.0-9]+\\)*\\)\\.[0-9]+$" emacs-version)
+ (concat "Emacs/" (match-string 1 emacs-version)
+ (if system-v
+ (concat " (" system-v ")")
+ "")))
+ ((string-match
+ "\\([A-Z]*[Mm][Aa][Cc][Ss]\\)[^(]*\\(\\((beta.*)\\|'\\)\\)?"
+ emacs-version)
+ (concat
+ (match-string 1 emacs-version)
+ (format "/%d.%d" emacs-major-version emacs-minor-version)
+ (if (match-beginning 3)
+ (match-string 3 emacs-version)
+ "")
+ (if (boundp 'xemacs-codename)
+ (concat
+ " (" xemacs-codename
+ (if system-v
+ (concat ", " system-v ")")
+ ")"))
+ "")))
+ (t emacs-version))))
+
(provide 'gnus-util)
;;; gnus-util.el ends here
projects / gnus / blobdiff