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

   1 ;;; gnus-util.el --- utility functions for Gnus
   2 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004
   3 ;;        Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;; Keywords: news
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; Nothing in this file depends on any other parts of Gnus -- all
  28 ;; functions and macros in this file are utility functions that are
  29 ;; used by Gnus and may be used by any other package without loading
  30 ;; Gnus first.
  31
  32 ;; [Unfortunately, it does depend on other parts of Gnus, e.g. the
  33 ;; autoloads and defvars below...]
  34
  35 ;;; Code:
  36
  37 (eval-when-compile
  38   (require 'cl)
  39   ;; Fixme: this should be a gnus variable, not nnmail-.
  40   (defvar nnmail-pathname-coding-system)
  41
  42   ;; Inappropriate references to other parts of Gnus.
  43   (defvar gnus-emphasize-whitespace-regexp)
  44   )
  45 (require 'time-date)
  46 (require 'netrc)
  47
  48 (eval-and-compile
  49   (autoload 'message-fetch-field "message")
  50   (autoload 'gnus-get-buffer-window "gnus-win")
  51   (autoload 'rmail-insert-rmail-file-header "rmail")
  52   (autoload 'rmail-count-new-messages "rmail")
  53   (autoload 'rmail-show-message "rmail")
  54   (autoload 'nnheader-narrow-to-headers "nnheader")
  55   (autoload 'nnheader-replace-chars-in-string "nnheader"))
  56
  57 (eval-and-compile
  58   (cond
  59    ((fboundp 'replace-in-string)
  60     (defalias 'gnus-replace-in-string 'replace-in-string))
  61    ((fboundp 'replace-regexp-in-string)
  62     (defun gnus-replace-in-string  (string regexp newtext &optional literal)
  63       "Replace all matches for REGEXP with NEWTEXT in STRING.
  64 If LITERAL is non-nil, insert NEWTEXT literally.  Return a new
  65 string containing the replacements.
  66
  67 This is a compatibility function for different Emacsen."
  68       (replace-regexp-in-string regexp newtext string nil literal)))))
  69
  70 (defun gnus-boundp (variable)
  71   "Return non-nil if VARIABLE is bound and non-nil."
  72   (and (boundp variable)
  73        (symbol-value variable)))
  74
  75 (defmacro gnus-eval-in-buffer-window (buffer &rest forms)
  76   "Pop to BUFFER, evaluate FORMS, and then return to the original window."
  77   (let ((tempvar (make-symbol "GnusStartBufferWindow"))
  78         (w (make-symbol "w"))
  79         (buf (make-symbol "buf")))
  80     `(let* ((,tempvar (selected-window))
  81             (,buf ,buffer)
  82             (,w (gnus-get-buffer-window ,buf 'visible)))
  83        (unwind-protect
  84            (progn
  85              (if ,w
  86                  (progn
  87                    (select-window ,w)
  88                    (set-buffer (window-buffer ,w)))
  89                (pop-to-buffer ,buf))
  90              ,@forms)
  91          (select-window ,tempvar)))))
  92
  93 (put 'gnus-eval-in-buffer-window 'lisp-indent-function 1)
  94 (put 'gnus-eval-in-buffer-window 'edebug-form-spec '(form body))
  95
  96 (defmacro gnus-intern-safe (string hashtable)
  97   "Set hash value.  Arguments are STRING, VALUE, and HASHTABLE."
  98   `(let ((symbol (intern ,string ,hashtable)))
  99      (or (boundp symbol)
 100          (set symbol nil))
 101      symbol))
 102
 103 ;; Added by Geoffrey T. Dairiki <dairiki@u.washington.edu>.  A safe way
 104 ;; to limit the length of a string.  This function is necessary since
 105 ;; `(substr "abc" 0 30)' pukes with "Args out of range".
 106 ;; Fixme: Why not `truncate-string-to-width'?
 107 (defsubst gnus-limit-string (str width)
 108   (if (> (length str) width)
 109       (substring str 0 width)
 110     str))
 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     (when (string-match "\\b[^@ \t<>]+[!@][^@ \t<>]+\\b" from)
 168       (setq address (substring from (match-beginning 0) (match-end 0))))
 169     ;; Then we check whether the "name <address>" format is used.
 170     (and address
 171          ;; Linear white space is not required.
 172          (string-match (concat "[ \t]*<" (regexp-quote address) ">") from)
 173          (and (setq name (substring from 0 (match-beginning 0)))
 174               ;; Strip any quotes from the name.
 175               (string-match "^\".*\"$" name)
 176               (setq name (substring name 1 (1- (match-end 0))))))
 177     ;; If not, then "address (name)" is used.
 178     (or name
 179         (and (string-match "(.+)" from)
 180              (setq name (substring from (1+ (match-beginning 0))
 181                                    (1- (match-end 0)))))
 182         (and (string-match "()" from)
 183              (setq name address))
 184         ;; XOVER might not support folded From headers.
 185         (and (string-match "(.*" from)
 186              (setq name (substring from (1+ (match-beginning 0))
 187                                    (match-end 0)))))
 188     (list (if (string= name "") nil name) (or address from))))
 189
 190
 191 (defun gnus-fetch-field (field)
 192   "Return the value of the header FIELD of current article."
 193   (save-excursion
 194     (save-restriction
 195       (let ((inhibit-point-motion-hooks t))
 196         (nnheader-narrow-to-headers)
 197         (message-fetch-field field)))))
 198
 199 (defun gnus-fetch-original-field (field)
 200   "Fetch FIELD from the original version of the current article."
 201   (with-current-buffer gnus-original-article-buffer
 202     (gnus-fetch-field field)))
 203
 204
 205 (defun gnus-goto-colon ()
 206   (beginning-of-line)
 207   (let ((eol (point-at-eol)))
 208     (goto-char (or (text-property-any (point) eol 'gnus-position t)
 209                    (search-forward ":" eol t)
 210                    (point)))))
 211
 212 (defun gnus-decode-newsgroups (newsgroups group &optional method)
 213   (let ((method (or method (gnus-find-method-for-group group))))
 214     (mapconcat (lambda (group)
 215                  (gnus-group-name-decode group (gnus-group-name-charset
 216                                                 method group)))
 217                (message-tokenize-header newsgroups)
 218                ",")))
 219
 220 (defun gnus-remove-text-with-property (prop)
 221   "Delete all text in the current buffer with text property PROP."
 222   (let ((start (point-min))
 223         end)
 224     (unless (get-text-property start prop)
 225       (setq start (next-single-property-change start prop)))
 226     (while start
 227       (setq end (text-property-any start (point-max) prop nil))
 228       (delete-region start (or end (point-max)))
 229       (setq start (when end
 230                     (next-single-property-change start prop))))))
 231
 232 (defun gnus-newsgroup-directory-form (newsgroup)
 233   "Make hierarchical directory name from NEWSGROUP name."
 234   (let* ((newsgroup (gnus-newsgroup-savable-name newsgroup))
 235          (idx (string-match ":" newsgroup)))
 236     (concat
 237      (if idx (substring newsgroup 0 idx))
 238      (if idx "/")
 239      (nnheader-replace-chars-in-string
 240       (if idx (substring newsgroup (1+ idx)) newsgroup)
 241       ?. ?/))))
 242
 243 (defun gnus-newsgroup-savable-name (group)
 244   ;; Replace any slashes in a group name (eg. an ange-ftp nndoc group)
 245   ;; with dots.
 246   (nnheader-replace-chars-in-string group ?/ ?.))
 247
 248 (defun gnus-string> (s1 s2)
 249   (not (or (string< s1 s2)
 250            (string= s1 s2))))
 251
 252 ;;; Time functions.
 253
 254 (defun gnus-file-newer-than (file date)
 255   (let ((fdate (nth 5 (file-attributes file))))
 256     (or (> (car fdate) (car date))
 257         (and (= (car fdate) (car date))
 258              (> (nth 1 fdate) (nth 1 date))))))
 259
 260 ;;; Keymap macros.
 261
 262 (defmacro gnus-local-set-keys (&rest plist)
 263   "Set the keys in PLIST in the current keymap."
 264   `(gnus-define-keys-1 (current-local-map) ',plist))
 265
 266 (defmacro gnus-define-keys (keymap &rest plist)
 267   "Define all keys in PLIST in KEYMAP."
 268   `(gnus-define-keys-1 (quote ,keymap) (quote ,plist)))
 269
 270 (defmacro gnus-define-keys-safe (keymap &rest plist)
 271   "Define all keys in PLIST in KEYMAP without overwriting previous definitions."
 272   `(gnus-define-keys-1 (quote ,keymap) (quote ,plist) t))
 273
 274 (put 'gnus-define-keys 'lisp-indent-function 1)
 275 (put 'gnus-define-keys-safe 'lisp-indent-function 1)
 276 (put 'gnus-local-set-keys 'lisp-indent-function 1)
 277
 278 (defmacro gnus-define-keymap (keymap &rest plist)
 279   "Define all keys in PLIST in KEYMAP."
 280   `(gnus-define-keys-1 ,keymap (quote ,plist)))
 281
 282 (put 'gnus-define-keymap 'lisp-indent-function 1)
 283
 284 (defun gnus-define-keys-1 (keymap plist &optional safe)
 285   (when (null keymap)
 286     (error "Can't set keys in a null keymap"))
 287   (cond ((symbolp keymap)
 288          (setq keymap (symbol-value keymap)))
 289         ((keymapp keymap))
 290         ((listp keymap)
 291          (set (car keymap) nil)
 292          (define-prefix-command (car keymap))
 293          (define-key (symbol-value (caddr keymap)) (cadr keymap) (car keymap))
 294          (setq keymap (symbol-value (car keymap)))))
 295   (let (key)
 296     (while plist
 297       (when (symbolp (setq key (pop plist)))
 298         (setq key (symbol-value key)))
 299       (if (or (not safe)
 300               (eq (lookup-key keymap key) 'undefined))
 301           (define-key keymap key (pop plist))
 302         (pop plist)))))
 303
 304 (defun gnus-completing-read-with-default (default prompt &rest args)
 305   ;; Like `completing-read', except that DEFAULT is the default argument.
 306   (let* ((prompt (if default
 307                      (concat prompt " (default " default ") ")
 308                    (concat prompt " ")))
 309          (answer (apply 'completing-read prompt args)))
 310     (if (or (null answer) (zerop (length answer)))
 311         default
 312       answer)))
 313
 314 ;; Two silly functions to ensure that all `y-or-n-p' questions clear
 315 ;; the echo area.
 316 (defun gnus-y-or-n-p (prompt)
 317   (prog1
 318       (y-or-n-p prompt)
 319     (message "")))
 320
 321 (defun gnus-yes-or-no-p (prompt)
 322   (prog1
 323       (yes-or-no-p prompt)
 324     (message "")))
 325
 326 ;; By Frank Schmitt <ich@Frank-Schmitt.net>. Allows to have
 327 ;; age-depending date representations. (e.g. just the time if it's
 328 ;; from today, the day of the week if it's within the last 7 days and
 329 ;; the full date if it's older)
 330
 331 (defun gnus-seconds-today ()
 332   "Return the number of seconds passed today."
 333   (let ((now (decode-time (current-time))))
 334     (+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600))))
 335
 336 (defun gnus-seconds-month ()
 337   "Return the number of seconds passed this month."
 338   (let ((now (decode-time (current-time))))
 339     (+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600)
 340        (* (- (car (nthcdr 3 now)) 1) 3600 24))))
 341
 342 (defun gnus-seconds-year ()
 343   "Return the number of seconds passed this year."
 344   (let ((now (decode-time (current-time)))
 345         (days (format-time-string "%j" (current-time))))
 346     (+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600)
 347        (* (- (string-to-number days) 1) 3600 24))))
 348
 349 (defvar gnus-user-date-format-alist
 350   '(((gnus-seconds-today) . "%k:%M")
 351     (604800 . "%a %k:%M")                   ;;that's one week
 352     ((gnus-seconds-month) . "%a %d")
 353     ((gnus-seconds-year) . "%b %d")
 354     (t . "%b %d '%y"))                      ;;this one is used when no
 355                                             ;;other does match