cgit.sxemacs.org Git - gnus/blob - lisp/gnus-util.el

   1 ;;; gnus-util.el --- utility functions for Gnus
   2
   3 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
   4 ;;   2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
   5
   6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   7 ;; Keywords: news
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;; Nothing in this file depends on any other parts of Gnus -- all
  27 ;; functions and macros in this file are utility functions that are
  28 ;; used by Gnus and may be used by any other package without loading
  29 ;; Gnus first.
  30
  31 ;; [Unfortunately, it does depend on other parts of Gnus, e.g. the
  32 ;; autoloads and defvars below...]
  33
  34 ;;; Code:
  35
  36 ;; For Emacs < 22.2.
  37 (eval-and-compile
  38   (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
  39 (eval-when-compile
  40   (require 'cl))
  41
  42 (eval-when-compile
  43   (unless (fboundp 'with-no-warnings)
  44     (defmacro with-no-warnings (&rest body)
  45       `(progn ,@body))))
  46
  47 ;; Fixme: this should be a gnus variable, not nnmail-.
  48 (defvar nnmail-pathname-coding-system)
  49 (defvar nnmail-active-file-coding-system)
  50
  51 ;; Inappropriate references to other parts of Gnus.
  52 (defvar gnus-emphasize-whitespace-regexp)
  53 (defvar gnus-original-article-buffer)
  54 (defvar gnus-user-agent)
  55
  56 (autoload 'gnus-get-buffer-window "gnus-win")
  57 (autoload 'nnheader-narrow-to-headers "nnheader")
  58 (autoload 'nnheader-replace-chars-in-string "nnheader")
  59 (autoload 'mail-header-remove-comments "mail-parse")
  60
  61 (eval-and-compile
  62   (cond
  63    ;; Prefer `replace-regexp-in-string' (present in Emacs, XEmacs 21.5,
  64    ;; SXEmacs 22.1.4) over `replace-in-string'.  The latter leads to inf-loops
  65    ;; on empty matches:
  66    ;;   (replace-in-string "foo" "/*$" "/")
  67    ;;   (replace-in-string "xe" "\\(x\\)?" "")
  68    ((fboundp 'replace-regexp-in-string)
  69     (defun gnus-replace-in-string  (string regexp newtext &optional literal)
  70       "Replace all matches for REGEXP with NEWTEXT in STRING.
  71 If LITERAL is non-nil, insert NEWTEXT literally.  Return a new
  72 string containing the replacements.
  73
  74 This is a compatibility function for different Emacsen."
  75       (replace-regexp-in-string regexp newtext string nil literal)))
  76    ((fboundp 'replace-in-string)
  77     (defalias 'gnus-replace-in-string 'replace-in-string))))
  78
  79 (defun gnus-boundp (variable)
  80   "Return non-nil if VARIABLE is bound and non-nil."
  81   (and (boundp variable)
  82        (symbol-value variable)))
  83
  84 (defmacro gnus-eval-in-buffer-window (buffer &rest forms)
  85   "Pop to BUFFER, evaluate FORMS, and then return to the original window."
  86   (let ((tempvar (make-symbol "GnusStartBufferWindow"))
  87         (w (make-symbol "w"))
  88         (buf (make-symbol "buf")))
  89     `(let* ((,tempvar (selected-window))
  90             (,buf ,buffer)
  91             (,w (gnus-get-buffer-window ,buf 'visible)))
  92        (unwind-protect
  93            (progn
  94              (if ,w
  95                  (progn
  96                    (select-window ,w)
  97                    (set-buffer (window-buffer ,w)))
  98                (pop-to-buffer ,buf))
  99              ,@forms)
 100          (select-window ,tempvar)))))
 101
 102 (put 'gnus-eval-in-buffer-window 'lisp-indent-function 1)
 103 (put 'gnus-eval-in-buffer-window 'edebug-form-spec '(form body))
 104
 105 (defmacro gnus-intern-safe (string hashtable)
 106   "Get hash value.  Arguments are STRING and HASHTABLE."
 107   `(let ((symbol (intern ,string ,hashtable)))
 108      (or (boundp symbol)
 109          (set symbol nil))
 110      symbol))
 111
 112 (defsubst gnus-goto-char (point)
 113   (and point (goto-char point)))
 114
 115 (defmacro gnus-buffer-exists-p (buffer)
 116   `(let ((buffer ,buffer))
 117      (when buffer
 118        (funcall (if (stringp buffer) 'get-buffer 'buffer-name)
 119                 buffer))))
 120
 121 ;; The LOCAL arg to `add-hook' is interpreted differently in Emacs and
 122 ;; XEmacs.  In Emacs we don't need to call `make-local-hook' first.
 123 ;; It's harmless, though, so the main purpose of this alias is to shut
 124 ;; up the byte compiler.
 125 (defalias 'gnus-make-local-hook
 126   (if (eq (get 'make-local-hook 'byte-compile)
 127           'byte-compile-obsolete)
 128       'ignore                           ; Emacs
 129     'make-local-hook))                  ; XEmacs
 130
 131 (defun gnus-delete-first (elt list)
 132   "Delete by side effect the first occurrence of ELT as a member of LIST."
 133   (if (equal (car list) elt)
 134       (cdr list)
 135     (let ((total list))
 136       (while (and (cdr list)
 137                   (not (equal (cadr list) elt)))
 138         (setq list (cdr list)))
 139       (when (cdr list)
 140         (setcdr list (cddr list)))
 141       total)))
 142
 143 ;; Delete the current line (and the next N lines).
 144 (defmacro gnus-delete-line (&optional n)
 145   `(delete-region (point-at-bol)
 146                   (progn (forward-line ,(or n 1)) (point))))
 147
 148 (defun gnus-byte-code (func)
 149   "Return a form that can be `eval'ed based on FUNC."
 150   (let ((fval (indirect-function func)))
 151     (if (byte-code-function-p fval)
 152         (let ((flist (append fval nil)))
 153           (setcar flist 'byte-code)
 154           flist)
 155       (cons 'progn (cddr fval)))))
 156
 157 (defun gnus-extract-address-components (from)
 158   "Extract address components from a From header.
 159 Given an RFC-822 address FROM, extract full name and canonical address.
 160 Returns a list of the form (FULL-NAME CANONICAL-ADDRESS).  Much more simple
 161 solution than `mail-extract-address-components', which works much better, but
 162 is slower."
 163   (let (name address)
 164     ;; First find the address - the thing with the @ in it.  This may
 165     ;; not be accurate in mail addresses, but does the trick most of
 166     ;; the time in news messages.
 167     (cond (;; Check ``<foo@bar>'' first in order to handle the quite common
 168            ;; form ``"abc@xyz" <foo@bar>'' (i.e. ``@'' as part of a comment)
 169            ;; correctly.
 170            (string-match "<\\([^@ \t<>]+[!@][^@ \t<>]+\\)>" from)
 171            (setq address (substring from (match-beginning 1) (match-end 1))))
 172           ((string-match "\\b[^@ \t<>]+[!@][^@ \t<>]+\\b" from)
 173            (setq address (substring from (match-beginning 0) (match-end 0)))))
 174     ;; Then we check whether the "name <address>" format is used.
 175     (and address
 176          ;; Linear white space is not required.
 177          (string-match (concat "[ \t]*<" (regexp-quote address) ">") from)
 178          (and (setq name (substring from 0 (match-beginning 0)))
 179               ;; Strip any quotes from the name.
 180               (string-match "^\".*\"$" name)
 181               (setq name (substring name 1 (1- (match-end 0))))))
 182     ;; If not, then "address (name)" is used.
 183     (or name
 184         (and (string-match "(.+)" from)
 185              (setq name (substring from (1+ (match-beginning 0))
 186                                    (1- (match-end 0)))))
 187         (and (string-match "()" from)
 188              (setq name address))
 189         ;; XOVER might not support folded From headers.
 190         (and (string-match "(.*" from)
 191              (setq name (substring from (1+ (match-beginning 0))
 192                                    (match-end 0)))))
 193     (list (if (string= name "") nil name) (or address from))))
 194
 195 (defun gnus-extract-address-component-name (from)
 196   "Extract name from a From header.
 197 Uses `gnus-extract-address-components'."
 198   (nth 0 (gnus-extract-address-components from)))
 199
 200 (defun gnus-extract-address-component-email (from)
 201   "Extract e-mail address from a From header.
 202 Uses `gnus-extract-address-components'."
 203   (nth 1 (gnus-extract-address-components from)))
 204
 205 (declare-function message-fetch-field "message" (header &optional not-all))
 206
 207 (defun gnus-fetch-field (field)
 208   "Return the value of the header FIELD of current article."
 209   (require 'message)
 210   (save-excursion
 211     (save-restriction
 212       (let ((inhibit-point-motion-hooks t))
 213         (nnheader-narrow-to-headers)
 214         (message-fetch-field field)))))
 215
 216 (defun gnus-fetch-original-field (field)
 217   "Fetch FIELD from the original version of the current article."
 218   (with-current-buffer gnus-original-article-buffer
 219     (gnus-fetch-field field)))
 220
 221
 222 (defun gnus-goto-colon ()
 223   (beginning-of-line)
 224   (let ((eol (point-at-eol)))
 225     (goto-char (or (text-property-any (point) eol 'gnus-position t)
 226                    (search-forward ":" eol t)
 227                    (point)))))
 228
 229 (declare-function gnus-find-method-for-group "gnus" (group &optional info))
 230 (declare-function gnus-group-name-decode "gnus-group" (string charset))
 231 (declare-function gnus-group-name-charset "gnus-group" (method group))
 232 ;; gnus-group requires gnus-int which requires message.
 233 (declare-function message-tokenize-header "message"
 234                   (header &optional separator))
 235
 236 (defun gnus-decode-newsgroups (newsgroups group &optional method)
 237   (require 'gnus-group)
 238   (let ((method (or method (gnus-find-method-for-group group))))
 239     (mapconcat (lambda (group)
 240                  (gnus-group-name-decode group (gnus-group-name-charset
 241                                                 method group)))
 242                (message-tokenize-header newsgroups)
 243                ",")))
 244
 245 (defun gnus-remove-text-with-property (prop)
 246   "Delete all text in the current buffer with text property PROP."
 247   (let ((start (point-min))
 248         end)
 249     (unless (get-text-property start prop)
 250       (setq start (next-single-property-change start prop)))
 251     (while start
 252       (setq end (text-property-any start (point-max) prop nil))
 253       (delete-region start (or end (point-max)))
 254       (setq start (when end
 255                     (next-single-property-change start prop))))))
 256
 257 (defun gnus-newsgroup-directory-form (newsgroup)
 258   "Make hierarchical directory name from NEWSGROUP name."
 259   (let* ((newsgroup (gnus-newsgroup-savable-name newsgroup))
 260          (idx (string-match ":" newsgroup)))
 261     (concat
 262      (if idx (substring newsgroup 0 idx))
 263      (if idx "/")
 264      (nnheader-replace-chars-in-string
 265       (if idx (substring newsgroup (1+ idx)) newsgroup)
 266       ?. ?/))))
 267
 268 (defun gnus-newsgroup-savable-name (group)
 269   ;; Replace any slashes in a group name (eg. an ange-ftp nndoc group)
 270   ;; with dots.
 271   (nnheader-replace-chars-in-string group ?/ ?.))
 272
 273 (defun gnus-string> (s1 s2)
 274   (not (or (string< s1 s2)
 275            (string= s1 s2))))
 276
 277 (defun gnus-string< (s1 s2)
 278   "Return t if first arg string is less than second in lexicographic order.
 279 Case is significant if and only if `case-fold-search' is nil.
 280 Symbols are also allowed; their print names are used instead."
 281   (if case-fold-search
 282       (string-lessp (downcase (if (symbolp s1) (symbol-name s1) s1))
 283                     (downcase (if (symbolp s2) (symbol-name s2) s2)))
 284     (string-lessp s1 s2)))
 285
 286 ;;; Time functions.
 287
 288 (defun gnus-file-newer-than (file date)
 289   (let ((fdate (nth 5 (file-attributes file))))
 290     (or (> (car fdate) (car date))
 291         (and (= (car fdate) (car date))
 292              (> (nth 1 fdate) (nth 1 date))))))
 293
 294 (eval-and-compile
 295   (if (and (fboundp 'float-time)
 296            (subrp (symbol-function 'float-time)))
 297       (defalias 'gnus-float-time 'float-time)
 298     (defun gnus-float-time (&optional time)
 299       "Convert time value TIME to a floating point number.
 300 TIME defaults to the current time."
 301       (with-no-warnings (time-to-seconds (or time (current-time)))))))
 302
 303 ;;; Keymap macros.
 304
 305 (defmacro gnus-local-set-keys (&rest plist)
 306   "Set the keys in PLIST in the current keymap."
 307   `(gnus-define-keys-1 (current-local-map) ',plist))
 308
 309 (defmacro gnus-define-keys (keymap &rest plist)
 310   "Define all keys in PLIST in KEYMAP."
 311   `(gnus-define-keys-1 (quote ,keymap) (quote ,plist)))
 312
 313 (defmacro gnus-define-keys-safe (keymap &rest plist)
 314   "Define all keys in PLIST in KEYMAP without overwriting previous definitions."
 315   `(gnus-define-keys-1 (quote ,keymap) (quote ,plist) t))
 316
 317 (put 'gnus-define-keys 'lisp-indent-function 1)
 318 (put 'gnus-define-keys-safe 'lisp-indent-function 1)
 319 (put 'gnus-local-set-keys 'lisp-indent-function 1)
 320
 321 (defmacro gnus-define-keymap (keymap &rest plist)
 322   "Define all keys in PLIST in KEYMAP."
 323   `(gnus-define-keys-1 ,keymap (quote ,plist)))
 324
 325 (put 'gnus-define-keymap 'lisp-indent-function 1)
 326