;;; gnus-util.el --- utility functions for Gnus
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
(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"))
(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
(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 ") ")
(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
(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
+ (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
(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))))
"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)))
(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 "<[^<]+\\'" references)
+ (match-string 0 references)))))
(defun gnus-buffer-live-p (buffer)
"Say whether BUFFER is alive or not."
(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.
;; 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 ()
(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."
(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
(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))))))
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))))
+
(provide 'gnus-util)
;;; gnus-util.el ends here
projects / gnus / blobdiff