head 1.3; access; symbols; locks sacha:1.3; strict; comment @; @; 1.3 date 2006.11.02.20.05.59; author sacha; state Exp; branches; next 1.2; 1.2 date 2006.11.02.20.02.18; author sacha; state Exp; branches; next 1.1; 1.1 date 2006.11.02.20.01.56; author sacha; state Exp; branches; next ; desc @@ 1.3 log @Remove unneeded function @ text @(add-to-list 'load-path "/usr/src/bbdb/lisp") (setq bbdb-file-coding-system 'utf-8) (require 'bbdb-autoloads) (require 'bbdb) (require 'bbdb-com) ;(load "bbdb-com" t) (bbdb-initialize 'gnus 'message) ;; (bbdb-insinuate-sc) ;; I want to see the BBDB buffer only when I ask for it. (setq bbdb-use-pop-up nil) ;; Sometimes people have work and personal e-mail addresses. (setq bbdb-complete-name-allow-cycling t) ;; Ignore subnets (setq bbdb-canonicalize-redundant-nets-p t) ;; Always save (setq bbdb-offer-save 1) ;; My screen is not that wide, so I need information displayed on multiple ;; lines (setq bbdb-display-layout 'multi-line) ;; The window should be as small as possible, though. (setq bbdb-pop-up-target-lines 1) ;; Who uses north American numbers, anyway? ;) (setq bbdb-north-american-phone-numbers-p nil) ;; I love my Gnus (add-hook 'gnus-startup-hook 'bbdb-insinuate-gnus) (put 'subjects 'field-separator "\n") (defun sacha/bbdb-canonicalize-net-hook (addr) "Do not notice member@@orkut.com or noreplyaddresses." (cond ((null addr) addr) ((string-match "member@@orkut\\.com" addr) nil) ((string-match "noreply" addr) nil) ((string-match "info@@evite.com" addr) nil) ((string-match "NO-REPLY" addr) nil) (t addr))) (setq bbdb-canonicalize-net-hook 'sacha/bbdb-canonicalize-net-hook) (setq bbdb-auto-notes-alist (quote (("Organization" (".*" company 0 nil)) ("To" ("w3o" . "w3o") ("plug" . "plug") ("linux" . "linux") ("emacs-commit" . "emacs commit") ("emacs" . "emacs") ("emacs-wiki-discuss" . "planner") ("pinoyjug" . "pinoyjug") ("digitalfilipino" . "digitalfilipino") ("sacha" . "personal mail") ("handhelds" . "handhelds") ("debian-edu" . "debian-edu") ("sigcse" . "sigcse") ("debian" . "debian")) ("Cc" ("w3o" . "w3o") ("plug" . "plug") ("linux" . "linux") ("emacs-commit" . "emacs commit") ("emacs" . "emacs") ("sigcse" . "sigcse") ("pinoyjug" . "pinoyjug") ("digitalfilipino" . "digitalfilipino") ("sacha" . "personal mail") ("debian-edu" . "debian-edu") ("debian" . "debian") ("handhelds" . "handhelds")) ("From" ("admu" company "Ateneo de Manila University") ("orkut" . "orkut"))))) (setq bbdb-auto-notes-ignore '((("Organization" . "^Gatewayed from\\\\|^Source only") ("Path" . "main\\.gmane\\.org") ("From" . "NO-REPLY")))) (setq bbdb-auto-notes-ignore-all nil) (setq bbdb-check-zip-codes-p nil) (setq bbdb-default-area-code nil) (setq bbdb-default-country "Canada") (setq bbdb-ignore-most-messages-alist (quote (("To" . "sacha") ("Cc" . "sacha") ("To" "emacs-wiki-discuss")))) (add-hook 'bbdb-notice-hook 'bbdb-auto-notes-hook) (setq bbdb-quiet-about-name-mismatches 0) (setq bbdb/mail-auto-create-p 'bbdb-ignore-most-messages) (setq bbdb/news-auto-create-p nil) (put 'notes 'field-separator "; ") (add-to-list 'bbdb-auto-notes-alist (list "x-face" (list (concat "[ \t\n]*\\([^ \t\n]*\\)" "\\([ \t\n]+\\([^ \t\n]+\\)\\)?" "\\([ \t\n]+\\([^ \t\n]+\\)\\)?" "\\([ \t\n]+\\([^ \t\n]+\\)\\)?") 'face "\\1\\3\\5\\7"))) (defun sacha/bbdb-create-factoid (title &optional text) "Store a factoid named TITLE with associated TEXT into my BBDB. If PREFIX is non-nil, get TEXT from the buffer instead." (interactive (list (read-string "Title: ") (read-string "Text:"))) (unless text (setq text (read-string "Text: "))) (bbdb-create-internal title "factoid" nil nil nil text)) ;; Stolen from http://www.esperi.demon.co.uk/nix/xemacs/personal/dot-gnus-bbdb.html (defadvice bbdb/gnus-update-records (around nix-bbdb-use-summary-buffer-news-auto-create-p activate preactivate) "Propagate the value of news-auto-create-p from the Summary buffer. This allows it to be buffer-local there, so that we can have different values of this variable in different simultaneously active Summary buffers." (let ((bbdb/news-auto-create-p (with-current-buffer gnus-summary-buffer bbdb/news-auto-create-p)) (bbdb/mail-auto-create-p (with-current-buffer gnus-summary-buffer bbdb/mail-auto-create-p))) ad-do-it)) (defun sacha/bbdb-should-not-truncate () "Do not truncate lines in BBDB buffers." (setq truncate-lines nil)) (add-hook 'bbdb-list-hook 'sacha/bbdb-should-not-truncate) (defalias 'bbdb-vcard-export-record-insert-vcard 'sacha/bbdb-vcard-export-record-insert-vcard) (defun sacha/bbdb-vcard-export-record-insert-vcard (record) "Insert a vcard formatted version of RECORD into the current buffer" (let ((name (bbdb-record-name record)) (first-name (bbdb-record-firstname record)) (last-name (bbdb-record-lastname record)) (aka (bbdb-record-aka record)) (company (bbdb-record-company record)) (notes (bbdb-record-notes record)) (phones (bbdb-record-phones record)) (addresses (bbdb-record-addresses record)) (blog (bbdb-record-getprop record 'blog)) (web (bbdb-record-getprop record 'web)) (net (bbdb-record-net record)) (categories (bbdb-record-getprop record bbdb-define-all-aliases-field))) (insert "begin:vcard\n" "version:3.0\n") ;; Specify the formatted text corresponding to the name of the ;; object the vCard represents. The property MUST be present in ;; the vCard object. (insert "fn:" (bbdb-vcard-export-escape name) "\n") ;; Family Name, Given Name, Additional Names, Honorific ;; Prefixes, and Honorific Suffixes (when (or last-name first-name) (insert "n:" (bbdb-vcard-export-escape last-name) ";" (bbdb-vcard-export-escape first-name) ";;;\n")) ;; Nickname of the object the vCard represents. One or more text ;; values separated by a COMMA character (ASCII decimal 44). (when aka (insert "nickname:" (bbdb-vcard-export-several aka) "\n")) ;; FIXME: use face attribute for this one. ;; PHOTO;ENCODING=b;TYPE=JPEG:MIICajCCAdOgAwIBAgICBEUwDQYJKoZIhvcN ;; AQEEBQAwdzELMAkGA1UEBhMCVVMxLDAqBgNVBAoTI05ldHNjYXBlIENvbW11bm ;; ljYXRpb25zIENvcnBvcmF0aW9uMRwwGgYDVQQLExNJbmZvcm1hdGlvbiBTeXN0 ;; FIXME: use birthday attribute if there is one. ;; BDAY:1996-04-15 ;; BDAY:1953-10-15T23:10:00Z ;; BDAY:1987-09-27T08:30:00-06:00 ;; A single structured text value consisting of components ;; separated the SEMI-COLON character (ASCII decimal 59). But ;; BBDB doesn't use this. So there's just one level: (when company (insert "org:" (bbdb-vcard-export-escape company) "\n")) (when blog (insert "URL:" blog "\n")) (when web (insert "URL:" web "\n")) (when notes (insert "note:" (bbdb-vcard-export-escape notes) "\n")) (dolist (phone phones) (insert "tel;type=" (bbdb-vcard-export-escape (bbdb-phone-location phone)) ":" (bbdb-vcard-export-escape (bbdb-phone-string phone)) "\n")) (dolist (address addresses) (insert (bbdb-vcard-export-address-string address) "\n")) (dolist (mail net) (insert "email;type=internet:" (bbdb-vcard-export-escape mail) "\n")) ;; Use CATEGORIES based on mail-alias. One or more text values ;; separated by a COMMA character (ASCII decimal 44). (when categories (insert "categories:" (bbdb-join (mapcar 'bbdb-vcard-export-escape (bbdb-split categories ",")) ",") "\n")) (insert "end:vcard\n"))) (defun sacha/bbdb-records-postal () (sort (delq nil (mapcar (lambda (item) (and (car (bbdb-record-addresses item)) item)) (bbdb-records))) (lambda (a b) (string< (bbdb-address-country (car (bbdb-record-addresses a))) (bbdb-address-country (car (bbdb-record-addresses b))))))) ;(setq sacha/contact-list (sacha/bbdb-records-postal)) ; (bbdb-display-records sacha/contact-list) (defun sacha/bbdb-ping () (interactive) (cond ((eq major-mode 'bbdb-mode) (call-interactively 'sacha/bbdb-ping-bbdb-record)) ((eq major-mode 'gnus-article-mode) (call-interactively 'sacha/bbdb-gnus-ping)) ((eq major-mode 'message-mode) (call-interactively 'sacha/bbdb-gnus-ping)))) (global-set-key "\C-c\C-p" 'sacha/bbdb-ping) (defun sacha/bbdb-ping-bbdb-record (bbdb-record text &optional date regrind) "Adds a note for today to the current BBDB record. Call with a prefix to specify date." (interactive (list (bbdb-current-record t) (read-string "Notes: ") (if current-prefix-arg (planner-read-date) (planner-today)) t)) (bbdb-record-set-notes bbdb-record (concat date ": " text "\n" (bbdb-record-notes bbdb-record))) (if regrind (save-excursion (set-buffer bbdb-buffer-name) (bbdb-redisplay-one-record bbdb-record))) nil) (defun sacha/bbdb-gnus-ping (text) "Add a ping for authors/recipients of this message. Call with a prefix to specify a manual note." (interactive (list (if current-prefix-arg (read-string "Notes: ")))) (let* ((from-me-p (string-match gnus-ignored-from-addresses (message-fetch-field "From"))) (bbdb-get-only-first-address-p nil) (bbdb-get-addresses-headers (list (assoc (if from-me-p 'recipients 'authors) bbdb-get-addresses-headers))) (bbdb/gnus-update-records-mode 'annotating) (bbdb-message-cache nil) (bbdb-user-mail-names nil) (gnus-ignored-from-addresses nil) records) (setq records (bbdb/gnus-update-records t)) (if records (bbdb-display-records records) (bbdb-undisplay-records)) (while records (sacha/bbdb-ping-bbdb-record (car records) (concat (if from-me-p "-> " "<- ") (or text (message-fetch-field "Subject"))) (planner-date-to-filename (date-to-time (message-fetch-field "Date")))) (setq records (cdr records))) (setq records (bbdb/gnus-update-records t)) (if records (bbdb-display-records records) (bbdb-undisplay-records)))) (defun sacha/bbdb-find-people-with-addresses (&optional regexp) (interactive "MRegexp: ") (let ((records bbdb-records) filtered cons next) (while bbdb-records (when (and (bbdb-record-get-field-internal (car (car bbdb-records)) 'address) (or (null regexp) (delq nil (mapcar (lambda (address) (string-match regexp (sacha/bbdb-address-string address))) (bbdb-record-get-field-internal (car (car bbdb-records)) 'address))))) (setq filtered (cons (car bbdb-records) filtered))) (setq bbdb-records (cdr bbdb-records))) (setq bbdb-records filtered) (bbdb-display-records filtered))) (defun sacha/bbdb-sort-by-country () (setq filtered (sort filtered (lambda (rec1 rec2) (cond ((string< (or (bbdb-address-country rec1) "") (or (bbdb-address-country rec2) "")) t) ((string< (or (bbdb-address-country rec2) "") (or (bbdb-address-country rec1) "")) nil) ((string< (or (bbdb-address-state rec1) "") (or (bbdb-address-state rec2) "")) t) ((string< (or (bbdb-address-state rec2) "") (or (bbdb-address-state rec1) "")) nil) (t (string< (sacha/bbdb-address-string rec1) (sacha/bbdb-address-string rec2)))))))) (defun sacha/bbdb-address-string (address) "Return ADDRESS as a string." (mapconcat 'identity (delq nil (list (mapconcat 'identity (bbdb-address-streets address) ", ") (bbdb-address-city address) (bbdb-address-state address) (bbdb-address-zip address) (bbdb-address-country address))) ", ")) (defun sacha/bbdb-yank-addresses () (interactive) (kill-new (mapconcat (lambda (record) (concat (bbdb-record-name (car record)) "\n" (mapconcat (lambda (address) (concat (bbdb-address-location address) ": " (sacha/bbdb-address-string address))) (bbdb-record-get-field-internal (car record) 'address) "\n"))) bbdb-records "\n\n"))) (defun sacha/planner-bbdb-annotation-from-bbdb (&optional record) "If called from a bbdb buffer, return an annotation. Suitable for use in `planner-annotation-functions'." (when (or record (eq major-mode 'bbdb-mode)) (setq record (if record (car record) (bbdb-current-record))) (or (bbdb-record-getprop record 'plan) ;; From a BBDB entry with a plan page; use that. Yay! (and (bbdb-record-name record) (planner-make-link (concat "bbdb://" (planner-replace-regexp-in-string " " "." (bbdb-record-name record))) (bbdb-record-name record)))))) (defalias 'planner-bbdb-annotation-from-bbdb 'sacha/planner-bbdb-annotation-from-bbdb) (defun sacha/yank-planner-bbdb-list () "Copy the list of people displayed in the buffer." (interactive) (kill-new (mapconcat 'sacha/planner-bbdb-annotation-from-bbdb bbdb-records ", "))) (defun sacha/yank-planner-bbdb-list-as-list () "Copy the list of people displayed in the buffer." (interactive) (kill-new (mapconcat (lambda (entry) (if entry (concat " 1. " (sacha/planner-bbdb-annotation-from-bbdb entry) "\n") "")) bbdb-records ""))) (defun sacha/bbdb-grab-email-addresses () "Kill a list of names and e-mail addresses." (interactive) (let ((records bbdb-records) list) (while records (mapc (lambda (email) (setq list (cons (concat (bbdb-record-name (caar records)) "\t" email) list))) (bbdb-record-net (caar records))) (setq records (cdr records))) (kill-new (mapconcat 'identity list "\n")))) ;;;_+ Mail aliases ;; Code for working with aliases ;; You can use "a" (bbdb-add-or-remove-mail-alias) in BBDB buffers to add ;; a mail alias to the current entry, or "* a" to add a mail alias to ;; all displayed entries. ;; Goal: Be able to specify ALIAS and ALIAS ;; M-x sacha/bbdb-filter-displayed-records-by-alias RET alias alias ;; Goal: Be able to specify ALIAS or ALIAS ;; C-u M-x sacha/bbdb-filter-displayed-records-by-alias RET alias alias ;; Goal: Be able to specify not ... ;; M-x sacha/bbdb-omit-displayed-records-by-alias RET alias alias ;; C-u M-x sacha/bbdb-omit-displayed-records-by-alias RET alias alias (defun sacha/bbdb-filter-by-alias-match-all (query-aliases record-aliases) "Return non-nil if all QUERY-ALIASES are in RECORD-ALIASES." (let ((result t)) (while query-aliases (unless (member (car query-aliases) record-aliases) (setq query-aliases nil result nil)) (setq query-aliases (cdr query-aliases))) result)) (defun sacha/bbdb-filter-by-alias-match-any (query-aliases record-aliases) "Return non-nil if any in QUERY-ALIASES can be found in RECORD-ALIASES." (let (result) (while query-aliases (when (member (car query-aliases) record-aliases) (setq query-aliases nil result t)) (setq query-aliases (cdr query-aliases))) result)) ;; Moved this to a convenience function so that we don't ;; have to deal with invert and property splitting. (defun sacha/bbdb-filter-by-alias (bbdb-records alias-filter-function query &optional invert) "Return only the BBDB-RECORDS that match ALIAS-FILTER-FUNCTION. ALIAS-FILTER-FUNCTION should accept two arguments: - QUERY, a list of keywords to search for - aliases, a list of keywords from the record If INVERT is non-nil, return only the records that do not match." (delq nil (mapcar (lambda (rec) (if (funcall alias-filter-function query (split-string (or (bbdb-record-getprop (if (vectorp rec) rec (car rec)) propsym) "") "[ \n\t,]+")) (when (null invert) rec) (when invert rec))) bbdb-records))) ;; Splitting this into two functions because of interactive calling. (defun sacha/bbdb-filter-displayed-records-by-alias (query &optional any) "Display only records whose mail-aliases match QUERY. If ANY is non-nil, match if any of the keywords in QUERY are present. See also `sacha/bbdb-omit-displayed-records-by-alias'." (interactive (list (let ((crm-separator " ")) (completing-read-multiple "Mail aliases: " (bbdb-get-mail-aliases))) current-prefix-arg)) (when (stringp query) (setq query (split-string query "[ \n\t,]+"))) (bbdb-display-records (sacha/bbdb-filter-by-alias-by-function (or bbdb-records (bbdb-records)) (if any 'sacha/bbdb-filter-by-alias-match-any 'sacha/bbdb-filter-by-alias-match-all) query))) ;; Splitting this into two functions because of interactive calling. (defun sacha/bbdb-omit-displayed-records-by-alias (query &optional any) "Display only records whose mail-aliases do not match QUERY. If ANY is non-nil, match if any of the keywords in QUERY are present. See also `sacha/bbdb-filter-displayed-records-by-alias'." (interactive (list (let ((crm-separator " ")) (completing-read-multiple "Mail aliases: " (bbdb-get-mail-aliases)) current-prefix-arg))) (when (stringp query) (setq query (split-string query "[ \n\t,]+"))) (bbdb-display-records (sacha/bbdb-filter-by-alias-by-function (or bbdb-records (bbdb-records)) (if any 'sacha/bbdb-filter-by-alias-match-any 'sacha/bbdb-filter-by-alias-match-all) query t))) ;;;_+ Advanced mail alias queries ;; Goal: Use complicated lambda expressions to filter displayed records ;; M-x sacha/bbdb-filter-by-alias-function RET ;; (lambda (aliases) (and (member "planner" aliases) ;; (not (member "muse" aliases))))) RET ;; Thanks to Paul Lussier for the suggestion! (defun sacha/bbdb-filter-by-alias-function (bbdb-records alias-filter-function) "Return only the BBDB-RECORDS that match ALIAS-FILTER-FUNCTION. ALIAS-FILTER-FUNCTION should accept one argument: - aliases, a list of keywords from the record." (interactive (list (or bbdb-records (bbdb-records)) (read t))) (let (records) (setq records (delq nil (mapcar (lambda (rec) (when (funcall alias-filter-function (split-string (or (bbdb-record-getprop (if (vectorp rec) rec (car rec)) propsym) "") "[ \n\t,]+")) rec)) bbdb-records))) (if (interactive-p) (bbdb-display-records records)) records)) ;;;_+ Show only no contact since... ;; Goal: Filter displayed contacts to show only the people I haven't pinged in a while (require 'planner) (require 'bbdb) (defun sacha/bbdb-show-only-no-contact-since (date) "Show only people who haven't been pinged since DATE or at all." (interactive (list (planner-read-date))) (let ((records bbdb-records) new-records last-match omit notes) (while records ;; Find the latest date mentioned in the entry (setq notes (or (bbdb-record-notes (caar records)) "")) (setq last-match nil omit nil) (while (string-match "[0-9][0-9][0-9][0-9]\\.[0-9][0-9]\\.[0-9][0-9]" notes (or last-match 0)) (unless (string> date (match-string 0 notes)) (setq omit t) (setq last-match (length notes))) (setq last-match (match-end 0))) (unless (and last-match omit) (add-to-list 'new-records (caar records) t)) (setq records (cdr records))) (bbdb-display-records new-records))) ;;;_+ rapid serial visualization ;; Goal: Be reminded of people ;; Very quickly flash through displayed entries (defvar sacha/bbdb-rapid-serial-visualization-delay 1 "*Number of seconds to wait between records. Set to 0 to wait for input.") (defun sacha/bbdb-rapid-serial-visualization () "Breeze through everyone's name and notes." (interactive) (window-configuration-to-register ?a) ;; Copy the currently visible records (let ((records bbdb-records) (default-size (face-attribute 'default :height)) (new-size 400) (continue t)) (set-face-attribute 'default nil :height new-size) (pop-to-buffer (get-buffer-create "BBDB-Serial")) (delete-other-windows) (while (and records continue) (insert (bbdb-record-name (caar records)) "\n\n" (or (car (bbdb-record-net (caar records))) "No e-mail") "\n\n" (or (bbdb-record-notes (caar records)) "") (make-string 50 ?\n)) (goto-char (point-min)) (sit-for sacha/bbdb-rapid-serial-visualization-delay) (setq records (cdr records))) (set-face-attribute 'default nil :height default-size) (when continue (jump-to-register ?a)))) ;;;_+ Prioritize exact matches (defun sacha/bbdb (string no-notes-search) "Display all entries in the BBDB matching the regexp STRING in either the name(s), company, network address, or notes. Prioritize non-note matches." (interactive (list (bbdb-search-prompt "Search records %m regexp: ") current-prefix-arg)) (let* ((notes (cons '* string)) (records-top (bbdb-search (bbdb-records) string string string nil nil)) (records (unless no-notes-search (bbdb-search (bbdb-records) string string string notes nil))) temp) (setq temp records-top) (while temp (setq records (delete (car temp) records)) (setq temp (cdr temp))) (if (or records-top records) (bbdb-display-records (append records-top records)) ;; we could use error here, but it's not really an error. (message "No records matching '%s'" string)))) (defalias 'bbdb 'sacha/bbdb) ;;;_+ LinkedIn import (require 'csv) (require 'lookout) (setq lookout-bbdb-mapping-table '(("lastname" "Last Name") ("firstname" "First Name") ("company" "Company") ("job" "Job Title") ("net" "E-mail Address"))) (defun sacha/lookout-bbdb-check-linkedin (line) (let* ((lastname (lookout-bbdb-get-value "lastname" line)) (firstname (lookout-bbdb-get-value "firstname" line)) (company (lookout-bbdb-get-value "company" line)) (job (lookout-bbdb-get-value "job" line)) (net (lookout-bbdb-get-value "net" line)) (addr1 (lookout-bbdb-get-value "addr1" line)) (addr2 (lookout-bbdb-get-value "addr2" line)) (addr3 (lookout-bbdb-get-value "addr3" line)) (phones (lookout-bbdb-get-value "phones" line t)) ;; ! (notes (lookout-bbdb-get-value "notes" line )) (j (concat job ", " company)) (otherfields (lookout-bbdb-get-value "otherfields" line t)) (addrs nil) (n (concat "^" firstname " " lastname)) (record (or (bbdb-search (bbdb-records) n) (bbdb-search (bbdb-records) nil nil net))) (message "")) (unless record (if (string= company "") (setq company nil)) (if (string= notes "") (setq notes nil)) (if (and addr1 (> (length addr1) 0)) (add-to-list 'addrs (vector "Address 1" (list addr1) "" "" "" ""))) (if (and addr2 (> (length addr2) 0)) (add-to-list 'addrs (vector "Address 2" (list addr2) "" "" "" ""))) (if (and addr3 (> (length addr3) 0)) (add-to-list 'addrs (vector "Address 3" (list addr3) "" "" "" ""))) (setq record (list (lookout-bbdb-create-entry (concat firstname " " lastname) (concat job ", " company) net addrs phones notes otherfields)))) ;; Check if net has changed (when record (setq record (car record)) (let ((nets (bbdb-record-net record))) (unless (member net nets) ;; New e-mail address noticed, add to front of list (add-to-list 'nets net) (bbdb-record-set-net record nets) (message "%s %s: New e-mail address noticed: %s" firstname lastname net))) ;; Check if job title and company have changed (when (or job company) (cond ((string= (or (bbdb-record-company record) "") "") (bbdb-record-set-company record j)) ((string= (bbdb-record-company record) j) nil) (t (bbdb-record-set-notes record (concat (planner-today) ": " "Noticed change from job title of " (bbdb-record-company record) "\n" (bbdb-record-notes record))) (message "%s %s: Noticed change from job title of %s to %s" (planner-today) firstname lastname (bbdb-record-company record) j) (bbdb-record-set-company record j)))) (let* ((propsym bbdb-define-all-aliases-field) (oldaliases (bbdb-record-getprop record propsym))) (if oldaliases (setq oldaliases (if (stringp oldaliases) (bbdb-split oldaliases ",") oldaliases))) (add-to-list 'oldaliases "linkedin") (setq oldaliases (bbdb-join oldaliases ", ")) (bbdb-record-putprop record propsym oldaliases))))) (defun lookout-bbdb-create-entry (name company net addrs phones notes &optional otherfields) (when (or t (y-or-n-p (format "Add %s to bbdb? " name))) ;;(message "Adding record to bbdb: %s" name) (let ((record (bbdb-create-internal name company net addrs phones notes))) (unless record (error "Error creating bbdb record")) (mapcar (lambda (i) (let ((field (make-symbol (aref i 0))) (value (aref i 1))) (when (and value (not (string= "" value))) (bbdb-insert-new-field record field value)))) otherfields) record))) (defun lookout-bbdb-get-value (key entry &optional as-vector-list) "Returns the value for a key from a lispified csv line, using the mapping table." (let* ((table (if (listp lookout-bbdb-mapping-table) lookout-bbdb-mapping-table (symbol-value lookout-bbdb-mapping-table))) (mapped-keys (cdr (assoc key table))) (result nil) (separator "")) ; (unless mapped-keys ; (error ; (format "Cannot find `%s' -- have you set `lookout-bbdb-mapping-table'?" ; key))) (unless as-vector-list (setq result "")) (when mapped-keys (if (stringp mapped-keys) (setq mapped-keys (list mapped-keys))) (mapcar (lambda (i) ;;(message "%s...%s" i (cdr (assoc i entry))) (let ((value (cdr (assoc i entry)))) (unless (string= "" value) (if as-vector-list (add-to-list 'result (vector i value)) (setq result (concat result separator value))) (setq separator " ")))) mapped-keys)) ;;(message "%s" result) result)) (defun sacha/linkedin-import () (interactive) (mapcar 'sacha/lookout-bbdb-check-linkedin (csv-parse-buffer))) (defun sacha/bbdb-clone-record (name net notes record) "Create a new record with the office details of the current record." (interactive (list (read-string "Name: ") (read-string "Net: ") (read-string "Notes: ") (bbdb-current-record))) (bbdb-create-internal name (bbdb-record-company record) net (bbdb-record-addresses record) (bbdb-record-phones record) notes)) ;;;_+ Contact report (defun sacha/count-matches (regexp string) (let ((count 0) (start 0)) (while (string-match regexp string start) (setq start (match-end 0) count (1+ count))) count)) (defun sacha/bbdb-contact-report-as-alist (&rest regexps) "Creates a list of (name count-regexp1 count-regexp2 count-regexp3)..." (setq regexps (reverse regexps)) (delq nil (mapcar (lambda (rec) (when (bbdb-record-name (car rec)) (let ((reg regexps) (notes (bbdb-record-notes (car rec))) list) (while reg (setq list (cons (sacha/count-matches (car reg) notes) list)) (setq reg (cdr reg))) (cons (sacha/planner-bbdb-annotation-from-bbdb rec) list)))) bbdb-records))) (defun sacha/bbdb-alist-sort-by-total (alist) "Sort ALIST by total contact." (sort alist 'sacha/bbdb-contact-sort-predicate)) (defun sacha/bbdb-contact-sort-predicate (a b) (and a b (let ((count-a (apply '+ (cdr a))) (count-b (apply '+ (cdr b)))) (or (> count-a count-b) (and (= count-a count-b) ;; If equal, look at the subtotal of the rest (sacha/bbdb-contact-sort-predicate (cdr a) (cdr b))))))) (defun sacha/bbdb-kill-contact-barchart (alist) "Kill a barchart with the contact report for ALIST." (kill-new (mapconcat (lambda (entry) (concat (car entry) " | " (mapconcat (lambda (count) (if (= count 0) " " (make-string count ?-))) (cdr entry) " | "))) alist "\n"))) ;; Usage: (sacha/bbdb-kill-contact-barchart (sacha/bbdb-alist-sort-by-total (sacha/bbdb-contact-report-as-alist "2006.09" "2006.10"))) (provide 'bbdb-config) @ 1.2 log @Contact barchart @ text @a792 17 (defun sacha/bbdb-contact-report-histogram () (kill-new (mapconcat (lambda (rec) (when (bbdb-record-name (car rec)) (let ((oct (sacha/count-matches "2006.10...:" (bbdb-record-notes (car rec)))) (sept (sacha/count-matches "2006.09...:" (bbdb-record-notes (car rec))))) (concat (sacha/planner-bbdb-annotation-from-bbdb rec) " | " (if (> sept 0) (make-string sept ?-) "   ") " | " (if (> oct 0) (make-string oct ?-) "   ") "\n")))) bbdb-records ""))) @ 1.1 log @Initial revision @ text @d782 59 d842 19 @