;;; gnus-util.el --- utility functions for Gnus
-;; Copyright (C) 1996,97 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001
+;; Free Software Foundation, Inc.
-;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
;; This file is part of GNU Emacs.
;;; Code:
(require 'custom)
-(eval-when-compile (require 'cl))
+(eval-when-compile
+ (require 'cl)
+ ;; Fixme: this should be a gnus variable, not nnmail-.
+ (defvar nnmail-pathname-coding-system))
(require 'nnheader)
-(require 'timezone)
-(require 'message)
+(require 'time-date)
(eval-and-compile
- (autoload 'nnmail-date-to-time "nnmail"))
+ (autoload 'message-fetch-field "message")
+ (autoload 'rmail-insert-rmail-file-header "rmail")
+ (autoload 'rmail-count-new-messages "rmail")
+ (autoload 'rmail-show-message "rmail"))
(defun gnus-boundp (variable)
"Return non-nil if VARIABLE is bound and non-nil."
(set symbol nil))
symbol))
-;; modified by MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;; function `substring' might cut on a middle of multi-octet
-;; character.
-(defun gnus-truncate-string (str width)
- (substring str 0 width))
-
;; 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".
(when (gnus-buffer-exists-p buf)
(kill-buffer buf))))
-(if (fboundp 'point-at-bol)
- (fset 'gnus-point-at-bol 'point-at-bol)
- (defun gnus-point-at-bol ()
- "Return point at the beginning of the line."
- (let ((p (point)))
- (beginning-of-line)
- (prog1
- (point)
- (goto-char p)))))
-
-(if (fboundp 'point-at-eol)
- (fset 'gnus-point-at-eol 'point-at-eol)
- (defun gnus-point-at-eol ()
- "Return point at the end of the line."
- (let ((p (point)))
- (end-of-line)
- (prog1
- (point)
- (goto-char p)))))
+(defalias 'gnus-point-at-bol
+ (if (fboundp 'point-at-bol)
+ 'point-at-bol
+ 'line-beginning-position))
+
+(defalias 'gnus-point-at-eol
+ (if (fboundp 'point-at-eol)
+ 'point-at-eol
+ 'line-end-position))
(defun gnus-delete-first (elt list)
"Delete by side effect the first occurrence of ELT as a member of LIST."
(setq address (substring from (match-beginning 0) (match-end 0))))
;; Then we check whether the "name <address>" format is used.
(and address
- ;; Fix by MORIOKA Tomohiko <morioka@jaist.ac.jp>
;; Linear white space is not required.
(string-match (concat "[ \t]*<" (regexp-quote address) ">") from)
(and (setq name (substring from 0 (match-beginning 0)))
(1- (match-end 0)))))
(and (string-match "()" from)
(setq name address))
- ;; Fix by MORIOKA Tomohiko <morioka@jaist.ac.jp>.
;; XOVER might not support folded From headers.
(and (string-match "(.*" from)
(setq name (substring from (1+ (match-beginning 0))
(match-end 0)))))
- ;; Fix by Hallvard B Furuseth <h.b.furuseth@usit.uio.no>.
- (list (or name from) (or address from))))
+ (list (if (string= name "") nil name) (or address from))))
+
(defun gnus-fetch-field (field)
"Return the value of the header FIELD of current article."
(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))
- (len (length newsgroup))
- idx)
- ;; If this is a foreign group, we don't want to translate the
- ;; entire name.
- (if (setq idx (string-match ":" newsgroup))
- (aset newsgroup idx ?/)
- (setq idx 0))
- ;; Replace all occurrences of `.' with `/'.
- (while (< idx len)
- (when (= (aref newsgroup idx) ?.)
- (aset newsgroup idx ?/))
- (setq idx (1+ idx)))
- newsgroup))
+ (let* ((newsgroup (gnus-newsgroup-savable-name newsgroup))
+ (idx (string-match ":" newsgroup)))
+ (concat
+ (if idx (substring newsgroup 0 idx))
+ (if idx "/")
+ (nnheader-replace-chars-in-string
+ (if idx (substring newsgroup (1+ idx)) newsgroup)
+ ?. ?/))))
(defun gnus-newsgroup-savable-name (group)
;; Replace any slashes in a group name (eg. an ange-ftp nndoc group)
;;; Time functions.
-(defun gnus-days-between (date1 date2)
- ;; Return the number of days between date1 and date2.
- (- (gnus-day-number date1) (gnus-day-number date2)))
-
-(defun gnus-day-number (date)
- (let ((dat (mapcar (lambda (s) (and s (string-to-int s)) )
- (timezone-parse-date date))))
- (timezone-absolute-from-gregorian
- (nth 1 dat) (nth 2 dat) (car dat))))
-
-(defun gnus-time-to-day (time)
- "Convert TIME to day number."
- (let ((tim (decode-time time)))
- (timezone-absolute-from-gregorian
- (nth 4 tim) (nth 3 tim) (nth 5 tim))))
-
-(defun gnus-encode-date (date)
- "Convert DATE to internal time."
- (let* ((parse (timezone-parse-date date))
- (date (mapcar (lambda (d) (and d (string-to-int d))) parse))
- (time (mapcar 'string-to-int (timezone-parse-time (aref parse 3)))))
- (encode-time (caddr time) (cadr time) (car time)
- (caddr date) (cadr date) (car date)
- (* 60 (timezone-zone-to-minute (nth 4 date))))))
-
-(defun gnus-time-minus (t1 t2)
- "Subtract two internal times."
- (let ((borrow (< (cadr t1) (cadr t2))))
- (list (- (car t1) (car t2) (if borrow 1 0))
- (- (+ (if borrow 65536 0) (cadr t1)) (cadr t2)))))
-
-(defun gnus-time-less (t1 t2)
- "Say whether time T1 is less than time T2."
- (or (< (car t1) (car t2))
- (and (= (car t1) (car t2))
- (< (nth 1 t1) (nth 1 t2)))))
-
(defun gnus-file-newer-than (file date)
(let ((fdate (nth 5 (file-attributes file))))
(or (> (car fdate) (car date))
(yes-or-no-p prompt)
(message "")))
-;; I suspect there's a better way, but I haven't taken the time to do
-;; it yet. -erik selberg@cs.washington.edu
(defun gnus-dd-mmm (messy-date)
- "Return a string like DD-MMM from a big messy string"
- (let ((datevec (ignore-errors (timezone-parse-date messy-date))))
- (if (not datevec)
- "??-???"
- (format "%2s-%s"
- (condition-case ()
- ;; Make sure leading zeroes are stripped.
- (number-to-string (string-to-number (aref datevec 2)))
- (error "??"))
- (capitalize
- (or (car
- (nth (1- (string-to-number (aref datevec 1)))
- timezone-months-assoc))
- "???"))))))
+ "Return a string like DD-MMM from a big messy string."
+ (condition-case ()
+ (format-time-string "%d-%b" (safe-date-to-time messy-date))
+ (error " - ")))
(defmacro gnus-date-get-time (date)
"Convert DATE string to Emacs time.
'(0 0)
(or (get-text-property 0 'gnus-time d)
;; or compute the value...
- (let ((time (nnmail-date-to-time d)))
+ (let ((time (safe-date-to-time d)))
;; and store it back in the string.
(put-text-property 0 1 'gnus-time time d)
time)))))
(defsubst gnus-time-iso8601 (time)
- "Return a string of TIME in YYMMDDTHHMMSS format."
+ "Return a string of TIME in YYYYMMDDTHHMMSS format."
(format-time-string "%Y%m%dT%H%M%S" time))
-(defun gnus-date-iso8601 (header)
- "Convert the date field in HEADER to YYMMDDTHHMMSS"
+(defun gnus-date-iso8601 (date)
+ "Convert the DATE to YYYYMMDDTHHMMSS."
(condition-case ()
- (gnus-time-iso8601 (gnus-date-get-time (mail-header-date header)))
+ (gnus-time-iso8601 (gnus-date-get-time date))
(error "")))
(defun gnus-mode-string-quote (string)
"Return a list of Message-IDs in REFERENCES."
(let ((beg 0)
ids)
- (while (string-match "<[^>]+>" references beg)
+ (while (string-match "<[^> \t]+>" references beg)
(push (substring references (match-beginning 0) (setq beg (match-end 0)))
ids))
(nreverse ids)))
-(defun gnus-parent-id (references &optional n)
+(defsubst gnus-parent-id (references &optional n)
"Return the last Message-ID in REFERENCES.
If N, return the Nth ancestor instead."
(when references
(let* ((orig (point))
(end (window-end (get-buffer-window (current-buffer) t)))
(max 0))
- ;; Find the longest line currently displayed in the window.
- (goto-char (window-start))
- (while (and (not (eobp))
- (< (point) end))
- (end-of-line)
- (setq max (max max (current-column)))
- (forward-line 1))
- (goto-char orig)
- ;; Scroll horizontally to center (sort of) the point.
- (if (> max (window-width))
- (set-window-hscroll
- (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))
- max)))
+ (when end
+ ;; Find the longest line currently displayed in the window.
+ (goto-char (window-start))
+ (while (and (not (eobp))
+ (< (point) end))
+ (end-of-line)
+ (setq max (max max (current-column)))
+ (forward-line 1))
+ (goto-char orig)
+ ;; Scroll horizontally to center (sort of) the point.
+ (if (> max (window-width))
+ (set-window-hscroll
+ (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))
+ max))))
(defun gnus-read-event-char ()
"Get the next event."
(cons (and (numberp event) event) event)))
(defun gnus-sortable-date (date)
- "Make sortable string by string-lessp from DATE.
-Timezone package is used."
- (condition-case ()
- (progn
- (setq date (inline (timezone-fix-time
- date nil
- (aref (inline (timezone-parse-date date)) 4))))
- (inline
- (timezone-make-sortable-date
- (aref date 0) (aref date 1) (aref date 2)
- (inline
- (timezone-make-time-string
- (aref date 3) (aref date 4) (aref date 5))))))
- (error "")))
+ "Make string suitable for sorting from DATE."
+ (gnus-time-iso8601 (date-to-time date)))
(defun gnus-copy-file (file &optional to)
"Copy FILE to TO."
(file-name-nondirectory file))))
(copy-file file to))
-(defun gnus-kill-all-overlays ()
- "Delete all overlays in the current buffer."
- (let* ((overlayss (overlay-lists))
- (buffer-read-only nil)
- (overlays (delq nil (nconc (car overlayss) (cdr overlayss)))))
- (while overlays
- (delete-overlay (pop overlays)))))
-
(defvar gnus-work-buffer " *gnus work*")
(defun gnus-set-work-buffer ()
(progn
(set-buffer gnus-work-buffer)
(erase-buffer))
- (set-buffer (get-buffer-create gnus-work-buffer))
+ (set-buffer (gnus-get-buffer-create gnus-work-buffer))
(kill-all-local-variables)
- (buffer-disable-undo (current-buffer))))
+ (mm-enable-multibyte)))
(defmacro gnus-group-real-name (group)
"Find the real name of a foreign newsgroup."
(defun gnus-make-sort-function (funs)
"Return a composite sort condition based on the functions in FUNC."
(cond
- ((not (listp funs)) funs)
+ ;; Just a simple function.
+ ((gnus-functionp funs) funs)
+ ;; No functions at all.
((null funs) funs)
- ((cdr funs)
+ ;; A list of functions.
+ ((or (cdr funs)
+ (listp (car funs)))
`(lambda (t1 t2)
,(gnus-make-sort-function-1 (reverse funs))))
+ ;; A list containing just one function.
(t
(car funs))))
(defun gnus-make-sort-function-1 (funs)
"Return a composite sort condition based on the functions in FUNC."
- (if (cdr funs)
- `(or (,(car funs) t1 t2)
- (and (not (,(car funs) t2 t1))
- ,(gnus-make-sort-function-1 (cdr funs))))
- `(,(car funs) t1 t2)))
+ (let ((function (car funs))
+ (first 't1)
+ (last 't2))
+ (when (consp function)
+ (cond
+ ;; Reversed spec.
+ ((eq (car function) 'not)
+ (setq function (cadr function)
+ first 't2
+ last 't1))
+ ((gnus-functionp function)
+ ;; Do nothing.
+ )
+ (t
+ (error "Invalid sort spec: %s" function))))
+ (if (cdr funs)
+ `(or (,function ,first ,last)
+ (and (not (,function ,last ,first))
+ ,(gnus-make-sort-function-1 (cdr funs))))
+ `(,function ,first ,last))))
(defun gnus-turn-off-edit-menu (type)
"Turn off edit menu in `gnus-TYPE-mode-map'."
Bind `print-quoted' and `print-readably' to t while printing."
(let ((print-quoted t)
(print-readably t)
+ (print-escape-multibyte nil)
print-level print-length)
(prin1 form (current-buffer))))
(defun gnus-make-directory (directory)
"Make DIRECTORY (and all its parents) if it doesn't exist."
- (when (and directory
- (not (file-exists-p directory)))
- (make-directory directory t))
+ (require 'nnmail)
+ (let ((file-name-coding-system nnmail-pathname-coding-system))
+ (when (and directory
+ (not (file-exists-p directory)))
+ (make-directory directory t)))
t)
(defun gnus-write-buffer (file)
"Write the current buffer's contents to FILE."
;; Make sure the directory exists.
(gnus-make-directory (file-name-directory file))
- ;; Write the buffer.
- (write-region (point-min) (point-max) file nil 'quietly))
-
-(defmacro gnus-delete-assq (key list)
- `(let ((listval (eval ,list)))
- (setq ,list (delq (assq ,key listval) listval))))
-
-(defmacro gnus-delete-assoc (key list)
- `(let ((listval ,list))
- (setq ,list (delq (assoc ,key listval) listval))))
+ (let ((file-name-coding-system nnmail-pathname-coding-system))
+ ;; Write the buffer.
+ (write-region (point-min) (point-max) file nil 'quietly)))
(defun gnus-delete-file (file)
"Delete FILE if it exists."
(setq string (replace-match "" t t string)))
string)
-(defun gnus-put-text-property-excluding-newlines (beg end prop val)
+(defsubst gnus-put-text-property-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 "[ \t]*\n" end 'move)
- (put-text-property beg (match-beginning 0) prop val)
+ (while (re-search-forward gnus-emphasize-whitespace-regexp end 'move)
+ (gnus-put-text-property beg (match-beginning 0) prop val)
(setq beg (point)))
- (put-text-property beg (point) prop val)))))
+ (gnus-put-text-property 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."
+ (let ((b beg))
+ (while (/= b end)
+ (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)))))
;;; Protected and atomic operations. dmoore@ucsd.edu 21.11.1996
;;; The primary idea here is to try to protect internal datastructures
(save-excursion
(set-buffer file-buffer)
(rmail-insert-rmail-file-header)
- (let ((require-final-newline nil))
+ (let ((require-final-newline nil)
+ (coding-system-for-write mm-text-coding-system))
(gnus-write-buffer filename)))
(kill-buffer file-buffer))
(error "Output file does not exist")))
;; Decide whether to append to a file or to an Emacs buffer.
(let ((outbuf (get-file-buffer filename)))
(if (not outbuf)
- (append-to-file (point-min) (point-max) filename)
+ (mm-append-to-file (point-min) (point-max) filename)
;; File has been visited, in buffer OUTBUF.
(set-buffer outbuf)
(let ((buffer-read-only nil)
(when msg
(goto-char (point-min))
(widen)
- (search-backward "\^_")
- (narrow-to-region (point) (point-max))
- (goto-char (1+ (point-min)))
+ (search-backward "\n\^_")
+ (narrow-to-region (point) (point-max))
+ (rmail-count-new-messages t)
+ (when (rmail-summary-exists)
+ (rmail-select-summary
+ (rmail-update-summary)))
(rmail-count-new-messages t)
- (rmail-show-message msg))))))
+ (rmail-show-message msg))
+ (save-buffer)))))
(kill-buffer tmpbuf)))
(defun gnus-output-to-mail (filename &optional ask)
(let ((file-buffer (create-file-buffer filename)))
(save-excursion
(set-buffer file-buffer)
- (let ((require-final-newline nil))
+ (let ((require-final-newline nil)
+ (coding-system-for-write mm-text-coding-system))
(gnus-write-buffer filename)))
(kill-buffer file-buffer))
(error "Output file does not exist")))
(insert "\n"))
(insert "\n"))
(goto-char (point-max))
- (append-to-file (point-min) (point-max) filename)))
+ (mm-append-to-file (point-min) (point-max) filename)))
;; File has been visited, in buffer OUTBUF.
(set-buffer outbuf)
(let ((buffer-read-only nil))
(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)
- (myarg arg))
+ (let ((myfuns funs))
(while myfuns
(setq arg (funcall (pop myfuns) 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)))
+
+;;; Various
+
+(defvar gnus-group-buffer) ; Compiler directive
+(defun gnus-alive-p ()
+ "Say whether Gnus is running or not."
+ (and (boundp 'gnus-group-buffer)
+ (get-buffer gnus-group-buffer)
+ (save-excursion
+ (set-buffer gnus-group-buffer)
+ (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)))
+ (nreverse new)))
+
+(defun gnus-delete-if (predicate list)
+ "Delete elements from LIST that satisfy PREDICATE."
+ (let (out)
+ (while list
+ (unless (funcall predicate (car list))
+ (push (car list) out))
+ (pop list))
+ (nreverse out)))
+
+(if (fboundp 'assq-delete-all)
+ (defalias 'gnus-delete-alist 'assq-delete-all)
+ (defun gnus-delete-alist (key alist)
+ "Delete from ALIST all elements whose car is KEY.
+Return the modified alist."
+ (let (entry)
+ (while (setq entry (assq key alist))
+ (setq alist (delq entry alist)))
+ alist)))
+
+(defmacro gnus-pull (key alist &optional assoc-p)
+ "Modify ALIST to be without KEY."
+ (unless (symbolp alist)
+ (error "Not a symbol: %s" alist))
+ (let ((fun (if assoc-p 'assoc 'assq)))
+ `(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."
+ (concat (unless (string-match "^\\^" re) "^.*")
+ re
+ (unless (string-match "\\$$" re) ".*$")))
+
+(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)))
+ (when win
+ (set-window-start win (or point (point))))))
+
+(defun gnus-annotation-in-region-p (b e)
+ (if (= b e)
+ (eq (cadr (memq 'gnus-undeletable (text-properties-at b))) t)
+ (text-property-any b e 'gnus-undeletable t)))
+
+(defun gnus-or (&rest elems)
+ "Return non-nil if any of the elements are non-nil."
+ (catch 'found
+ (while elems
+ (when (pop elems)
+ (throw 'found t)))))
+
+(defun gnus-and (&rest elems)
+ "Return non-nil if all of the elements are non-nil."
+ (catch 'found
+ (while elems
+ (unless (pop elems)
+ (throw 'found nil)))
+ t))
+
+(defun gnus-write-active-file (file hashtb &optional full-names)
+ (let ((coding-system-for-write nnmail-active-file-coding-system))
+ (with-temp-file file
+ (mapatoms
+ (lambda (sym)
+ (when (and sym
+ (boundp sym)
+ (symbol-value sym))
+ (insert (format "%S %d %d y\n"
+ (if full-names
+ sym
+ (intern (gnus-group-real-name (symbol-name sym))))
+ (or (cdr (symbol-value sym))
+ (car (symbol-value sym)))
+ (car (symbol-value sym))))))
+ hashtb)
+ (goto-char (point-max))
+ (while (search-backward "\\." nil t)
+ (delete-char 1)))))
+
+(if (fboundp 'union)
+ (defalias 'gnus-union 'union)
+ (defun gnus-union (l1 l2)
+ "Set union of lists L1 and L2."
+ (cond ((null l1) l2)
+ ((null l2) l1)
+ ((equal l1 l2) l1)
+ (t
+ (or (>= (length l1) (length l2))
+ (setq l1 (prog1 l2 (setq l2 l1))))
+ (while l2
+ (or (member (car l2) l1)
+ (push (car l2) l1))
+ (pop l2))
+ l1))))
+
+(defun gnus-add-text-properties-when
+ (property value start end properties &optional object)
+ "Like `gnus-add-text-properties', only applied on where PROPERTY is VALUE."
+ (let (point)
+ (while (and start
+ (< start end) ;; XEmacs will loop for every when start=end.
+ (setq point (text-property-not-all start end property value)))
+ (gnus-add-text-properties start point properties object)
+ (setq start (text-property-any point end property value)))
+ (if start
+ (gnus-add-text-properties start end properties object))))
+
+(defun gnus-remove-text-properties-when
+ (property value start end properties &optional object)
+ "Like `remove-text-properties', only applied on where PROPERTY is VALUE."
+ (let (point)
+ (while (and start
+ (< start end)
+ (setq point (text-property-not-all start end property value)))
+ (remove-text-properties start point properties object)
+ (setq start (text-property-any point end property value)))
+ (if start
+ (remove-text-properties start end properties object))
+ t))
+
+(defun gnus-string-equal (x y)
+ "Like `string-equal', except it compares case-insensitively."
+ (and (= (length x) (length y))
+ (or (string-equal x y)
+ (string-equal (downcase x) (downcase y)))))
+
(provide 'gnus-util)
;;; gnus-util.el ends here
projects / elisp / gnus.git- / blobdiff