Download
(require 'bbdb)
(require 'sms)
(defcustom bbdb-sms-phone-number-types '("Mobile")
"Which phone number types to use when sending SMS text messages.
This should be a list of labels that are also members of bbdb-phone-label-list"
:type '(repeat string)
:group 'bbdb-phone-dialing)
(defcustom bbdb-sms-all-phone-numbers nil
"When non-nil then all valid phone numbers whose type is in `bbdb-sms-phone-number-types' will be used
for sending SMS text messages. Otherwise only the first valid number for each record will be used."
:type 'boolean
:group 'bbdb-phone-dialing)
(defvar bbdb-sms-completion-type 'name)
(defcustom bbdb-sms-complete-name-allow-cycling t
"Whether to allow cycling of phone numbers when calling
`bbdb-sms-complete-name' on a completed phone. This only work when
`bbdb-sms-all-phone-numbers' is nil"
:type 'boolean
:group 'bbdb-phone-dialing)
(defun bbdb-sms-get-mobile-phone-nums ()
"Get each record's mobile phone num in current *BBDB* buffer.
If there is not a *BBDB* buffer, give an error message;
if there are several mobile phone numbers for a record, the first legal one
will be used if `bbdb-sms-all-phone-numbers' is nil, otherwise, all the legal ones are collected.
In both cases only numbers whose type is in `bbdb-sms-phone-number-types' are allowed.
The spaces in the numbers are removed.
A single string of form \"NAME1 <NUM1>, NAME2<NUM2>...\" will be returned; empty
string will be returned if no mobile phone number is found."
(let ((bbdb-display-buffer (get-buffer bbdb-buffer-name)))
(if (bufferp bbdb-display-buffer)
(save-excursion
(set-buffer bbdb-display-buffer)
(let (phone-nums)
(dolist (record bbdb-records)
(let ((record-phone-nums (bbdb-sms-mobile-phone-num (car record))))
(unless (string= record-phone-nums "")
(push record-phone-nums phone-nums))))
(let ((result-string ""))
(dolist (phone-num phone-nums)
(setq result-string (concat phone-num ", " result-string)))
(unless (string= result-string "")
(setq result-string (substring result-string 0 (- (length result-string) 2))))
result-string)))
(error "No *BBDB* buffer found"))))
(defun bbdb-sms-mobile-phone-num (record)
"Get RECORD's mobile phone number as a string with RECORD's name
Return a string of RECORD's mobile phone numbers whose types are in `bbdb-sms-phone-number-types',
or empty string (\"\") if RECORD doesn't have it or doesn't have a legal one. If
`bbdb-sms-all-phone-numbers' is nil, only the first legal mobile phone number will be
in the returned string; if it's non-nil, all the legal mobile phone numbers will be put to
the returned string.
The returned string also contains RECORD's name, and it looks like:
NAME <NUM1> or NAME <NUM1> <NUM2> ...
In NUM1 or NUM2, all the whitespaces are removed."
(let ((phones (bbdb-sms-mobile-phone-num-no-format record))
(record-name (bbdb-record-name record))
(result-string ""))
(when phones
(setq result-string (format "<%s>" (car phones)))
(dolist (phone (cdr phones))
(setq result-string (format "<%s> %s" phone result-string)))
(setq result-string (format "%s %s" record-name result-string)))
result-string))
(defun bbdb-sms-mobile-phone-num-no-format (record &optional all-nums)
"Return a list of valid phone number strings (see `bbdb-sms-mobile-phone-num') for record.
The phone numbers are not formatted.
If the optional ALL-NUMS is non-nil, all the nubmbers according to
`bbdb-sms-phone-number-types' will be returned; otherwise whether all numbers
are returned is controled by `bbdb-sms-all-phone-numbers'"
(or all-nums (setq all-nums bbdb-sms-all-phone-numbers))
(let ((phones (bbdb-record-phones record))
legal-phone-nums)
(when phones
(dolist (phone phones)
(when (member (elt phone 0) bbdb-sms-phone-number-types)
(let* ((phone-num (elt phone 1))
(phone-num-without-spaces (sms-string-remove-number-separators phone-num)))
(unless (string= phone-num-without-spaces "")
(push phone-num-without-spaces legal-phone-nums))
(unless all-nums
(return))))))
legal-phone-nums))
(defun bbdb-sms-completion-predicate (symbol)
"Predicate used for completion in bbdb-sms-complete-name function."
(cond ((null bbdb-sms-completion-type)
t)
((not (boundp symbol))
nil)
(t
(let ((sym (symbol-name symbol))
(recs (symbol-value symbol))
ok)
(while (and recs (not ok))
(setq ok (bbdb-sms-completion-check-record sym (car recs))
recs (cdr recs)))
ok))))
(defun bbdb-sms-completion-check-record (sym rec)
"Used in bbdb-sms-completion-predicate to check record."
(let ((name (or (bbdb-record-name rec)
(bbdb-record-company rec)
""))
ok)
(if (null bbdb-sms-completion-type)
(setq ok 't)
(setq ok (string= sym (downcase name))))
ok))
(defun bbdb-sms-extract-phone-components (phoneline)
"Splite PHONELINE into a list of parsed phone numbers.
NAME1 <NUM1>, NAME2 <NUM2>
will be parsed to
((NAME1 NUM1) (NAME2 NUM2))"
(let (phones (start 0))
(setq phoneline (concat phoneline ","))
(while (string-match "\\([^,]+\\)" phoneline start)
(let* ((thisphone (substring phoneline 0 (match-end 1)))
(comma (match-end 0)))
(if (bbdb-sms-legal-phone-with-namep thisphone)
(setq phones
(append phones (list (bbdb-sms-extract-phone-component
thisphone)))
phoneline (substring phoneline (1+ comma))
start 0)
(setq start (1+ comma)))))
phones))
(defun bbdb-sms-legal-phone-with-namep (name-phone-string)
"Return t if PHONELINE is in format NAME <NUM>, otherwise nil."
(let ((phone-beg (string-match "<\\([0-9]+\\)>[ \t]*" name-phone-string)))
(and phone-beg
(not (string= (bbdb-string-trim (substring name-phone-string 0 phone-beg))
"")))))
(defun bbdb-sms-extract-phone-component (name-phone-string)
"Return a list of the form (NAME PHONE)."
(let* ((phone-beg (string-match "<\\([0-9]+\\)>[ \t]*" name-phone-string))
(phone-end (string-match ">" name-phone-string phone-beg))
(phone (substring name-phone-string (1+ phone-beg) phone-end))
(name (bbdb-string-trim (substring name-phone-string 0 phone-beg))))
(list name phone)))
(defun bbdb-sms-dwim-phone-number (record phone)
"Return a string to use as the email address of the given record."
(format "%s <%s>" (bbdb-record-name record) phone))
(defun bbdb-sms-search-intertwingle (name phone)
"Find bbdb the records matching NAME and PHONE."
(bbdb-records t)
(unless name
(error "NAME can not be nil in `bbdb-sms-search-intertwingle"))
(let ((name-recs (let ((recs (bbdb-gethash (downcase name)))
answer)
(while recs
(let ((n-rec (car recs)))
(if (string= (downcase name)
(downcase
(bbdb-record-name
n-rec)))
(setq answer (append recs (list n-rec))))
(setq recs (cdr recs))))
answer))
recs)
(dolist (rec name-recs)
(let ((phones (bbdb-sms-mobile-phone-num-no-format rec t)))
(if (member phone phones)
(add-to-list 'recs rec))))
recs))
(defun bbdb-sms-complete-name (&optional start-pos)
"Complete the user full-name before point (up to the
preceeding newline, colon, or comma, or the value of START-POS). If
what has been typed is unique, insert the name followed by valid phone numbers
surrounded by angle brackets and the a comma (e.g: joe <07989845524> <014323578987>).
If it is a valid completion but not unique, a list of completions is displayed.
If the completion is done and `bbdb-complete-name-allow-cycling' is
true then cycle through the nets for the matching record.
When called with a prefix arg then display a list of all nets.
Completion behaviour can be controlled with `bbdb-completion-type'."
(interactive)
(let* ((end (point))
(beg (or start-pos
(save-excursion
(re-search-backward "\\(\\`\\|[\n:,]\\)[ \t]*")
(goto-char (match-end 0))
(point))))
(orig (buffer-substring beg end))
(typed (downcase orig))
(pattern (bbdb-string-trim typed))
(ht (bbdb-hashtable))
(only-one-p t)
(all-the-completions nil)
(pred
(lambda (sym)
(when (bbdb-sms-completion-predicate sym)
(if (and only-one-p
all-the-completions
(or
(> (length (symbol-value sym)) 1)
(delete t (mapcar (lambda(x)
(equal (symbol-value x)
(symbol-value sym)))
all-the-completions))))
(setq only-one-p nil))
(if (not (memq sym all-the-completions))
(setq all-the-completions (cons sym all-the-completions))))))
(completion (progn (all-completions pattern ht pred) (try-completion pattern ht)))
(exact-match (eq completion t)))
(cond
((or (null completion)
(and bbdb-complete-name-allow-cycling
exact-match
(member orig
(bbdb-record-net
(car (symbol-value (intern-soft pattern ht)))))))
(bbdb-complete-name-cleanup)
(or (catch 'bbdb-sms-cycling-exit
(when bbdb-sms-all-phone-numbers
(throw 'bbdb-sms-cycling-exit nil))
(or bbdb-sms-complete-name-allow-cycling
(throw 'bbdb-sms-cycling-exit nil))
(let* ((phone (bbdb-sms-extract-phone-components orig))
(rec
(if (listp phone)
(car (bbdb-sms-search-intertwingle (caar phone)
(cadar phone)))
nil)))
(or rec
(throw 'bbdb-sms-cycling-exit nil))
(let* ((phones (bbdb-sms-mobile-phone-num-no-format rec t))
(this-phone (or (cadr (member (car (cdar phone)) phones))
(nth 0 phones))))
(if (= (length phones) 1)
(throw 'bbdb-sms-cycling-exit t)
(delete-region beg end)
(insert (bbdb-sms-dwim-phone-number rec this-phone))
(run-hooks 'bbdb-complete-name-hooks)
(throw 'bbdb-sms-cycling-exit t)))))))
((and only-one-p (or exact-match bbdb-sms-complete-name-allow-cycling))
(let* ((sym (if exact-match (intern-soft pattern ht) (car all-the-completions)))
(recs (symbol-value sym))
match-recs lst primary matched)
(while recs
(when (bbdb-sms-mobile-phone-num-no-format (car recs))
(let ((b-r-name (or (bbdb-record-name (car recs)) "")))
(if (string= pattern
(substring (downcase b-r-name) 0
(min (length b-r-name)
(length pattern))))
(setq match-recs (cons (car recs) match-recs)
matched t)))
(let ((b-r-name (or (bbdb-record-lfname (car recs)) "")))
(if (string= pattern
(substring (downcase b-r-name) 0
(min (length b-r-name)
(length pattern))))
(setq match-recs (cons (car recs) match-recs)
matched t)))
(when (not matched)
(setq lst (bbdb-record-aka (car recs)))
(while lst
(if (string= pattern (substring (downcase (car lst)) 0
(min (length (downcase
(car
lst)))
(length pattern))))
(setq match-recs (append match-recs (list (car recs)))
matched t
lst '())
(setq lst (cdr lst))))))
(setq recs (cdr recs)
matched nil))
(if (null match-recs)
(progn
(message "completion for \"%s\" unfound." pattern)
(ding))
(delete-region beg end)
(insert (bbdb-sms-mobile-phone-num (car match-recs)))
(if (and
(bbdb-auto-fill-function)
(>= (current-column) fill-column))
(let ((p (point))
bol)
(save-excursion
(beginning-of-line)
(setq bol (point))
(goto-char p)
(if (search-backward "," bol t)
(progn
(forward-char 1)
(insert "\n "))))))
(if bbdb-completion-display-record
(let ((bbdb-gag-messages t))
(bbdb-display-records-1 match-recs t)))
(bbdb-complete-name-cleanup)
(run-hooks 'bbdb-complete-name-hooks))))
((and (stringp completion) (not (string= typed completion)))
(delete-region beg end)
(insert completion)
(setq end (point))
(let ((last "")
(bbdb-complete-name-allow-cycling nil))
(while (and (stringp completion)
(not (string= completion last))
(setq last completion
pattern (downcase orig)
completion (progn (all-completions pattern ht pred) (try-completion pattern ht))))
(if (stringp completion)
(progn (delete-region beg end)
(insert completion))))
(bbdb-sms-complete-name beg)))
(t
(or (eq (selected-window) (minibuffer-window))
(message "Making completion list..."))
(let (dwim-completions
uniq name lfname akas)
(bbdb-mapc
(lambda (sym)
(bbdb-mapc
(lambda (rec)
(when (not (member rec uniq))
(setq uniq (cons rec uniq)
phones (bbdb-sms-mobile-phone-num-no-format rec)
name (downcase (or (bbdb-record-name rec) ""))
lfname (downcase (or (bbdb-record-lfname rec) ""))
akas (mapcar 'downcase (bbdb-record-aka rec)))
(while phones
(setq phone (car phones))
(when (cond ((and name
(let ((cname (symbol-name sym)))
(or (string= cname name)
(string= cname lfname)
(member cname akas))))
(setq name nil)
t))
(setq dwim-completions
(cons (bbdb-sms-mobile-phone-num rec)
dwim-completions))
(if exact-match (setq phones nil)))
(setq phones (cdr phones)))))
(symbol-value sym)))
all-the-completions)
(if (and dwim-completions (null (cdr dwim-completions)))
(progn
(delete-region beg end)
(insert (car dwim-completions))
(message ""))
(if (not (get-buffer-window "*Completions*"))
(setq bbdb-complete-name-saved-window-config
(current-window-configuration)))
(let ((arg (list (current-buffer)
(set-marker (make-marker) beg)
(set-marker (make-marker) end))))
(with-output-to-temp-buffer "*Completions*"
(bbdb-display-completion-list
dwim-completions
'bbdb-complete-clicked-name
arg)))
(or (eq (selected-window) (minibuffer-window))
(message "Making completion list...done"))))))))
(defun bbdb-sms-send-text-message-all nil
"Send a text message to mobile phone numbers in the current bbdb buffer.
If `bbdb-sms-all-phone-numbers' is t, the text will be sent to all valid mobile phone numbers
whose types are in `bbdb-sms-phone-number-types', otherwise it will just be sent to the first
valid mobile phone number of each record in the bbdb buffer.
A new buffer in sms-mode will be opened in which the text message can be written.
Then when C-c C-c is pressed the buffer will be sent as a text message."
(interactive)
(let ((numbers (bbdb-sms-get-mobile-phone-nums)))
(switch-to-buffer-other-window (sms-create-buffer numbers))))
(defun bbdb-sms-send-text-message nil
"Send a text message to mobile phone number of record at point in the current bbdb buffer.
If `bbdb-sms-all-phone-numbers' is t, the text will be sent to all valid mobile phone numbers
whose types are in `bbdb-sms-phone-number-types', otherwise it will just be sent to the first
valid mobile phone number.
A new buffer in sms-mode will be opened in which the text message can be written.
Then when C-c C-c is pressed the buffer will be sent as a text message."
(interactive)
(let ((numbers (bbdb-sms-mobile-phone-num (bbdb-current-record))))
(switch-to-buffer-other-window (sms-create-buffer numbers))))
(provide 'bbdb-sms)