cgit.sxemacs.org Git - packages/blob - xemacs-packages/bbdb/utils/bbdb-to-netscape.el

   1 ;;; -*- Mode:Emacs-Lisp -*-
   2
   3 ;;; This file is the part of the Insidious Big Brother Database (aka BBDB),
   4 ;;; copyright (c) 1991, 1992, 1993, 1995 Jamie Zawinski <jwz@lucid.com>.
   5 ;;; Converting a BBDB database to a Netscape Address Book.
   6 ;;; last change21-feb-97.
   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 2, 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 attempts to convert a BBDB database to a Netscape Address Book
  23 ;;; file.  It doesn't work very well.  If you fix it, let me know.  -- jwz
  24
  25 (require 'bbdb)
  26
  27 (defun bbdb-mozilla-insert-url (string)
  28   (let ((p (point))
  29         c)
  30     (insert string)
  31     (goto-char (prog1 p (setq p (point))))
  32     (while (progn
  33              (skip-chars-forward "-a-zA-Z0-9.@/_\r\n" p)
  34              (< (point) p))
  35       (setq c (following-char))
  36       (delete-char 1)
  37       (insert (format "%%%02X" c))
  38       (setq p (+ 2 p)))
  39     (goto-char p)))
  40
  41 (defun bbdb-mozilla-insert-html (string)
  42   (let ((p (point))
  43         c)
  44     (insert string)
  45     (goto-char (prog1 p (setq p (point))))
  46     (while (progn
  47              (skip-chars-forward "^&<>" p)
  48              (< (point) p))
  49       (setq c (following-char))
  50       (delete-char 1)
  51       (cond ((= c ?&) (insert "&amp;") (setq p (+ p 4)))
  52             ((= c ?<) (insert "&lt;") (setq p (+ p 3)))
  53             (t (insert "&gt;") (setq p (+ p 3)))))
  54     (goto-char p)))
  55
  56 (defun bbdb-mozilla-emit-record (record aliases)
  57   (let (addr)
  58     (cond ((setq addr (car (bbdb-record-net record)))
  59            (insert "    <DT><A HREF=\"mailto:")
  60            (bbdb-mozilla-insert-url addr)
  61            (insert "\"")
  62            (let ((nick nil))
  63              (cond (nick
  64                     (insert " NICKNAME=\"")
  65                     (bbdb-mozilla-insert-html nick)
  66                     (insert "\"")))
  67              (insert ">"))
  68            (let ((name (or (bbdb-record-name record)
  69                            (bbdb-record-company record)
  70                            "")))
  71              (bbdb-mozilla-insert-html name))
  72            (insert "</A>\n")
  73            (let ((notes nil))
  74              (cond (notes
  75                     )))
  76            t)
  77           (t nil))))
  78
  79 (defun bbdb-to-netscape ()
  80   (let* ((target (cons bbdb-define-all-aliases-field
  81                        "^[a-z, ]+$"))
  82          (records1 (bbdb-search (bbdb-records)
  83                                 nil                     ; name
  84                                 nil                     ; company
  85                                 nil ;"netscape\\.com"   ; net
  86                                 target                  ; notes
  87                                 ))
  88          (records records1)
  89          result record aliases match
  90          (lists nil)
  91          (single-aliases nil)
  92          (count 0)
  93          )
  94     (message "%d" (length records1))
  95     (while records
  96       (setq record (car records))
  97       (setq aliases (bbdb-record-getprop record bbdb-define-all-aliases-field))
  98       (setq aliases (and aliases (bbdb-split aliases ",")))
  99       (while aliases
 100         (if (setq match (assoc (car aliases) result))
 101             (nconc match (cons record nil))
 102           (setq result (cons (list (car aliases) record) result)))
 103         (setq aliases (cdr aliases)))
 104       (setq records (cdr records)))
 105     (while result
 106       (let ((alias (downcase (car (car result))))
 107             (expansion (cdr (car result))))
 108         (cond
 109          ((cdr expansion)
 110           (setq lists (cons (cons alias expansion) lists)))
 111          (expansion
 112           (setq single-aliases (cons (cons (car expansion) alias)
 113                                      single-aliases))))
 114         (setq result (cdr result))))
 115
 116 ;    (setq records (bbdb-records))
 117     (setq records records1)
 118     (set-buffer (get-buffer-create "*netscape-address-book*"))
 119     (erase-buffer)
 120     (insert "<!DOCTYPE NETSCAPE-Addressbook-file-1>\n"
 121             "<!-- This is an automatically generated file.\n"
 122             "It will be read and overwritten.\n"
 123             "Do Not Edit! -->\n"
 124             "<TITLE>" (user-full-name) "'s Address book</TITLE>\n"
 125             "<H1>" (user-full-name) "'s Address book</H1>\n"
 126             "\n"
 127             "<DL><p>\n")
 128     (while records
 129       (setq record (car records))
 130       (insert "    <DT><A HREF=\"mailto:")
 131       (let ((net (car (bbdb-record-net record))))
 132         (if net (insert net))
 133         (insert "\" ALIASID=\"")
 134         (prin1 count (current-buffer))
 135         (insert "\"")
 136         (message "%d..." count)
 137         (setq count (1+ count))
 138         (cond ((setq match (cdr (assq record single-aliases)))
 139                (insert " NICKNAME=\"")
 140                (princ match (current-buffer))
 141                (insert "\"")))
 142         (insert ">")
 143         (insert (or (bbdb-record-name record)
 144                     net
 145                     (bbdb-record-company record)
 146                     "")))
 147
 148       (insert "</A>\n")
 149       (let ((phones (bbdb-record-phones record))
 150             (addrs (bbdb-record-addresses record))
 151             (aka (bbdb-record-aka record))
 152             phone
 153             )
 154
 155         (insert "<DD>")
 156         (setq match nil)
 157         (while phones
 158           (setq phone (car phones))
 159           (setq match t)
 160           (insert (format " %14s: " (bbdb-phone-location phone)))
 161           (insert (bbdb-phone-string phone) "\n<BR>")
 162           (setq phones (cdr phones)))
 163         (let (addr c s)
 164           (while addrs
 165             (setq addr (car addrs))
 166             (setq match t)
 167             (insert (format " %14s: " (bbdb-address-location addr)))
 168             (if (= 0 (length (setq s (bbdb-address-street1 addr)))) nil
 169               (indent-to 17) (insert s "\n<BR>"))
 170             (if (= 0 (length (setq s (bbdb-address-street2 addr)))) nil
 171               (indent-to 17) (insert s "\n<BR>"))
 172             (if (= 0 (length (setq s (bbdb-address-street3 addr)))) nil
 173               (indent-to 17) (insert s "\n<BR>"))
 174             (indent-to 17)
 175             (insert (setq c (bbdb-address-city addr)))
 176             (setq s (bbdb-address-state addr))
 177             (if (and (> (length c) 0) (> (length s) 0)) (insert ", "))
 178             (insert s "  ")
 179             (insert (bbdb-address-zip-string addr) "\n<BR>")
 180             (setq addrs (cdr addrs))))
 181         (cond (aka
 182                (setq match t)
 183                (insert (format " %14s: %s\n<BR>" "AKA"
 184                                (mapconcat (function identity) aka ", ")))))
 185         (let ((notes (bbdb-record-raw-notes record)))
 186           (if (stringp notes)
 187               (setq notes (list (cons 'notes notes))))
 188           (while notes
 189             (if (memq (car (car notes))
 190                       '(mail-alias password bbdb mail-name face mark-char aka))
 191                 nil
 192               (setq match t)
 193               (insert (format " %14s: " (car (car notes))))
 194               (let ((p (point)))
 195                 (insert (cdr (car notes)))
 196                 (save-excursion
 197                   (save-restriction
 198                     (narrow-to-region p (1- (point)))
 199                     (goto-char (1+ p))
 200                     (while (search-forward "\n" nil t)
 201                       (forward-char -1)
 202                       (insert "<BR>")
 203                       (forward-char 1)
 204                       (insert (make-string 17 ?\ )))))
 205                 (insert "\n")))
 206             (setq notes (cdr notes)))))
 207
 208       (or match (delete-char -4))
 209
 210       (setq records (cdr records))
 211       )
 212     (insert "</DL><p>\n")
 213     ))