cgit.sxemacs.org Git - packages/blob - xemacs-packages/bbdb/lisp/bbdb-whois.el

   1 ;;; bbdb-whois.el -- Big Brother gets a little help from Big Brother
   2 ;;; This file is part of the Insidious Big Brother Database (aka BBDB).
   3 ;;;
   4 ;;; Copyright (C) 1992, 1993 Roland McGrath
   5 ;;;
   6 ;;; This program is free software; you can redistribute it and/or modify
   7 ;;; it under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 2, or (at your option)
   9 ;;; any later version.
  10 ;;;
  11 ;;; This program is distributed in the hope that it will be useful,
  12 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; A copy of the GNU General Public License can be obtained from this
  17 ;;; program's author (send electronic mail to roland@gnu.ai.mit.edu) or
  18 ;;; from the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA
  19 ;;; 02139, USA.
  20 ;;;
  21 ;;; Send bug reports to bbdb@waider.ie
  22
  23 (require 'bbdb-com)
  24
  25 (defmacro bbdb-add-to-field (record field text)
  26   (let ((get (intern (concat "bbdb-record-" (symbol-name field))))
  27     (set (intern (concat "bbdb-record-set-" (symbol-name field)))))
  28     (` (let ((old ((, get) (, record)))
  29          (text (, text)))
  30      (or (member text old)
  31          ((, set) (, record) (nconc old (list text))))))))
  32
  33 (defcustom bbdb-whois-server (or (and (boundp 'whois-server) whois-server)
  34                                  "whois.geektools.com")
  35   "*Server for \\[bbdb-whois] lookups."
  36   :group 'bbdb-utilities
  37   :type 'string)
  38
  39 (defvar bbdb-whois-name nil
  40   "Used to store the name during a whois call.")
  41 (make-variable-buffer-local 'bbdb-whois-name)
  42 (defvar bbdb-whois-record nil
  43   "Used to store the record during a whois call.")
  44 (make-variable-buffer-local 'bbdb-whois-record)
  45
  46 ;;; main entry point. it'd be nice if we could bbdb-whois an arbitrary
  47 ;;; name and make a record from that directly.
  48
  49 ;;;###autoload
  50 (defun bbdb-whois (the-record &optional server)
  51   (interactive (list (bbdb-get-record "BBDB Whois: ")
  52              (and current-prefix-arg
  53               (read-string "Query whois server: "
  54                        bbdb-whois-server))))
  55   (or server (setq server bbdb-whois-server))
  56   (if (or (bbdb-record-lastname the-record) (bbdb-record-firstname the-record))
  57       ;; XXX we seem to get called with a vector of nils.
  58       (save-excursion
  59     (set-buffer (generate-new-buffer " *bbdb-whois*"))
  60     (set bbdb-whois-record the-record)
  61     (set bbdb-whois-name
  62          (if (bbdb-record-getprop the-record 'nic)
  63              (concat "!" (bbdb-record-getprop the-record 'nic))
  64            (concat (bbdb-record-lastname the-record) ", "
  65                    (bbdb-record-firstname the-record))))
  66     (let ((proc (open-network-stream "whois" (current-buffer) server 43)))
  67       (set-process-sentinel proc 'bbdb-whois-sentinel)
  68       (process-send-string proc (concat bbdb-whois-name "\r\n"))))))
  69
  70 ;;; This function parses the results from the server.
  71 (defun bbdb-whois-sentinel (proc status)
  72   (save-excursion
  73     (let (rec)
  74       (set-buffer (process-buffer proc))
  75       (setq rec bbdb-whois-record)
  76       (goto-char 1)
  77
  78       ;; check for multiple replies
  79       ;; should maybe present a menu/completion buffer of multiples and do a
  80       ;; refetch.
  81       (if (not (re-search-forward "Record last updated" (point-max) t))
  82           (if (re-search-forward "No match" (point-max) t)
  83               (message "Can not find a whois record for `%s'" bbdb-whois-name)
  84             (if (re-search-forward "Access Limit Exceeded" (point-max) t)
  85                 (message "Per-day access limit to %s exceeded."
  86                          bbdb-whois-server) ;; bah!
  87               (message "%s is ambiguous to whois; try a different name"
  88                        bbdb-whois-name)))
  89
  90         ;; clean up & parse buffer, otherwise.
  91         (replace-string "\r\n" "\n")
  92         (goto-char 1)
  93         (if (re-search-forward
  94              (concat (if (string-match "^!" bbdb-whois-name)
  95                          (concat "(\\("
  96                                  (regexp-quote (substring bbdb-whois-name 1))
  97                  "\\))")
  98                (concat (regexp-quote bbdb-whois-name)
  99                    ".*(\\([A-Z0-9]+\\))"))
 100              "\\s *\\(\\S +@\\S +\\)?$")
 101          nil t)
 102         (let ((net (if (match-beginning 2)
 103                (downcase (buffer-substring (match-beginning 2)
 104                                (match-end 2)))))
 105           (nic (buffer-substring (match-beginning 1) (match-end 1)))
 106           (lines nil))
 107           (if net
 108           (bbdb-add-to-field rec net net))
 109           (bbdb-record-putprop rec 'nic nic)
 110
 111           ;; Snarf company.
 112           ;; not all nic records have companies, though.
 113           (forward-line 1)
 114           (back-to-indentation)
 115           (let ((company (buffer-substring (point) (progn (end-of-line)
 116                                   (point))))
 117             (old (bbdb-record-company rec)))
 118         (cond ((not old)
 119                (bbdb-record-set-company rec company))
 120               ((string= old company)
 121                nil)
 122               (t
 123                (bbdb-record-putprop rec 'nic-organization company))))
 124
 125           ;; Read the address info into LINES.
 126           (while (progn (forward-line 1)
 127                 (not (looking-at "^$")))
 128             (back-to-indentation)
 129             (setq lines (cons (buffer-substring (point)
 130                                                 (progn (end-of-line)
 131                                                        (point)))
 132                               lines)))
 133
 134           ;; Snarf phone number.
 135           ;; phone, fax are presented, it seems, as
 136           ;; +country area prefix number +country area prefix number
 137           ;; we can look for the " +" and split there, I guess.
 138           (if (car lines)
 139               (let ((phones (car lines))
 140                     (n 1)
 141                     phone-numbers)
 142                 (while (string-match "^\\(.+\\) \\+" phones)
 143                   (setq phone-numbers
 144                         (append phone-numbers
 145                                 (list (substring phones 0 (match-end 1))))
 146                         phones (substring phones (+ 1 (match-end 1)))))
 147                 (setq phone-numbers (append phone-numbers
 148                                             (list phones)))
 149
 150                 ;; now add each member of the list to the bbdb record
 151                 ;; it'd be nice if we could be smarter about this.
 152                 (mapcar (function
 153                          (lambda(p)
 154                            (if (not (bbdb-find-phone
 155                                      p (bbdb-record-phones rec)))
 156                                (let ((p-n
 157                                       (vector (format "nic-phone-%d" n) p)))
 158                                  (bbdb-add-to-field rec phones p-n)
 159                                  (setq n (+ 1 n))))))
 160                         phone-numbers)
 161
 162                 ;; throw away phones line from what we've snarfed
 163                 (setq lines (cdr lines))))
 164
 165           ;; Snarf address.
 166           (if (car lines)
 167               (let ((addr (make-vector bbdb-address-length nil))
 168                     (city "")
 169                     (state "")
 170                     (zip "")
 171                     (country ""))
 172
 173                 ;; extract country
 174                 (if (string-match "^[A-Z][A-Z]$" (car lines))
 175                     (setq country (car lines) ;; could convert from ISO...
 176                           lines (cdr lines)))
 177
 178                 ;; extract city, state, zip
 179                 ;; it would be nice if this could all use bbdb-snarf.
 180                 ;; or if NICs would hand out something machine
 181                 ;; readable, like <shudder> XML.
 182                 ;;
 183                 ;; note the zipcode check at the end of the regexp
 184                 ;; isn't really a zipcode check, because we don't do
 185                 ;; zipcode checks any more.
 186                 (if (string-match
 187                      "\\([^,]+\\),\\s *\\(\\S +\\)\\s *\\(.+\\)"
 188                      (car lines))
 189                     (setq city (substring (car lines)
 190                                           (match-beginning 1)
 191                                           (match-end 1))
 192                           state (substring (car lines)
 193                                            (match-beginning 2)
 194                                            (match-end 2))
 195                           zip (substring (car lines)
 196                                          (match-beginning 3)
 197                                          (match-end 3))
 198                           lines (cdr lines))
 199                   ;; otherwise we just stuff everything into the
 200                   ;; streets list and let the user clean it up. This
 201                   ;; would be nice to do heuristically, if I knew
 202                   ;; enough about variable address formats.
 203                   ;; (bbdb-snarf-grok-address (ADDR)) would be neat.
 204                   )
 205
 206                 (bbdb-address-set-location addr "nic-address")
 207                 (bbdb-address-set-city addr (or city ""))
 208                 (bbdb-address-set-state addr (or state ""))
 209                 (bbdb-address-set-zip addr (or zip ""))
 210                 (bbdb-address-set-country addr (or country ""))
 211                 (setq lines (nreverse lines))
 212                 (bbdb-address-set-streets addr lines)
 213
 214                 ;; should probably overwrite existing nic-address field.
 215                 (bbdb-add-to-field rec addresses addr)))
 216
 217           ;; Snarf any random notes.
 218           (setq lines nil)
 219           (while (progn
 220                    (forward-line 1)
 221                    (back-to-indentation)
 222                    (not (looking-at
 223                          "$\\|Record last updated on")))
 224             (if (looking-at "Alternate mailbox: \\(\\S +\\)$")
 225                 (bbdb-add-to-field rec net
 226                                    (buffer-substring (match-beginning 1)
 227                                                      (match-end 1)))
 228               (setq lines (cons (buffer-substring (point)
 229                                                   (progn (end-of-line)
 230                                                          (point)))
 231                                 lines))))
 232           (if lines
 233               (bbdb-record-putprop rec 'nic-notes
 234                                    (mapconcat 'identity
 235                                               (nreverse lines)
 236                                               "\n")))
 237
 238           ;; Snarf the last-update date.
 239           (if (re-search-forward "Record last updated on \\(\\S *\\)\\."
 240                                  nil t)
 241               (bbdb-record-putprop rec 'nic-updated
 242                                    (buffer-substring (match-beginning 1)
 243                                                      (match-end 1))))
 244
 245           (save-excursion
 246             (set-buffer bbdb-buffer-name)
 247             (bbdb-redisplay-one-record rec)))
 248         (message "No whois information for %s" bbdb-whois-name)))
 249       (delete-process proc)
 250       (kill-buffer (current-buffer)))))
 251
 252 (defun bbdb-find-phone (string record)
 253   "Return the vector entry if STRING is a phone number listed in RECORD."
 254   (let ((phone nil)
 255     (done nil))
 256     (while (and record (not done))
 257       (setq phone (car record))
 258       (if (string= string (bbdb-phone-string phone))
 259       (setq done phone))
 260       (setq record (cdr record)))
 261     done))
 262
 263 (provide 'bbdb-whois)