mu-cite.el

   1 ;;; mu-cite.el --- yet another citation tool for GNU Emacs
   2
   3 ;; Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc.
   4
   5 ;; Author: MORIOKA Tomohiko <tomo@m17n.org>
   6 ;;         Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
   7 ;; Maintainer: Katsumi Yamaoka <yamaoka@jpl.org>
   8 ;; Keywords: mail, news, citation
   9
  10 ;; This file is part of MU (Message Utilities).
  11
  12 ;; This program is free software; you can redistribute it and/or
  13 ;; modify it under the terms of the GNU General Public License as
  14 ;; published by the Free Software Foundation; either version 2, or (at
  15 ;; your option) any later version.
  16
  17 ;; This program is distributed in the hope that it will be useful, but
  18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20 ;; General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26
  27 ;;; Commentary:
  28
  29 ;; - How to use
  30 ;;   1. bytecompile this file and copy it to the apropriate directory.
  31 ;;   2. put the following lines to your ~/.emacs:
  32 ;;      for EMACS 19 or later and XEmacs
  33 ;;              (autoload 'mu-cite-original "mu-cite" nil t)
  34 ;;              ;; for all but message-mode
  35 ;;              (add-hook 'mail-citation-hook (function mu-cite-original))
  36 ;;              ;; for message-mode only
  37 ;;              (setq message-cite-function (function mu-cite-original))
  38 ;;      for EMACS 18
  39 ;;              ;; for all but mh-e
  40 ;;              (add-hook 'mail-yank-hooks (function mu-cite-original))
  41 ;;              ;; for mh-e only
  42 ;;              (add-hook 'mh-yank-hooks (function mu-cite-original))
  43
  44 ;;; Code:
  45
  46 ;; Pickup some macros, e.g. `with-temp-buffer', for old Emacsen.
  47 (require 'poe)
  48
  49 (require 'pcustom)
  50 (require 'widget)
  51 (require 'std11)
  52 (require 'alist)
  53
  54 (autoload 'mu-cite-get-prefix-method "mu-register")
  55 (autoload 'mu-cite-get-prefix-register-method "mu-register")
  56 (autoload 'mu-cite-get-prefix-register-verbose-method "mu-register")
  57
  58 (autoload 'mu-bbdb-get-prefix-method "mu-bbdb")
  59 (autoload 'mu-bbdb-get-prefix-register-method "mu-bbdb")
  60 (autoload 'mu-bbdb-get-prefix-register-verbose-method "mu-bbdb")
  61
  62
  63 ;;; @ version
  64 ;;;
  65
  66 (defconst mu-cite-version "8.0")
  67
  68
  69 ;;; @ obsoletes
  70 ;;;
  71
  72 ;; This part will be abolished in the future.
  73
  74 (eval-when-compile (require 'static))
  75
  76 (defconst mu-cite-obsolete-variable-alist
  77   '((mu-cite/cited-prefix-regexp        mu-cite-cited-prefix-regexp)
  78     (mu-cite/default-methods-alist      mu-cite-default-methods-alist)
  79     (mu-cite/get-field-value-method-alist
  80      mu-cite-get-field-value-method-alist)
  81     (mu-cite/instantiation-hook         mu-cite-instantiation-hook)
  82     (mu-cite/ml-count-field-list        mu-cite-ml-count-field-list)
  83     (mu-cite/post-cite-hook             mu-cite-post-cite-hook)
  84     (mu-cite/pre-cite-hook              mu-cite-pre-cite-hook)
  85     (mu-cite/prefix-format              mu-cite-prefix-format)
  86     (mu-cite/top-format                 mu-cite-top-format)))
  87
  88 (static-if (featurep 'xemacs)
  89     (dolist (def mu-cite-obsolete-variable-alist)
  90       (apply (function define-obsolete-variable-alias) def)))
  91
  92 (dolist (def '((mu-cite/cite-original   mu-cite-original)
  93                (mu-cite/get-field-value mu-cite-get-field-value)
  94                (mu-cite/get-value       mu-cite-get-value)))
  95   (apply (function define-obsolete-function-alias) def))
  96
  97
  98 ;;; @ set up
  99 ;;;
 100
 101 (defgroup mu-cite nil
 102   "yet another citation tool for GNU Emacs."
 103   :prefix "mu-cite-"
 104   :group 'mail
 105   :group 'news)
 106
 107 (defvar mu-cite-default-methods-alist
 108   (list (cons 'from
 109               (function
 110                (lambda ()
 111                  (mu-cite-get-field-value "From"))))
 112         (cons 'date
 113               (function
 114                (lambda ()
 115                  (mu-cite-get-field-value "Date"))))
 116         (cons 'message-id
 117               (function
 118                (lambda ()
 119                  (mu-cite-get-field-value "Message-Id"))))
 120         (cons 'subject
 121               (function
 122                (lambda ()
 123                  (mu-cite-get-field-value "Subject"))))
 124         (cons 'ml-name
 125               (function
 126                (lambda ()
 127                  (mu-cite-get-field-value "X-Ml-Name"))))
 128         (cons 'ml-count (function mu-cite-get-ml-count-method))
 129         (cons 'address-structure
 130               (function
 131                (lambda ()
 132                  (car
 133                   (std11-parse-address-string (mu-cite-get-value 'from))))))
 134         (cons 'full-name
 135               (function
 136                (lambda ()
 137                  (std11-full-name-string
 138                   (mu-cite-get-value 'address-structure)))))
 139         (cons 'address
 140               (function
 141                (lambda ()
 142                  (std11-address-string
 143                   (mu-cite-get-value 'address-structure)))))
 144         (cons 'id
 145               (function
 146                (lambda ()
 147                  (let ((ml-name (mu-cite-get-value 'ml-name)))
 148                    (if ml-name
 149                        (concat "["
 150                                ml-name
 151                                " : No."
 152                                (mu-cite-get-value 'ml-count)
 153                                "]")
 154                      (mu-cite-get-value 'message-id))))))
 155         (cons 'in-id
 156               (function
 157                (lambda ()
 158                  (let ((id (mu-cite-get-value 'id)))
 159                    (if id
 160                        (format ">>>>> In %s \n" id)
 161                      "")))))
 162         (cons 'x-attribution
 163               (function
 164                (lambda ()
 165                  (mu-cite-get-field-value "X-Attribution"))))
 166         ;; mu-register
 167         (cons 'prefix (function mu-cite-get-prefix-method))
 168         (cons 'prefix-register
 169               (function mu-cite-get-prefix-register-method))
 170         (cons 'prefix-register-verbose
 171               (function mu-cite-get-prefix-register-verbose-method))
 172         ;; mu-bbdb
 173         (cons 'bbdb-prefix
 174               (function mu-bbdb-get-prefix-method))
 175         (cons 'bbdb-prefix-register
 176               (function mu-bbdb-get-prefix-register-method))
 177         (cons 'bbdb-prefix-register-verbose
 178               (function mu-bbdb-get-prefix-register-verbose-method))
 179         ))
 180
 181
 182 ;;; @ formats
 183 ;;;
 184
 185 (define-widget 'mu-cite-choose-prefix-format 'group
 186   "Widget for entering a prefix citation method."
 187   :convert-widget
 188   (function
 189    (lambda (widget)
 190      (list 'choice
 191            :tag "Method or String"
 192            :args (nconc
 193                   (mapcar
 194                    (function (lambda (elem) (list 'choice-item (car elem))))
 195                    mu-cite-default-methods-alist)
 196                   '((symbol :tag "Method")
 197                     (const :tag "-" nil)
 198                     (choice-item :tag "String: \"> \"" "> ")
 199                     (string)))))))
 200
 201 (define-widget 'mu-cite-choose-top-format 'group
 202   "Widget for entering a top citation method."
 203   :convert-widget
 204   (function
 205    (lambda (widget)
 206      (list 'choice
 207            :tag "Method or String"
 208            :args (nconc
 209                   (mapcar
 210                    (function (lambda (elem) (list 'choice-item (car elem))))
 211                    mu-cite-default-methods-alist)
 212                   '((symbol :tag "Method")
 213                     (const :tag "-" nil)
 214                     (choice-item :tag "String: \">>>>>\\t\"" ">>>>>\t")
 215                     (choice-item :tag "String: \" wrote:\\n\"" " wrote:\n")
 216                     (string :tag "String")))))))
 217
 218 (defun mu-cite-custom-set-variable (symbol value)
 219   (set-default symbol (delq nil value)))
 220
 221 (defcustom mu-cite-cited-prefix-regexp
 222   "\\(^[^ \t\n<>]+>+[ \t]*\\|^[ \t]*$\\)"
 223   "Regexp to match the citation prefix.
 224 If match, mu-cite doesn't insert citation prefix."
 225   :type 'regexp
 226   :group 'mu-cite)
 227
 228 (defcustom mu-cite-prefix-format '(prefix-register-verbose "> ")
 229   "List to represent citation prefix.
 230 Each elements must be string or method name."
 231   :type '(repeat mu-cite-choose-prefix-format)
 232   :set (function mu-cite-custom-set-variable)
 233   :group 'mu-cite)
 234
 235 (defcustom mu-cite-top-format '(in-id ">>>>>\t" from " wrote:\n")
 236   "List to represent top string of citation.
 237 Each elements must be string or method name."
 238   :type '(repeat mu-cite-choose-top-format)
 239   :set (function mu-cite-custom-set-variable)
 240   :group 'mu-cite)
 241
 242
 243 ;;; @ hooks
 244 ;;;
 245
 246 (defcustom mu-cite-instantiation-hook nil
 247   "List of functions called just before narrowing to the message."
 248   :type 'hook
 249   :group 'mu-cite)
 250
 251 (defcustom mu-cite-pre-cite-hook nil
 252   "List of functions called before citing a region of text."
 253   :type 'hook
 254   :group 'mu-cite)
 255
 256 (defcustom mu-cite-post-cite-hook nil
 257   "List of functions called after citing a region of text."
 258   :type 'hook
 259   :group 'mu-cite)
 260
 261
 262 ;;; @ field
 263 ;;;
 264
 265 (defvar mu-cite-get-field-value-method-alist nil
 266   "Alist major-mode vs. function to get field-body of header.")
 267
 268 (defun mu-cite-get-field-value (name)
 269   "Return the value of the header field NAME.
 270 If the field is not found in the header, a method function which is
 271 registered in variable `mu-cite-get-field-value-method-alist' is called."
 272   (or (std11-field-body name)
 273       (let ((method (assq major-mode mu-cite-get-field-value-method-alist)))
 274         (if method
 275             (funcall (cdr method) name)))))
 276
 277
 278 ;;; @ item methods
 279 ;;;
 280
 281 ;;; @@ ML count
 282 ;;;
 283
 284 (defcustom mu-cite-ml-count-field-list
 285   '("X-Ml-Count" "X-Mail-Count" "X-Seqno" "X-Sequence" "Mailinglist-Id")
 286   "List of header fields which contain sequence number of mailing list."
 287   :type '(repeat (choice :tag "Field Name"
 288                          (choice-item "X-Ml-Count")
 289                          (choice-item "X-Mail-Count")
 290                          (choice-item "X-Seqno")
 291                          (choice-item "X-Sequence")
 292                          (choice-item "Mailinglist-Id")
 293                          (const :tag "-" nil)
 294                          (string :tag "Other")))
 295   :set (function mu-cite-custom-set-variable)
 296   :group 'mu-cite)
 297
 298 (defun mu-cite-get-ml-count-method ()
 299   "A mu-cite method to return a ML-count.
 300 This function searches a field about ML-count, which is specified by
 301 variable `mu-cite-ml-count-field-list', in a header.
 302 If the field is found, the function returns a number part of the
 303 field.
 304
 305 Notice that please use (mu-cite-get-value 'ml-count)
 306 instead of call the function directly."
 307   (let ((field-list mu-cite-ml-count-field-list))
 308     (catch 'tag
 309       (while field-list
 310         (let* ((field (car field-list))
 311                (ml-count (mu-cite-get-field-value field)))
 312           (if (and ml-count (string-match "[0-9]+" ml-count))
 313               (throw 'tag (match-string 0 ml-count)))
 314           (setq field-list (cdr field-list)))))))
 315
 316
 317 ;;; @ fundamentals
 318 ;;;
 319
 320 (defvar mu-cite-methods-alist nil)
 321
 322 (defun mu-cite-make-methods ()
 323   (setq mu-cite-methods-alist
 324         (copy-alist mu-cite-default-methods-alist))
 325   (run-hooks 'mu-cite-instantiation-hook))
 326
 327 (defun mu-cite-get-value (item)
 328   "Return current value of ITEM."
 329   (let ((ret (cdr (assoc item mu-cite-methods-alist))))
 330     (if (functionp ret)
 331         (prog1
 332             (setq ret (save-excursion (funcall ret)))
 333           (set-alist 'mu-cite-methods-alist item ret))
 334       ret)))
 335
 336 (defun mu-cite-eval-format (list)
 337   (mapconcat (function
 338               (lambda (elt)
 339                 (cond ((stringp elt) elt)
 340                       ((symbolp elt) (mu-cite-get-value elt)))))
 341              list ""))
 342
 343
 344 ;;; @ main function
 345 ;;;
 346
 347 ;;;###autoload
 348 (defun mu-cite-original ()
 349   "Citing filter function.
 350 This is callable from the various mail and news readers' reply
 351 function according to the agreed upon standard."
 352   (interactive)
 353   (mu-cite-make-methods)
 354   (save-restriction
 355     (if (< (mark t) (point))
 356         (exchange-point-and-mark))
 357     (narrow-to-region (point)(point-max))
 358     (run-hooks 'mu-cite-pre-cite-hook)
 359     (let ((last-point (point))
 360           (top (mu-cite-eval-format mu-cite-top-format))
 361           (prefix (mu-cite-eval-format mu-cite-prefix-format)))
 362       (if (re-search-forward "^-*$" nil nil)
 363           (forward-line 1))
 364       (widen)
 365       (delete-region last-point (point))
 366       (insert top)
 367       (setq last-point (point))
 368       (while (< (point)(mark t))
 369         (or (looking-at mu-cite-cited-prefix-regexp)
 370             (insert prefix))
 371         (forward-line 1))
 372       (goto-char last-point))
 373     (run-hooks 'mu-cite-post-cite-hook)))
 374
 375
 376 ;;; @ message editing utilities
 377 ;;;
 378
 379 (defcustom citation-mark-chars ">}|"
 380   "String of characters for citation delimiter."
 381   :type 'string
 382   :group 'mu-cite)
 383
 384 (defcustom citation-disable-chars "<{"
 385   "String of characters not allowed as citation-prefix."
 386   :type 'string
 387   :group 'mu-cite)
 388
 389 (defun-maybe-cond char-category (character)
 390   "Return string of category mnemonics for CHAR in TABLE.
 391 CHAR can be any multilingual character
 392 TABLE defaults to the current buffer's category table."
 393   ((and (subr-fboundp 'char-category-set)
 394         (subr-fboundp 'category-set-mnemonics))
 395    (category-set-mnemonics (char-category-set character))
 396    )
 397   ((fboundp 'char-category-list)
 398    (mapconcat (lambda (chr)
 399                 (char-to-string (int-char chr)))
 400               (char-category-list character)
 401               "")
 402    )
 403   ((boundp 'NEMACS)
 404    (if (< (char-int character) 128)
 405        "al"
 406      "j")
 407    )
 408   (t
 409    (if (< (char-int character) 128)
 410        "al"
 411      "l")
 412    ))
 413
 414 (defun detect-paragraph-cited-prefix ()
 415   (save-excursion
 416     (goto-char (point-min))
 417     (let ((i 0)
 418           (prefix
 419            (buffer-substring (line-beginning-position)
 420                              (line-end-position)))
 421           str ret)
 422       (while (and (= (forward-line) 0)
 423                   (setq str (buffer-substring
 424                              (progn (beginning-of-line)(point))
 425                              (progn (end-of-line)(point))))
 426                   (setq ret (string-compare-from-top prefix str)))
 427         (setq prefix
 428               (if (stringp ret)
 429                   ret
 430                 (cadr ret)))
 431         (setq i (1+ i)))
 432       (cond ((> i 1) prefix)
 433             ((> i 0)
 434              (goto-char (point-min))
 435              (save-restriction
 436                (narrow-to-region (point)
 437                                  (+ (point)(length prefix)))
 438                (goto-char (point-max))
 439                (if (re-search-backward
 440                     (concat "[" citation-mark-chars "]") nil t)
 441                    (progn
 442                      (goto-char (match-end 0))
 443                      (if (looking-at "[ \t]+")
 444                          (goto-char (match-end 0)))
 445                      (buffer-substring (point-min)(point)))
 446                  prefix)))
 447             ((progn
 448                (goto-char (point-max))
 449                (re-search-backward
 450                 (concat "[" citation-disable-chars "]") nil t)
 451                (re-search-backward
 452                 (concat "[" citation-mark-chars "]") nil t))
 453              (goto-char (match-end 0))
 454              (if (looking-at "[ \t]+")
 455                  (goto-char (match-end 0)))
 456              (buffer-substring (point-min)(point)))
 457             (t "")))))
 458
 459 ;;;###autoload
 460 (defun fill-cited-region (beg end)
 461   "Fill each of the paragraphs in the region as a cited text."
 462   (interactive "*r")
 463   (save-excursion
 464     (save-restriction
 465       (goto-char end)
 466       (and (search-backward "\n" nil t)
 467            (setq end (match-end 0)))
 468       (narrow-to-region beg end)
 469       (let* ((fill-prefix (detect-paragraph-cited-prefix))
 470              (pat (concat fill-prefix "\n")))
 471         (goto-char (point-min))
 472         (while (search-forward pat nil t)
 473           (let ((b (match-beginning 0))
 474                 (e (match-end 0)))
 475             (delete-region b e)
 476             (if (and (> b (point-min))
 477                      (let ((cat (char-category
 478                                  (char-before b))))
 479                        (or (string-match "a" cat)
 480                            (string-match "l" cat))))
 481                 (insert " "))))
 482         (goto-char (point-min))
 483         (fill-region (point-min) (point-max))))))
 484
 485 ;;;###autoload
 486 (defun compress-cited-prefix ()
 487   "Compress nested cited prefixes."
 488   (interactive)
 489   (save-excursion
 490     (goto-char (point-min))
 491     (re-search-forward
 492      (concat "^" (regexp-quote mail-header-separator) "$") nil t)
 493     (while (re-search-forward
 494             (concat "^\\([ \t]*[^ \t\n" citation-mark-chars "]*["
 495                     citation-mark-chars "]\\)+") nil t)
 496       (let* ((b (match-beginning 0))
 497              (e (match-end 0))
 498              (prefix (buffer-substring b e))
 499              ps pe (s 0)
 500              (nest (let ((i 0))
 501                      (if (string-match "<[^<>]+>" prefix)
 502                          (setq prefix
 503                                (substring prefix 0 (match-beginning 0))))
 504                      (while (string-match
 505                              (concat "\\([" citation-mark-chars "]+\\)[ \t]*")
 506                              prefix s)
 507                        (setq i (+ i (- (match-end 1)(match-beginning 1)))
 508                              ps s
 509                              pe (match-beginning 1)
 510                              s (match-end 0)))
 511                      i)))
 512         (when (and ps (< ps pe))
 513           (delete-region b e)
 514           (insert (concat (substring prefix ps pe) (make-string nest ?>))))
 515         ))))
 516
 517 (defun replace-top-string (old new)
 518   (interactive "*sOld string: \nsNew string: ")
 519   (while (re-search-forward
 520           (concat "^" (regexp-quote old)) nil t)
 521     (replace-match new)))
 522
 523 (defun string-compare-from-top (str1 str2)
 524   (let* ((len1 (length str1))
 525          (len2 (length str2))
 526          (len (min len1 len2))
 527          (p 0)
 528          c1 c2)
 529     (while (and (< p len)
 530                 (progn
 531                   (setq c1 (sref str1 p)
 532                         c2 (sref str2 p))
 533                   (eq c1 c2)))
 534       (setq p (char-next-index c1 p)))
 535     (and (> p 0)
 536          (let ((matched (substring str1 0 p))
 537                (r1 (and (< p len1)(substring str1 p)))
 538                (r2 (and (< p len2)(substring str2 p))))
 539            (if (eq r1 r2)
 540                matched
 541              (list 'seq matched (list 'or r1 r2)))))))
 542
 543
 544 ;;; @ end
 545 ;;;
 546
 547 (provide 'mu-cite)
 548
 549 (run-hooks 'mu-cite-load-hook)
 550
 551 ;; This part will be abolished in the future.
 552
 553 (static-unless (featurep 'xemacs)
 554   (let ((rest mu-cite-obsolete-variable-alist)
 555         def new-sym old-sym)
 556     (while rest
 557       (setq def (car rest))
 558       (apply (function make-obsolete-variable) def)
 559       (setq old-sym (car def)
 560             new-sym (car (cdr def)))
 561       (or (get new-sym 'saved-value) ; saved?
 562           (not (eq (eval (car (get new-sym 'standard-value)))
 563                    (symbol-value new-sym))) ; set as new name?
 564           (and (boundp old-sym) ; old name seems used
 565                (or (eq (symbol-value new-sym)
 566                        (symbol-value old-sym))
 567                    (set new-sym (symbol-value old-sym)))))
 568       (setq rest (cdr rest)))))
 569
 570 ;;; mu-cite.el ends here