Import bbdb_2.36.orig.tar.gz

[dgit import orig bbdb_2.36.orig.tar.gz]

1 files changed, 322 insertions, 0 deletions

diff --git a/bits/bbdb-sort-mailrc.el b/bits/bbdb-sort-mailrc.el
new file mode 100644
index 0000000..c465f14
--- /dev/null
+++ b/bits/bbdb-sort-mailrc.el
@@ -0,0 +1,322 @@
+;;; >>>>> Ronan Waide writes:
+
+;;; >> * birthdays/anniversaries
+
+;;; RW> This /is/ venturing into calendar land. Still, go to yer bbdb buffer
+;;; RW> and create a field with C-o. Again, I prefer not to add baggage to the
+;;; RW> file format unless it's absolutely necessary. Also, you should be able
+;;; RW> to attach bbdb to calendar.el using the bbdb record-dinking hooks so
+;;; RW> that it auto-fills your calendar with goop for you. And maybe get
+;;; RW> working on calendar-pilot.el...
+
+;;; Well, this isn't really release-ready -- but since someone asks, it
+;;; could be a good starting point for someone.  Feel free to
+;;; redistribute, or chop up and use the useful bits.
+
+;;; Bng
+
+;;; BBDB-BNG
+;;;  Various functions I have added to enhance the big brother database.
+;;; Boris Goldowsky, <boris@cs.rochester.edu>
+;;;   $Revision: 1.1 $  $Date: 2001/01/24 21:19:08 $
+;;;  
+;;; This file allows you to do the following things:
+;;;  * Sort by firstname or company rather than last name.
+;;;  * Mark people's birthdays in emacs's calendar and diary displays.
+;;;  * Maintains a file of mail aliases, for use by other mailers,
+;;;    automatically updated when the information changes in your database.
+;;;  * Make sure that everyone has their username defined as an alias
+;;;    for their complete net addresses.
+;;;
+;;; INSTALLATION:
+;;;  Put this file in emacs's load-path, and make sure it gets loaded whenever
+;;;  you load BBDB.
+;;;  * To use alternate sorting, evaluate (bbdb-sort-by ...) whenever you load
+;;;    bbdb.  YOU MUST EITHER ALWAYS DO THIS, OR NEVER DO IT.  When you switch
+;;;    over, evaluate (bbdb-resort-database).
+;;;  * To make a file of mail-aliases, set bbdb-mail-alias-file to a filename,
+;;;    and source that file from your .mailrc.
+;;;  * Username-aliases are enabled by default.  Set
+;;;   `bbdb-auto-username-alias' to nil if you don't want them.
+;;;    You can also use the function `bbdb-add-user-name-as-alias' to
+;;;    add such aliases manually.
+;;;  * The bbdb/calendar stuff is under development, and may not work.
+;;;
+;;; EXAMPLE:
+;;;  The following code could go in your .emacs:
+;;;  (add-hook 'bbdb-load-hook 
+;;;            (function (lambda ()
+;;;                        (setq bbdb-mail-alias-file 
+;;;                                (expand-file-name "~/.mail_aliases")
+;;;                        (require 'bbdb-bng)
+;;;                        (bbdb-sort-by 'firstname))))
+
+;;; USE:
+;;;  If installed as above, these functions operate automatically.
+
+;;; DEPENDENCIES:
+;;;  BBDB, of course.
+;;;  calendar.el and diary-lib.el are built into recent emacs versions.
+;;;  dates.el is available from me.
+
+(provide 'bbdb-bng)
+
+;;;
+;;; New birthday stuff.
+;;;
+
+(require 'calendar)
+(require 'dates)
+
+(if (not (featurep 'diary))  ; the library of many names.
+    (or (load "diary-lib" t)
+	(load "diary")))
+
+(defvar bbdb/calendar-marker 
+  (if (not window-system)
+      "^"
+    (require 'faces)
+    'bold-italic)
+  "*How to mark birthdays in calendar.
+Can be either a single-character string or a face.")
+
+(add-hook 'list-diary-entries-hook 'bbdb/calendar-list-entries)
+(add-hook 'mark-diary-entries-hook 'bbdb/calendar-mark-entries)
+
+(defun bbdb/calendar-mark-entries ()
+  (save-excursion
+    (set-buffer calendar-buffer)
+    (let ((month displayed-month)
+	  (year displayed-year))
+      (bbdb/calendar-mark-month month year)
+      (increment-calendar-month month year -1)
+      (bbdb/calendar-mark-month month year)
+      (increment-calendar-month month year 2)
+      (bbdb/calendar-mark-month month year))))
+
+(defun bbdb/calendar-mark-month (month year)
+  (message "Marking birthdays..."
+  (let ((days (aref (bbdb/calendar-birthdays) month)))
+    (while days
+      (mark-visible-calendar-date (list month (car (car days)) year)
+				  bbdb/calendar-marker)
+      (setq days (cdr days))))
+  (message nil)))
+
+(defun bbdb/calendar-list-entries ()
+  (message "Listing birthdays..."
+  (let* ((bdays (bbdb/calendar-birthdays))
+	 (start-date (calendar-absolute-from-gregorian original-date))
+	 (end-date (+ number start-date)))
+    (calendar-for-loop abs-date from start-date to end-date do
+      (let* ((date (calendar-gregorian-from-absolute abs-date))
+	     (entries (cdr (assoc (extract-calendar-day date)
+				  (aref bdays 
+					(extract-calendar-month date))))))
+	(while entries
+	  (add-to-diary-list date (car entries))
+	  (setq entries (cdr entries))))))
+  (message nil)))
+
+(defvar bbdb/calendar-birthdays nil
+  "Used by function of the same name, which see.")
+
+(defun bbdb/calendar-birthdays ()
+  "Returns a vector containing the birthdays in your BBDB.
+This is a vector with one element per month:
+ [birthdays                               ; identifier in spot 0
+  ((4 \"Isaac Newton's birthday\"))       ; Newton's birthday is Jan 4.
+  ((11 \"Thomas Edison's birthday\")      ; Edison's is Feb 11.
+   (15 \"Galileo's birthday\" \"Susan B. Anthony's birthday\")) ; Both Feb 15.
+  ...march through dec...
+ ]"
+  (or bbdb/calendar-birthdays
+      (setq bbdb/calendar-birthdays
+	    (let ((cal (make-vector 13 nil))
+		  (recs (bbdb-records))
+		  birthday-string)
+	      (aset cal 0 'birthdays)
+	      (while recs
+		(if (setq birthday-string
+			  (bbdb-record-getprop (car recs) 'birthday))
+		    (let ((events (bbdb-split birthday-string ","))
+			  (name (bbdb-record-name (car recs))))
+		      (while events
+			(let ((bday (date-parse (car events))))
+			  (if (null bday)
+			      (message "Unparsable birthday: %s" (car events))
+			    (let* ((date-end (parse-string-end))
+				   (eventname (if (eq t date-end) 
+						  "birthday"
+						(substring (car events)
+							   date-end)))
+				   (event (concat name "'s "
+						  (if (equal "" eventname) 
+						      "birthday"
+						    eventname)))
+				   (month (extract-calendar-month bday))
+				   (day (extract-calendar-day bday))
+				   (monthlist (aref cal month))
+				   (daylist (assoc day monthlist)))
+			      (if daylist
+				  (setcdr daylist (cons event (cdr daylist)))
+				(aset cal month (cons (list day event)
+						      monthlist))))))
+			(setq events (cdr events)))))
+		(setq recs (cdr recs)))
+	      cal))))
+
+;;;
+;;; Mail alias code
+;;;
+
+(defvar bbdb-mail-alias-file nil
+  "*File to save mail-aliases into.
+Aliases are also kept in the database proper; this is just for the convenience
+of other programs that are interested in mail aliases.  For example, you can
+use your bbdb mail aliases with ucb mail by including the line
+source ~/.mail_aliases
+in your .mailrc file.
+Set this to nil to avoid storing mail aliases in a file.")
+
+(defvar bbdb-auto-username-alias t
+  "*If t, always have a person's username as a mail-alias for them.")
+
+(if bbdb-mail-alias-file
+    (add-hook 'bbdb-after-change-hook (function bbdb-check-mail-alias)))
+
+(defun bbdb-add-user-name-as-alias ()
+  (interactive)
+  (let ((bbdb-auto-username-alias t)
+	(this(bbdb-current-record)))
+    (bbdb-check-mail-alias this)
+    (bbdb-redisplay-one-record this)))
+
+(defun bbdb-record-username (record)
+  "Return just the username part of RECORD's first net address,
+if it looks like a well-formed internet address; nil otherwise."
+  (let ((addr (car (bbdb-record-net record))))
+    (if (and addr (string-match "^[a-zA-z0-9]+@" addr))
+        (substring addr 0 (1- (match-end 0))))))
+
+(defun bbdb-record-mail-aliases (record)
+  (let ((all (bbdb-record-getprop record bbdb-define-all-aliases-field)))
+    (if all (bbdb-split all ","))))
+
+(defun bbdb-check-mail-alias (record)
+  "Makes sure the person's username is defined as a mail abbrev
+for them, and makes sure all their mail abbreves are ready for use."
+  (let ((username (bbdb-record-username record))
+	(current (bbdb-record-getprop record bbdb-define-all-aliases-field)))
+    (if (and current (string-match "\\(,\\)? *\n" current))
+	(setq current (replace-match ", " nil nil current)))
+    (if (and bbdb-auto-username-alias 
+	     username
+	     (not (and (boundp 'mail-abbrevs)
+		       (intern-soft username mail-abbrevs)))
+	     (not (member username (bbdb-record-mail-aliases record))))
+	(setq current
+	      (if current (concat current ", " username)
+		username)))
+    (if current
+	(bbdb-record-putprop record bbdb-define-all-aliases-field current))
+
+    ;; And make sure aliases are all defined (if any are)
+    (if (boundp 'mail-abbrevs)
+	(mapcar (function 
+		 (lambda (alias)
+		   (if (not (intern-soft alias mail-abbrevs))
+		       (my-define-mail-abbrev 
+			alias (bbdb-dwim-net-address record)))))
+		(bbdb-record-mail-aliases record)))))
+
+(defun my-define-mail-abbrev (abbrev address)
+  "Defines abbrev, and marks bbdb-mail-alias-file as modified." 
+  (define-mail-abbrev abbrev address)
+  (save-excursion
+    (set-buffer (find-file-noselect bbdb-mail-alias-file))
+    (setq buffer-read-only t)
+    (set-buffer-modified-p t)
+    (make-variable-buffer-local 'local-write-file-hooks)
+    (if (not (memq 'bbdb-mail-alias-file-write-hook 
+		   local-write-file-hooks))
+	(setq local-write-file-hooks '(bbdb-mail-alias-file-write-hook)))))
+
+(defun bbdb-insert-mail-aliases ()
+  (let ((begin (point)))
+    (if (not (boundp 'mail-abbrevs))
+        (bbdb-define-all-aliases))
+    (insert-abbrev-table-description 'mail-abbrevs nil)
+    (goto-char begin)
+    (let ((abbrevs (nth 1 (nth 2 (read (current-buffer))))))
+      (setq abbrevs (sort abbrevs (function 
+                                   (lambda (x y)
+                                     (string-lessp (car x) (car y))))))
+      (delete-region begin (point))
+      (mapcar (function
+               (lambda (abbrev)
+                 (let ((alias (car abbrev))
+                       (addr  (mapconcat (function simplify-address) 
+                                         (bbdb-split (nth 1 abbrev) ",") " ")))
+                   (if (not (string-equal alias addr))
+                       (insert (format "alias %s\t%s\n" alias addr))))))
+              abbrevs))))
+
+(defun simplify-address (addr)
+  (let ((addr (car (cdr (mail-extract-address-components addr)))))
+    (if (string-match (concat "@" (system-name) "$") addr)
+        (substring addr 0 (match-beginning 0))
+      addr)))
+
+(defun bbdb-mail-alias-file-write-hook ()
+  "Regenerate mail-aliases if necc.  
+Call from local-write-file-hooks."
+  (let ((buffer-read-only nil))
+    (message "Writing aliases...")
+    (delete-region (point-min) (point-max))
+    (bbdb-insert-mail-aliases)
+    (message "Writing aliases...done")
+    nil))
+
+;;;
+;;; sorting frobnification.
+;;;
+
+(defun bbdb-sort-by (field)
+  "Tell BBDB which field is the primary sort key.
+Currently FIELD must be one of 'firstname 'lastname or 'company.
+The first time you use this, use bbdb-resort-database immediately
+afterwards.  Then put \(bbdb-sort-by 'firstname), or whichever field is
+your choice, on your bbdb-after-load-db-hook."
+  (cond ((eq field 'lastname)
+         (defun bbdb-record-sortkey (record)
+           (or (bbdb-cache-sortkey (bbdb-record-cache record))
+               (bbdb-cache-set-sortkey
+                (bbdb-record-cache record)
+                (downcase
+                 (concat (bbdb-record-lastname record)
+                         (bbdb-record-firstname record)
+                         (bbdb-record-company record)))))))
+        ((eq field 'firstname)
+         (defun bbdb-record-sortkey (record)
+           (or (bbdb-cache-sortkey (bbdb-record-cache record))
+               (bbdb-cache-set-sortkey
+                (bbdb-record-cache record)
+                (downcase
+                 (concat (bbdb-record-firstname record)
+                         (bbdb-record-lastname record)
+                         (bbdb-record-company record)))))))
+        ((eq field 'company)
+         (defun bbdb-record-sortkey (record)
+           (or (bbdb-cache-sortkey (bbdb-record-cache record))
+               (bbdb-cache-set-sortkey
+                (bbdb-record-cache record)
+                (downcase
+                 (concat (bbdb-record-company record)
+                         (bbdb-record-lastname record)
+                         (bbdb-record-firstname record)))))))
+        (t (error "Can only sort by firstname lastname or company!"))))
+
+;;; Local Variables:
+;;; eval:(put 'calendar-for-loop 'lisp-indent-hook 6)
+;;; End: