diff options
| -rw-r--r-- | bits/bbdb-edit.el | 135 | ||||
| -rw-r--r-- | bits/bbdb-pgp.el | 161 | ||||
| -rw-r--r-- | bits/bbdb-sort-mailrc.el | 323 | ||||
| -rw-r--r-- | bits/bbdb-to-outlook.el | 252 |
4 files changed, 871 insertions, 0 deletions
diff --git a/bits/bbdb-edit.el b/bits/bbdb-edit.el new file mode 100644 index 0000000..f0cdd45 --- /dev/null +++ b/bits/bbdb-edit.el @@ -0,0 +1,135 @@ +;;; bbdb-edit.el --- BBDB field edit +;; Copyright (C) 1999, 2000 Shenghuo ZHU + +;; Author: Shenghuo ZHU <zsh@cs.rochester.edu> +;; Created: Fri Aug 27 17:45:25 EDT 1999 +;; Keywords: BBDB field edit + +;; This file is not a part of GNU Emacs. +;; +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published +;; by the Free Software Foundation; either version 2, or (at your +;; option) any later version. +;; +;; This file is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; bbdb-field-edit-add (`insert') and bbdb-field-edit-del (`delete') +;; add/del a item to/from a certain field of the bbdb record. These +;; keys also support `*'. + +;;; Code: + +(require 'bbdb) + +(defun bbdb-field-edit-get-values (record field) + (cond + ((eq field 'net) (bbdb-record-net record)) + ((eq field 'AKA) (bbdb-record-aka record)) + ((eq field 'address) (bbdb-record-addresses record)) + ((eq field 'phone) (bbdb-record-phones record)) + (t (bbdb-split (or (bbdb-record-getprop record field) "") ",")))) + +(defun bbdb-field-edit-put-values (record field values) + (if values + (cond + ((eq field 'net) (bbdb-record-set-net record values)) + ((eq field 'AKA) (bbdb-record-set-aka record values)) + ((eq field 'address) (bbdb-record-set-addresses record values)) + ((eq field 'phone) (bbdb-record-set-phones record values)) + (t (bbdb-record-putprop record field + (mapconcat 'identity values ",")))) + (if (memq field '(net AKA address)) + (bbdb-record-store-field-internal record field nil) + (bbdb-record-putprop record field nil))) + (bbdb-change-record record t) + (bbdb-redisplay-one-record record)) + +;;;###autoload +(defun bbdb-field-edit-add (bbdb-record field value) + "Add VALUE to FIELD of bbdb-record(s)." + (interactive (list (if (bbdb-do-all-records-p) + (mapcar 'car bbdb-records) + (list (bbdb-current-record))) + (completing-read + "Field: " + (append '(("net")("notes")("AKA")) + (bbdb-propnames)) + nil nil + (symbol-name + (let ((on-field (bbdb-current-field t))) + (cond ((null on-field) 'mail-alias) + ((eq (car on-field) 'property) + (car (nth 1 on-field))) + (t (car on-field)))))) + (bbdb-read-string "Value: "))) + (if (stringp field) (setq field (intern field))) + (if (memq field '(name address phone)) + (error "Use `e' to edit this field.")) + (while bbdb-record + (let ((values (bbdb-field-edit-get-values (car bbdb-record) field))) + (if (member value values) nil + (bbdb-field-edit-put-values (car bbdb-record) field + (cons value values)))) + (setq bbdb-record (cdr bbdb-record)))) + +;;;###autoload +(defun bbdb-field-edit-del (bbdb-record field value) + "Delete VALUE to FIELD of bbdb-record(s). +If prefix arg exists, delete all existing field values matching VALUE(regexp)." + (interactive (list (if (bbdb-do-all-records-p) + (mapcar 'car bbdb-records) + (list (bbdb-current-record))) + (completing-read + "Field: " + (append '(("net")("notes")("AKA")) + (bbdb-propnames)) + nil nil (symbol-name + (let ((on-field (bbdb-current-field t))) + (cond ((null on-field) 'mail-alias) + ((eq (car on-field) 'property) + (car (nth 1 on-field))) + (t (car on-field)))))) + (bbdb-read-string (if current-prefix-arg + "Regexp: " + "Value: ")))) + (if (stringp field) (setq field (intern field))) + (if (memq field '(name address phone)) + (error "Use `e' to edit this field.")) + (while bbdb-record + (let ((values (bbdb-field-edit-get-values (car bbdb-record) field))) + (cond + (current-prefix-arg + (let (nvalues found) + (while values + (if (string-match value (car values)) + (setq found t) + (setq nvalues (cons (car values) nvalues))) + (setq values (cdr values))) + (if found + (bbdb-field-edit-put-values (car bbdb-record) field + (nreverse nvalues))))) + (t + (if (member value values) + (bbdb-field-edit-put-values (car bbdb-record) field + (delete value values)))))) + (setq bbdb-record (cdr bbdb-record)))) + +;;; The key binding might be moved to somewhere else. + +(define-key bbdb-mode-map [(insert)] 'bbdb-field-edit-add) +(define-key bbdb-mode-map [(delete)] 'bbdb-field-edit-del) + +(provide 'bbdb-edit) + +;; bbdb-edit.el ends here diff --git a/bits/bbdb-pgp.el b/bits/bbdb-pgp.el new file mode 100644 index 0000000..bbacb50 --- /dev/null +++ b/bits/bbdb-pgp.el @@ -0,0 +1,161 @@ +;;; BBDB-PGP.EL --- use BBDB to store PGP preferences + +;; Copyright (C) 1997,1999 Kevin Davidson + +;; Author: Kevin Davidson tkld@quadstone.com +;; Maintainer: Kevin Davidson tkld@quadstone.com +;; Created: 10 Nov 1997 +;; Version: $Revision$ +;; Keywords: PGP BBDB message mailcrypt + + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; A copy of the GNU General Public License can be obtained from this +;; program's author (send electronic mail to tkld@quadstone.com) or +;; from the Free Software Foundation, Inc.,59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;; LCD Archive Entry: +;; bbdb-pgp|Kevin Davidson|tkld@quadstone.com +;; |Use BBDB to store PGP preferences +;; |$Date$|$Revision$|~/packages/bbdb-pgp.el + +;;; Commentary: +;; +;; It is believed that encrypted mail works best if all mail between +;; individuals is encrypted - even concerning matters that are not +;; confidential. The reasoning is that confidential messages cannot +;; then be easily spotted and decryption efforts concentrated on them. +;; Some people therefore prefer to have all their email encrypted. +;; This package allows you to mark the BBDB entries for those +;; individuals so that messages will be encrypted when they are sent. +;; +;; These packages are required: BBDB, mailcrypt, message +;; +;; message.el is included with recent versions of Emacs. +;; You can use mail-mode as well as message-mode to send mail. + +;;; Usage: +;; (require 'bbdb-pgp) +;; +;; Then for all users who you want to send encrypted mail to, add the field +;; pgp-mail with the value `encrypt'. Alternatively you can add the value +;; `sign' if you just want to send signed messages. +;; +;; and possibly (if you do not want the PGP field printed out) +;; (add-hook 'bbdb-print-elide bbdb-pgp-field) +;; +;; The variable bbdb/pgp-default-action defines what to do if the recipient +;; is not in the BBDB. + +;;; TODO +;; Spot incoming PGP mail by hooking into mc-verify/decrypt and adding pgp-mail +;; field to BBDB entry (creating one if necessary); like bbdb-sc.el maintains +;; attribution prefs. + +;;; PGP Public Key +;; The author's public key is available from any public PGP keyserver +;; eg http://www.pgp.net/pgpnet/ +;; Fingerprint: 1F A9 3F 3E 90 F7 85 64 55 35 32 C8 75 91 3A E3 + +;;; Change log: +;; $Log$ +;; Revision 1.1 2001/01/24 21:19:08 waider +;; Add-ons that didn't make it to the current release. +;; +;; Revision 1.4 1999/01/05 13:17:00 tkld +;; Update GPL version number and FSF snail mail address. +;; +;; Revision 1.3 1997/11/10 15:20:29 tkld +;; Expand commentary. Support encrypt/sign. Support mail-mode +;; (sendmail.el). +;; +;; Revision 1.3 1997/11/10 15:10:19 tkld +;; Update commentary. Support sendmail.el. Support signing or encrypting. +;; +;; Revision 1.2 1997/11/10 14:27:07 tkld +;; Remembered to widen buffer before encrypting. +;; +;; Revision 1.1 1997/11/10 14:22:06 tkld +;; Initial revision +;; + +;;; Code: + +(require 'message) +(require 'bbdb) +(require 'mailcrypt) + +(defconst bbdb/pgp-version (substring "$Revision$" 11 -2) + "$Id$ + +Report bugs to: Kevin Davidson tkld@quadstone.com") + +(defvar bbdb/pgp-field 'pgp-mail + "*Field to use in BBDB to store PGP preferences. +If this field's value in a record is \"encrypt\" then messages are +encrypted. If it is \"sign\" then messages are signed.") + +(defvar bbdb/pgp-default-action nil + "*Default action when sending a message and the recipient is not in BBDB. +nil means do nothing. +'encrypt means encrypt message. +'sign means sign message.") + +(defun bbdb/pgp-get-pgp (name address) + "Look up user NAME and ADDRESS in BBDB and return the PGP preference." + (let* ((record (bbdb-search-simple name address)) + (pgp (and record + (bbdb-record-getprop record bbdb/pgp-field)))) + pgp)) + +(defun bbdb/pgp-hook-fun () + "Function to be added to message-send-hook +Uses PGP to encrypt messages to users marked in the BBDB with the +field `bbdb/pgp-field'. +The user is prompted before encryption or signing." + (save-restriction + (save-excursion + (message-narrow-to-headers) + (and (featurep 'mailalias) + (not (featurep 'mailabbrev)) + mail-aliases + (expand-mail-aliases (point-min) (point-max))) + (let* ((to-field (mail-fetch-field "To" nil t)) + (address (mail-extract-address-components (or to-field "")))) + (widen) + (if (not (equal address '(nil nil))) + (let ((pgp-p (bbdb/pgp-get-pgp (car address) (car (cdr address))))) + (cond + ((string= "encrypt" pgp-p) + (and (y-or-n-p "Encrypt message ? ") + (mc-encrypt 0))) + ((string= "sign" pgp-p) + (and (y-or-n-p "Sign message ? ") + (mc-sign 0))) + (t + (cond + ((eq bbdb/pgp-default-action 'encrypt) + (and (y-or-n-p "Encrypt message ? ") + (mc-encrypt 0))) + ((eq bbdb/pgp-default-action 'sign) + (and (y-or-n-p "Sign message ? ") + (mc-sign 0))) + (t + nil)))))))))) + +(add-hook 'message-send-hook 'bbdb/pgp-hook-fun) +(add-hook 'mail-send-hook 'bbdb/pgp-hook-fun) + +(provide 'bbdb-pgp) + +;;; BBDB-PGP.EL ends here diff --git a/bits/bbdb-sort-mailrc.el b/bits/bbdb-sort-mailrc.el new file mode 100644 index 0000000..f1d0f05 --- /dev/null +++ b/bits/bbdb-sort-mailrc.el @@ -0,0 +1,323 @@ +>>>>> Ronan Waide writes: + +>> * birthdays/anniversaries + +RW> This /is/ venturing into calendar land. Still, go to yer bbdb buffer +RW> and create a field with C-o. Again, I prefer not to add baggage to the +RW> file format unless it's absolutely necessary. Also, you should be able +RW> to attach bbdb to calendar.el using the bbdb record-dinking hooks so +RW> that it auto-fills your calendar with goop for you. And maybe get +RW> working on calendar-pilot.el... + +Well, this isn't really release-ready -- but since someone asks, it +could be a good starting point for someone. Feel free to +redistribute, or chop up and use the useful bits. + +Bng + + +;;; BBDB-BNG +;;; Various functions I have added to enhance the big brother database. +;;; Boris Goldowsky, <boris@cs.rochester.edu> +;;; $Revision$ $Date$ +;;; +;;; This file allows you to do the following things: +;;; * Sort by firstname or company rather than last name. +;;; * Mark people's birthdays in emacs's calendar and diary displays. +;;; * Maintains a file of mail aliases, for use by other mailers, +;;; automatically updated when the information changes in your database. +;;; * Make sure that everyone has their username defined as an alias +;;; for their complete net addresses. +;;; +;;; INSTALLATION: +;;; Put this file in emacs's load-path, and make sure it gets loaded whenever +;;; you load BBDB. +;;; * To use alternate sorting, evaluate (bbdb-sort-by ...) whenever you load +;;; bbdb. YOU MUST EITHER ALWAYS DO THIS, OR NEVER DO IT. When you switch +;;; over, evaluate (bbdb-resort-database). +;;; * To make a file of mail-aliases, set bbdb-mail-alias-file to a filename, +;;; and source that file from your .mailrc. +;;; * Username-aliases are enabled by default. Set +;;; `bbdb-auto-username-alias' to nil if you don't want them. +;;; You can also use the function `bbdb-add-user-name-as-alias' to +;;; add such aliases manually. +;;; * The bbdb/calendar stuff is under development, and may not work. +;;; +;;; EXAMPLE: +;;; The following code could go in your .emacs: +;;; (add-hook 'bbdb-load-hook +;;; (function (lambda () +;;; (setq bbdb-mail-alias-file +;;; (expand-file-name "~/.mail_aliases") +;;; (require 'bbdb-bng) +;;; (bbdb-sort-by 'firstname)))) + +;;; USE: +;;; If installed as above, these functions operate automatically. + +;;; DEPENDENCIES: +;;; BBDB, of course. +;;; calendar.el and diary-lib.el are built into recent emacs versions. +;;; dates.el is available from me. + +(provide 'bbdb-bng) + +;;; +;;; New birthday stuff. +;;; + +(require 'calendar) +(require 'dates) + +(if (not (featurep 'diary)) ; the library of many names. + (or (load "diary-lib" t) + (load "diary"))) + +(defvar bbdb/calendar-marker + (if (not window-system) + "^" + (require 'faces) + 'bold-italic) + "*How to mark birthdays in calendar. +Can be either a single-character string or a face.") + +(add-hook 'list-diary-entries-hook 'bbdb/calendar-list-entries) +(add-hook 'mark-diary-entries-hook 'bbdb/calendar-mark-entries) + +(defun bbdb/calendar-mark-entries () + (save-excursion + (set-buffer calendar-buffer) + (let ((month displayed-month) + (year displayed-year)) + (bbdb/calendar-mark-month month year) + (increment-calendar-month month year -1) + (bbdb/calendar-mark-month month year) + (increment-calendar-month month year 2) + (bbdb/calendar-mark-month month year)))) + +(defun bbdb/calendar-mark-month (month year) + (message "Marking birthdays..." + (let ((days (aref (bbdb/calendar-birthdays) month))) + (while days + (mark-visible-calendar-date (list month (car (car days)) year) + bbdb/calendar-marker) + (setq days (cdr days)))) + (message nil))) + +(defun bbdb/calendar-list-entries () + (message "Listing birthdays..." + (let* ((bdays (bbdb/calendar-birthdays)) + (start-date (calendar-absolute-from-gregorian original-date)) + (end-date (+ number start-date))) + (calendar-for-loop abs-date from start-date to end-date do + (let* ((date (calendar-gregorian-from-absolute abs-date)) + (entries (cdr (assoc (extract-calendar-day date) + (aref bdays + (extract-calendar-month date)))))) + (while entries + (add-to-diary-list date (car entries)) + (setq entries (cdr entries)))))) + (message nil))) + +(defvar bbdb/calendar-birthdays nil + "Used by function of the same name, which see.") + +(defun bbdb/calendar-birthdays () + "Returns a vector containing the birthdays in your BBDB. +This is a vector with one element per month: + [birthdays ; identifier in spot 0 + ((4 \"Isaac Newton's birthday\")) ; Newton's birthday is Jan 4. + ((11 \"Thomas Edison's birthday\") ; Edison's is Feb 11. + (15 \"Galileo's birthday\" \"Susan B. Anthony's birthday\")) ; Both Feb 15. + ...march through dec... + ]" + (or bbdb/calendar-birthdays + (setq bbdb/calendar-birthdays + (let ((cal (make-vector 13 nil)) + (recs (bbdb-records)) + birthday-string) + (aset cal 0 'birthdays) + (while recs + (if (setq birthday-string + (bbdb-record-getprop (car recs) 'birthday)) + (let ((events (bbdb-split birthday-string ",")) + (name (bbdb-record-name (car recs)))) + (while events + (let ((bday (date-parse (car events)))) + (if (null bday) + (message "Unparsable birthday: %s" (car events)) + (let* ((date-end (parse-string-end)) + (eventname (if (eq t date-end) + "birthday" + (substring (car events) + date-end))) + (event (concat name "'s " + (if (equal "" eventname) + "birthday" + eventname))) + (month (extract-calendar-month bday)) + (day (extract-calendar-day bday)) + (monthlist (aref cal month)) + (daylist (assoc day monthlist))) + (if daylist + (setcdr daylist (cons event (cdr daylist))) + (aset cal month (cons (list day event) + monthlist)))))) + (setq events (cdr events))))) + (setq recs (cdr recs))) + cal)))) + +;;; +;;; Mail alias code +;;; + +(defvar bbdb-mail-alias-file nil + "*File to save mail-aliases into. +Aliases are also kept in the database proper; this is just for the convenience +of other programs that are interested in mail aliases. For example, you can +use your bbdb mail aliases with ucb mail by including the line +source ~/.mail_aliases +in your .mailrc file. +Set this to nil to avoid storing mail aliases in a file.") + +(defvar bbdb-auto-username-alias t + "*If t, always have a person's username as a mail-alias for them.") + +(if bbdb-mail-alias-file + (add-hook 'bbdb-after-change-hook (function bbdb-check-mail-alias))) + +(defun bbdb-add-user-name-as-alias () + (interactive) + (let ((bbdb-auto-username-alias t) + (this(bbdb-current-record))) + (bbdb-check-mail-alias this) + (bbdb-redisplay-one-record this))) + +(defun bbdb-record-username (record) + "Return just the username part of RECORD's first net address, +if it looks like a well-formed internet address; nil otherwise." + (let ((addr (car (bbdb-record-net record)))) + (if (and addr (string-match "^[a-zA-z0-9]+@" addr)) + (substring addr 0 (1- (match-end 0)))))) + +(defun bbdb-record-mail-aliases (record) + (let ((all (bbdb-record-getprop record bbdb-define-all-aliases-field))) + (if all (bbdb-split all ",")))) + +(defun bbdb-check-mail-alias (record) + "Makes sure the person's username is defined as a mail abbrev +for them, and makes sure all their mail abbreves are ready for use." + (let ((username (bbdb-record-username record)) + (current (bbdb-record-getprop record bbdb-define-all-aliases-field))) + (if (and current (string-match "\\(,\\)? *\n" current)) + (setq current (replace-match ", " nil nil current))) + (if (and bbdb-auto-username-alias + username + (not (and (boundp 'mail-abbrevs) + (intern-soft username mail-abbrevs))) + (not (member username (bbdb-record-mail-aliases record)))) + (setq current + (if current (concat current ", " username) + username))) + (if current + (bbdb-record-putprop record bbdb-define-all-aliases-field current)) + + ;; And make sure aliases are all defined (if any are) + (if (boundp 'mail-abbrevs) + (mapcar (function + (lambda (alias) + (if (not (intern-soft alias mail-abbrevs)) + (my-define-mail-abbrev + alias (bbdb-dwim-net-address record))))) + (bbdb-record-mail-aliases record))))) + +(defun my-define-mail-abbrev (abbrev address) + "Defines abbrev, and marks bbdb-mail-alias-file as modified." + (define-mail-abbrev abbrev address) + (save-excursion + (set-buffer (find-file-noselect bbdb-mail-alias-file)) + (setq buffer-read-only t) + (set-buffer-modified-p t) + (make-variable-buffer-local 'local-write-file-hooks) + (if (not (memq 'bbdb-mail-alias-file-write-hook + local-write-file-hooks)) + (setq local-write-file-hooks '(bbdb-mail-alias-file-write-hook))))) + +(defun bbdb-insert-mail-aliases () + (let ((begin (point))) + (if (not (boundp 'mail-abbrevs)) + (bbdb-define-all-aliases)) + (insert-abbrev-table-description 'mail-abbrevs nil) + (goto-char begin) + (let ((abbrevs (nth 1 (nth 2 (read (current-buffer)))))) + (setq abbrevs (sort abbrevs (function + (lambda (x y) + (string-lessp (car x) (car y)))))) + (delete-region begin (point)) + (mapcar (function + (lambda (abbrev) + (let ((alias (car abbrev)) + (addr (mapconcat (function simplify-address) + (bbdb-split (nth 1 abbrev) ",") " "))) + (if (not (string-equal alias addr)) + (insert (format "alias %s\t%s\n" alias addr)))))) + abbrevs)))) + +(defun simplify-address (addr) + (let ((addr (car (cdr (mail-extract-address-components addr))))) + (if (string-match (concat "@" (system-name) "$") addr) + (substring addr 0 (match-beginning 0)) + addr))) + +(defun bbdb-mail-alias-file-write-hook () + "Regenerate mail-aliases if necc. +Call from local-write-file-hooks." + (let ((buffer-read-only nil)) + (message "Writing aliases...") + (delete-region (point-min) (point-max)) + (bbdb-insert-mail-aliases) + (message "Writing aliases...done") + nil)) + +;;; +;;; sorting frobnification. +;;; + +(defun bbdb-sort-by (field) + "Tell BBDB which field is the primary sort key. +Currently FIELD must be one of 'firstname 'lastname or 'company. +The first time you use this, use bbdb-resort-database immediately +afterwards. Then put \(bbdb-sort-by 'firstname), or whichever field is +your choice, on your bbdb-after-load-db-hook." + (cond ((eq field 'lastname) + (defun bbdb-record-sortkey (record) + (or (bbdb-cache-sortkey (bbdb-record-cache record)) + (bbdb-cache-set-sortkey + (bbdb-record-cache record) + (downcase + (concat (bbdb-record-lastname record) + (bbdb-record-firstname record) + (bbdb-record-company record))))))) + ((eq field 'firstname) + (defun bbdb-record-sortkey (record) + (or (bbdb-cache-sortkey (bbdb-record-cache record)) + (bbdb-cache-set-sortkey + (bbdb-record-cache record) + (downcase + (concat (bbdb-record-firstname record) + (bbdb-record-lastname record) + (bbdb-record-company record))))))) + ((eq field 'company) + (defun bbdb-record-sortkey (record) + (or (bbdb-cache-sortkey (bbdb-record-cache record)) + (bbdb-cache-set-sortkey + (bbdb-record-cache record) + (downcase + (concat (bbdb-record-company record) + (bbdb-record-lastname record) + (bbdb-record-firstname record))))))) + (t (error "Can only sort by firstname lastname or company!")))) + +;;; Local Variables: +;;; eval:(put 'calendar-for-loop 'lisp-indent-hook 6) +;;; End: diff --git a/bits/bbdb-to-outlook.el b/bits/bbdb-to-outlook.el new file mode 100644 index 0000000..7fdb7c6 --- /dev/null +++ b/bits/bbdb-to-outlook.el @@ -0,0 +1,252 @@ +;;; This is bbdb-to-outlook.el, version 0.1 +;;; +;;; Author: Bin Mu <mubin@cs.uchicago.edu> +;;; <http://www.cs.uchicago.edu/~mubin> +;;; Created: 30 Oct 1997 +;;; Version: 0.1 +;;; +;;; The Insidious Big Brother Database is free software; you can redistribute +;;; it and/or modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation; either version 1, or (at your +;;; option) any later version. +;;; +;;; BBDB is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Emacs; see the file COPYING. If not, write to +;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;;; +;;; This module is for exporting BBDB databases into a comma delimited +;;; text file, which can be imported into microsoft outlook contact forms and +;;; ms address book. +;;; +;;; USE: In the *BBDB* buffer, type O to convert the listing to text format. +;;; It will prompt you for a filename. And then you can import the file +;;; into Microsoft outlook contacts and outlook express address boook +;;; etc. +;;; +;;; INSTALLATION: Put this file somewhere on your load-path. +;;; Put (require 'bbdb-to-outlook) in your .emacs, or autoload it. +;;; +;;; + +(require 'bbdb) +(require 'bbdb-com) + +(define-key bbdb-mode-map "O" 'bbdb-to-outlook) + +;;; +;;; Variables +;;; + +(defvar bbdb-to-outlook-file-name "~/bbdb.txt" + "*Default file name for printouts of BBDB database.") + +(defvar bbdb-to-outlook-prolog + (concat "\"First Name\"" + ",\"Last Name\"" + ",\"Company\"" + + ;; phones + ",\"Business Phone\"" + ",\"Home Phone\"" + ",\"Business Fax\"" + ",\"Car Phone\"" + ",\"Pager\"" + + ;; EMAIL + ",\"E-mail Address\"" + ",\"E-mail 2 Address\"" + ",\"\"E-mail 3 Address\"" + + ;; addresses + ",\"Business Street\"" + ",\"\"Business Street 2\"" + ",\"\"Business Street 3\"" + ",\"Business City\"" + ",\"Business State\"" + ",\"Business Postal Code\"" + + ",\"Home Street\"" + ",\"\"Home Street 2\"" + ",\"\"Home Street 3\"" + ",\"Home City\"" + ",\"Home State\"" + ",\"Home Postal Code\"" + + ;; notes + ; ",\"Nickname\"" doesn't work + ",\"Notes\"" + + ;; end of prolog + "\n" + ) + "*TeX statements to include at the beginning of the bbdb-to-outlook file.") + +(defvar bbdb-to-outlook-epilog "" + "*TeX statements to include at the end of the bbdb-to-outlook file.") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun bbdb-to-outlook (to-file) + "Outlook the selected BBDB entries" + (interactive (list (read-file-name "To File: " bbdb-to-outlook-file-name))) + (setq bbdb-to-outlook-file-name (expand-file-name to-file)) + (let ((current-letter t) + (records (progn (set-buffer bbdb-buffer-name) + bbdb-records))) + (find-file bbdb-to-outlook-file-name) + (delete-region (point-min) (point-max)) + (while records + (setq current-letter + (bbdb-to-outlook-format-record (car (car records)) current-letter)) + (setq records (cdr records))) + (goto-char (point-min)) (insert bbdb-to-outlook-prolog) + (goto-char (point-max)) (insert bbdb-to-outlook-epilog) + (goto-char (point-min)))) + +(defun bbdb-to-outlook-format-record (record &optional current-letter brief) + "Insert the bbdb RECORD in TeX format. +Optional CURRENT-LETTER is the section we're in -- if this is non-nil and +the first letter of the sortkey of the record differs from it, a new section +heading will be outlook \(an arg of t will always produce a heading). +The new current-letter is the return value of this function. +Someday, optional third arg BRIEF will produce one-line format." + (bbdb-debug (if (bbdb-record-deleted-p record) + (error "plus ungood: tex formatting deleted record"))) + + (let* ((first-letter + (substring (concat (bbdb-record-sortkey record) "?") 0 1)) + (lname (and (bbdb-field-shown-p 'name) + (bbdb-record-lastname record))) + (fname (and (bbdb-field-shown-p 'name) + (bbdb-record-firstname record))) + (comp (and (bbdb-field-shown-p 'company) + (bbdb-record-company record))) + (net (and (bbdb-field-shown-p 'net) + (bbdb-record-net record))) + (phones (and (bbdb-field-shown-p 'phone) + (bbdb-record-phones record))) + (addrs (and (bbdb-field-shown-p 'address) + (bbdb-record-addresses record))) + (aka (and (bbdb-field-shown-p 'aka) + (bbdb-record-aka record))) + (notes (bbdb-record-raw-notes record)) + (begin (point))) + + ;; Section header, if neccessary. + + ;; name + (insert (format "\"%s\"" (bbdb-to-outlook-if-not-blank fname))) + (insert (format ",\"%s\"" (bbdb-to-outlook-if-not-blank lname))) + (insert (format ",\"%s\"" (bbdb-to-outlook-if-not-blank comp))) + + ;; Phone numbers + (insert (bbdb-to-outlook-phone phones "work\\|office")) + (insert (bbdb-to-outlook-phone phones "home")) + (insert (bbdb-to-outlook-phone phones "fax")) + (insert (bbdb-to-outlook-phone phones "car\\|mobile")) + (insert (bbdb-to-outlook-phone phones "page")) + + ;; Email address + ;; at most three email address + (insert (format ",\"%s\"" (bbdb-to-outlook-if-not-blank (car net)))) + (setq net (cdr net)) + (insert (format ",\"%s\"" (bbdb-to-outlook-if-not-blank (car net)))) + (setq net (cdr net)) + (insert (format ",\"%s\"" (bbdb-to-outlook-if-not-blank (car net)))) + (setq net (cdr net)) + + ;; Addresses + (insert (bbdb-to-outlook-address addrs "work\\|office")) + (insert (bbdb-to-outlook-address addrs "home")) + + ;; Notes + (if (stringp notes) + (setq notes (list (cons 'notes notes)))) + +; (if aka +; (insert (format ",\"%s\"" +; (mapconcat (function identity) aka ", "))) +; (insert ",\"\"")) +; + (insert ",\"") + (while notes + (let ((thisnote (car notes))) + (if (bbdb-field-shown-p (car thisnote)) + (progn + (if (eq 'notes (car thisnote)) + (insert (format "Note: %s\n" + (bbdb-print-outlook-quote (cdr thisnote)))) + (if (not (eq 'mail-folders (car thisnote))) + (insert (format "%s: %s\n" + (bbdb-print-outlook-quote + (symbol-name (car thisnote))) + (bbdb-print-outlook-quote + (cdr thisnote)))))) + (setq notes (cdr notes)))))) + + (if aka (insert (format "AKA: %s\n" + (mapconcat (function identity) aka ", ")))) + + (insert "\"") + + ;; end of everything + (insert "\n") + ;; If record is bare, delete anything we may have inserted. + ;; otherwise, mark the end of this record. + current-letter)) + +(defun bbdb-to-outlook-if-not-blank (string &rest more) + "If STRING is not null, then return it concatenated +with rest of arguments. If it is null, then all arguments are +ignored and the null string is returned." + (if (or (null string) (equal "" string)) + "" + (apply 'concat string more))) + +(defun bbdb-print-outlook-quote (string) + "replace \" with \' in the string" + (let (i) + (while (setq i (string-match "\"" string i)) + (setq string (concat (substring string 0 i) "\'" (substring string (1+ i)))))) + string) + +(defun bbdb-to-outlook-phone (phones pattern) + (let ((found nil) + (result ",\"\"")) + (while (and phones (not found)) + (let ((place (downcase (aref (car phones) 0))) + (number (bbdb-phone-string (car phones)))) + (if (setq found (string-match pattern place)) + (setq result (format ",\"%s\"" number))) + (setq phones (cdr phones)))) + result)) + + +(defun bbdb-to-outlook-address (addrs pattern) + (let ((found nil) + (result ",\"\",\"\",\"\",\"\",\"\",\"\"")) + (while addrs + (let ((place (downcase (aref (car addrs) 0))) + (addr (car addrs))) + (if (setq found (string-match pattern place)) + (setq result + (format + ",\"%s\",\"%s\",\"%s\",\"%s\",\"%s\",\"%s\"" + (bbdb-to-outlook-if-not-blank (bbdb-address-street1 addr)) + (bbdb-to-outlook-if-not-blank (bbdb-address-street2 addr)) + (bbdb-to-outlook-if-not-blank (bbdb-address-street3 addr)) + (bbdb-to-outlook-if-not-blank (bbdb-address-city addr)) + (bbdb-to-outlook-if-not-blank (bbdb-address-state addr)) + (bbdb-to-outlook-if-not-blank (bbdb-address-zip-string addr)) + ))) + (setq addrs (cdr addrs)))) + result)) + +(provide 'bbdb-to-outlook) + + |