From 093ffa5fbf7143f4668bb0a3dc9659a5cc836e12 Mon Sep 17 00:00:00 2001 From: Yuchen Pei Date: Sat, 17 Jun 2023 17:20:29 +1000 Subject: Moving things one level deeper To ease gnu stow usage. Now we can do stow -t ~ emacs --- emacs/.emacs.d/lisp/my/my-bbdb.el | 190 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 190 insertions(+) create mode 100644 emacs/.emacs.d/lisp/my/my-bbdb.el (limited to 'emacs/.emacs.d/lisp/my/my-bbdb.el') diff --git a/emacs/.emacs.d/lisp/my/my-bbdb.el b/emacs/.emacs.d/lisp/my/my-bbdb.el new file mode 100644 index 0000000..80661cd --- /dev/null +++ b/emacs/.emacs.d/lisp/my/my-bbdb.el @@ -0,0 +1,190 @@ +;;; my-bbdb.el -- Extensions for bbdb -*- lexical-binding: t -*- + +;; Copyright (C) 2023 Free Software Foundation. + +;; Author: Yuchen Pei +;; Package-Requires: ((emacs "28.2")) + +;; This file is part of dotfiles. + +;; dotfiles is free software: you can redistribute it and/or modify it under +;; the terms of the GNU Affero General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; dotfiles is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Affero General +;; Public License for more details. + +;; You should have received a copy of the GNU Affero General Public +;; License along with dotfiles. If not, see . + +;;; Commentary: + +;; Extensions for bbdb. + +;;; Code: + + +;; overrides bbdb-read-record in bbdb-com.el +(defun my-bbdb-read-record (&optional first-and-last) + "Read and return a new BBDB record. +Does not insert it into the database or update the hashtables, +but does ensure that there will not be name collisions." + (bbdb-editable) + (let ((record (bbdb-empty-record))) + ;; name + (let (name) + (bbdb-error-retry + (setq name (bbdb-read-name first-and-last)) + (bbdb-check-name (car name) (cdr name))) + (bbdb-record-set-firstname record (car name)) + (bbdb-record-set-lastname record (cdr name))) + + ;; akas + (bbdb-record-set-aka record + (bbdb-split 'aka (bbdb-read-string "AKAs: "))) + + ;; urls + (bbdb-record-set-xfield record 'url (bbdb-read-string "urls: ")) + + ;; mail + (bbdb-record-set-mail + record (bbdb-split 'mail (bbdb-read-string "E-Mail Addresses: "))) + + ;; notes + (bbdb-record-set-xfield record 'notes (bbdb-read-string "notes: ")) + + record)) + +;; overrides bbdb-create +;;;###autoload +(defun my-bbdb-create (record) + "Add a new RECORD to BBDB. +When called interactively read all relevant info. +Do not call this from a program; call `bbdb-create-internal' instead." + (interactive (list (bbdb-read-record current-prefix-arg))) + (bbdb-change-record record) + (bbdb-display-records (list record) nil nil t)) + +(defun my-bbdb-form (name) + "Insert or update a bbdb record using a form. + +If NAME exists in bbdb, update. Otherwise insert." + (interactive + (list (completing-read "Name: " (mapcar 'bbdb-record-name (bbdb-records))))) + (let* ((record (or (car (bbdb-gethash name)) + (bbdb-empty-record))) + (new-first-name) (new-last-name)) + (switch-to-buffer-other-window "*Form BBDB*") + (kill-all-local-variables) + (let ((inhibit-read-only t)) (erase-buffer)) + (remove-overlays) + (widget-insert "BBDB form\n\n") + (setq my-bbdb-widget-first-name + (widget-create 'editable-field :format "First Name: %v" + (or (bbdb-record-firstname record) + (car (bbdb-divide-name name))))) + (setq my-bbdb-widget-last-name + (widget-create 'editable-field :format "Last Name: %v" + (or (bbdb-record-lastname record) + (cdr (bbdb-divide-name name))))) + (setq my-bbdb-widget-aka + (widget-create 'editable-field + :format "Aliases: %v" + :value (bbdb-concat + 'aka + (bbdb-record-aka record)))) + (setq my-bbdb-widget-org + (widget-create 'editable-field + :format "Organisations: %v" + :value (bbdb-concat + 'organization + (bbdb-record-organization record)))) + (setq my-bbdb-widget-mail + (widget-create 'editable-field + :format "Email addresses: %v" + :value (bbdb-concat 'mail (bbdb-record-mail record)))) + (widget-insert "Phone numbers\n") + (setq my-bbdb-widget-phone + (widget-create 'editable-list + :entry-format "%i %d %v" + :value + (mapcar (lambda (phone-info) + (list (aref phone-info 0) + (aref phone-info 1))) + (bbdb-record-phone record)) + '(group + (menu-choice + :tag "Type" + (choice-item :value "cell") + (choice-item :value "work") + (choice-item :value "home") + (choice-item :value "other")) + (editable-field :format "number: %v" "")))) + (widget-create + 'push-button + :notify (lambda (&rest _) + (setq new-first-name (widget-value my-bbdb-widget-first-name)) + (setq new-last-name (widget-value my-bbdb-widget-last-name)) + (unless (equal name + (bbdb-concat 'name-first-last new-first-name + new-last-name)) + (bbdb-check-name new-first-name new-last-name)) + (bbdb-record-set-name record new-first-name new-last-name) + (bbdb-record-set-organization + record (bbdb-split 'organization (widget-value my-bbdb-widget-org))) + (bbdb-record-set-mail + record (bbdb-split 'mail (widget-value my-bbdb-widget-mail))) + (bbdb-record-set-aka + record (bbdb-split 'aka (widget-value my-bbdb-widget-aka))) + (bbdb-record-set-phone + record (mapcar + (lambda (pair) + (vector (car pair) (cadr pair))) + (widget-value my-bbdb-widget-phone))) + (bbdb-change-record record) + (bbdb-display-records (list record) nil nil t)) + "Submit")) + (use-local-map widget-keymap) + (widget-setup) + (goto-char (point-min))) + +(defun my-bbdb-parse-record (record) + (list + (cons 'Name (bbdb-record-name record)) + (cons 'First-name (bbdb-record-firstname record)) + (cons 'Last-name (bbdb-record-lastname record)) + (cons 'Organisation (car (bbdb-record-organization record))) + (cons 'Notes (bbdb-record-xfield record 'notes)) + (cons 'Website (bbdb-record-xfield record 'url)))) + +(defun my-bbdb-insert-record-to-org (parsed) + (goto-char (point-min)) + (insert "\n* "(alist-get 'Name parsed)) + (insert "\n" (or + (and (alist-get 'Notes parsed) + (format "- %s" (alist-get 'Notes parsed))) + "")) + (dolist (pair parsed) + (when (and (not (member (car pair) '(Name Notes))) (cdr pair)) + (org-set-property (symbol-name (car pair)) (cdr pair))))) + +(defun my--bbdb-to-org () + "ONLY do this in a new buffer!" + (dolist (record (bbdb-records)) + (my-bbdb-insert-record-to-org (my-bbdb-parse-record record)))) + +(defun my-bbdb-done () + "Save and quit bbdb window" + (interactive) + (bbdb-save) (quit-window)) + +(defun my-bbdb-all () + "Dispaly all bbdb records" + (interactive) + (bbdb "")) + +(provide 'my-bbdb) +;;; my-bbdb.el ends here -- cgit v1.2.3