home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / packages / bbdb / bbdb-hooks.el < prev    next >
Encoding:
Text File  |  1992-07-04  |  18.7 KB  |  496 lines
  1. ;;; -*- Mode:Emacs-Lisp -*-
  2.  
  3. ;;; This file is part of the Insidious Big Brother Database (aka BBDB),
  4. ;;; copyright (c) 1991, 1992 Jamie Zawinski <jwz@lucid.com>.
  5. ;;; Various additional functionality for the BBDB.  See bbdb.texinfo.
  6. ;;; last change  4-jul-92.
  7.  
  8. ;;; The Insidious Big Brother Database is free software; you can redistribute
  9. ;;; it and/or modify it under the terms of the GNU General Public License as
  10. ;;; published by the Free Software Foundation; either version 1, or (at your
  11. ;;; option) any later version.
  12. ;;;
  13. ;;; BBDB is distributed in the hope that it will be useful, but WITHOUT ANY
  14. ;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
  15. ;;; FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
  16. ;;; details.
  17. ;;;
  18. ;;; You should have received a copy of the GNU General Public License
  19. ;;; along with GNU Emacs; see the file COPYING.  If not, write to
  20. ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  21.  
  22. ;;; This file lets you do stuff like
  23. ;;;
  24. ;;;    o  automatically update a "timestamp" field each time a record is 
  25. ;;;        modified
  26. ;;;    o  automatically add some string to the notes field(s) based on the
  27. ;;;       contents of header fields of the current message
  28. ;;;    o  only automatically create entries when certain header fields
  29. ;;;       are matched
  30. ;;;    o  don't automatically create entries when certain header fields
  31. ;;;       are matched
  32. ;;;
  33. ;;; Read the docstrings; read the texinfo file.
  34.  
  35. (require 'bbdb)
  36.  
  37. (defmacro the-v18-byte-compiler-sucks-wet-farts-from-dead-pigeons ()
  38.   ;; no such thing as eval-when, no way to conditionally require something
  39.   ;; at compile time (except this!! <evil laughter> )
  40.   (condition-case () (require 'vm) (error nil))
  41.   nil)
  42. (defun Nukem-til-they-glow ()
  43.   (the-v18-byte-compiler-sucks-wet-farts-from-dead-pigeons))
  44.  
  45. (defun bbdb-time-string ()
  46.   "Returns a string for use as a timestamp.  
  47. Currently this returns strings like \"13 Mar 92\".  Redefine to taste."
  48.   (let* ((time (current-time-string))
  49.      (day (substring time 8 10))
  50.      (mon (substring time 4 7))
  51.      (year (substring time 22 24)))
  52.     (concat day " " mon " " year)))
  53.  
  54. (defun bbdb-timestamp-hook (record)
  55.   "For use as a bbdb-change-hook; maintains a notes-field called `timestamp'
  56. for the given record which contains the time when it was last modified.  If
  57. there is such a field there already, it is changed, otherwise it is added."
  58.   (bbdb-record-putprop record 'timestamp (bbdb-time-string)))
  59.  
  60. (defun bbdb-creation-date-hook (record)
  61.   "For use as a bbdb-create-hook; adds a notes-field called `creation-date'
  62. which is the current time string."
  63.   ;; hey buddy, we've known about your antics since the eighties...
  64.   (bbdb-record-putprop record 'creation-date (bbdb-time-string)))
  65.  
  66.  
  67. ;;; Determining whether to create a record based on the content of the 
  68. ;;; current message.
  69.  
  70. (defun bbdb-header-start ()
  71.   "Returns a marker at the beginning of the header block of the current
  72. message.  This will not necessarily be in the current buffer."
  73.   (cond ((memq major-mode '(vm-mode vm-summary-mode))
  74.      (if vm-mail-buffer (set-buffer vm-mail-buffer))
  75.      (vm-start-of (car vm-message-pointer)))
  76.     ((memq major-mode '(rmail-mode rmail-summary-mode))
  77.      (if (and (boundp 'rmail-buffer) rmail-buffer)
  78.          (set-buffer rmail-buffer))
  79.      (point-min-marker))
  80.     ((memq major-mode
  81.            '(gnus-Group-mode gnus-Subject-mode gnus-Article-mode))
  82.      (set-buffer gnus-Article-buffer)
  83.      (point-min-marker))
  84.     ;; ## need an MH-E clause.
  85.     (t (point-min-marker))
  86.     ))
  87.  
  88.  
  89. (defun bbdb-extract-field-value (field-name)
  90.   "Given the name of a field (like \"Subject\") this returns the value of
  91. that field in the current message, or nil.  This works whether you're in
  92. GNUS, Rmail, or VM.  This works on multi-line fields, but if more than
  93. one field of the same name is present, only the last is returned.  It is
  94. expected that the current buffer has a message in it, and (point) is at the
  95. beginning of the message headers."
  96.   ;; we can't special-case VM here to use its cache, because the cache has
  97.   ;; divided real-names from addresses; the actual From: and Subject: fields
  98.   ;; exist only in the message.
  99.   (setq field-name (concat (regexp-quote field-name) "[ \t]*:[ \t]*"))
  100.   (let (done)
  101.     (while (not (or done
  102.             (looking-at "\n") ; we're at BOL
  103.             (eobp)))
  104.       (if (looking-at field-name)
  105.       (progn
  106.         (goto-char (match-end 0))
  107.         (setq done (buffer-substring (point)
  108.                      (progn (end-of-line) (point))))
  109.         (while (looking-at "\n[ \t]")
  110.           (setq done (concat done " "
  111.                (buffer-substring (match-end 0)
  112.                  (progn (end-of-line 2) (point))))))))
  113.       (forward-line 1))
  114.     done))
  115.  
  116.  
  117. (defvar bbdb-ignore-most-messages-alist '()
  118.   "*An alist describing which messages to automatically create BBDB
  119. records for.  This only works if bbdb/news-auto-create-p or 
  120. bbdb/mail-auto-create-p (or both) is 'bbdb-ignore-most-messages-hook.
  121. The format of this alist is 
  122.    (( HEADER-NAME . REGEXP ) ... )
  123. for example,
  124.    ((\"From\" . \"@.*\\.maximegalon\\.edu\")
  125.     (\"Subject\" . \"time travel\"))
  126. will cause BBDB entries to be made only for messages sent by people at 
  127. Maximegalon U., or (that's *or*) people posting about time travel.
  128.  
  129. See also bbdb-ignore-some-messages-alist, which has the opposite effect.")
  130.  
  131.  
  132. (defvar bbdb-ignore-some-messages-alist '()
  133.   "*An alist describing which messages *not* to automatically create
  134. BBDB records for.  This only works if bbdb/news-auto-create-p or 
  135. bbdb/mail-auto-create-p (or both) is 'bbdb-ignore-some-messages-hook.
  136. The format of this alist is 
  137.    (( HEADER-NAME . REGEXP ) ... )
  138. for example,
  139.    ((\"From\" . \"mailer-daemon\")
  140.     (\"To\" . \"mailing-list-1\\\\|mailing-list-2\")
  141.     (\"CC\" . \"mailing-list-1\\\\|mailing-list-2\"))
  142. will cause BBDB entries to not be made for messages from any mailer daemon,
  143. or messages sent to or CCed to either of two mailing lists.
  144.  
  145. See also bbdb-ignore-most-messages-alist, which has the opposite effect.")
  146.  
  147.  
  148. (defun bbdb-ignore-most-messages-hook (&optional invert-sense)
  149.   "For use as the value of bbdb/news-auto-create-p or bbdb/mail-auto-create-p.
  150. This will automatically create BBDB entries for messages which match
  151. the bbdb-ignore-some-messages-alist (which see) and *no* others."
  152.   ;; don't need to optimize this to check the cache, because if
  153.   ;; bbdb/*-update-record uses the cache, this won't be called.
  154.   (let ((rest (if invert-sense
  155.           bbdb-ignore-some-messages-alist
  156.           bbdb-ignore-most-messages-alist))
  157.     (case-fold-search t)
  158.     (done nil)
  159.     (b (current-buffer))
  160.     (marker (bbdb-header-start))
  161.     field regexp fieldval)
  162.     (set-buffer (marker-buffer marker))
  163.     (save-restriction
  164.       (widen)
  165.       (while (and rest (not done))
  166.     (goto-char marker)
  167.     (setq field (car (car rest))
  168.           regexp (cdr (car rest))
  169.           fieldval (bbdb-extract-field-value field))
  170.     (if (and fieldval (string-match regexp fieldval))
  171.         (setq done t))
  172.     (setq rest (cdr rest))))
  173.     (set-buffer b)
  174.     (if invert-sense
  175.     (not done)
  176.     done)))
  177.  
  178.  
  179. (defun bbdb-ignore-some-messages-hook ()
  180.   "For use as a bbdb/news-auto-create-hook or bbdb/mail-auto-create-hook.
  181. This will automatically create BBDB entries for messages which do *not*
  182. match the bbdb-ignore-some-messages-alist (which see)."
  183.   (bbdb-ignore-most-messages-hook t))
  184.  
  185.  
  186. ;;; Automatically add to the notes field based on the current message.
  187.  
  188. (defvar bbdb-auto-notes-alist '()
  189.   "*An alist which lets you have certain pieces of text automatically added
  190. to the BBDB record representing the sender of the current message based on
  191. the subject or other header fields.  This only works if bbdb-notice-hook 
  192. is 'bbdb-auto-notes-hook.  The format of this alist is 
  193.  
  194.    (( HEADER-NAME
  195.        (REGEXP . STRING) ... )
  196.       ... )
  197. for example,
  198.    ((\"To\" (\"-vm@\" . \"VM mailing list\"))
  199.     (\"Subject\" (\"sprocket\" . \"mail about sprockets\")
  200.                (\"you bonehead\" . \"called me a bonehead\")))
  201.  
  202. will cause the text \"VM mailing list\" to be added to the notes field of
  203. the record corresponding to anyone you get mail from via one of the VM
  204. mailing lists.  If, that is, bbdb/mail-auto-create-p is set such that the
  205. record would have been created, or the record already existed.
  206.  
  207. The format of elements of this list may also be 
  208.        (REGEXP FIELD-NAME STRING)
  209. or
  210.        (REGEXP FIELD-NAME STRING REPLACE-P)
  211. instead of
  212.        (REGEXP . STRING)
  213.  
  214. meaning add the given string to the named field.  The field-name may not
  215. be name, address, phone, or net (builtin fields) but must be either ``notes,''
  216. ``company,'' or the name of a user-defined note-field. 
  217.        (\"pattern\" . \"string to add\")
  218. is equivalent to
  219.        (\"pattern\" notes \"string to add\")
  220.  
  221. STRING can contain \\& or \\N escapes like in function
  222. `replace-match'.  For example, to automatically add the contents of the
  223. \"organization\" field of a message to the \"company\" field of a BBDB
  224. record, you can use this:
  225.  
  226.         (\"Organization\" (\".*\" company \"\\\\&\"))
  227.  
  228. \(Note you need two \\ to get a single \\ into a lisp string literal.\)
  229. If STRING is an integer N, the N'th matching subexpression is used, so
  230. the above example could be written more efficiently as
  231.  
  232.         (\"Organization\" (\".*\" company 0))
  233.  
  234. If REPLACE-P is t, the string replaces the old contents instead of
  235. being appended to it.
  236.  
  237. If multiple clauses match the message, all of the corresponding strings
  238. will be added.
  239.  
  240. This works for news as well.  You might want to arrange for this to have
  241. a different value when in mail as when in news.
  242.  
  243. See also variables `bbdb-auto-notes-ignore' and `bbdb-auto-notes-ignore-all'.")
  244.  
  245. (defvar bbdb-auto-notes-ignore nil
  246.   "Alist of headers and regexps to ignore in bbdb-auto-notes-hook.
  247. Each element looks like
  248.  
  249.     (HEADER . REGEXP)
  250.  
  251. For example,
  252.  
  253.     (\"Organization\" . \"^Gatewayed from\\\\\|^Source only\")
  254.  
  255. would exclude the phony `Organization:' headers in GNU mailing-lists
  256. gatewayed to gnu.* newsgroups.  Note that this exclusion applies only
  257. to a single field, not to the entire message.  For that, use the variable
  258. bbdb-auto-notes-ignore-all.")
  259.  
  260. (defvar bbdb-auto-notes-ignore-all nil
  261.   "Alist of headers and regexps which cause the entire message to be ignored
  262. in bbdb-auto-notes-hook.  Each element looks like
  263.  
  264.     (HEADER . REGEXP)
  265.  
  266. For example,
  267.  
  268.     (\"From\" . \"BLAT\\\\.COM\")
  269.  
  270. would exclude any notes recording for message coming from BLAT.COM. 
  271. Note that this is different from `bbdb-auto-notes-ignore', which applies
  272. only to a particular header field, rather than the entire message.")
  273.  
  274.  
  275. (defun bbdb-auto-notes-hook (record)
  276.   "For use as a bbdb-notice-hook.  This might automatically add some text
  277. to the notes field of the BBDB record corresponding to the current record
  278. based on the header of the current message.  See the documentation for
  279. the variables bbdb-auto-notes-alist and bbdb-auto-notes-ignore."
  280.   ;; This could stand to be faster...
  281.   ;; could optimize this to check the cache, and noop if this record is
  282.   ;; cached for any other message, but that's probably not the right thing.
  283.   (or bbdb-readonly-p
  284.   (let ((rest bbdb-auto-notes-alist)
  285.     ignore
  286.     (ignore-all bbdb-auto-notes-ignore-all)
  287.     (case-fold-search t)
  288.     (b (current-buffer))
  289.     (marker (bbdb-header-start))
  290.     field pairs fieldval  ; do all bindings here for speed
  291.     regexp string notes-field-name notes
  292.      replace-p replace-or-add-msg)
  293.     (set-buffer (marker-buffer marker))
  294.     (save-restriction
  295.       (widen)
  296.       (goto-char marker)
  297.       (if (and (setq fieldval (bbdb-extract-field-value "From"))
  298.            (string-match (bbdb-user-mail-names) fieldval))
  299.       ;; Don't do anything if this message is from us.  Note that we have
  300.       ;; to look at the message instead of the record, because the record
  301.       ;; will be of the recipient of the message if it is from us.
  302.       nil
  303.     ;; check the ignore-all pattern
  304.     (while (and ignore-all (not ignore))
  305.       (goto-char marker)
  306.       (setq field (car (car ignore-all))
  307.         regexp (cdr (car ignore-all))
  308.         fieldval (bbdb-extract-field-value field))
  309.       (if (and fieldval
  310.            (string-match regexp fieldval))
  311.           (setq ignore t)
  312.         (setq ignore-all (cdr ignore-all))))
  313.  
  314.     (if ignore  ; ignore-all matched
  315.         nil
  316.      (while rest ; while their still are clauses in the auto-notes alist
  317.       (goto-char marker)
  318.       (setq field (car (car rest))    ; name of header, e.g., "Subject"
  319.         pairs (cdr (car rest))    ; (REGEXP . STRING) or
  320.                     ; (REGEXP FIELD-NAME STRING) or
  321.                     ; (REGEXP FIELD-NAME STRING REPLACE-P)
  322.         fieldval (bbdb-extract-field-value field)) ; e.g., Subject line
  323.       (if fieldval
  324.           (while pairs
  325.         (setq regexp (car (car pairs))
  326.               string (cdr (car pairs)))
  327.         (if (consp string)    ; not just the (REGEXP .STRING) format
  328.             (setq notes-field-name (car string)
  329.               replace-p (nth 2 string) ; perhaps nil
  330.               string (nth 1 string))
  331.           ;; else it's simple (REGEXP . STRING)
  332.           (setq notes-field-name 'notes
  333.             replace-p nil))
  334.         (setq notes (bbdb-record-getprop record notes-field-name))
  335.         (let ((did-match
  336.                (and (string-match regexp fieldval)
  337.                 ;; make sure it is not to be ignored
  338.                 (let ((re (cdr (assoc field bbdb-auto-notes-ignore))))
  339.                   (if re
  340.                   (not (string-match re fieldval))
  341.                 t)))))
  342.           ;; An integer as STRING is an index into match-data: 
  343.           (if did-match
  344.               (setq string
  345.                 (if (integerp string) ; backward compat
  346.                 (substring fieldval
  347.                        (match-beginning string)
  348.                        (match-end string))
  349.                   (bbdb-auto-expand-newtext fieldval string))))
  350.           ;; need expanded version of STRING here:
  351.           (if (and did-match
  352.                (not (and notes
  353.                      ;; check that STRING is not already
  354.                      ;; present in the NOTES field
  355.                      (string-match
  356.                       (concat "\\b" (regexp-quote string)
  357.                           "\\b")
  358.                       notes))))
  359.               (if replace-p
  360.               ;; replace old contents of field with STRING
  361.               (progn
  362.                 (if (eq notes-field-name 'notes)
  363.                 (message "Replacing with note \"%s\"" string)
  364.                   (message "Replacing field \"%s\" with \"%s\""
  365.                        notes-field-name string))
  366.                 (bbdb-record-putprop record notes-field-name
  367.                          string)
  368.                 (bbdb-maybe-update-display record))
  369.             ;; add STRING to old contents, don't replace 
  370.             (if (eq notes-field-name 'notes)
  371.                 (message "Adding note \"%s\"" string)
  372.               (message "Adding \"%s\" to field \"%s\""
  373.                    string notes-field-name))
  374.             (bbdb-annotate-notes record string notes-field-name))))
  375.         (setq pairs (cdr pairs))))
  376.       (setq rest (cdr rest))))))
  377.     (set-buffer b))))
  378.  
  379.  
  380. (defun bbdb-auto-expand-newtext (string newtext)
  381.   ;; Expand \& and \1..\9 (referring to STRING) in NEWTEXT.
  382.   ;; Note that in Emacs 18 match data are clipped to current buffer
  383.   ;; size...so the buffer had better not be smaller than STRING (arrrrggggh!!)
  384.   (let ((pos 0)
  385.     (len (length newtext))
  386.     (expanded-newtext ""))
  387.     (while (< pos len)
  388.       (setq expanded-newtext
  389.         (concat expanded-newtext
  390.             (let ((c (aref newtext pos)))
  391.               (if (= ?\\ c)
  392.               (cond ((= ?\& (setq c (aref newtext
  393.                               (setq pos (1+ pos)))))
  394.                  (substring string
  395.                         (match-beginning 0)
  396.                         (match-end 0)))
  397.                 ((and (>= c ?1) 
  398.                       (<= c ?9))
  399.                  ;; return empty string if N'th
  400.                  ;; sub-regexp did not match:
  401.                  (let ((n (- c ?0)))
  402.                    (if (match-beginning n)
  403.                        (substring string
  404.                           (match-beginning n)
  405.                           (match-end n))
  406.                      "")))
  407.                 (t (char-to-string c)))
  408.             (char-to-string c)))))
  409.       (setq pos (1+ pos)))
  410.     expanded-newtext))
  411.  
  412.  
  413. ;;; I use this as the value of bbdb-canonicalize-net-hook; it is provided
  414. ;;; as an example for you to customize.
  415.  
  416. (defvar bbdb-canonical-hosts
  417.   (mapconcat 'regexp-quote
  418.          '("cs.cmu.edu" "ri.cmu.edu" "edrc.cmu.edu" "andrew.cmu.edu"
  419.            "lucid.com" "cenatls.cena.dgac.fr" "cenaath.cena.dgac.fr"
  420.            "irit.fr" "enseeiht.fr" "inria.fr")
  421.          "\\|")
  422.   "Certain sites have a single mail-host; for example, all mail originating
  423. at hosts whose names end in \".cs.cmu.edu\" can (and probably should) be
  424. addressed to \"user@cs.cmu.edu\" instead.  This variable lists other hosts
  425. which behave the same way.")
  426.  
  427. (defmacro bbdb-match-substring (string match)
  428.   (list 'substring string
  429.     (list 'match-beginning match) (list 'match-end match)))
  430.  
  431. (defun sample-bbdb-canonicalize-net-hook (addr)
  432.   (cond
  433.    ;;
  434.    ;; rewrite mail-drop hosts.
  435.    ;;
  436.    ((string-match
  437.      (concat "\\`\\([^@%!]+@\\).*\\.\\(" bbdb-canonical-hosts "\\)\\'")
  438.      addr)
  439.     (concat (bbdb-match-substring addr 1) (bbdb-match-substring addr 2)))
  440.    ;;
  441.    ;; Here at Lucid, our workstation names sometimes get into our email
  442.    ;; addresses in the form "jwz%thalidomide@lucid.com" (instead of simply
  443.    ;; "jwz@lucid.com").  This removes the workstation name.
  444.    ;;
  445.    ((string-match "\\`\\([^@%!]+\\)%[^@%!.]+@\\(lucid\\.com\\)\\'" addr)
  446.     (concat (bbdb-match-substring addr 1) "@" (bbdb-match-substring addr 2)))
  447.    ;;
  448.    ;; Another way that our local mailer is misconfigured: sometimes addresses
  449.    ;; which should look like "user@some.outside.host" end up looking like
  450.    ;; "user%some.outside.host" or even "user%some.outside.host@lucid.com"
  451.    ;; instead.  This rule rewrites it into the original form.
  452.    ;;
  453.    ((string-match "\\`\\([^@%]+\\)%\\([^@%!]+\\)\\(@lucid\\.com\\)?\\'" addr)
  454.     (concat (bbdb-match-substring addr 1) "@" (bbdb-match-substring addr 2)))
  455.    ;;
  456.    ;; Sometimes I see addresses like "foobar.com!user@foobar.com".
  457.    ;; That's totally redundant, so this rewrites it as "user@foobar.com".
  458.    ;;
  459.    ((string-match "\\`\\([^@%!]+\\)!\\([^@%!]+[@%]\\1\\)\\'" addr)
  460.     (bbdb-match-substring addr 2))
  461.    ;;
  462.    ;; Sometimes I see addresses like "foobar.com!user".  Turn it around.
  463.    ;;
  464.    ((string-match "\\`\\([^@%!.]+\\.[^@%!]+\\)!\\([^@%]+\\)\\'" addr)
  465.     (concat (bbdb-match-substring addr 2) "@" (bbdb-match-substring addr 1)))
  466.    ;;
  467.    ;; The mailer at hplb.hpl.hp.com tends to puke all over addresses which
  468.    ;; pass through mailing lists which are maintained there: it turns normal
  469.    ;; addresses like "user@foo.com" into "user%foo.com@hplb.hpl.hp.com".
  470.    ;; This reverses it.  (I actually could have combined this rule with
  471.    ;; the similar lucid.com rule above, but then the regexp would have been
  472.    ;; more than 80 characters long...)
  473.    ;;
  474.    ((string-match "\\`\\([^@!]+\\)%\\([^@%!]+\\)@hplb\\.hpl\\.hp\\.com\\'"
  475.           addr)
  476.     (concat (bbdb-match-substring addr 1) "@" (bbdb-match-substring addr 2)))
  477.    ;;
  478.    ;; Another local mail-configuration botch: sometimes mail shows up
  479.    ;; with addresses like "user@workstation", where "workstation" is a
  480.    ;; local machine name.  That should really be "user" or "user@lucid.com".
  481.    ;; (I'm told this one is due to a bug in SunOS 4.1.1 sendmail.)
  482.    ;;
  483.    ((string-match "\\`\\([^@%!]+\\)[@%][^@%!.]+\\'" addr)
  484.     (bbdb-match-substring addr 1))
  485.    ;;
  486.    ;; Sometimes I see addrs like "foo%somewhere%uunet.uu.net@somewhere.else".
  487.    ;; This is silly, because I know that I can send mail to uunet directly.
  488.    ;;
  489.    ((string-match ".%uunet\\.uu\\.net@[^@%!]+\\'" addr)
  490.     (concat (substring addr 0 (+ (match-beginning 0) 1)) "@UUNET.UU.NET"))
  491.    ;;
  492.    ;; Otherwise, leave it as it is.  Returning a string EQ to the one passed
  493.    ;; in tells BBDB that we're done.
  494.    ;;
  495.    (t addr)))
  496.