diff options
Diffstat (limited to 'bits/bbdb-sort-mailrc.el')
| -rw-r--r-- | bits/bbdb-sort-mailrc.el | 321 |
1 files changed, 0 insertions, 321 deletions
diff --git a/bits/bbdb-sort-mailrc.el b/bits/bbdb-sort-mailrc.el deleted file mode 100644 index 1a1710d..0000000 --- a/bits/bbdb-sort-mailrc.el +++ /dev/null @@ -1,321 +0,0 @@ -;;; >>>>> 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> -;;; -;;; 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: |