home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / packages / bbdb / bbdb-com.el < prev    next >
Encoding:
Text File  |  1992-08-11  |  69.1 KB  |  1,876 lines
  1. ;;; -*- Mode:Emacs-Lisp -*-
  2.  
  3. ;;; This file is the part of the Insidious Big Brother Database (aka BBDB),
  4. ;;; copyright (c) 1991, 1992 Jamie Zawinski <jwz@lucid.com>.
  5. ;;; Most of the user-level interactive commands for BBDB.  See bbdb.texinfo.
  6. ;;; last change 11-aug-92.
  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 1, 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. (require 'bbdb)
  23.  
  24. (defmacro bbdb-grovel-elide-arg (arg)
  25.   (list 'if arg
  26.     (list 'not (list 'eq arg 0))
  27.     'bbdb-elided-display))
  28.  
  29. (defun bbdb (string elidep)
  30.   "Display all entries in the bbdb database which match the regexp STRING in
  31. either the name(s), company, network address, or notes."
  32.   (interactive "sRegular Expression: \nP")
  33.   (let ((bbdb-elided-display (bbdb-grovel-elide-arg elidep)))
  34.     (bbdb-display-records
  35.       (bbdb-search (bbdb-records) string string string string))))
  36.  
  37. (defun bbdb-name (string elidep)
  38.   "Display all entries in the bbdb database which match the regexp STRING in
  39. the name (or ``alternate'' names)."
  40.   (interactive "sRegular Expression: \nP")
  41.   (let ((bbdb-elided-display (bbdb-grovel-elide-arg elidep)))
  42.     (bbdb-display-records (bbdb-search (bbdb-records) string))))
  43.  
  44. (defun bbdb-company (string elidep)
  45.   "Display all entries in the bbdb database which match the regexp STRING in
  46. the company field."
  47.   (interactive "sRegular Expression: \nP")
  48.   (let ((bbdb-elided-display (bbdb-grovel-elide-arg elidep)))
  49.     (bbdb-display-records (bbdb-search (bbdb-records) nil string))))
  50.  
  51. (defun bbdb-net (string elidep)
  52.   "Display all entries in the bbdb database which match the regexp STRING in
  53. the network address."
  54.   (interactive "sRegular Expression: \nP")
  55.   (let ((bbdb-elided-display (bbdb-grovel-elide-arg elidep)))
  56.     (bbdb-display-records (bbdb-search (bbdb-records) nil nil string))))
  57.  
  58. (defun bbdb-notes (which string elidep)
  59.   "Display all entries in the bbdb database which match the regexp STRING in
  60. the named notes field."
  61.   (interactive
  62.     (list (completing-read "Notes field to search (RET for all): "
  63.                (append '(("notes")) (bbdb-propnames))
  64.                nil t)
  65.       (if (featurep 'gmhist)
  66.           (read-with-history-in 'bbdb-notes-field "Regular expression: ")
  67.           (read-string "Regular Expression: "))
  68.       current-prefix-arg))
  69.   (let ((bbdb-elided-display (bbdb-grovel-elide-arg elidep)))
  70.     (bbdb-display-records (bbdb-search (bbdb-records) nil nil nil
  71.                        (if (string= which "")
  72.                        (cons '* string)
  73.                        (cons (intern which) string))))))
  74.  
  75. (defun bbdb-changed (elidep)
  76.   "Display all entries in the bbdb database which have been changed since
  77. the database was last last saved."
  78.   (interactive "P")
  79.   (let ((bbdb-elided-display (bbdb-grovel-elide-arg elidep)))
  80.     (bbdb-display-records
  81.       (bbdb-with-db-buffer
  82.     bbdb-changed-records))))
  83.  
  84. ;;; general searching
  85.  
  86. (defun bbdb-search (records &optional name company net notes)
  87.   (let ((matches '())
  88.     (all-fields (cons 'notes (mapcar (function (lambda (x) (intern (car x)))) (bbdb-propnames))))
  89.     (case-fold-search bbdb-case-fold-search))
  90.     (while records
  91.       (let ((record (car records)))
  92.     (if (or (and company (string-match company
  93.                    (or (bbdb-record-company record) "")))
  94.         (and net
  95.              (let ((rest-of-nets (bbdb-record-net record))
  96.                (done nil))
  97.                (if rest-of-nets
  98.                (while (and rest-of-nets (not done))
  99.                  (setq done (string-match net (car rest-of-nets))
  100.                    rest-of-nets (cdr rest-of-nets)))
  101.                ;; so that "^$" can be used to find entries that
  102.                ;; have no net addresses.
  103.                (setq done (string-match net "")))
  104.                done))
  105.         (and notes
  106.              (if (stringp notes)
  107.              (string-match notes
  108.                        (or (bbdb-record-notes record) ""))
  109.                (if (eq (car notes) '*)
  110.                (let ((fields all-fields) done)
  111.                  (while (and (not done) fields)
  112.                    (setq done (string-match (cdr notes) (or (bbdb-record-getprop record (car fields)) ""))
  113.                      fields (cdr fields)))
  114.                  done)
  115.              (string-match (cdr notes)
  116.                        (or (bbdb-record-getprop record (car notes)) "")))))
  117.         (and name (string-match name
  118.                 (or (bbdb-record-name record) "")))
  119.         (and name
  120.              (let ((rest-of-aka (bbdb-record-aka record))
  121.                (done nil))
  122.                (if rest-of-aka
  123.                (while (and rest-of-aka (not done))
  124.                  (setq done (string-match name (car rest-of-aka))
  125.                    rest-of-aka (cdr rest-of-aka))))
  126.                done))
  127.         )
  128.         (setq matches (cons record matches))))
  129.       (setq records (cdr records)))
  130.     (nreverse matches)))
  131.  
  132. ;;; fancy redisplay
  133.  
  134. (defun bbdb-redisplay-records ()
  135.   "Regrinds the contents of the *BBDB* buffer, without scrolling.
  136. If possible, you should call bbdb-redisplay-one-record instead."
  137.   (let ((p (point))
  138.     (m (mark)))
  139.     (goto-char (window-start))
  140.     (let ((p2 (point)))
  141.       (bbdb-display-records-1 bbdb-records)
  142.       (goto-char p2)
  143.       (if m (set-mark m)))
  144.     (recenter 0)
  145.     (goto-char p)
  146.     (save-excursion
  147.       (run-hooks 'bbdb-list-hook))
  148.     ))
  149.  
  150. (defun bbdb-redisplay-one-record (record &optional record-cons next-record-cons
  151.                      delete-p)
  152.   "Regrind one record.  The *BBDB* buffer must be current when this is called."
  153.   (bbdb-debug (if (not (eq (not (not delete-p))
  154.                (not (not (bbdb-record-deleted-p record)))))
  155.           (error "splorch.")))
  156.   (if (null record-cons) (setq record-cons (assq record bbdb-records)))
  157.   (if (null next-record-cons)
  158.       (setq next-record-cons (car (cdr (memq record-cons bbdb-records)))))
  159.   (beginning-of-line)
  160.   (let ((marker (nth 2 record-cons))
  161.     (next-marker (nth 2 next-record-cons))
  162.     (buffer-read-only nil)
  163.     (p (point)))
  164.     (bbdb-debug
  165.       (if (null record-cons) (error "doubleplus ungood: record unexists!"))
  166.       (if (null marker) (error "doubleplus ungood: marker unexists!")))
  167.     (goto-char marker)
  168.     (if delete-p nil
  169.     (bbdb-format-record (car record-cons) (car (cdr record-cons))))
  170.     (delete-region (point) (or next-marker (point-max)))
  171.     (goto-char p)
  172.     (save-excursion
  173.       (run-hooks 'bbdb-list-hook))
  174.     ))
  175.  
  176. ;;; Parsing phone numbers
  177.  
  178. (defconst bbdb-phone-area-regexp "(?[ \t]*\\+?1?[ \t]*[-\(]?[ \t]*[-\(]?[ \t]*\\([0-9][012][0-9]\\)[ \t]*)?[- \t]*")
  179. (defconst bbdb-phone-main-regexp "\\([1-9][0-9][0-9]\\)[ \t]*-?[ \t]*\\([0-9][0-9][0-9][0-9]\\)[ \t]*")
  180. (defconst bbdb-phone-ext-regexp  "x?[ \t]*\\([0-9]+\\)[ \t]*")
  181.  
  182. (defconst bbdb-phone-regexp-1 (concat "^[ \t]*" bbdb-phone-area-regexp bbdb-phone-main-regexp bbdb-phone-ext-regexp "$"))
  183. (defconst bbdb-phone-regexp-2 (concat "^[ \t]*" bbdb-phone-area-regexp bbdb-phone-main-regexp "$"))
  184. (defconst bbdb-phone-regexp-3 (concat "^[ \t]*" bbdb-phone-main-regexp bbdb-phone-ext-regexp "$"))
  185. (defconst bbdb-phone-regexp-4 (concat "^[ \t]*" bbdb-phone-main-regexp "$"))
  186. (defconst bbdb-phone-regexp-5 (concat "^[ \t]*" bbdb-phone-ext-regexp "$"))
  187.  
  188. (defun bbdb-parse-phone-number (string &optional number-type)
  189.   "Parse a phone number from STRING and return a list of integers the form
  190. \(area-code exchange number) or (area-code exchange number extension).
  191. This is both lenient and strict in what it will parse - whitespace may 
  192. appear (or not) between any of the groups of digits, parentheses around the
  193. area code are optional, as is a dash between the exchange and number, and
  194. a '1' preceeding the area code; but there must be three digits in the area 
  195. code and exchange, and four in the number (if they are present).  An error 
  196. will be signalled if unparsable.  All of these are unambigously parsable:
  197.  
  198.   ( 415 ) 555 - 1212 x123   ->   (415 555 1212 123)
  199.   (415)555-1212 123         ->   (415 555 1212 123)
  200.   (1-415) 555-1212 123      ->   (415 555 1212 123)
  201.   1 (415)-555-1212 123      ->   (415 555 1212 123)
  202.   555-1212 123              ->   (0 555 1212 123)
  203.   555 1212                  ->   (0 555 1212)
  204.   415 555 1212              ->   (415 555 1212)
  205.   1 415 555 1212            ->   (415 555 1212)
  206.   5551212                   ->   (0 555 1212)
  207.   4155551212                ->   (415 555 1212)
  208.   4155551212123             ->   (415 555 1212 123)
  209.   5551212x123               ->   (0 555 1212 123)
  210.   1234                      ->   (0 0 0 1234)
  211.  
  212. Note that \"4151212123\" is ambiguous; it could be interpreted either as
  213. \"(415) 121-2123\" or as \"415-1212 x123\".  (However, all area codes have
  214. either 0, 1, or 2 as their second digit, and no exchange begins with 0, 
  215. so this function can sometimes use that to disambiguate.)
  216.  
  217. \(And uh, oh yeah, this does little if bbdb-north-american-phone-numbers-p
  218. is nil...\)"
  219.  
  220.   (cond ((if number-type
  221.          (eq number-type 'euro)
  222.        (not bbdb-north-american-phone-numbers-p))
  223.      (list (bbdb-string-trim string)))
  224.     ((string-match bbdb-phone-regexp-1 string)
  225.      ;; (415) 555-1212 x123
  226.      (list (bbdb-subint string 1) (bbdb-subint string 2)
  227.            (bbdb-subint string 3) (bbdb-subint string 4)))
  228.     ((string-match bbdb-phone-regexp-2 string)
  229.      ;; (415) 555-1212
  230.      (list (bbdb-subint string 1) (bbdb-subint string 2)
  231.            (bbdb-subint string 3)))
  232.     ((string-match bbdb-phone-regexp-3 string)
  233.      ;; 555-1212 x123
  234.      (list 0 (bbdb-subint string 1) (bbdb-subint string 2)
  235.            (bbdb-subint string 3)))
  236.     ((string-match bbdb-phone-regexp-4 string)
  237.      ;; 555-1212
  238.      (list 0 (bbdb-subint string 1) (bbdb-subint string 2)))
  239.     ((string-match bbdb-phone-regexp-5 string)
  240.      ;; x123
  241.      (list 0 0 0 (bbdb-subint string 1)))
  242.     (t (error "phone number unparsable."))))
  243.  
  244. ;;; Parsing other things
  245.  
  246. (defun bbdb-parse-zip-string (string)
  247.   (cond ((string-match "^[ \t\n]*$" string) 0)
  248.     ((string-match "^[ \t\n]*[0-9][0-9][0-9][0-9][0-9][ \t\n]*$" string)
  249.      (string-to-int string))
  250.     ((string-match "^[ \t\n]*\\([0-9][0-9][0-9][0-9][0-9]\\)[ \t\n]*-?[ \t\n]*\\([0-9][0-9][0-9][0-9]\\)[ \t\n]*$" string)
  251.      (list (bbdb-subint string 1) (bbdb-subint string 2)))
  252.     ;; Match zip codes for Canada, UK, etc. (result is ("LL47" "U4B")).
  253.     ((string-match
  254.       "^[ \t\n]*\\([A-Za-z0-9]\\)[ \t\n]*\\([A-Za-z0-9]\\)[ \t\n]*$"
  255.       string)
  256.      (list (bbdb-substr string 1) (bbdb-substr string 2)))
  257.     ((string-match "-[^-]-" string)
  258.      (error "too many dashes in zip code."))
  259.     ((string-match "[^-0-9 \t\n]" string)
  260.      (error "illegal characters in zip code."))
  261.     ((string-match "[0-9][0-9][0-9][0-9][0-9][0-9]" string)
  262.      (error "too many digits in zip code."))
  263.     ((< (length string) 5)
  264.      (error "not enough digits in zip code."))
  265.     (t (error "not a valid 5-digit or 5+4 digit zip code."))))
  266.  
  267.  
  268. (defun bbdb-read-new-record ()
  269.   "Prompt for and return a completely new bbdb-record.  Doesn't insert it in to
  270. the database or update the hashtables, but does insure that there will not be
  271. name collisions."
  272.   (bbdb-records) ; make sure database is loaded
  273.   (if bbdb-readonly-p (error "The Insidious Big Brother Database is read-only."))
  274.   (let (firstname lastname)
  275.     (bbdb-error-retry
  276.       (progn
  277.     (if current-prefix-arg
  278.         (setq firstname (bbdb-read-string "First Name: ")
  279.           lastname (bbdb-read-string "Last Name: "))
  280.       (let ((names (bbdb-divide-name (bbdb-read-string "Name: "))))
  281.         (setq firstname (car names)
  282.           lastname (nth 1 names))))
  283.     (if (string= firstname "") (setq firstname nil))
  284.     (if (string= lastname "") (setq lastname nil))
  285.     (if (bbdb-gethash (downcase (if (and firstname lastname) (concat firstname " " lastname)
  286.                     (or firstname lastname ""))))
  287.         (error "%s %s is already in the database" (or firstname "") (or lastname "")))))
  288.     (let ((company (bbdb-read-string "Company: "))
  289.       (net (bbdb-split (bbdb-read-string "Network Address: ") ","))
  290.       (addrs (let (L L-tail str addr)
  291.            (while (not (string= ""
  292.                  (setq str (bbdb-read-string "Address Description [RET when no more addrs]: "))))
  293.              (setq addr (make-vector bbdb-address-length nil))
  294.              (bbdb-record-edit-address addr str)
  295.              (if L
  296.              (progn (setcdr L-tail (cons addr nil))
  297.                 (setq L-tail (cdr L-tail)))
  298.              (setq L (cons addr nil)
  299.                    L-tail L)))
  300.            L))
  301.       (phones (let (L L-tail str)
  302.             (while (not (string= ""
  303.                      (setq str
  304.                            (bbdb-read-string "Phone Location [RET when no more phones]: "))))
  305.               (let* ((phonelist
  306.                   (bbdb-error-retry
  307.                 (bbdb-parse-phone-number
  308.                   (read-string "Phone: "
  309.                            (and bbdb-default-area-code (format "(%03d) " bbdb-default-area-code))))))
  310.                  (phone (apply 'vector str
  311.                        (if (= 3 (length phonelist))
  312.                            (nconc phonelist '(0))
  313.                            phonelist))))
  314.             (if L
  315.                 (progn (setcdr L-tail (cons phone nil))
  316.                    (setq L-tail (cdr L-tail)))
  317.                 (setq L (cons phone nil)
  318.                   L-tail L))))
  319.             L))
  320.       (notes (bbdb-read-string "Additional Comments: ")))
  321.       (if (string= company "") (setq company nil))
  322.       (if (string= notes "") (setq notes nil))
  323.       (let ((record
  324.          (vector firstname lastname nil company phones addrs net notes
  325.              (make-vector bbdb-cache-length nil))))
  326.     record))))
  327.  
  328. (defun bbdb-create (record)
  329.   "Add a new entry to the bbdb database; prompts for all relevant info
  330. using the echo area, inserts the new record in the db, sorted alphabetically,
  331. and offers to save the db file.  DO NOT call this from a program.  Call
  332. bbdb-create-internal instead."
  333.   (interactive (list (bbdb-read-new-record)))
  334.   (bbdb-invoke-hook 'bbdb-create-hook record)
  335.   (bbdb-change-record record t)
  336.   (bbdb-display-records (list record)))
  337.  
  338.  
  339. (defmacro bbdb-check-type (place predicate)
  340.   (list 'while (list 'not (list predicate place))
  341.     (nconc (cond ((eq (car-safe place) 'aref)
  342.               (list 'aset (nth 1 place) (nth 2 place)))
  343.              ((eq (car-safe place) 'car)
  344.               (list 'setcar (nth 1 place)))
  345.              ((eq (car-safe place) 'cdr)
  346.               (list 'setcdr (nth 1 place)))
  347.              (t (list 'setq place)))
  348.            (list 
  349.         (list 'signal ''wrong-type-argument
  350.               (list 'list (list 'quote predicate) place))))))
  351.  
  352.  
  353. (defun bbdb-create-internal (name company net addrs phones notes)
  354.   "Adds a record to the database; this function does a fair amount of
  355. error-checking on the passed in values, so it's safe to call this from
  356. other programs.
  357.  
  358. NAME is a string, the name of the person to add.  An error is signalled
  359.  if that name is already in use.
  360. COMPANY is a string or nil.
  361. NET is a comma-separated list of email addresses, or a list of strings.
  362.  An error is signalled if that name is already in use.
  363. ADDRS is a list of address objects.  An address is a vector of the form
  364.    [\"location\" \"line1\" \"line2\" \"line3\" \"City\" \"State\" zip]
  365.  where `zip' is nil, an integer, or a cons of two integers.
  366. PHONES is a list of phone-number objects.  A phone-number is a vector of
  367.  the form
  368.    [\"location\" areacode prefix suffix extension-or-nil]
  369.  or
  370.    [\"location\" \"phone-number\"]
  371. NOTES is a string, or an alist associating symbols with strings."
  372.   (let (firstname lastname aka)
  373.     (while (progn
  374.          (setq name (and name (bbdb-divide-name name)))
  375.          (setq firstname (car name) lastname (nth 1 name))
  376.          (bbdb-gethash (downcase (if (and firstname lastname)
  377.                      (concat firstname " " lastname)
  378.                        (or firstname lastname "")))))
  379.       (setq name (signal 'error
  380.              (list (format "%s %s is already in the database"
  381.                        (or firstname "") (or lastname ""))))))
  382.     (and company (bbdb-check-type company stringp))
  383.     (if (stringp net)
  384.     (setq net (bbdb-split net ",")))
  385.     (let ((rest net))
  386.       (while rest
  387.     (while (bbdb-gethash (downcase (car rest)))
  388.       (setcar rest
  389.           (signal 'error (list (format
  390.                     "%s is already in the database"
  391.                     (car rest))))))
  392.     (setq rest (cdr rest))))
  393.     (setq addrs
  394.       (mapcar
  395.         (function (lambda (addr)
  396.           (while (or (not (vectorp addr))
  397.              (/= (length addr) bbdb-address-length))
  398.         (setq addr (signal 'wrong-type-argument (list 'vectorp addr))))
  399.           (bbdb-check-type (aref addr 0) stringp)
  400.           (bbdb-check-type (aref addr 1) stringp)
  401.           (bbdb-check-type (aref addr 2) stringp)
  402.           (bbdb-check-type (aref addr 3) stringp)
  403.           (bbdb-check-type (aref addr 4) stringp)
  404.           (bbdb-check-type (aref addr 5) stringp)
  405.           (while (and (aref addr 6)
  406.               (not (integerp (aref addr 6)))
  407.               (not (and (consp (aref addr 6))
  408.                     (integerp (car (aref addr 6)))
  409.                     (integerp (car (cdr (aref addr 6))))
  410.                     (null (cdr (cdr (aref addr 6)))))))
  411.         (aset addr 6 (signal 'wrong-type-argument
  412.                      (list 'zipcodep (aref addr 6)))))
  413.           addr))
  414.         addrs))
  415.     (setq phones
  416.       (mapcar
  417.        (function (lambda (phone)
  418.          (while (or (not (vectorp phone))
  419.             (and (/= (length phone) 2)
  420.                  (/= (length phone) bbdb-phone-length)))
  421.            (setq phone
  422.              (signal 'wrong-type-argument (list 'vectorp phone))))
  423.          (bbdb-check-type (aref phone 0) stringp)
  424.          (if (= 2 (length phone))
  425.          (bbdb-check-type (aref phone 1) stringp)
  426.            (bbdb-check-type (aref phone 1) integerp)
  427.            (bbdb-check-type (aref phone 2) integerp)
  428.            (bbdb-check-type (aref phone 3) integerp)
  429.            (and (aref phone 4) (bbdb-check-type (aref phone 4) integerp))
  430.            (if (eq 0 (aref phone 4)) (aset phone 4 nil)))
  431.          phone))
  432.        phones))
  433.     (or (stringp notes)
  434.     (setq notes
  435.           (mapcar (function (lambda (note)
  436.                 (bbdb-check-type note consp)
  437.             (bbdb-check-type (car note) symbolp)
  438.             (if (consp (cdr note))
  439.                 (setq note (cons (car note) (car (cdr note)))))
  440.             (bbdb-check-type (cdr note) stringp)
  441.                 note))
  442.               notes)))
  443.     (let ((record
  444.        (vector firstname lastname aka company phones addrs net notes
  445.            (make-vector bbdb-cache-length nil))))
  446.       (bbdb-invoke-hook 'bbdb-create-hook record)
  447.       (bbdb-change-record record t)
  448.       record)))
  449.  
  450.  
  451. ;;; bbdb-mode stuff
  452.  
  453. (defun bbdb-current-record (&optional planning-on-modifying)
  454.   "Returns the record which the point is point at.  In linear time, man..."
  455.   (if (and planning-on-modifying bbdb-readonly-p)
  456.       (error "The Insidious Big Brother Database is read-only."))
  457.   (if (not (equal bbdb-buffer-name (buffer-name (current-buffer))))
  458.       (error "this command only works while in the \"%s\" buffer."
  459.          bbdb-buffer-name))
  460.   (let ((p (point))
  461.     (rest bbdb-records)
  462.     (rec nil))
  463.     (while (and (cdr rest) (not rec))
  464.       (if (> (nth 2 (car (cdr rest))) p)
  465.       (setq rec (car (car rest))))
  466.       (setq rest (cdr rest)))
  467.     (or rec (car (car rest)))))
  468.  
  469.  
  470. ;; yow, are we object oriented yet?
  471. (defun bbdb-record-get-field-internal (record field)
  472.   (cond ((eq field 'name)    (bbdb-record-name record))
  473.     ((eq field 'net)    (bbdb-record-net record))
  474.     ((eq field 'aka)    (bbdb-record-aka record))
  475.     ((eq field 'phone)    (bbdb-record-phones record))
  476.     ((eq field 'address)    (bbdb-record-addresses record))
  477.     ((eq field 'property)    (bbdb-record-raw-notes record))
  478.     (t (error "doubleplus ungood: unknown field type %s" field))))
  479.  
  480. (defun bbdb-record-store-field-internal (record field value)
  481.   (cond ((eq field 'name)    (error "doesn't work on names"))
  482.     ((eq field 'net)    (bbdb-record-set-net record value))
  483.     ((eq field 'aka)    (bbdb-record-set-aka record value))
  484.     ((eq field 'phone)    (bbdb-record-set-phones record value))
  485.     ((eq field 'address)    (bbdb-record-set-addresses record value))
  486.     ((eq field 'property)    (bbdb-record-set-raw-notes record value))
  487.     (t (error "doubleplus ungood: unknown field type %s" field))))
  488.  
  489. (defun bbdb-record-edit-field-internal (record field &optional which)
  490.   (cond ((eq field 'name)    (bbdb-record-edit-name record))
  491.     ((eq field 'net)    (bbdb-record-edit-net record))
  492.     ((eq field 'aka)    (bbdb-record-edit-aka record))
  493.     ((eq field 'phone)    (bbdb-record-edit-phone which))
  494.     ((eq field 'address)    (bbdb-record-edit-address which))
  495.     ((eq field 'property)    (bbdb-record-edit-property record (car which)))
  496.     (t (error "doubleplus ungood: unknown field type %s" field))))
  497.  
  498.     
  499. (defun bbdb-current-field (&optional planning-on-modifying)
  500.   (save-excursion
  501.     ;; get to beginning of this record
  502.     (beginning-of-line)
  503.     (let ((p (point)))
  504.       (while (not (or (eobp) (looking-at "^[^ \t\n]")))
  505.     (forward-line -1))
  506.       (let* ((record (or (bbdb-current-record planning-on-modifying)
  507.              (error "unperson")))
  508.          (bbdb-elided-display (nth 1 (assq record bbdb-records)))
  509.          (count 0)
  510.          (tmp (nconc
  511.            (list (list 'name record))
  512.            (and (bbdb-field-shown-p 'phone)
  513.              (mapcar (function (lambda (phone) (list 'phone phone)))
  514.                  (bbdb-record-phones record)))
  515.            (and (bbdb-field-shown-p 'address)
  516.              (apply 'nconc
  517.                (mapcar (function (lambda (addr)
  518.                 (let ((L (list 'address addr)))
  519.                   (nconc
  520.                    (if (string= "" (bbdb-address-street1 addr))
  521.                        nil (list L))
  522.                    (if (string= "" (bbdb-address-street2 addr))
  523.                        nil (list L))
  524.                    (if (string= "" (bbdb-address-street3 addr))
  525.                        nil (list L))
  526.                    (list L)))))
  527.                    (bbdb-record-addresses record))))
  528.            (if (and (bbdb-record-net record)
  529.                 (bbdb-field-shown-p 'net))
  530.                (list (list 'net record)))
  531.            (if (and (bbdb-record-aka record)
  532.                 (bbdb-field-shown-p 'aka))
  533.                (list (list 'aka record)))
  534.            (let ((notes (bbdb-record-raw-notes record)))
  535.              (if (stringp notes)
  536.              (setq notes (list (cons 'notes notes))))
  537.              (apply
  538.                'nconc
  539.                (mapcar
  540.             (function (lambda (note)
  541.               (if (bbdb-field-shown-p (car note))
  542.                   (let* ((L (list 'property note))
  543.                      (LL (list L))
  544.                      (i 0))
  545.                 (while (string-match "\n" (cdr note) i)
  546.                   (setq i (match-end 0)
  547.                     LL (cons L LL)))
  548.                 LL))))
  549.             notes)))
  550.            )))
  551.     (while (< (point) p)
  552.       (setq count (1+ count))
  553.       (forward-line 1))
  554.     (nth count tmp)))))
  555.  
  556.  
  557. (defun bbdb-apply-next-command-to-all-records ()
  558.   "Typing \\<bbdb-mode-map>\\[bbdb-apply-next-command-to-all-records] \
  559. in the *BBDB* buffer makes the next command operate on all
  560. of the records currently displayed.  \(Note that this only works for
  561. certain commands.\)"
  562.   (interactive)
  563.   (message (substitute-command-keys
  564.         "\\<bbdb-mode-map>\\[bbdb-apply-next-command-to-all-records] - "))
  565.   (setq prefix-arg current-prefix-arg
  566.     last-command this-command)
  567.   nil)
  568.  
  569. (defmacro bbdb-do-all-records-p ()
  570.   "Whether the last command was bbdb-apply-next-command-to-all-records."
  571.   '(eq last-command 'bbdb-apply-next-command-to-all-records))
  572.  
  573.  
  574. (defun bbdb-insert-new-field (name contents)
  575.   "Add a new field to the current record; the field type and contents
  576. are prompted for if not supplied.
  577.  
  578. If you are inserting a new phone-number field, you can control whether
  579. it is a north american or european phone number by providing a prefix
  580. argument.  A prefix arg of ^U means it's to be a euronumber, and any
  581. other prefix arg means it's to be a a structured north american number.
  582. Otherwise, which style is used is controlled by the variable
  583. bbdb-north-american-phone-numbers-p."
  584.   (interactive (let ((name "")
  585.              (completion-ignore-case t))
  586.          (while (string= name "")
  587.            (setq name
  588.              (downcase
  589.                (completing-read "Insert Field: "
  590.                  (append '(("phone") ("address") ("net")
  591.                        ("AKA") ("notes"))
  592.                      (bbdb-propnames))
  593.                  nil
  594.                  nil ; used to be t
  595.                  nil))))
  596.          (setq name (intern name))
  597.          (list name (bbdb-prompt-for-new-field-value name))))
  598.   (if (null contents)
  599.       (setq contents (bbdb-prompt-for-new-field-value name)))
  600.   (let ((record (bbdb-current-record t)))
  601.     (if (null record) (error "current record unexists!"))
  602.     (cond ((eq name 'phone)
  603.        (bbdb-record-set-phones record
  604.          (nconc (bbdb-record-phones record) (list contents))))
  605.       ((eq name 'address)
  606.        (bbdb-record-set-addresses record
  607.          (nconc (bbdb-record-addresses record) (list contents))))
  608.       ((eq name 'net)
  609.        (if (bbdb-record-net record)
  610.            (error "There already are net addresses!"))
  611.        (if (stringp contents)
  612.            (setq contents (bbdb-split contents ",")))
  613.        ;; first detect any conflicts....
  614.        (let ((nets contents))
  615.          (while nets
  616.            (let ((old (bbdb-gethash (downcase (car nets)))))
  617.          (if (and old (not (eq old record)))
  618.              (error "net address \"%s\" is used by \"%s\""
  619.                 (car nets)
  620.                 (or (bbdb-record-name old) (car (bbdb-record-net old))))))
  621.            (setq nets (cdr nets))))
  622.        ;; then store.
  623.        (let ((nets contents))
  624.          (while nets
  625.            (bbdb-puthash (downcase (car nets)) record)
  626.            (setq nets (cdr nets))))
  627.        (bbdb-record-set-net record contents)
  628.        )
  629.       ((eq name 'aka)
  630.        (if (bbdb-record-aka record)
  631.            (error "there already are alternate names!"))
  632.        (if (stringp contents)
  633.            (setq contents (bbdb-split contents ";")))
  634.        ;; first detect any conflicts....
  635.        (let ((aka contents))
  636.          (while aka
  637.            (let ((old (bbdb-gethash (downcase (car aka)))))
  638.          (if (and old (not (eq old record)))
  639.              (error "alternate name \"%s\" is used by \"%s\""
  640.                 (car aka)
  641.                 (or (bbdb-record-name old)
  642.                 (car (bbdb-record-net old))))))
  643.            (setq aka (cdr aka))))
  644.        ;; then store.
  645.        (let ((aka contents))
  646.          (while aka
  647.            (bbdb-puthash (downcase (car aka)) record)
  648.            (setq aka (cdr aka))))
  649.        (bbdb-record-set-aka record contents)
  650.        )
  651.       ((eq name 'notes)
  652.        (if (bbdb-record-notes record) (error "there already are notes!"))
  653.        (bbdb-record-set-notes record contents))
  654.       ((assoc (symbol-name name) (bbdb-propnames))
  655.        (if (and (consp (bbdb-record-raw-notes record))
  656.             (assq name (bbdb-record-raw-notes record)))
  657.            (error "there is already a \"%s\" note!" name))
  658.        (bbdb-record-putprop record name contents))
  659.       (t (error "doubleplus ungood: unknow how to set slot %s" name)))
  660.     (bbdb-change-record record nil)
  661. ;    (bbdb-offer-save)
  662.     (let ((bbdb-elided-display nil))
  663.       (bbdb-redisplay-one-record record))))
  664.  
  665. (defun bbdb-prompt-for-new-field-value (name)
  666.   (cond ((eq name 'net) (bbdb-read-string "Net: "))
  667.     ((eq name 'aka) (bbdb-read-string "Alternate Names: "))
  668.     ((eq name 'phone)
  669.      (let ((p (make-vector
  670.             (if (if current-prefix-arg
  671.                 (numberp current-prefix-arg)
  672.                 bbdb-north-american-phone-numbers-p)
  673.             bbdb-phone-length
  674.             2)
  675.             0)))
  676.        (aset p 0 nil)
  677.        (aset p 1
  678.          (if (= bbdb-phone-length (length p))
  679.              (or bbdb-default-area-code 0)
  680.              nil))
  681.        (bbdb-record-edit-phone p)
  682.        p))
  683.     ((eq name 'address)
  684.      (let ((a (make-vector bbdb-address-length nil)))
  685.        (bbdb-record-edit-address a)
  686.        a))
  687.     ((eq name 'notes) (bbdb-read-string "Notes: "))
  688.     ((assoc (symbol-name name) (bbdb-propnames))
  689.      (bbdb-read-string (format "%s: " name)))
  690.     (t
  691.      (if (bbdb-y-or-n-p (format "\"%s\" is an unknown field name.  Define it? " name))
  692.          (bbdb-set-propnames
  693.            (append (bbdb-propnames) (list (list (symbol-name name)))))
  694.          (error "unknown field \"%s\"" name))
  695.      (bbdb-read-string (format "%s: " name)))))
  696.  
  697.  
  698. (defun bbdb-edit-current-field ()
  699.   "Edit the contents of the Insidious Big Brother Database field displayed on 
  700. the current line (this is only meaningful in the \"*BBDB*\" buffer.)   If the 
  701. cursor is in the middle of a multi-line field, such as an address or comments 
  702. section, then the entire field is edited, not just the current line."
  703.   (interactive)
  704.   (let* ((record (bbdb-current-record t))
  705.      (field (bbdb-current-field t))
  706.      need-to-sort)
  707.     (or field (error "on an unfield"))
  708.     (setq need-to-sort
  709.       (bbdb-record-edit-field-internal record (car field) (nth 1 field)))
  710.     (bbdb-change-record record need-to-sort)
  711.     (bbdb-redisplay-one-record record)
  712. ;    (bbdb-offer-save)
  713.     ))
  714.  
  715. (defun bbdb-record-edit-name (bbdb-record)
  716.   (let (fn ln co need-to-sort new-name old-name)
  717.     (bbdb-error-retry
  718.       (progn
  719.     (if current-prefix-arg
  720.         (setq fn (bbdb-read-string "First Name: "
  721.                        (bbdb-record-firstname bbdb-record))
  722.           ln (bbdb-read-string "Last Name: "
  723.                        (bbdb-record-lastname bbdb-record)))
  724.       (let ((names (bbdb-divide-name
  725.             (bbdb-read-string "Name: "
  726.               (bbdb-record-name bbdb-record)))))
  727.         (setq fn (car names)
  728.           ln (nth 1 names))))
  729.     (setq need-to-sort (or (not (string= fn
  730.                          (or (bbdb-record-firstname bbdb-record) "")))
  731.                    (not (string= ln
  732.                          (or (bbdb-record-lastname bbdb-record) "")))))
  733.     (if (string= "" fn) (setq fn nil))
  734.     (if (string= "" ln) (setq ln nil))
  735.     ;; check for collisions
  736.     (setq new-name (if (and fn ln) (concat fn " " ln)
  737.                (or fn ln))
  738.           old-name (bbdb-record-name bbdb-record))
  739.     (if (and new-name
  740.          (not (and old-name (string= (downcase new-name)
  741.                          (downcase old-name))))
  742.          (bbdb-gethash (downcase new-name)))
  743.         (error "%s is already in the database!" new-name))))
  744.     (setq co (bbdb-read-string "Company: "
  745.                    (bbdb-record-company bbdb-record)))
  746.     (if (string= "" co) (setq co nil))
  747.     (setq need-to-sort
  748.       (or need-to-sort
  749.           (not (equal (if co (downcase co) "")
  750.               (downcase (or (bbdb-record-company bbdb-record)
  751.                     ""))))))
  752.     ;;
  753.     ;; delete the old hash entry
  754.     (and (bbdb-record-name bbdb-record)
  755.      (bbdb-remhash (downcase (bbdb-record-name bbdb-record))))
  756.     (bbdb-record-set-namecache bbdb-record nil)
  757.     (bbdb-record-set-firstname bbdb-record fn)
  758.     (bbdb-record-set-lastname bbdb-record ln)
  759.     (bbdb-record-set-company bbdb-record co)
  760.     ;; add a new hash entry
  761.     (and (or fn ln)
  762.      (bbdb-puthash (downcase (bbdb-record-name bbdb-record))
  763.                bbdb-record))
  764.     need-to-sort))
  765.  
  766. (defun bbdb-record-edit-address (addr &optional location)
  767.   (let* ((loc (or location (bbdb-read-string "Location: " (bbdb-address-location addr))))
  768.      (st1 (bbdb-read-string "Street, line 1: " (bbdb-address-street1 addr)))
  769.      (st2 (if (string= st1 "") ""
  770.           (bbdb-read-string "Street, line 2: " (bbdb-address-street2 addr))))
  771.      (st3 (if (string= st2 "") ""
  772.           (bbdb-read-string "Street, line 3: " (bbdb-address-street3 addr))))
  773.      (cty (bbdb-read-string "City: " (bbdb-address-city addr)))
  774.      (ste (bbdb-read-string "State: " (bbdb-address-state addr)))
  775.      (zip (bbdb-error-retry
  776.         (bbdb-parse-zip-string
  777.           (bbdb-read-string "Zip Code: " (bbdb-address-zip-string addr))))))
  778.     (bbdb-address-set-location addr loc)
  779.     (bbdb-address-set-street1 addr st1)
  780.     (bbdb-address-set-street2 addr st2)
  781.     (bbdb-address-set-street3 addr st3)
  782.     (bbdb-address-set-city addr cty)
  783.     (bbdb-address-set-state addr ste)
  784.     (bbdb-address-set-zip addr zip)
  785.     nil))
  786.  
  787. (defun bbdb-record-edit-phone (phone-number)
  788.   (let ((newl (bbdb-read-string "Location: "
  789.                  (bbdb-phone-location phone-number)))
  790.     (newp (let ((bbdb-north-american-phone-numbers-p
  791.              (= (length phone-number) bbdb-phone-length)))
  792.         (bbdb-error-retry
  793.           (bbdb-parse-phone-number
  794.             (read-string "Phone: " (bbdb-phone-string phone-number))
  795.             )))))
  796.     (bbdb-phone-set-location phone-number newl)
  797.     (bbdb-phone-set-area phone-number (nth 0 newp)) ; euronumbers too.
  798.     (if (= (length phone-number) 2)
  799.     nil
  800.       (bbdb-phone-set-exchange phone-number (nth 1 newp))
  801.       (bbdb-phone-set-suffix phone-number (nth 2 newp))
  802.       (bbdb-phone-set-extension phone-number (or (nth 3 newp) 0))))
  803.   nil)
  804.  
  805. (defun bbdb-record-edit-net (bbdb-record)
  806.   (let ((str (bbdb-read-string "Net: "
  807.            (mapconcat (function identity)
  808.               (bbdb-record-net bbdb-record)
  809.               ", "))))
  810.     (let ((oldnets (bbdb-record-net bbdb-record))
  811.       (newnets (bbdb-split str ",")))
  812.       ;; first check for any conflicts...
  813.       (let ((rest newnets))
  814.     (while rest
  815.       (let ((old (bbdb-gethash (downcase (car rest)))))
  816.         (if (and old (not (eq old bbdb-record)))
  817.         (error "net address \"%s\" is used by \"%s\""
  818.                (car rest) (bbdb-record-name old))))
  819.       (setq rest (cdr rest))))
  820.       ;; then update.
  821.       (let ((rest oldnets))
  822.     (while rest
  823.       (bbdb-remhash (downcase (car rest)))
  824.       (setq rest (cdr rest))))
  825.       (let ((nets newnets))
  826.     (while nets
  827.       (bbdb-puthash (downcase (car nets)) bbdb-record)
  828.       (setq nets (cdr nets))))
  829.       (bbdb-record-set-net bbdb-record newnets)
  830.       ))
  831.   nil)
  832.  
  833. (defun bbdb-record-edit-aka (bbdb-record)
  834.   (let ((str (bbdb-read-string "AKA: "
  835.            (mapconcat (function identity)
  836.               (bbdb-record-aka bbdb-record)
  837.               "; "))))
  838.     (let ((oldaka (bbdb-record-aka bbdb-record))
  839.       (newaka (bbdb-split str ";")))
  840.       ;; first check for any conflicts...
  841.       (let ((rest newaka))
  842.     (while rest
  843.       (let ((old (bbdb-gethash (downcase (car rest)))))
  844.         (if (and old (not (eq old bbdb-record)))
  845.         (error "alternate name address \"%s\" is used by \"%s\""
  846.                (car rest) (bbdb-record-name old))))
  847.       (setq rest (cdr rest))))
  848.       ;; then update.
  849.       (let ((rest oldaka))
  850.     (while rest
  851.       (bbdb-remhash (downcase (car rest)))
  852.       (setq rest (cdr rest))))
  853.       (let ((aka newaka))
  854.     (while aka
  855.       (bbdb-puthash (downcase (car aka)) bbdb-record)
  856.       (setq aka (cdr aka))))
  857.       (bbdb-record-set-aka bbdb-record newaka)
  858.       ))
  859.   nil)
  860.  
  861. (defun bbdb-record-edit-notes (bbdb-record &optional regrind)
  862.   (interactive (list (bbdb-current-record t) t))
  863.   (let ((notes (bbdb-read-string "Notes: " (bbdb-record-notes bbdb-record))))
  864.     (bbdb-record-set-notes bbdb-record (if (string= "" notes) nil notes)))
  865.   (if regrind
  866.       (save-excursion
  867.     (set-buffer bbdb-buffer-name)
  868.     (bbdb-redisplay-one-record bbdb-record)))
  869.   nil)
  870.  
  871. (defun bbdb-record-edit-property (bbdb-record &optional prop regrind)
  872.   (interactive (list (bbdb-current-record t) nil t))
  873.   (let* ((propnames (bbdb-propnames))
  874.      (propname (if prop (symbol-name prop)
  875.              (completing-read
  876.                (format "Edit property of %s: "
  877.                    (bbdb-record-name bbdb-record))
  878.                (cons '("notes") propnames))))
  879.      (propsym (or prop (if (equal "" propname) 'notes (intern propname))))
  880.      (string (bbdb-read-string (format "%s: " propname)
  881.                    (bbdb-record-getprop bbdb-record propsym))))
  882.     (bbdb-record-putprop bbdb-record propsym
  883.              (if (string= "" string) nil string)))
  884.   (if regrind
  885.       (save-excursion
  886.     (set-buffer bbdb-buffer-name)
  887.     (bbdb-redisplay-one-record bbdb-record)))
  888.   nil)
  889.  
  890.  
  891. (defsubst bbdb-field-equal (x y)
  892.   (if (and (consp x) (consp y))
  893.       (and (eq (car x) (car y))
  894.        (eq (car (cdr x)) (car (cdr y)))
  895.        (eq (car (cdr (cdr x))) (car (cdr (cdr y)))))
  896.     (eq x y)))
  897.  
  898. (defun bbdb-next-field (&optional count planning-on-modifying)
  899.   (or count (setq count 1))
  900.   (beginning-of-line)
  901.   (let* ((record (bbdb-current-record planning-on-modifying))
  902.      (field (bbdb-current-field planning-on-modifying))
  903.      (next-record record)
  904.      (next-field field)
  905.      (signum (if (< count 0) -1 1))
  906.      (i 0))
  907.     (if (< count 0) (setq count (- count)))
  908.     (if field
  909.     (while (and next-field (< i count))
  910.       (while (bbdb-field-equal next-field field)
  911.         (forward-line signum)
  912.         (setq next-record (bbdb-current-record planning-on-modifying)
  913.           next-field (bbdb-current-field planning-on-modifying))
  914.         (or (eq next-record record)
  915.         (setq next-field nil)))
  916.       (setq i (1+ i))
  917.       (setq field next-field)))
  918.     next-field))
  919.  
  920. (defun bbdb-transpose-fields (&optional arg)
  921.   "This is like the `transpose-lines' command, but it is for BBDB fields.
  922. If the cursor is on a field of a BBDB record, that field and the previous
  923. field will be transposed.
  924.  
  925. With argument ARG, takes previous line and moves it past ARG fields.
  926. With argument 0, interchanges field point is in with field mark is in.
  927.  
  928. Both fields must be in the same record, and must be of the same basic type
  929. \(that is, you can use this command to change the order in which phone-number
  930. fields are listed, but you can't use it to make an address appear before a
  931. phone number; the order of field types is fixed.\)"
  932.   (interactive "p")
  933.   (let ((record (bbdb-current-record t))
  934.     moving-field position-after position-before
  935.     swap-p type list)
  936.     (if (/= arg 0)
  937.     (setq moving-field (or (bbdb-next-field -1 t)
  938.                    (error "no previous field"))
  939.           position-after (bbdb-next-field arg t)
  940.           position-before (bbdb-next-field (if (< arg 0) -1 1) t))
  941.       ;; if arg is 0, swap fields at point and mark
  942.       (setq swap-p t)
  943.       (setq position-after (bbdb-current-field))
  944.       (save-excursion
  945.     (goto-char (mark))
  946.     (setq moving-field (bbdb-current-field))
  947.     (or (eq record (bbdb-current-record)) (error "not in the same record"))
  948.     ))
  949.     (if (< arg 0)
  950.     (let ((x position-after))
  951.       (setq position-after position-before
  952.         position-before x)
  953.       (forward-line 2)))
  954.     (setq type (car moving-field))
  955.     (or position-after position-before
  956.     (error "that would be out of the record!"))
  957.     (or (eq type (car position-after))
  958.     (eq type (car position-before))
  959.     (error "can't transpose fields of different types (%s and %s)"
  960.            type (if (eq type (car position-after))
  961.             (car position-before) (car position-after))))
  962.     (or (eq type (car position-after)) (setq position-after nil))
  963.     (or (eq type (car position-before)) (setq position-before nil))
  964.     (setq moving-field (nth 1 moving-field)
  965.       position-after (nth 1 position-after)
  966.       position-before (nth 1 position-before))
  967.     (cond ((memq type '(name aka net))
  968.        (error "there is only one %s field, so you can't transpose it"
  969.           type))
  970.       ((memq type '(phone address property))
  971.        (setq list (bbdb-record-get-field-internal record type)))
  972.       (t (error "doubleplus ungood: unknown field %s" type)))
  973.     (if swap-p
  974.     (let ((rest list))
  975.       (while rest
  976.         (cond ((eq (car rest) moving-field) (setcar rest position-after))
  977.           ((eq (car rest) position-after) (setcar rest moving-field)))
  978.         (setq rest (cdr rest))))
  979.       (if (eq position-before (car list))
  980.       (setq list (cons moving-field (delq moving-field list)))
  981.     (let ((rest list))
  982.       (while (and rest (not (eq position-after (car rest))))
  983.         (setq rest (cdr rest)))
  984.       (or rest (error "doubleplus ungood: couldn't reorder list"))
  985.       (let ((inhibit-quit t))
  986.         (setq list (delq moving-field list))
  987.         (setcdr rest (cons moving-field (cdr rest)))))))
  988.     (bbdb-record-store-field-internal record type list)
  989.     (bbdb-change-record record nil)
  990.     (bbdb-redisplay-one-record record)))
  991.  
  992.  
  993. (defun bbdb-delete-current-field-or-record ()
  994.   "Delete the line which the cursor is on; actually, delete the field which
  995. that line represents from the database.  If the cursor is on the first line
  996. of a database entry (the name/company line) then the entire entry will be
  997. deleted."
  998.   (interactive)
  999.   (let* ((record (bbdb-current-record t))
  1000.      (field (bbdb-current-field t))
  1001.      (type (car field))
  1002.      (uname (bbdb-record-name record))
  1003.      (name (cond ((null field) (error "on an unfield"))
  1004.              ((eq type 'property) (symbol-name (car (nth 1 field))))
  1005.              (t (symbol-name type)))))
  1006.     (if (eq type 'name)
  1007.     (bbdb-delete-current-record record)
  1008.     (if (not (bbdb-y-or-n-p (format "delete this %s field (of %s)? "
  1009.                     name uname)))
  1010.         nil
  1011.       (cond ((memq type '(phone address))
  1012.          (bbdb-record-store-field-internal record type
  1013.          (delq (nth 1 field)
  1014.                (bbdb-record-get-field-internal record type))))
  1015.         ((memq type '(net aka))
  1016.          (let ((rest (bbdb-record-get-field-internal record type)))
  1017.            (while rest
  1018.              (bbdb-remhash (downcase (car rest)))
  1019.              (setq rest (cdr rest))))
  1020.          (bbdb-record-store-field-internal record type nil))
  1021.         ((eq type 'property)
  1022.          (bbdb-record-putprop record (car (nth 1 field)) nil))
  1023.         (t (error "doubleplus ungood: unknown field type")))
  1024.       (bbdb-change-record record nil)
  1025.       (bbdb-redisplay-one-record record)))))
  1026.  
  1027. (defun bbdb-delete-current-record (r &optional noprompt)
  1028.   "Delete the entire bbdb database entry which the cursor is within."
  1029.   (interactive (list (bbdb-current-record t)))
  1030.   (if (or noprompt
  1031.       (prog1 (y-or-n-p (format "delete the entire db entry of %s? " (bbdb-record-name r)))
  1032.         (message " ")))
  1033.       (let* ((record-cons (assq r bbdb-records))
  1034.          (next-record-cons (car (cdr (memq record-cons bbdb-records)))))
  1035.     (bbdb-debug (if (bbdb-record-deleted-p r)
  1036.             (error "deleting deleted record")))
  1037.     (bbdb-record-set-deleted-p r t)
  1038.     (bbdb-delete-record-internal r)
  1039.     (if (eq record-cons (car bbdb-records))
  1040.         (setq bbdb-records (cdr bbdb-records))
  1041.         (let ((rest bbdb-records))
  1042.           (while (cdr rest)
  1043.         (if (eq record-cons (car (cdr rest)))
  1044.             (progn
  1045.               (setcdr rest (cdr (cdr rest)))
  1046.               (setq rest nil)))
  1047.         (setq rest (cdr rest)))))
  1048.     (bbdb-redisplay-one-record r record-cons next-record-cons t)
  1049.     (bbdb-with-db-buffer
  1050.       (setq bbdb-changed-records (delq r bbdb-changed-records)))
  1051.     ;;(bbdb-offer-save)
  1052.     )))
  1053.  
  1054. (defun bbdb-elide-record (arg)
  1055.   "Toggle whether the current record is displayed expanded or elided
  1056. \(multi-line or one-line display.\)  With a numeric argument of 0, the 
  1057. current record will unconditionally be made elided; with any other argument,
  1058. the current record will unconditionally be shown expanded.
  1059. \\<bbdb-mode-map>
  1060. If \"\\[bbdb-apply-next-command-to-all-records]\\[bbdb-elide-record]\" is \
  1061. used instead of simply \"\\[bbdb-elide-record]\", then the state of all \
  1062. records will
  1063. be changed instead of just the one at point.  In this case, an argument 
  1064. of 0 means that all records will unconditionally be made elided; any other
  1065. numeric argument means that all of the records will unconditionally be shown
  1066. expanded; and no numeric argument means that the records are made to be in
  1067. the opposite state of the record under point."
  1068.   (interactive "P")
  1069.   (if (bbdb-do-all-records-p)
  1070.       (bbdb-elide-all-records-internal arg)
  1071.     (bbdb-elide-record-internal arg)))
  1072.  
  1073.  
  1074. (defun bbdb-elide-record-internal (arg)
  1075.   (let* ((record (bbdb-current-record))
  1076.      (cons (assq record bbdb-records))
  1077.      (current-state (nth 1 cons))
  1078.      (desired-state
  1079.       (cond ((null arg) (not current-state))
  1080.         ((eq arg 0) nil)
  1081.         (t t))))
  1082.     (if (eq current-state desired-state)
  1083.     nil
  1084.       (setcar (cdr cons) desired-state)
  1085.       (bbdb-redisplay-one-record record))))
  1086.  
  1087. (defun bbdb-elide-all-records-internal (arg)
  1088.   (let* ((record (bbdb-current-record))
  1089.      (cons (assq record bbdb-records))
  1090.      (current-state (nth 1 cons))
  1091.      (desired-state
  1092.       (cond ((null arg) (not current-state))
  1093.         ((eq arg 0) nil)
  1094.         (t t)))
  1095.      (records bbdb-records)
  1096.      (any-change-p nil))
  1097.     (while records
  1098.       (if (eq desired-state (nth 1 (car records)))
  1099.       nil
  1100.     (setq any-change-p t)
  1101.     (setcar (cdr (car records)) desired-state))
  1102.       (setq records (cdr records)))
  1103.     (if (not any-change-p)
  1104.     nil
  1105.       (bbdb-redisplay-records)
  1106.       (set-buffer bbdb-buffer-name)
  1107.       (goto-char (nth 2 (assq record bbdb-records)))
  1108.       (recenter '(4)))))
  1109.  
  1110. (defun bbdb-omit-record (n)
  1111.   "Remove the current record from the display without deleting it from the
  1112. database.  With a prefix argument, omit the next N records.  If negative, 
  1113. omit backwards."
  1114.   (interactive "p")
  1115.   (while (not (= n 0))
  1116.     (if (< n 0) (bbdb-prev-record 1))
  1117.     (let* ((record (or (bbdb-current-record) (error "no records")))
  1118.        (rest bbdb-records)
  1119.        cons next prev-tail)
  1120.       (while rest
  1121.     (if (eq (car (car rest)) record)
  1122.         (setq cons (car rest)
  1123.           next (car (cdr rest))
  1124.           rest nil)
  1125.       (setq prev-tail rest
  1126.         rest (cdr rest))))
  1127.       (or record (error "can't find current record"))
  1128.       (let ((buffer-read-only nil))
  1129.     (delete-region (nth 2 cons) (if next (nth 2 next) (point-max))))
  1130.       (if prev-tail
  1131.       (setcdr prev-tail (cdr (cdr prev-tail)))
  1132.     (setq bbdb-records (cdr bbdb-records)))
  1133.       (setq n (if (> n 0) (1- n) (1+ n)))))
  1134.   (bbdb-frob-mode-line (length bbdb-records)))
  1135.  
  1136. ;;; Fixing up bogus entries
  1137.  
  1138. (defun bbdb-refile-record (old-record new-record)
  1139.   "Merge the current record into some other record; that is, delete the
  1140. record under point after copying all of the data within it into some other
  1141. record.  this is useful if you realize that somehow a redundant record has
  1142. gotten into the database, and you want to merge it with another.
  1143.  
  1144. If both records have names and/or companies, you are asked which to use.
  1145. Phone numbers, addresses, and network addresses are simply concatenated.
  1146. The first record is the record under the point; the second is prompted for.
  1147. Completion behaviour is as dictated by the variable `bbdb-completion-type'."
  1148.   (interactive
  1149.     (let ((r (bbdb-current-record)))
  1150.       (list r
  1151.         (bbdb-completing-read-record
  1152.       (format "merge record \"%s\" into: "
  1153.           (or (bbdb-record-name r) (car (bbdb-record-net r))
  1154.               "???"))))))
  1155.   (if (or (null new-record) (eq old-record new-record))
  1156.       (error "those are the same"))
  1157.   (let*(extra-name
  1158.     (name
  1159.      (cond ((and (/= 0 (length (bbdb-record-name old-record)))
  1160.              (/= 0 (length (bbdb-record-name new-record))))
  1161.         (prog1
  1162.             (if (y-or-n-p (format "Use name \"%s\" instead of \"%s\"? "
  1163.                       (bbdb-record-name old-record)
  1164.                       (bbdb-record-name new-record)))
  1165.             (progn
  1166.               (setq extra-name new-record)
  1167.               (cons (bbdb-record-firstname old-record)
  1168.                 (bbdb-record-lastname old-record)))
  1169.             (setq extra-name old-record)
  1170.             (cons (bbdb-record-firstname new-record)
  1171.                   (bbdb-record-lastname new-record)))
  1172.           (or (and bbdb-use-alternate-names
  1173.                (y-or-n-p
  1174.                  (format "Keep \"%s\" as an alternate name? "
  1175.                      (bbdb-record-name extra-name))))
  1176.               (setq extra-name nil))
  1177.           ))
  1178.            ((= 0 (length (bbdb-record-name old-record)))
  1179.         (cons (bbdb-record-firstname new-record)
  1180.               (bbdb-record-lastname new-record)))
  1181.            (t (cons (bbdb-record-firstname old-record)
  1182.             (bbdb-record-lastname old-record)))))
  1183.     (comp
  1184.      (cond ((and (/= 0 (length (bbdb-record-company old-record)))
  1185.              (/= 0 (length (bbdb-record-company new-record))))
  1186.         (if (y-or-n-p (format "Use company \"%s\" instead of \"%s\"? "
  1187.                       (bbdb-record-company old-record)
  1188.                       (bbdb-record-company new-record)))
  1189.             (bbdb-record-company old-record)
  1190.             (bbdb-record-company new-record)))
  1191.            ((= 0 (length (bbdb-record-company old-record)))
  1192.         (bbdb-record-company new-record))
  1193.            (t (bbdb-record-company old-record))))
  1194.     (old-nets (bbdb-record-net old-record))
  1195.     (old-aka (bbdb-record-aka old-record))
  1196.     )
  1197.     (if extra-name
  1198.     (setq old-aka (cons (bbdb-record-name extra-name) old-aka)))
  1199.     (bbdb-record-set-phones new-record
  1200.       (nconc (bbdb-record-phones new-record)
  1201.          (bbdb-record-phones old-record)))
  1202.     (bbdb-record-set-addresses new-record
  1203.       (nconc (bbdb-record-addresses new-record)
  1204.          (bbdb-record-addresses old-record)))
  1205.     (bbdb-record-set-company new-record comp)
  1206.     (let ((n1 (bbdb-record-raw-notes new-record))
  1207.       (n2 (bbdb-record-raw-notes old-record))
  1208.       tmp)
  1209.       (or (equal n1 n2)
  1210.       (progn
  1211.         (or (listp n1) (setq n1 (list (cons 'notes n1))))
  1212.         (or (listp n2) (setq n2 (list (cons 'notes n2))))
  1213.         (while n2
  1214.           (if (setq tmp (assq (car (car n2)) n1))
  1215.           (setcdr tmp (concat (cdr tmp) "\n" (cdr (car n2))))
  1216.         (setq n1 (nconc n1 (list (car n2)))))
  1217.           (setq n2 (cdr n2)))
  1218.         (bbdb-record-set-raw-notes new-record n1))))
  1219.     (bbdb-delete-current-record old-record 'noprompt)
  1220.     (bbdb-record-set-net new-record
  1221.       (nconc (bbdb-record-net new-record) old-nets))
  1222.     (bbdb-record-set-firstname new-record (car name))
  1223.     (bbdb-record-set-lastname new-record (cdr name))
  1224.     (bbdb-record-set-namecache new-record nil)
  1225.     (bbdb-record-set-aka new-record
  1226.       (nconc (bbdb-record-aka new-record) old-aka))
  1227.     (bbdb-change-record new-record t) ; don't always need-to-sort...
  1228.     (let ((bbdb-elided-display nil))
  1229.       (if (assq new-record bbdb-records)
  1230.       (bbdb-redisplay-one-record new-record))
  1231.       (bbdb-with-db-buffer
  1232.     (if (not (memq new-record bbdb-changed-records))
  1233.         (setq bbdb-changed-records
  1234.           (cons new-record bbdb-changed-records))))
  1235.       (if (null bbdb-records)  ; nothing displayed, display something.
  1236.       (bbdb-display-records (list new-record)))))
  1237.   (message "records merged."))
  1238.  
  1239.  
  1240. ;;; Send-Mail interface
  1241.  
  1242. (defun bbdb-dwim-net-address (record &optional net)
  1243.   "Returns a string to use as the email address of the given record.  The
  1244. given address is the address the mail is destined to; this is formatted like
  1245. \"Firstname Lastname <addr>\" unless both the first name and last name are
  1246. constituents of the address, as in John.Doe@SomeHost, or the address is
  1247. already in the form \"Name <foo>\" or \"foo (Name)\", in which case the
  1248. address is used as-is."
  1249.   (or net (setq net (car (bbdb-record-net record))))
  1250.   (or net (error "record unhas network addresses"))
  1251.   (let* ((override (bbdb-record-getprop record 'mail-name))
  1252.      (name (or override (bbdb-record-name record)))
  1253.      fn ln both (i 0))
  1254.     (if override
  1255.     (setq both (bbdb-divide-name override)
  1256.           fn (car both)
  1257.           ln (car (cdr both)))
  1258.       (setq fn (bbdb-record-firstname record)
  1259.         ln (bbdb-record-lastname record)))
  1260.     ;; if the name contains backslashes or double-quotes, backslash them.
  1261.     (if name
  1262.     (while (setq i (string-match "[\\\"]" name i))
  1263.       (setq name (concat (substring name 0 i) "\\" (substring name i))
  1264.         i (+ i 2))))
  1265.     (cond ((or (null name)
  1266.            (cond ((and fn ln)
  1267.               (or (string-match
  1268.                (concat "\\`[^!@%]*\\b" (regexp-quote fn)
  1269.                    "\\b[^!%@]+\\b" (regexp-quote ln) "\\b")
  1270.                net)
  1271.               (string-match
  1272.                (concat "\\`[^!@%]*\\b" (regexp-quote ln)
  1273.                    "\\b[^!%@]+\\b" (regexp-quote fn) "\\b")
  1274.                net)))
  1275.              ((or fn ln)
  1276.               (string-match
  1277.                (concat "\\`[^!@%]*\\b" (regexp-quote (or fn ln))
  1278.                    "\\b[^!%@]")
  1279.                (or fn ln))))
  1280.            ;; already in "foo <bar>" or "bar <foo>" format.
  1281.            (string-match "\\`[ \t]*[^<]+[ \t]*<" net)
  1282.            (string-match "\\`[ \t]*[^(]+[ \t]*(" net))
  1283.        net)
  1284.       ;; if the name contains control chars or RFC822 specials, it needs
  1285.       ;; to be enclosed in quotes.  Double-quotes and backslashes have
  1286.       ;; already been escaped.  This quotes a few extra characters as
  1287.       ;; well (!,%, and $) just for common sense.
  1288.       ((string-match "[][\000-\037\177()<>@,;:.!$%]" name)
  1289.        (format "\"%s\" <%s>" name net))
  1290.       (t
  1291.        (format "%s <%s>" name net)))))
  1292.  
  1293.  
  1294. (defun bbdb-send-mail-internal (&optional to subj records)
  1295.   (let ((type (or bbdb-send-mail-style
  1296.           (cond ((featurep 'mh-e) 'mh)
  1297.             ((featurep 'vm) 'vm)
  1298.             (t 'mail)))))
  1299.     (cond
  1300.      ((eq type 'mh)
  1301.       (or (fboundp 'mh-send) (autoload 'mh-send "mh-e"))
  1302.       (mh-send to "" (or subj "")))
  1303.      ((eq type 'vm)
  1304.       (cond ((not (fboundp 'vm-mail-internal))
  1305.          (load-library "vm") ; 5.32 or later
  1306.          (or (fboundp 'vm-mail-internal)
  1307.          (load-library "vm-reply")))) ; 5.31 or earlier
  1308.       (vm-mail-internal
  1309.         (and records (format "mail to %s%s" (bbdb-record-name (car records))
  1310.                  (if (cdr records) ", ..." "")))
  1311.     to subj))
  1312.      ((or (eq type 'mail) (eq type 'rmail))
  1313.       (mail nil to subj))
  1314.      (t
  1315.       (error "bbdb-send-mail-style must be vm, mh, or rmail")))))
  1316.            
  1317.  
  1318. (defun bbdb-send-mail (bbdb-record &optional subject)
  1319.   "Compose a mail message to the person indicated by the current bbdb record.
  1320. The first (most-recently-added) address is used if there are more than one.
  1321. \\<bbdb-mode-map>
  1322. If \"\\[bbdb-apply-next-command-to-all-records]\\[bbdb-send-mail]\" is \
  1323. used instead of simply \"\\[bbdb-send-mail]\", then mail will be sent to \
  1324. all of the
  1325. folks listed in the *BBDB* buffer instead of just the person at point."
  1326.   (interactive (list (if (bbdb-do-all-records-p)
  1327.              (mapcar 'car bbdb-records)
  1328.                (bbdb-current-record))))
  1329.   (if (consp bbdb-record)
  1330.       (bbdb-send-mail-many bbdb-record subject)
  1331.     (bbdb-send-mail-1 bbdb-record subject)))
  1332.  
  1333.  
  1334. (defun bbdb-send-mail-1 (bbdb-record &optional subject)
  1335.   (if bbdb-inside-electric-display
  1336.       (bbdb-electric-throw-to-execute
  1337.     (list 'bbdb-send-mail bbdb-record subject)))
  1338.   ;; else...
  1339.  
  1340.   (cond ((null bbdb-record) (error "record unexists"))
  1341.     ((null (bbdb-record-net bbdb-record))
  1342.      (error "Current record unhas a network addresses."))
  1343.     (t (bbdb-send-mail-internal (bbdb-dwim-net-address bbdb-record)
  1344.                     subject (list bbdb-record))
  1345.        (if (re-search-backward "^Subject: $" nil t) (end-of-line)))))
  1346.  
  1347.  
  1348. (defun bbdb-send-mail-many (records &optional subject)
  1349.   (if bbdb-inside-electric-display
  1350.       (bbdb-electric-throw-to-execute
  1351.     (list 'bbdb-send-mail (list 'quote records) subject)))
  1352.   ;; else...
  1353.  
  1354.   (let ((good '()) (bad '())
  1355.     (orec records))
  1356.     (while records
  1357.       (if (bbdb-record-net (car records))
  1358.       (setq good (cons (car records) good))
  1359.       (setq bad (cons (car records) bad)))
  1360.       (setq records (cdr records)))
  1361.     (bbdb-send-mail-internal
  1362.       (mapconcat (function (lambda (x) (bbdb-dwim-net-address x)))
  1363.          (nreverse good) ",\n    ")
  1364.       subject orec)
  1365.     (if (not bad) nil
  1366.       (goto-char (point-max))
  1367.       (let ((p (point))
  1368.         (fill-prefix "    ")
  1369.         (fill-column 70))
  1370.     (insert "*** Warning: No net addresses for "
  1371.         (mapconcat (function (lambda (x) (bbdb-record-name x)))
  1372.                (nreverse bad) ", ") ".")
  1373.     (fill-region-as-paragraph p (point))
  1374.     (goto-char p))))
  1375.   (if (re-search-backward "^Subject: $" nil t) (end-of-line)))
  1376.  
  1377.  
  1378. (defun bbdb-yank-addresses ()
  1379.   "CC the people displayed in the *BBDB* buffer on this message.
  1380. The primary net-address of each of the records currently listed in the
  1381. *BBDB* buffer (whether it is visible or not) will be appended to the 
  1382. CC: field of the current buffer (assuming the current buffer is a mail
  1383. composition buffer.)"
  1384.   (interactive)
  1385.   (let ((addrs (save-excursion
  1386.          (set-buffer bbdb-buffer-name)
  1387.          (delq nil
  1388.                (mapcar (function (lambda (x)
  1389.                        (if (bbdb-record-net (car x))
  1390.                            (bbdb-dwim-net-address (car x))
  1391.                          nil)))
  1392.                    bbdb-records)))))
  1393.     (goto-char (point-min))
  1394.     ;; If there's a CC field, move to the end of it, inserting a comma if 
  1395.     ;;  there are already addresses present.
  1396.     ;; Otherwise, if there's an empty To: field, move to the end of it.
  1397.     ;; Otherwise, insert an empty CC: field.
  1398.     (if (re-search-forward "^CC:[ \t]*" nil t)
  1399.     (if (eolp)
  1400.         nil
  1401.       (end-of-line)
  1402.       (while (looking-at "\n[ \t]")
  1403.         (forward-char) (end-of-line))
  1404.       (insert ",\n")
  1405.       (indent-relative))
  1406.       (re-search-forward "^To:[ \t]*")
  1407.       (if (eolp)
  1408.       nil
  1409.     (end-of-line)
  1410.     (while (looking-at "\n[ \t]")
  1411.       (forward-char) (end-of-line))
  1412.     (insert "\nCC:")
  1413.     (indent-relative)))
  1414.     ;; Now insert each of the addresses on its own line.
  1415.     (while addrs
  1416.       (insert (car addrs))
  1417.       (if (cdr addrs) (progn (insert ",\n") (indent-relative)))
  1418.       (setq addrs (cdr addrs)))))
  1419.  
  1420.  
  1421. ;;; completion
  1422.  
  1423. (defun bbdb-completion-predicate (symbol)
  1424.   "For use as the third argument to completing-read, to obey the
  1425. semantics of bbdb-completion-type."
  1426.   (let (name r n)
  1427.     (and (boundp symbol)
  1428.      (setq name (symbol-name symbol)
  1429.            r (symbol-value symbol))
  1430.      (or (null bbdb-completion-type)
  1431.          (and (memq bbdb-completion-type
  1432.             '(name primary-or-name name-or-primary))
  1433.           (setq n (bbdb-record-name r))
  1434.           (string= name (downcase n)))
  1435.          (and (setq n (bbdb-record-net r))
  1436.           (or (and (memq bbdb-completion-type
  1437.                  '(primary primary-or-name name-or-primary))
  1438.                (string= name (downcase (car n))))
  1439.               (and (eq bbdb-completion-type 'net)
  1440.                (let ((done nil))
  1441.                  (while (and n (not done))
  1442.                    (if (string= name (downcase (car n)))
  1443.                    (setq done t))
  1444.                    (setq n (cdr n)))
  1445.                  done))))))))
  1446.  
  1447. (defun bbdb-completing-read-record (prompt)
  1448.   "Prompt for and return a record from the bbdb; completion is done according
  1449. to bbdb-completion-type.  If the user just hits return, nil is returned.
  1450. Otherwise, a valid response is forced."
  1451.   (let* ((ht (bbdb-hashtable))
  1452.      (string (completing-read prompt ht 'bbdb-completion-predicate))
  1453.      (symbol (and (not (= 0 (length string)))
  1454.               (intern-soft string ht))))
  1455.     (if symbol
  1456.     (if (and (boundp symbol) (symbol-value symbol))
  1457.         (symbol-value symbol)
  1458.         (error "selecting deleted (unhashed) record \"%s\"!" symbol))
  1459.     nil)))
  1460.  
  1461.  
  1462. (defvar bbdb-read-addresses-with-completion-map
  1463.   (let ((map (copy-keymap minibuffer-local-completion-map)))
  1464.     (define-key map " " 'self-insert-command)
  1465.     (define-key map "\t" 'bbdb-complete-name)
  1466.     (define-key map "\M-\t" 'bbdb-complete-name)
  1467.     map))
  1468.  
  1469. (defun bbdb-read-addresses-with-completion (prompt &optional default)
  1470.   "Like read-string, but allows bbdb-complete-name style completion."
  1471.     (read-from-minibuffer prompt default
  1472.               bbdb-read-addresses-with-completion-map))
  1473.  
  1474.  
  1475. (defvar bbdb-complete-name-saved-window-config nil)
  1476.  
  1477. (defun bbdb-complete-name-cleanup ()
  1478.   (if bbdb-complete-name-saved-window-config
  1479.       (progn
  1480.     (if (get-buffer-window "*Completions*")
  1481.         (set-window-configuration
  1482.           bbdb-complete-name-saved-window-config))
  1483.     (setq bbdb-complete-name-saved-window-config nil))))
  1484.  
  1485. (defun bbdb-complete-name ()
  1486.   "Complete the user full-name or net-address before point (up to the 
  1487. preceeding newline, colon, or comma).  If what has been typed is unique,
  1488. insert an entry of the form \"User Name <net-addr>\".  If it is a valid
  1489. completion but not unique, a list of completions is displayed.  
  1490.  
  1491. Completion behaviour can be controlled with 'bbdb-completion-type'."
  1492.   (interactive)
  1493.   (let* ((end (point))
  1494.      (beg (save-excursion
  1495.         (re-search-backward "\\(\\`\\|[\n:,]\\)[ \t]*")
  1496.         (goto-char (match-end 0))
  1497.         (point)))
  1498.      (pattern (downcase (buffer-substring beg end)))
  1499.      (ht (bbdb-hashtable))
  1500.      (pred (function (lambda (sym)
  1501.          (and (bbdb-completion-predicate sym)
  1502.               (bbdb-record-net (symbol-value sym))))))
  1503.      (completion (try-completion pattern ht pred)))
  1504.     (cond ((eq completion t)
  1505.        (let* ((sym (intern-soft pattern ht))
  1506.           (val (symbol-value sym)))
  1507.          (delete-region beg end)
  1508.          (insert (bbdb-dwim-net-address val
  1509.                (if (string= (symbol-name sym)
  1510.                     (downcase (or (bbdb-record-name val) "")))
  1511.                nil
  1512.              ;; get the case right
  1513.              (let ((nets (bbdb-record-net val))
  1514.                    (want (symbol-name sym))
  1515.                    (the-one nil))
  1516.                (while (and nets (not the-one))
  1517.                  (if (string= want (downcase (car nets)))
  1518.                  (setq the-one (car nets))
  1519.                  (setq nets (cdr nets))))
  1520.                the-one))))
  1521.          ;;
  1522.          ;; if we're past fill-column, wrap at the previous comma.
  1523.          (if (and
  1524.           (if (boundp 'auto-fill-function) ; the emacs19 name.
  1525.               auto-fill-function
  1526.             auto-fill-hook)
  1527.           (>= (current-column) fill-column))
  1528.          (let ((p (point))
  1529.                bol)
  1530.            (save-excursion
  1531.              (beginning-of-line)
  1532.              (setq bol (point))
  1533.              (goto-char p)
  1534.              (if (search-backward "," bol t)
  1535.              (progn
  1536.                (forward-char 1)
  1537.                (insert "\n   "))))))
  1538.          ;;
  1539.          ;; Update the *BBDB* buffer if desired.
  1540.          (if bbdb-completion-display-record
  1541.          (let ((bbdb-gag-messages t))
  1542.            (bbdb-display-records-1 (list val) t)))
  1543.          (bbdb-complete-name-cleanup)
  1544.          ))
  1545.       ((null completion)
  1546.        (bbdb-complete-name-cleanup)
  1547.        (message "completion for \"%s\" unfound." pattern)
  1548.        (ding))
  1549.       ((not (string= pattern completion))
  1550.        (delete-region beg end)
  1551.        (insert completion)
  1552.        (setq end (point))
  1553.        (let ((last ""))
  1554.          (while (and (stringp completion)
  1555.              (not (string= completion last))
  1556.              (setq last completion
  1557.                    pattern (downcase (buffer-substring beg end))
  1558.                    completion (try-completion pattern ht pred)))
  1559.            (if (stringp completion)
  1560.            (progn (delete-region beg end)
  1561.               (insert completion))))
  1562.          (bbdb-complete-name)
  1563.          ))
  1564.       (t
  1565.        (message "Making completion list...")
  1566.        (let* ((list (all-completions pattern ht pred))
  1567.           (recs (delq nil (mapcar (function (lambda (x)
  1568.                         (symbol-value (intern-soft x ht))))
  1569.                       list))))
  1570.          (if (and (not (eq bbdb-completion-type 'net))
  1571.               (= 2 (length list))
  1572.               (eq (symbol-value (intern (car list) ht))
  1573.               (symbol-value (intern (nth 1 list) ht)))
  1574.               (not (string= completion (car list))))
  1575.          (progn
  1576.            (delete-region beg end)
  1577.            (insert (car list))
  1578.            (message " ")
  1579.            (bbdb-complete-name))
  1580.            (if (not (get-buffer-window "*Completions*"))
  1581.            (setq bbdb-complete-name-saved-window-config
  1582.              (current-window-configuration)))
  1583.            (with-output-to-temp-buffer "*Completions*"
  1584.          (display-completion-list list))
  1585.            (message "Making completion list...done")))))))
  1586.  
  1587. (defun bbdb-yank ()
  1588.   "Insert the current contents of the *BBDB* buffer at point."
  1589.   (interactive)
  1590.   (insert (let ((b (current-buffer)))
  1591.        (set-buffer bbdb-buffer-name)
  1592.        (prog1 (buffer-string) (set-buffer b)))))
  1593.  
  1594.  
  1595. ;;; interface to mail-abbrevs.el.
  1596.  
  1597. (defvar bbdb-define-all-aliases-field 'mail-alias
  1598.   "*The field which bbdb-define-all-aliases searches for.")
  1599.  
  1600. (defun bbdb-define-all-aliases ()
  1601.   "Define mail aliases for some of the records in the database.
  1602. Every record which has a `mail-alias' field will have a mail alias
  1603. defined for it which is the contents of that field.  If there are 
  1604. multiple comma-separated words in the `mail-alias' field, then all
  1605. of those words will be defined as aliases for that person.
  1606.  
  1607. If multiple entries in the database have the same mail alias, then 
  1608. that alias expands to a comma-separated list of the network addresses
  1609. of all of those people."
  1610.   (let* ((records (bbdb-search (bbdb-records) nil nil nil
  1611.                    (cons bbdb-define-all-aliases-field ".")))
  1612.      result record aliases match)
  1613.     (while records
  1614.       (setq record (car records))
  1615.       (setq aliases (bbdb-split 
  1616.              (bbdb-record-getprop record bbdb-define-all-aliases-field)
  1617.              ","))
  1618.       (while aliases
  1619.     (if (setq match (assoc (car aliases) result))
  1620.         (nconc match (cons record nil))
  1621.       (setq result (cons (list (car aliases) record) result)))
  1622.     (setq aliases (cdr aliases)))
  1623.       (setq records (cdr records)))
  1624.     (while result
  1625.       (let ((alias (car (car result)))
  1626.         (expansion (mapconcat 'bbdb-dwim-net-address (cdr (car result))
  1627.                   (if (boundp 'mail-alias-separator-string)
  1628.                       mail-alias-separator-string
  1629.                     ", "))))
  1630.     (define-mail-alias alias expansion)
  1631.     (setq alias (or (intern-soft alias mail-aliases)
  1632.             (error "couldn't find the alias we just defined!")))
  1633.     (or (eq (symbol-function alias) 'mail-abbrev-expand-hook)
  1634.         (error "mail-aliases contains unexpected hook %s"
  1635.            (symbol-function alias)))
  1636.     ;; The abbrev-hook is called with network addresses instead of bbdb
  1637.     ;; records to avoid keeping pointers to records, which would lose if
  1638.     ;; the database was reverted.  It uses -search-simple to convert
  1639.     ;; these to records, which is plenty fast.
  1640.     (fset alias (list 'lambda '()
  1641.               (list 'bbdb-mail-abbrev-expand-hook
  1642.                 (list 'quote
  1643.                       (mapcar
  1644.                        (function
  1645.                     (lambda (x) (car (bbdb-record-net x))))
  1646.                        (cdr (car result))))))))
  1647.       (setq result (cdr result)))))
  1648.  
  1649. (defun bbdb-mail-abbrev-expand-hook (records)
  1650.   (mail-abbrev-expand-hook)
  1651.   (if bbdb-completion-display-record
  1652.       (let ((bbdb-gag-messages t))
  1653.     (bbdb-display-records-1
  1654.      (mapcar (function (lambda (x) (bbdb-search-simple nil x))) records)
  1655.      t))))
  1656.  
  1657. ;;; Sound
  1658.  
  1659. (defvar bbdb-dial-local-prefix nil
  1660.   "*If this is non-nil, it should be a string of digits which your phone
  1661. system requires before making local calls (for example, if your phone system
  1662. requires you to dial 9 before making outside calls.)")
  1663.  
  1664. (defvar bbdb-dial-long-distance-prefix nil
  1665.   "*If this is non-nil, it should be a string of digits which your phone
  1666. system requires before making a long distance call (one not in your local
  1667. area code).  For example, in some areas you must dial 1 before an area code.")
  1668.  
  1669.  
  1670. (defvar bbdb-sound-player "/usr/demo/SOUND/play")
  1671. (defvar bbdb-sound-files
  1672.   '["/usr/demo/SOUND/sounds/touchtone.0.au"
  1673.     "/usr/demo/SOUND/sounds/touchtone.1.au"
  1674.     "/usr/demo/SOUND/sounds/touchtone.2.au"
  1675.     "/usr/demo/SOUND/sounds/touchtone.3.au"
  1676.     "/usr/demo/SOUND/sounds/touchtone.4.au"
  1677.     "/usr/demo/SOUND/sounds/touchtone.5.au"
  1678.     "/usr/demo/SOUND/sounds/touchtone.6.au"
  1679.     "/usr/demo/SOUND/sounds/touchtone.7.au"
  1680.     "/usr/demo/SOUND/sounds/touchtone.8.au"
  1681.     "/usr/demo/SOUND/sounds/touchtone.9.au"])
  1682.  
  1683. (defun bbdb-dial (phone force-area-code)
  1684.   "On a Sun SparcStation, play the appropriate tones on the builtin 
  1685. speaker to dial the phone number corresponding to the current line.
  1686. If the point is at the beginning of a record, dial the first phone
  1687. number.  Does not dial the extension.  Does not dial the area code if
  1688. it is the same as `bbdb-default-area-code' unless a prefix arg is given."
  1689.   (interactive (list (bbdb-current-field)
  1690.              current-prefix-arg))
  1691.   (if (eq (car-safe phone) 'name)
  1692.       (setq phone (car (bbdb-record-phones (car (cdr phone))))))
  1693.   (if (eq (car-safe phone) 'phone)
  1694.       (setq phone (car (cdr phone))))
  1695.   (or (vectorp phone) (error "not on a phone field"))
  1696.   (or window-system (error "You're not under window system."))
  1697.   (or (file-exists-p bbdb-sound-player)
  1698.       (error "no sound player program"))
  1699.   (let* ((str (bbdb-phone-string phone))
  1700.      L (i 0))
  1701.     (or force-area-code
  1702.     (if (string-match (format "^(%03d)" bbdb-default-area-code) str)
  1703.         (setq str (substring str (match-end 0)))))
  1704.     (if (string-match "x[0-9]+$" str)
  1705.     (setq str (substring str 0 (match-beginning 0))))
  1706.     (if bbdb-dial-local-prefix
  1707.     (let ((d (append bbdb-dial-local-prefix nil)))
  1708.       (or (string-match "\\`[0-9]*\\'" bbdb-dial-local-prefix)
  1709.           (error "bbdb-dial-local-prefix contains non-digits"))
  1710.       (while d
  1711.         (call-process bbdb-sound-player nil nil nil
  1712.               (aref bbdb-sound-files (- (car d) ?0)))
  1713.         (sleep-for 1)
  1714.         (setq d (cdr d)))))
  1715.     (if (and bbdb-dial-long-distance-prefix
  1716.          (string-match "^([0-9][0-9][0-9])" str))
  1717.     (let ((d (append bbdb-dial-long-distance-prefix nil)))
  1718.       (or (string-match "\\`[0-9]*\\'" bbdb-dial-long-distance-prefix)
  1719.           (error "bbdb-dial-long-distance-prefix contains non-digits"))
  1720.       (while d
  1721.         (call-process bbdb-sound-player nil nil nil
  1722.               (aref bbdb-sound-files (- (car d) ?0)))
  1723.         (sleep-for 1)
  1724.         (setq d (cdr d)))))
  1725.     (setq L (length str))
  1726.     (while (< i L)
  1727.       (if (and (<= ?0 (aref str i))
  1728.            (>= ?9 (aref str i)))
  1729.       (call-process bbdb-sound-player nil nil nil
  1730.             (aref bbdb-sound-files (- (aref str i) ?0)))
  1731.       (sit-for 0))
  1732.       (setq i (1+ i)))))
  1733.  
  1734.  
  1735. ;;; Finger, based on code by Sam Cramer <cramer@sun.com>.
  1736. ;;; Note that process-death bugs in 18.57 may make this eat up all the cpu...
  1737.  
  1738. (defvar bbdb-finger-buffer-name "*finger*")
  1739.  
  1740. (defun bbdb-finger-internal (address)
  1741.   (message "Fingering %s..." address)
  1742.   (condition-case condition
  1743.       (let* ((@ (string-match "@" address))
  1744.          (stream (open-network-stream
  1745.               "finger" bbdb-finger-buffer-name
  1746.               (if @ (substring address (1+ @)) "localhost")
  1747.               "finger")))
  1748.     (set-process-sentinel stream 'bbdb-finger-process-sentinel)
  1749.     (princ (concat "finger " address "\n"))
  1750.     (process-send-string stream
  1751.       (concat "/W " (if @ (substring address 0 @) address) "\n"))
  1752.     (process-send-eof stream))
  1753.     (error
  1754.      (princ (format "error fingering %s: %s\n" address
  1755.             (if (stringp condition) condition
  1756.               (concat "\n" (nth 1 condition)
  1757.                   (if (cdr (cdr condition)) ": ")
  1758.                   (mapconcat '(lambda (x)
  1759.                         (if (stringp x) x
  1760.                           (prin1-to-string x)))
  1761.                      (cdr (cdr condition)) ", ")))))
  1762.      (bbdb-finger-process-sentinel nil nil) ; hackaroonie
  1763.      )))
  1764.  
  1765. (defun bbdb-finger-process-sentinel (process s)
  1766.   (save-excursion
  1767.     (set-buffer bbdb-finger-buffer-name)
  1768.     (goto-char (point-min))
  1769.     (while (search-forward "\r" nil t)
  1770.       (delete-char -1))
  1771.     (if (and (boundp 'bbdb-remaining-addrs-to-finger)
  1772.          bbdb-remaining-addrs-to-finger)
  1773.     (let ((addr (car bbdb-remaining-addrs-to-finger)))
  1774.       (setq bbdb-remaining-addrs-to-finger
  1775.         (cdr bbdb-remaining-addrs-to-finger))
  1776.       (goto-char (point-max))
  1777.       (let ((standard-output (current-buffer)))
  1778.         (princ "\n\n\^L\n")
  1779.         (bbdb-finger-internal addr)))
  1780.       (goto-char (point-max))
  1781.       (message "Finger done."))))
  1782.  
  1783.  
  1784. (defun bbdb-finger (record &optional which-address)
  1785.   "Finger the network address of a BBDB record. 
  1786. If this command is executed from the *BBDB* buffer, finger the network
  1787. address of the record at point; otherwise, it prompts for a user.
  1788. With a numeric prefix argument, finger the Nth network address of the 
  1789. current record\; with a prefix argument of ^U, finger all of them.
  1790. The *finger* buffer is filled asynchronously, meaning that you don't
  1791. have to wait around for it to finish\; but fingering another user before
  1792. the first finger has finished could have unpredictable results.
  1793. \\<bbdb-mode-map>
  1794. If this command is executed from the *BBDB* buffer, it may be prefixed
  1795. with \"\\[bbdb-apply-next-command-to-all-records]\" \(as in \
  1796. \"\\[bbdb-apply-next-command-to-all-records]\\[bbdb-finger]\" instead of \
  1797. simply \"\\[bbdb-finger]\"\), meaning to finger all of 
  1798. the users currently listed in the *BBDB* buffer instead of just the one
  1799. at point.  The numeric prefix argument has the same interpretation."
  1800.   (interactive (list (if (string= bbdb-buffer-name (buffer-name))
  1801.              (if (bbdb-do-all-records-p)
  1802.                  (mapcar 'car bbdb-records)
  1803.                (bbdb-current-record))
  1804.                (let (r (p "BBDB Finger: "))
  1805.              (while (not r)
  1806.                (setq r (bbdb-completing-read-record p))
  1807.                (if (not r) (ding))
  1808.                (setq p "Not in the BBDB!  Finger: "))
  1809.              r))
  1810.              current-prefix-arg))
  1811.   (if (not (consp record)) (setq record (list record)))
  1812.   (let ((addrs nil))
  1813.     (while record
  1814.       (cond ((null which-address)
  1815.          (setq addrs
  1816.            (nconc addrs
  1817.               (list (car (bbdb-record-net (car record)))))))
  1818.         ((stringp which-address)
  1819.          (setq addrs (nconc addrs (list which-address))))
  1820.         ((numberp which-address)
  1821.          (setq addrs
  1822.            (nconc addrs
  1823.               (list (nth which-address
  1824.                      (bbdb-record-net (car record)))))))
  1825.         (t
  1826.          (setq addrs
  1827.            (nconc addrs
  1828.               (copy-sequence (bbdb-record-net (car record)))))))
  1829.       (setq record (cdr record)))
  1830.     (save-excursion
  1831.       (with-output-to-temp-buffer bbdb-finger-buffer-name
  1832.     (set-buffer bbdb-finger-buffer-name)
  1833.     (make-local-variable 'bbdb-remaining-addrs-to-finger)
  1834.     (setq bbdb-remaining-addrs-to-finger (cdr addrs))
  1835.     (bbdb-finger-internal (car addrs))))))
  1836.  
  1837.  
  1838. ;;; Help and documentation
  1839.  
  1840. (defvar bbdb-info-file nil
  1841.   "*Set this to the location of the bbdb info file, if it's not in the
  1842. standard place.")
  1843.  
  1844. (defun bbdb-info ()
  1845.   (interactive)
  1846.   (require 'info)
  1847.   (if bbdb-inside-electric-display
  1848.       (bbdb-electric-throw-to-execute '(bbdb-info))
  1849.     (let ((file bbdb-info-file)
  1850.       (Info-directory (and (boundp 'Info-directory) Info-directory)))
  1851.       (if file
  1852.       (setq file (expand-file-name file Info-directory))
  1853.     (setq file (expand-file-name "bbdb" Info-directory))
  1854.     (or (file-exists-p file)
  1855.         (setq file (concat file ".info"))))
  1856.       (or (file-exists-p file) (error "Info file %s doesn't exist" file))
  1857.       (let ((Info-directory (file-name-directory file)))
  1858.     (Info-goto-node (format "(%s)Top" file))))))
  1859.  
  1860. (defun bbdb-help ()
  1861.   (interactive)
  1862.   (message (substitute-command-keys "\\<bbdb-mode-map>\
  1863. new field: \\[bbdb-insert-new-field]  \
  1864. edit field: \\[bbdb-edit-current-field]  \
  1865. delete field: \\[advertized-bbdb-delete-current-field-or-record]  \
  1866. mode help: \\[describe-mode]  \
  1867. info: \\[bbdb-info]")))
  1868.  
  1869.  
  1870. ;;; If Sebastian Kremer's minibuffer history package is around, use it.
  1871. (if (fboundp 'gmhist-make-magic)
  1872.     (mapcar 'gmhist-make-magic
  1873.         '(bbdb bbdb-name bbdb-company bbdb-net bbdb-changed)))
  1874.  
  1875. (provide 'bbdb-com)
  1876.