lisp/net/eudc-export.el

   1 ;;; eudc-export.el --- functions to export EUDC query results
   2
   3 ;; Copyright (C) 1998-2017 Free Software Foundation, Inc.
   4
   5 ;; Author: Oscar Figueiredo <oscar@cpe.fr>
   6 ;;         Pavel Janík <Pavel@Janik.cz>
   7 ;; Maintainer: Thomas Fitzsimmons <fitzsim@fitzsim.org>
   8 ;; Keywords: comm
   9 ;; Package: eudc
  10
  11 ;; This file is part of GNU Emacs.
  12
  13 ;; GNU Emacs is free software: you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation, either version 3 of the License, or
  16 ;; (at your option) any later version.
  17
  18 ;; GNU Emacs is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  25
  26 ;;; Commentary:
  27
  28 ;;; Usage:
  29 ;;    See the corresponding info file
  30
  31 ;;; Code:
  32
  33 (require 'eudc)
  34
  35 ;; NOERROR is so we can compile it.
  36 (require 'bbdb nil t)
  37 (require 'bbdb-com nil t)
  38
  39 (defun eudc-create-bbdb-record (record &optional silent)
  40   "Create a BBDB record using the RECORD alist.
  41 RECORD is an alist of (KEY . VALUE) where KEY is a directory attribute name
  42 symbol and VALUE is the corresponding value for the record.
  43 If SILENT is non-nil then the created BBDB record is not displayed."
  44   (require 'bbdb)
  45   ;; This function runs in a special context where lisp symbols corresponding
  46   ;; to field names in record are bound to the corresponding values
  47   (eval
  48    `(let* (,@(mapcar (lambda (c)
  49                         (list (car c) (if (listp (cdr c))
  50                                           (list 'quote (cdr c))
  51                                         (cdr c))))
  52                      record)
  53              bbdb-name
  54              bbdb-company
  55              bbdb-net
  56              bbdb-address
  57              bbdb-phones
  58              bbdb-notes
  59              spec
  60              bbdb-record
  61              value
  62              (conversion-alist (symbol-value eudc-bbdb-conversion-alist)))
  63
  64       ;; BBDB standard fields
  65       (setq bbdb-name (eudc-parse-spec (cdr (assq 'name conversion-alist)) record nil)
  66             bbdb-company (eudc-parse-spec (cdr (assq 'company conversion-alist)) record nil)
  67             bbdb-net (eudc-parse-spec (cdr (assq 'net conversion-alist)) record nil)
  68             bbdb-notes (eudc-parse-spec (cdr (assq 'notes conversion-alist)) record nil))
  69       (setq spec (cdr (assq 'address conversion-alist)))
  70       (setq bbdb-address (delq nil (eudc-parse-spec (if (listp (car spec))
  71                                                       spec
  72                                                     (list spec))
  73                                                   record t)))
  74       (setq spec (cdr (assq 'phone conversion-alist)))
  75       (setq bbdb-phones (delq nil (eudc-parse-spec (if (listp (car spec))
  76                                                      spec
  77                                                    (list spec))
  78                                                  record t)))
  79       ;; BBDB custom fields
  80       (setq bbdb-notes (append (list (and bbdb-notes (cons 'notes bbdb-notes)))
  81                                (mapcar (function
  82                                         (lambda (mapping)
  83                                           (if (and (not (memq (car mapping)
  84                                                               '(name company net address phone notes)))
  85                                                    (setq value (eudc-parse-spec (cdr mapping) record nil)))
  86                                               (cons (car mapping) value))))
  87                                        conversion-alist)))
  88       (setq bbdb-notes (delq nil bbdb-notes))
  89       (setq bbdb-record (bbdb-create-internal
  90                          bbdb-name
  91                          ,@(when (eudc--using-bbdb-3-or-newer-p)
  92                              '(nil
  93                                nil))
  94                          bbdb-company
  95                          bbdb-net
  96                          ,@(if (eudc--using-bbdb-3-or-newer-p)
  97                                '(bbdb-phones
  98                                  bbdb-address)
  99                              '(bbdb-address
 100                                bbdb-phones))
 101                          bbdb-notes))
 102       (or silent
 103           (bbdb-display-records (list bbdb-record))))))
 104
 105 (defun eudc-parse-spec (spec record recurse)
 106   "Parse the conversion SPEC using RECORD.
 107 If RECURSE is non-nil then SPEC may be a list of atomic specs."
 108   (cond
 109    ((or (stringp spec)
 110         (symbolp spec)
 111         (and (listp spec)
 112              (symbolp (car spec))
 113              (fboundp (car spec))))
 114     (condition-case nil
 115         (eval spec)
 116       (void-variable nil)))
 117    ((and recurse
 118          (listp spec))
 119     (mapcar (lambda (spec-elem)
 120                (eudc-parse-spec spec-elem record nil))
 121             spec))
 122    (t
 123     (error "Invalid specification for `%s' in `eudc-bbdb-conversion-alist'" spec))))
 124
 125 (defun eudc-bbdbify-address (addr location)
 126   "Parse ADDR into a vector compatible with BBDB.
 127 ADDR should be an address string of no more than four lines or a
 128 list of lines.
 129 The last two lines are searched for the zip code, city and state name.
 130 LOCATION is used as the address location for bbdb."
 131   (let* ((addr-components (if (listp addr)
 132                               (reverse addr)
 133                             (reverse (split-string addr "\n"))))
 134          (last1 (pop addr-components))
 135          (last2 (pop addr-components))
 136          zip city state)
 137     (setq addr-components (nreverse addr-components))
 138     ;; If not containing the zip code the last line is supposed to contain a
 139     ;; country name and the address is supposed to be in european style
 140     (if (not (string-match "[0-9][0-9][0-9]" last1))
 141         (progn
 142           (setq state last1)
 143           (if (string-match "\\([0-9]+\\)[ \t]+\\(.*\\)" last2)
 144               (setq city (match-string 2 last2)
 145                     zip (string-to-number (match-string 1 last2)))
 146             (error "Cannot parse the address")))
 147       (cond
 148        ;; American style
 149        ((string-match "\\(\\w+\\)\\W*\\([A-Z][A-Z]\\)\\W*\\([0-9]+\\)" last1)
 150         (setq city (match-string 1 last1)
 151               state (match-string 2 last1)
 152               zip (string-to-number (match-string 3 last1))))
 153        ;; European style
 154        ((string-match "\\([0-9]+\\)[ \t]+\\(.*\\)" last1)
 155         (setq city (match-string 2 last1)
 156               zip (string-to-number (match-string 1 last1))))
 157        (t
 158         (error "Cannot parse the address"))))
 159     (vector location
 160             (or (nth 0 addr-components) "")
 161             (or (nth 1 addr-components) "")
 162             (or (nth 2 addr-components) "")
 163             (or city "")
 164             (or state "")
 165             zip)))
 166
 167 ;; External.
 168 (declare-function bbdb-parse-phone-number "ext:bbdb-com"
 169                   (string &optional number-type))
 170 (declare-function bbdb-parse-phone "ext:bbdb-com" (string &optional style))
 171 (declare-function bbdb-string-trim "ext:bbdb" (string))
 172
 173 (defun eudc-bbdbify-company (&rest organizations)
 174   "Return ORGANIZATIONS as a list compatible with BBDB."
 175   organizations)
 176
 177 (defun eudc-bbdbify-phone (phone location)
 178   "Parse PHONE into a vector compatible with BBDB.
 179 PHONE is either a string supposedly containing a phone number or
 180 a list of such strings which are concatenated.
 181 LOCATION is used as the phone location for BBDB."
 182   (require 'bbdb)
 183   (cond
 184    ((stringp phone)
 185     (let (phone-list)
 186       (condition-case err
 187           (setq phone-list (if (eudc--using-bbdb-3-or-newer-p)
 188                                (bbdb-parse-phone phone)
 189                              (bbdb-parse-phone-number phone)))
 190         (error
 191          (if (string= "phone number unparsable." (cadr err))
 192              (if (not (y-or-n-p (format "BBDB claims %S to be unparsable--insert anyway? " phone)))
 193                  (error "Phone number unparsable")
 194                (setq phone-list (list (bbdb-string-trim phone))))
 195            (signal (car err) (cdr err)))))
 196       (if (= 3 (length phone-list))
 197           (setq phone-list (append phone-list '(nil))))
 198       (apply 'vector location phone-list)))
 199    ((listp phone)
 200     (vector location (mapconcat 'identity phone ", ")))
 201    (t
 202     (error "Invalid phone specification"))))
 203
 204 (defun eudc-batch-export-records-to-bbdb ()
 205   "Insert all the records returned by a directory query into BBDB."
 206   (interactive)
 207   (require 'bbdb)
 208   (goto-char (point-min))
 209   (let ((nbrec 0)
 210         record)
 211     (while (eudc-move-to-next-record)
 212       (and (overlays-at (point))
 213            (setq record (overlay-get (car (overlays-at (point))) 'eudc-record))
 214            (1+ nbrec)
 215            (eudc-create-bbdb-record record t)))
 216     (message "%d records imported into BBDB" nbrec)))
 217
 218 ;;;###autoload
 219 (defun eudc-insert-record-at-point-into-bbdb ()
 220   "Insert record at point into the BBDB database.
 221 This function can only be called from a directory query result buffer."
 222   (interactive)
 223   (require 'bbdb)
 224   (let ((record (and (overlays-at (point))
 225                      (overlay-get (car (overlays-at (point))) 'eudc-record))))
 226     (if (null record)
 227         (error "Point is not over a record")
 228       (eudc-create-bbdb-record record))))
 229
 230 ;;;###autoload
 231 (defun eudc-try-bbdb-insert ()
 232   "Call `eudc-insert-record-at-point-into-bbdb' if on a record."
 233   (interactive)
 234   (require 'bbdb)
 235   (and (overlays-at (point))
 236        (overlay-get (car (overlays-at (point))) 'eudc-record)
 237        (eudc-insert-record-at-point-into-bbdb)))
 238
 239 ;;; eudc-export.el ends here