home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / packages / bbdb / bbdb-whois.el < prev    next >
Encoding:
Text File  |  1992-08-29  |  6.6 KB  |  197 lines
  1. ;;; bbdb-whois.el -- Big Brother gets a little help from Big Brother
  2. ;;;
  3. ;;; Copyright (C) 1992 Roland McGrath
  4. ;;;
  5. ;;; This program is free software; you can redistribute it and/or modify
  6. ;;; it under the terms of the GNU General Public License as published by
  7. ;;; the Free Software Foundation; either version 2, or (at your option)
  8. ;;; any later version.
  9. ;;;
  10. ;;; This program is distributed in the hope that it will be useful,
  11. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13. ;;; GNU General Public License for more details.
  14. ;;;
  15. ;;; A copy of the GNU General Public License can be obtained from this
  16. ;;; program's author (send electronic mail to roland@gnu.ai.mit.edu) or
  17. ;;; from the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA
  18. ;;; 02139, USA.
  19. ;;;
  20. ;;; Send bug reports to roland@gnu.ai.mit.edu.
  21.  
  22. (require 'bbdb-com)
  23.  
  24. (defmacro bbdb-add-to-field (record field text)
  25.   (let ((get (intern (concat "bbdb-record-" (symbol-name field))))
  26.     (set (intern (concat "bbdb-record-set-" (symbol-name field)))))
  27.     (` (let ((old ((, get) (, record)))
  28.          (text (, text)))
  29.      (or (member text old)
  30.          ((, set) (, record) (nconc old (list text))))))))
  31.  
  32. (defvar bbdb-whois-server "nic.ddn.mil"
  33.   "Server for \\[bbdb-whois] lookups.")
  34.  
  35. ;;;###autoload
  36. (defun bbdb-whois (the-record &optional server)
  37.   (interactive (list (if (string= bbdb-buffer-name (buffer-name))
  38.              (bbdb-current-record)
  39.                (let (r (p "BBDB Whois: "))
  40.              (while (not r)
  41.                (setq r (bbdb-completing-read-record p))
  42.                (if (not r) (ding))
  43.                (setq p "Not in the BBDB!  Whois: "))
  44.              r))
  45.              (and current-prefix-arg
  46.               (read-string "Query whois server: "
  47.                        bbdb-whois-server))))
  48.   (or server
  49.       (setq server bbdb-whois-server))
  50.   (save-excursion
  51.     (set-buffer (generate-new-buffer " *bbdb-whois*"))
  52.     (set (make-local-variable 'bbdb-whois-record) the-record)
  53.     (set (make-local-variable 'bbdb-whois-name)
  54.      (if (bbdb-record-getprop the-record 'nic)
  55.          (concat "!" (bbdb-record-getprop the-record 'nic))
  56.        (concat (bbdb-record-lastname the-record) ", "
  57.            (bbdb-record-firstname the-record))))
  58.     (let ((proc (open-network-stream "whois" (current-buffer) server 43)))
  59.       (set-process-sentinel proc 'bbdb-whois-sentinel)
  60.       (process-send-string proc (concat bbdb-whois-name "\r\n")))))
  61.  
  62. (defun bbdb-whois-sentinel (proc status)
  63.   (save-excursion
  64.     (let (rec)
  65.       (set-buffer (process-buffer proc))
  66.       (setq rec bbdb-whois-record)
  67.       (goto-char 1)
  68.       (if (search-forward "To single out one record" nil t)
  69.       (message "%s is ambiguous to whois; try a different name"
  70.            bbdb-whois-name)
  71.     (replace-string "\r\n" "\n")
  72.     (goto-char 1)
  73.     (if (re-search-forward
  74.          (concat (if (string-match "^!" bbdb-whois-name)
  75.              (concat "(\\(" (substring bbdb-whois-name 1) "\\))")
  76.                (concat (regexp-quote bbdb-whois-name)
  77.                    ".*(\\([A-Z0-9]+\\))"))
  78.              "\\s *\\(\\S +@\\S +\\)$")
  79.          nil t)
  80.         (let ((net (downcase (buffer-substring (match-beginning 2)
  81.                            (match-end 2))))
  82.           (nic (buffer-substring (match-beginning 1) (match-end 1)))
  83.           (lines nil))
  84.           (bbdb-add-to-field rec net net)
  85.           (bbdb-record-putprop rec 'nic nic)
  86.  
  87.           ;; Snarf company.
  88.           (forward-line 1)
  89.           (back-to-indentation)
  90.           (let ((company (buffer-substring (point) (progn (end-of-line)
  91.                                   (point))))
  92.             (old (bbdb-record-company rec)))
  93.         (cond ((not old)
  94.                (bbdb-record-set-company rec company))
  95.               ((string= old company)
  96.                nil)
  97.               (t
  98.                (bbdb-record-putprop rec 'nic-organization company))))
  99.  
  100.           ;; Read the address info into LINES.
  101.           (while (progn (forward-line 1)
  102.                 (not (looking-at "^$")))
  103.         (back-to-indentation)
  104.         (setq lines (cons (buffer-substring (point)
  105.                             (progn (end-of-line)
  106.                                (point)))
  107.                   lines)))
  108.  
  109.           ;; Snarf phone number.
  110.           (if (car lines)
  111.           (progn
  112.             (if (not (bbdb-find-phone (car lines)
  113.                           (bbdb-record-phones rec)))
  114.             (let ((phone-number (vector "phone" (car lines))))
  115.               (bbdb-add-to-field rec phones phone-number)))
  116.             (setq lines (cdr lines))))
  117.  
  118.           ;; Snarf address.
  119.           (if (car lines)
  120.           (let ((addr (make-vector bbdb-address-length nil))
  121.             (city "")
  122.             (state "")
  123.             zip)
  124.             (if (string-match
  125.              "\\([^,]+\\),\\s *\\(\\S +\\)\\s *\\([0-9-]+\\)"
  126.              (car lines))
  127.             (setq city (substring (car lines)
  128.                           (match-beginning 1)
  129.                           (match-end 1))
  130.                   state (substring (car lines)
  131.                            (match-beginning 2)
  132.                            (match-end 2))
  133.                   zip (string-to-int (substring (car lines)
  134.                                 (match-beginning 3)
  135.                                 (match-end 3)))
  136.                   lines (cdr lines)))
  137.             (bbdb-address-set-location addr "address") ;???
  138.             (bbdb-address-set-city addr city)
  139.             (bbdb-address-set-state addr state)
  140.             (bbdb-address-set-zip addr zip)
  141.             (setq lines (nreverse lines))
  142.             (bbdb-address-set-street1 addr (or (car lines) ""))
  143.             (setq lines (cdr lines))
  144.             (bbdb-address-set-street2 addr (or (car lines) ""))
  145.             (setq lines (cdr lines))
  146.             (bbdb-address-set-street3 addr (or (car lines) ""))
  147.             (setq lines (cdr lines))
  148.             (bbdb-add-to-field rec addresses addr)))
  149.  
  150.           ;; Snarf any random notes.
  151.           (setq lines nil)
  152.           (while (progn
  153.                (forward-line 1)
  154.                (back-to-indentation)
  155.                (not (looking-at
  156.                  "$\\|Record last updated on")))
  157.         (if (looking-at "Alternate mailbox: \\(\\S +\\)$")
  158.             (bbdb-add-to-field rec net
  159.                        (buffer-substring (match-beginning 1)
  160.                              (match-end 1)))
  161.           (setq lines (cons (buffer-substring (point)
  162.                               (progn (end-of-line)
  163.                                  (point)))
  164.                     lines))))
  165.           (if lines
  166.           (bbdb-record-putprop rec 'nic-notes
  167.                        (mapconcat 'identity
  168.                           (nreverse lines)
  169.                           "\n")))
  170.         
  171.           ;; Snarf the last-update date.
  172.           (if (re-search-forward "Record last updated on \\(\\S *\\)\\."
  173.                      nil t)
  174.           (bbdb-record-putprop rec 'nic-updated
  175.                        (buffer-substring (match-beginning 1)
  176.                              (match-end 1))))
  177.  
  178.           (save-excursion
  179.         (set-buffer bbdb-buffer-name)
  180.         (bbdb-redisplay-one-record rec)))
  181.       (message "No whois information for %s" bbdb-whois-name)))
  182.       (delete-process proc)
  183.       (kill-buffer (current-buffer)))))
  184.           
  185. (defun bbdb-find-phone (string record)
  186.   "Return the vector entry if STRING is a phone number listed in RECORD."
  187.   (let ((phone nil)
  188.     (done nil))
  189.     (while (and record (not done))
  190.       (setq phone (car record))
  191.       (if (string= string (bbdb-phone-string phone))
  192.       (setq done phone))
  193.       (setq record (cdr record)))
  194.     done))
  195.  
  196. (provide 'bbdb-whois)
  197.