From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Andreas Merziger Newsgroups: gmane.emacs.devel Subject: diary-arch.el - Archive/Delete diary entries by last applicable date and/or contents Date: Sun, 26 May 2013 20:16:01 +0200 Message-ID: <878v31li8u.fsf@filista.fritz.box> NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: ger.gmane.org 1369617235 14284 80.91.229.3 (27 May 2013 01:13:55 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Mon, 27 May 2013 01:13:55 +0000 (UTC) To: emacs-devel@gnu.org Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Mon May 27 03:13:52 2013 Return-path: Envelope-to: ged-emacs-devel@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by plane.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1Ugm0T-0007z4-CD for ged-emacs-devel@m.gmane.org; Mon, 27 May 2013 03:13:49 +0200 Original-Received: from localhost ([::1]:37965 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1Ugm0S-00080K-Th for ged-emacs-devel@m.gmane.org; Sun, 26 May 2013 21:13:48 -0400 Original-Received: from eggs.gnu.org ([208.118.235.92]:45592) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1UgfTd-0007ki-85 for emacs-devel@gnu.org; Sun, 26 May 2013 14:15:36 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1UgfTV-00042I-PB for emacs-devel@gnu.org; Sun, 26 May 2013 14:15:28 -0400 Original-Received: from moutng.kundenserver.de ([212.227.17.10]:50193) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1UgfTV-00041q-8J for emacs-devel@gnu.org; Sun, 26 May 2013 14:15:21 -0400 Original-Received: from localhost (koln-5d81b710.pool.mediaWays.net [93.129.183.16]) by mrelayeu.kundenserver.de (node=mreu3) with ESMTP (Nemesis) id 0Ly7kn-1UM8N41kwv-015ciz; Sun, 26 May 2013 20:15:18 +0200 User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/24.3 (gnu/linux) X-Provags-ID: V02:K0:4eaaK3Cn+Ct1vcJjLMoVGo+EJ36AcqdkZSEZ5tH1yPz og+RXEEFhdfxnKrjjnqiJwuvrRcI8TGJens8ij16lXY5b02rIf do0eWkyR0Rrmtl1xBBiG96mFpPY1HTMy0N30hTPNCtfawgIX93 KeUSRWegimnFxV7BVyhNKX85zhOYzC9pIIEFyqqZO9BDZellQc JZQricI9g2n3Hd9wh3E7+hdS5GBVZfBylt3Bj3cmdkes92fvqh edYWCEVaFu6XyUCK+F9G8gVmn3ajy7nLSOVlgPnaFvir0y9MEC S1t1y+hzFy38/+XZiUAyx6jJ89/W2rnvVMeS9VT25FED66OJeU 2F/gf3vDZm2idCufMEyU= X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.4.x-2.6.x [generic] X-Received-From: 212.227.17.10 X-Mailman-Approved-At: Sun, 26 May 2013 21:13:46 -0400 X-BeenThere: emacs-devel@gnu.org X-Mailman-Version: 2.1.14 Precedence: list List-Id: "Emacs development discussions." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Original-Sender: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.emacs.devel:159818 Archived-At: --=-=-= Content-Type: text/plain Hi, after some time of extensive use of Edward M. Reingold's great calendar and diary I observed a measurable slow-down of the diary display on my 600 MHz machine which resulted from the fact that the diary file simply has grown too large over time. Inspecting the entries, one by one for candidates to delete or to move to an archive file turned out to be a tedious task... So I started to write some code for never having to do this by hand again. If this should be of general interest, please let me know. --=-=-= Content-Type: application/emacs-lisp Content-Disposition: attachment; filename=diary-arch.el Content-Transfer-Encoding: quoted-printable ;;; diary-arch.el --- Archive/delete diary entries by date and/or contents ;; Copyright (C) 2013 Andreas Merziger ;; This program is free software: you can redistribute it and/or ;; modify it under the terms of the GNU General Public License as ;; published by the Free Software Foundation, either version 3 of ;; the License, or (at your option) any later version. ;; This program 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 General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see . ;; Author: Andreas Merziger andreas.merziger@online.de ;; Created: June 2013 ;; Keywords: calendar, matching, convenience ;;; Commentary: ;; Edward M. Reingold's great calendar and diary offer numerous ways ;; to _insert_ entries to the diary. ;; This file, `diary-arch.el' gives the user the possibility to _remove_ ;; certain entries from the diary if this should be desirable ;; after some time by appending them to an archive file or just ;; deleting them. If this is not a point for you, `diary-arch.el' ;; will be of little use for you. ;; ;; The functions `diary-arch-preview', `diary-arch-archive' and ;; `diary-arch-delete' are intended for interactive use, ;; `diary-arch-operate' is designed for the general use in lisp code. ;; Diary entries are selectable by their last applicable date and/or ;; their contents. The selected entries as well as the remaining ones ;; may be previewed in seperate buffers, offering the user the ;; possibility to archive or delete the selected ones or just quitting ;; the preview buffers if he is not satisfied with the selection. ;; Installation: copy `diary-arch.elc' in a directory contained in your ;; `load-path' and add the following line to your .emacs file: ;; (load-library diary-arch) ;; ;; For easy accessability of `diary-arch-preview', `diary-arch-archive' and ;; `diary-arch-delete' you can customize the following key-bindings in your ;; .emacs file: ;; ;; (add-hook ;; 'calendar-mode-hook ;; '(lambda () ;; (define-key calendar-mode-map (kbd "C-c a") 'diary-arch-archive) ;; (define-key calendar-mode-map (kbd "C-c p") 'diary-arch-preview) ;; (define-key calendar-mode-map (kbd "C-c d") 'diary-arch-delete))) (require 'calendar) (require 'diary-lib) ;;; Code: (defgroup diary-arch nil "View, archive or delete diary entries selected by date and/or contents." :group 'diary) (defcustom diary-arch-diary-file diary-file "The default diary file to operate on." :type 'string :group 'diary-arch) (defcustom diary-arch-archive-directory nil "The default directory for archive files. When nil - the default - archive files are saved in the same directory as the diary file itself. When a string, use that as the directory." :type '(choice (const nil) directory) :group 'diary-arch) (defcustom diary-arch-archive-filename-suffix ".dar" "The filename suffix for diary archive files. The name of the archive file is obtained from the diary file by appending `diary-arch-archive-filename-suffix' to its name." :type 'string :group 'diary-arch) (defcustom diary-arch-selected-entries-buffer-name "*DA-Selected-Entries*" "The name of the buffer used for previewing selected entries." :type 'string :group 'diary-arch) (defcustom diary-arch-diary-preview-buffer-name "*DA-Diary-Preview*" "The name of the buffer used for previewing unselected entries." :type 'string :group 'diary-arch) (defcustom diary-arch-include-banner-flag t "Non-nil means include a banner-section in the archive file. If non-nil, `diary-arch-inlcude-banner' is called after `diary-arch-selected-entries-list' has been build." :type 'boolean :group 'diary-arch) (defcustom diary-arch-supress-inform-unknown-sexp t "When non-nil, don't inform the user about unknown sexp entries." :type 'boolean :group 'diary-arch) (defcustom diary-arch-squeeze-blank-lines-after-archiving t "Non-nil means to limit the amount of whitespace in the archive. Archivation or deletion of diary entries may lead to sequences of blank lines in the diary file, if the user has decided to seperate some entries by blank lines. Set this to non-nil, to remove all but the first blank line in such sequences from the diary file." :type 'boolean :group 'diary-arch) (defcustom diary-arch-selection-function 'diary-arch-select "The default function for selecting diary entries. A function of no arguments. Return non-nil if the currently inspected entry should be selected. Return nil, if not. When this function is called, the following variables have been bound to the respective values of the currently inspected entry: `diary-arch-entry-last-applicable-date', `diary-arch-entry-contents', `diary-arch-entry-is-marking-flag' and `diary-arch-entry-is-sexp-flag'." :type 'function :group 'diary-arch) ;; Dynamically bound variables (defvar diary-arch-operation-mode nil "The operation mode of `diary-arch-operate'.") (defvar diary-arch-gregorian-reference-date nil "This operation's gregorian reference date in internal dateform.") (defvar diary-arch-absolute-reference-date nil "This operation's absolute value of the gregorian reference date.") (defvar diary-arch-archive-file nil "The name of the file, archived entries are appended to.") (defvar diary-arch-entry-start nil) (defvar diary-arch-contents-start nil) (defvar diary-arch-entry-end nil) (defvar diary-arch-selected-entries-list nil) (defvar diary-arch-kept-lines nil) (defvar diary-arch-n-entries nil) (defvar diary-arch-n-selected nil) (defvar diary-arch-selection-regexp nil "The REGEXP to match diary entries by their contents.") (defvar diary-arch-entry-is-marking-flag nil "Non-nil means the currently parsed entry is marking.") (defvar diary-arch-entry-is-sexp-flag nil "Non-nil means the currently parsed entry is an sexp entry.") (defvar diary-arch-entry-last-applicable-date nil "The last applicable date of the currently parsed entry. The last applicable gregorian date of the currently parsed entry in internal dateform (MONTH DAY YEAR). Nil if no such date exists, or is known.") (defvar diary-arch-entry-contents nil "The contents string of the currently parsed entry. Starts behind the character delimiting this entry's date specifier.") (defvar diary-arch-old-point nil "The original value of POINT in a visited diary file.") (defvar diary-arch-new-point nil "The corrected value of POINT in a visited diary file.") (defvar diary-arch-saved-state-diary-file nil) (defvar diary-arch-saved-state-archive-file nil) (defvar diary-arch-saved-state-gregorian-reference-date nil) (defvar diary-arch-saved-state-selection-regexp nil) (defvar diary-arch-saved-state-selection-function nil) (defun diary-arch-select () "Select diary entries. Return non-nil, if both, the first and the second of the following conditions are true: 1. `diary-arch-absolute-reference-date' is nil or the non-nil `diary-arch-entry-last-applicable-date' is before `diary-arch-absolute-reference-date' 2. `diary-arch-selection-regexp' is nil or matches `diary-arch-entry-contents'. Return nil otherwize." (and (or (not diary-arch-absolute-reference-date) (and diary-arch-entry-last-applicable-date (< (calendar-absolute-from-gregorian diary-arch-entry-last-applicable-date) diary-arch-absolute-reference-date))) (or (not diary-arch-selection-regexp) (string-match diary-arch-selection-regexp diary-arch-entry-contents)))) (defvar diary-arch-preview-map (let ((map (make-sparse-keymap))) (define-key map "\C-cq" 'diary-arch-quit-preview) (define-key map "\C-c\C-q" 'diary-arch-quit-preview) (define-key map "\C-ca" 'diary-arch-archive-from-preview) (define-key map "\C-cd" 'diary-arch-delete-from-preview) map) "Keymap for `diary-arch-preview-mode', a major mode. Use this map to set additional keybindings. Do _not_ rename this to `diary-arch-preview-mode-map' - the inheritance of the diary major mode's keybindings is _not_ desired here.") (define-derived-mode diary-arch-preview-mode diary-mode "DA-Preview" "Major mode for previewing selected diary entries. \\{diary-arch-preview-map}" ) (add-hook 'diary-arch-preview-mode-hook (lambda() (view-mode 1) (toggle-read-only 1) (use-local-map diary-arch-preview-map))) (defun diary-arch-name-pattern (string-array &optional abbrev-array paren dwncs) "Return a regexp matching the strings in the array STRING-ARRAY. If the optional argument ABBREV-ARRAY is present, then the function `calendar-abbrev-construct' is used to construct abbreviations from the two supplied arrays. The returned regexp will then also match these abbreviations, with or without final `.' characters. If the optional argument PAREN is non-nil, the regexp is surrounded by parentheses. If the optional argument DWNCS is non-nil, the regexp returned will also match the elements of string-array and abbrev-array written in downcas= e." (let* ((my-string-array (vconcat string-array (if dwncs (mapcar 'downcase string-array)))) (my-abbrev-array (vconcat abbrev-array (if dwncs (mapcar (lambda(str) (if str (downcase str))) abbrev-array))))) (diary-name-pattern my-string-array my-abbrev-array paren))) (defconst diary-arch-month-name-pattern (format "\\(\\*\\|%s\\)" (diary-arch-name-pattern calendar-month-name-array calendar-month-abbrev-array nil 'inclusive-downcase))) (defconst diary-arch-day-name-pattern (format "\\(\\*\\|%s\\)" (diary-arch-name-pattern calendar-day-name-array calendar-day-abbrev-array nil 'inclusive-downcase))) (defconst diary-arch-asterix-or-digits "\\(\\*\\|[0-9]+\\)") (defconst diary-arch-non-entry-start-regexp (format "[ \n\t;]\\|%s" diary-include-string)) (defconst diary-arch-entry-start-regexp (format "^\\(%s\\)?\\(%s\\)?%s" diary-nonmarking-symbol diary-sexp-entry-symbol "[^ \n\t;#]")) (defconst diary-arch-abbreviated-month-names-list (append calendar-month-abbrev-array nil) "Internally used. Need a list rather than an array.") (defun diary-arch-list-of-integers-p (l) "Internal function. Return t, if the argument L is a list and each element of this list satisfies `integerp'. Return nil otherwize." (and (listp l) (not (memq nil (mapcar 'integerp l))) t)) (defun diary-arch-sexp-last-applicable-date (sexp) "Return the last applicable date of this SEXP diary entry. Return nil if no such date exists for this SEXP or if this type of SEXP entry is unrecognizable. For each user-defined named SEXP diary entry type (SEXPNAME ...) that the user wishes to be recognized, he needs to define a corresponding function of one argument, this SEXP, which returns the last applicable gregorian date in internal date form \(MONTH DAY YEAR) or nil, if no such last date exists. This function should respect `calendar-date-style' and must be named exactly `diary-arch-SEXPNAME-date-extractor'. For example, `diary-arch-diary-date-date-extractor' is the name of the function to extract the last applicable date of SEXPs of the form `%(diary-date ...)'. This file `diary-arch.el' provides the required extraction functions for the named SEXP diary types shipped with Emacs." (let ((fsymbol (intern-soft (format "diary-arch-%s-date-extractor" (symbol-name (car sexp)))))) (if (and fsymbol (functionp fsymbol)) (funcall fsymbol sexp) (unless diary-arch-supress-inform-unknown-sexp (message "diary-arch: unknown sexp diary entry type \`(%s ...)\'" (car sexp))) nil))) (defun diary-arch-date-form-archivable-p (df) "Return t, if this dateform DF is considered archivable." (memq 'year df)) (defun diary-arch-build-regexp (dateform) "Return a regexp, that matches a date of DATEFORM at point." (let ((day diary-arch-asterix-or-digits) (dayname diary-arch-day-name-pattern) (month diary-arch-asterix-or-digits) (monthname diary-arch-month-name-pattern) (year diary-arch-asterix-or-digits)) (format "\\=3D%s" (mapconcat 'eval dateform "")))) (defun diary-arch-find-date-form () "Internal function - return a matching dateform at point. Try each element of `diary-date-forms' to build a corresponding regexp that would match a date of exactly this dateform at point until searching with this regexp succeds. Return this dateform. Move point behind what has been found. Return nil and leave point where it has been, if none of these dateforms have led to a match." (let ((df-list diary-date-forms) df-matches df) (while (and (not df-matches) (setq df (car df-list))) (setq df-matches (search-forward-regexp (diary-arch-build-regexp (if (eq (car df) 'backup) (cdr df) df)) nil t)) (setq df-list (cdr df-list))) (and df-matches df))) (defun diary-arch-index-of (obj lst) "Return the index of first appearance of OBJ in LST. Return 1 for (car lst), and so on. Return nil, if (member obj lst) is nil." (let ((rslt (member obj lst))) (if rslt (1+ (- (length lst) (length rslt)))))) (defun diary-arch-find-matching-part (symb lst) "Return the index of SYMB in LST's match string of last search. Return nil if no such index exists." (let ((indx (diary-arch-index-of symb lst))) (when indx (match-string indx)))) (defun diary-arch-non-sexp-last-applicable-date (mdf) "Return the last applicable date for the matching dateform MDF. Knowing the matching dateform MDF for this non-sexp entry's date specifier, return its last applicable gregorian date in internal date form (MONTH DAY YEAR) which may or may not exist. Return nil if MDF is nil or no last matching date exists for this entry." (when mdf (let* ((datesymbols (delq nil (mapcar (lambda (x) (and (symbolp x) x)) mdf))) (ystr (diary-arch-find-matching-part 'year datesymbols))) (unless (or (not ystr) (string-equal ystr "*")) ;; year specified - entry has last applicable date (let* ((dstr (diary-arch-find-matching-part 'day datesymbols)) (mstr (diary-arch-find-matching-part 'month datesymbols)) (mnstr (diary-arch-find-matching-part 'monthname datesymbols)) (y (if (and (=3D (length ystr) 2) diary-abbreviated-year-flag) (let* ((current-y (calendar-extract-year (calendar-current-date))) (y (+ (string-to-number ystr) ;; current century, eg 2000. (* 100 (/ current-y 100)))) (offset (- y current-y))) (if (> offset 50) (- y 100) (if (< offset -50) (+ y 100) y))) (string-to-number ystr))) (m (or (and mstr (if (string-equal mstr "*") 12 (string-to-number mstr))) (and mnstr (if (string-equal mnstr "*") 12 (diary-arch-index-of (capitalize (substring mnstr 0 calendar-abbrev-length)) diary-arch-abbreviated-month-names-list))))) (d (if (string-equal dstr "*") (calendar-last-day-of-month m y) (string-to-number dstr)))) (list m d y)))))) (defun diary-arch-recompute-point (start end) "Internal helper function. Return the new value of `diary-arch-new-point' if the region from START to END is deleted." (setq diary-arch-new-point (cond ;; point behind entry ((< end diary-arch-old-point) (- diary-arch-new-point (- end start))) ;; point in the middle of entry ((and (< start diary-arch-old-point) (<=3D diary-arch-old-point end)) (- diary-arch-new-point (- diary-arch-old-point start))) ;; point before or at the boundary of entry (t diary-arch-new-point)))) (defun diary-arch-append-entries-to-archive-file () "Internal function." (let (saved-point) (with-current-buffer (find-file-noselect diary-arch-archive-file) (setq saved-point (point)) (goto-char (point-max)) (unless (file-exists-p diary-arch-archive-file) (insert "-*- mode: diary;-*-") (newline) (diary-mode)) (mapc 'insert diary-arch-selected-entries-list) (when diary-arch-include-banner-flag (diary-arch-include-banner)) (save-buffer) (goto-char saved-point)))) (defun diary-arch-include-banner () "Include into the diary archive file last insertion's parameters. Customize this to Your needs." (let ((horizontal-bar-string "; =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D= =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D= =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D= =3D=3D=3D\n")) (insert horizontal-bar-string) (insert "; Archived from: " diary-arch-diary-file) (newline) (insert (format "; Archived on: %s\n" (calendar-date-string (calendar-current-date)))) (insert (format "; Selection function: %s\n" diary-arch-selection-function)) (when diary-arch-gregorian-reference-date (insert (format "; Reference date: %s\n" (calendar-date-string diary-arch-gregorian-reference-date)))) (when diary-arch-selection-regexp (insert (format "; Matching regexp: \"%s\"\n" diary-arch-selection-regexp))) (insert horizontal-bar-string))) (defun diary-arch-prepare-entry-for-archivation () "Internal function." (setq diary-arch-n-selected (1+ diary-arch-n-selected) diary-arch-selected-entries-list (cons (buffer-substring-no-properties diary-arch-entry-start diary-arch-entry-end) diary-arch-selected-entries-list)) (diary-arch-recompute-point diary-arch-entry-start diary-arch-entry-end)) (defun diary-arch-keep-entry () "Internal function." (setq diary-arch-kept-lines (cons (buffer-substring-no-properties diary-arch-entry-start diary-arch-entry-end) diary-arch-kept-lines))) (defun diary-arch-check-for-local-variables-line () "Internal function." (when (looking-at ".*-\\*-") (forward-line) (setq diary-arch-kept-lines (cons (buffer-substring-no-properties (point-min) (point)) diary-arch-kept-lines)))) (defun diary-arch-search-forward-start-of-entry () "Internal function." (let ((nonentry-start (point)) entry-found) (while (looking-at-p diary-arch-non-entry-start-regexp) (forward-line 1)) (setq diary-arch-kept-lines (cons (buffer-substring-no-properties nonentry-start (point)) diary-arch-kept-lines) entry-found (search-forward-regexp diary-arch-entry-start-regexp nil t)) ;; last search took us one char too far (backward-char) entry-found)) (defun diary-arch-search-forward-end-of-entry () "Internal function." ;; actual entry starts on next line? (when (looking-at "[ \t]*\n[ \t]") (forward-line 1)) (forward-line 1) (while (looking-at "[ \t]") ; continued entry (forward-line 1)) (point)) (defun diary-arch-last-applicable-date () "Return the last applicable gregorian date of the entry following point. Return nil, if such a date does not exist." (if diary-arch-entry-is-sexp-flag ;; sexp date form (diary-arch-sexp-last-applicable-date (read (get-file-buffer diary-arch-diary-file))) ;; simple date form (let* ((df (diary-arch-find-date-form)) (backup (eq (car df) 'backup)) lastdate) (when backup (setq df (cdr df))) (when (diary-arch-date-form-archivable-p df) (setq lastdate (diary-arch-non-sexp-last-applicable-date df))) (when backup (re-search-backward "\\<" nil t)) lastdate))) (defun diary-arch-select-entries () "Select diary entries satisfying `diary-arch-selection-function'. Return `diary-arch-selected-entries-list', the list of selected diary entri= es." (with-current-buffer (or (find-buffer-visiting diary-arch-diary-file) (find-file-noselect diary-arch-diary-file)) (setq diary-arch-old-point (point) diary-arch-new-point diary-arch-old-point) (goto-char (point-min)) (diary-arch-check-for-local-variables-line) ;; start searching for entries (while (diary-arch-search-forward-start-of-entry) (setq diary-arch-n-entries (1+ diary-arch-n-entries) diary-arch-entry-start (match-beginning 0) diary-arch-entry-is-marking-flag (not (match-string 1)) diary-arch-entry-is-sexp-flag (and (match-string 2) t) diary-arch-entry-last-applicable-date (diary-arch-last-applicable-date) diary-arch-contents-start (point) diary-arch-entry-end (diary-arch-search-forward-end-of-entry) diary-arch-entry-contents (buffer-substring-no-properties diary-arch-contents-start diary-arch-entry-end)) (if (funcall diary-arch-selection-function) (diary-arch-prepare-entry-for-archivation) (diary-arch-keep-entry))) ;; finished searching the diary file (when (> diary-arch-n-selected 0) (setq diary-arch-selected-entries-list (nreverse diary-arch-selected-entries-list) diary-arch-kept-lines (nreverse diary-arch-kept-lines))) (goto-char diary-arch-old-point) diary-arch-selected-entries-list)) (defun diary-arch-view-selected-entries () "Internal function." (let ((buf (get-buffer-create diary-arch-selected-entries-buffer-name))) (with-current-buffer buf (view-mode 0) (erase-buffer) (mapc 'insert diary-arch-selected-entries-list) (diary-arch-preview-mode)) (switch-to-buffer-other-window buf))) (defun diary-arch-view-kept-lines () "Internal function." (let ((buf (get-buffer-create diary-arch-diary-preview-buffer-name))) (with-current-buffer buf (view-mode 0) (erase-buffer) (mapc 'insert diary-arch-kept-lines) (when diary-arch-squeeze-blank-lines-after-archiving (diary-arch-squeeze-blank-lines)) (goto-char diary-arch-new-point) (diary-arch-preview-mode)) (switch-to-buffer buf))) (defun diary-arch-kill-preview-buffers () "Internal function." (kill-buffer diary-arch-selected-entries-buffer-name) (kill-buffer diary-arch-diary-preview-buffer-name)) (defun diary-arch-quit-preview () "Kill both preview-buffers. Kill the buffers named `diary-arch-diary-preview-buffer-name' and `diary-arch-selected-entries-buffer-name'." (interactive) (diary-arch-kill-preview-buffers)) (defun diary-arch-confirm-operation () "Confirm the choosen operation." (yes-or-no-p (format "%s%s%s? " (cond ((eq diary-arch-operation-mode 'delete) "Delete") ((eq diary-arch-operation-mode 'archive) "Archive")) (format " %s diary entr%s of %s, %s%s from \"%s\"" diary-arch-n-selected (if (> diary-arch-n-selected 1)"ies" "y") diary-arch-n-entries (if diary-arch-gregorian-reference-date (format "older then \"%s\", " (calendar-date-string diary-arch-gregorian-reference-date)) "") (if diary-arch-selection-regexp (format "matching regexp \"%s\" " diary-arch-selection-regexp) "") diary-arch-diary-file) (cond ((eq diary-arch-operation-mode 'delete) "") ((eq diary-arch-operation-mode 'archive) (format " to \"%s\"" diary-arch-archive-file)))))) (defun diary-arch-post-op-inform () "Display a message after the operation has been completed." (message "%s%s%s" (cond ((eq diary-arch-operation-mode 'delete) "Deleted") ((eq diary-arch-operation-mode 'archive) "Archived") ((eq diary-arch-operation-mode 'preview) "Selected")) (format " %s diary entr%s of %s from \"%s\"" diary-arch-n-selected (if (> diary-arch-n-selected 1)"ies" "y") diary-arch-n-entries diary-arch-diary-file) (cond ((memq diary-arch-operation-mode '(delete preview)) ".") ((eq diary-arch-operation-mode 'archive) (format " to \"%s\"." diary-arch-archive-file))))) (defun diary-arch-operate (opmode grefdate regexp &optional diaryfile noconfirm selctfunc) "The main interface of `diary-arch'. OPMODE is the operation mode of `diary-arch-operate'. When it is the symbol `archive', archive selected entries: Remove them from `diary-arch-diary-file' and append them to `diary-arch-archive-file'. When it is the symbol `delete', delete them: Only remove them from `diary-arch-diary-file'. When it is the symbol `preview', offer a non-editable view of both: The selected entries in one buffer and the diary's remaining entries in another one. See `diary-arch-preview-mode'. GREFDATE specifies `diary-arch-gregorian-reference-date', the gregorian reference date of this operation. Allowed values are a gregorian date in internal date form \(MONTH DAY YEAR) or nil. If neither nil nor a valid date, signal an error. See `diary-arch-select' for details of the selection function. REGEXP is the regular expression string `diary-arch-selection-function' uses to match the contents of an entry. See `diary-arch-select' for details of the selection function. DIARYFILE may be specified to override the default value of `diary-arch-diary-file' the entries of which is operated on. A non-nil value of NOCONFIRM means not to ask the user for confirmation after selection of diary entries and before any changes to `diary-arch-diary-file' are written do disk. SELCTFUNC, a function of no argument, may be specified to override the default selection function `diary-arch-selection-function'. It has to return non-nil precisely for those diary entries which should be selected for this operation. When the selection function is called, the following variables have been dynamically bound to the respective values of the currently inspected diary entry: `diary-arch-entry-is-marking-flag', `diary-arch-entry-is-sexp-flag', `diary-arch-entry-last-applicable-date' and `diary-arch-entry-contents'." (let* ((diary-arch-operation-mode (or opmode diary-arch-operation-mode)) (diary-arch-gregorian-reference-date (setq diary-arch-saved-state-gregorian-reference-date (if (or (not grefdate) (calendar-date-is-valid-p grefdate)) grefdate (error "Invalid date %s" grefdate)))) (diary-arch-selection-regexp (setq diary-arch-saved-state-selection-regexp regexp)) (diary-arch-diary-file (setq diary-arch-saved-state-diary-file (or diaryfile diary-arch-diary-file))) (diary-arch-selection-function (setq diary-arch-saved-state-selection-function (or selctfunc diary-arch-selection-function))) (diary-arch-archive-file (setq diary-arch-saved-state-archive-file (or (and diary-arch-archive-directory (or (file-directory-p diary-arch-archive-directory) (error "Directory %s does not exist" diary-arch-archive-directory)) (concat (file-name-as-directory diary-arch-archive-directory) (file-name-nondirectory diary-arch-diary-file) diary-arch-archive-filename-suffix)) (concat diary-arch-diary-file diary-arch-archive-filename-suffix)))) (diary-arch-absolute-reference-date (and diary-arch-gregorian-reference-date (calendar-absolute-from-gregorian diary-arch-gregorian-reference-date))) (oldbuf (current-buffer)) (diary-arch-n-entries 0) (diary-arch-n-selected 0) diary-arch-kept-lines diary-arch-selected-entries-list diary-arch-entry-is-marking-flag diary-arch-entry-is-sexp-flag diary-arch-entry-last-applicable-date diary-arch-entry-contents) (if (file-exists-p diary-arch-diary-file) (if (memq diary-arch-operation-mode '(archive delete preview)) (progn (diary-arch-select-entries) (if (> diary-arch-n-selected 0) (if (or (eq diary-arch-operation-mode 'preview) noconfirm (diary-arch-confirm-operation)) (progn (cond ((eq diary-arch-operation-mode 'preview) (diary-arch-view-kept-lines) (diary-arch-view-selected-entries)) ((memq diary-arch-operation-mode '(archive delete)) (when (eq diary-arch-operation-mode 'archive) (diary-arch-append-entries-to-archive-file)) (set-buffer (find-buffer-visiting diary-arch-diary-file)) (erase-buffer) (mapc 'insert diary-arch-kept-lines) (when diary-arch-squeeze-blank-lines-after-archiving (diary-arch-squeeze-blank-lines)) (goto-char diary-arch-new-point) (save-buffer) (switch-to-buffer oldbuf))) (diary-arch-post-op-inform))) (message "Couldn't select any entries in \"%s\"." diary-arch-diary-file))) (error "Diary-arch-operate: Unknown operation: %s" diary-arch-operation-mode)) (error "File does not exist \"%s\"" diary-arch-diary-file)))) (defun diary-arch-archive (arg) "Archive selected diary entries. If called without any prefix argument ARG, select entries by date ONLY, when called with one prefix argument \\[universal-argument] by contents ONL= Y and when called with two prefix arguments \\[universal-argument] \\[universal-argument] by = date AND and by contents." (interactive "P") (let (regexp) (when arg (setq regexp (read-string "Select entries matching regexp: "))) (diary-arch-operate 'archive (unless (equal arg '(4)) (with-current-buffer calendar-buffer (calendar-cursor-to-nearest-date))) regexp))) (defun diary-arch-delete (arg) "Delete selected diary entries. If called without any prefix argument ARG, select entries by date ONLY, when called with one prefix argument \\[universal-argument] by contents ONL= Y and when called with two prefix arguments \\[universal-argument] \\[universal-argument] by = date AND and by contents." (interactive "P") (let (regexp) (when arg (setq regexp (read-string "Select entries matching regexp: "))) (diary-arch-operate 'delete (unless (equal arg '(4)) (with-current-buffer calendar-buffer (calendar-cursor-to-nearest-date))) regexp))) (defun diary-arch-preview (arg) "Preview selected diary entries. If called without any prefix argument ARG, select entries by date ONLY, when called with one prefix argument \\[universal-argument] by contents ONL= Y and when called with two prefix arguments \\[universal-argument] \\[universal-argument] by = date AND and by contents." (interactive "P") (let (regexp) (when arg (setq regexp (read-string "Select entries matching regexp: "))) (diary-arch-operate 'preview (unless (equal arg '(4)) (with-current-buffer calendar-buffer (calendar-cursor-to-nearest-date))) regexp nil t))) (defun diary-arch-archive-from-preview () "Archive the previewed entries. Archive the previewed entries, after the user has confirmed to do so. Then kill the preview buffers." (interactive) (diary-arch-operate 'archive diary-arch-saved-state-gregorian-reference-date diary-arch-saved-state-selection-regexp diary-arch-saved-state-diary-file nil diary-arch-saved-state-selection-function) (diary-arch-kill-preview-buffers)) (defun diary-arch-delete-from-preview () "Delete the previewed entries. Archive the previewed entries, after the user has confirmed to do so. Then kill the preview buffers." (interactive) (diary-arch-operate 'delete diary-arch-saved-state-gregorian-reference-date diary-arch-saved-state-selection-regexp diary-arch-saved-state-diary-file nil diary-arch-saved-state-selection-function) (diary-arch-kill-preview-buffers)) (defun diary-arch-internal-date-form (date) "Return the internal date form of Gregorian DATE. Return the internal date form (MONTH DAY YEAR) of the `calendar-date-style' form of Gregorian DATE. Return nil if DATE is nil." (and date (cond ((equal calendar-date-style 'european) (list (nth 1 date) (car date) (nth 2 date))) ((equal calendar-date-style 'iso) (list (nth 1 date) (nth 2 date) (car date))) (t date)))) (defun diary-arch-squeeze-blank-lines () "Limit number of immediately following newline characters. After archiving diary entries, in every uninterrupted sequence of newline characters delete all but the first two. Update the value of `diary-arch-new-point' accordingly." (goto-char (point-min)) (while (re-search-forward "[\n]\\{2\\}" nil t) (while (looking-at "\n") (delete-char 1) (if (< (point) diary-arch-new-point) (setq diary-arch-new-point (1- diary-arch-new-point)))))) ;;; =3D=3D=3D=3D=3D SEXP - Last Applicable Date - Extractors =3D=3D=3D=3D= =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D (defun diary-arch-diary-block-date-extractor (sexp) "Return the last applicable date of a `diary-block' SEXP. Return it in internal date form." (diary-arch-internal-date-form (mapcar (lambda(n) (nth n sexp)) '(4 5 6)))) (defun diary-arch-diary-date-date-extractor (sexp) "Return the last applicable date of a `diary-date' SEXP. Return it in internal date form." (let ((arg-list (mapcar 'eval (cdr sexp)))) (and (eq (length arg-list) 3) (not (memq nil (mapcar (lambda (x) (or (integerp x) (eq x t) (diary-arch-list-of-integers-p x))) (setq arg-list (diary-arch-internal-date-form arg-list))))) (let* ((dat (mapcar (lambda(x) (if (listp x) (apply 'max x) x)) arg-list)) (month (car dat)) (day (nth 1 dat)) (year (nth 2 dat))) (when (numberp year) (list (setq month (if (numberp month) month 12)) (if (numberp day) day (calendar-last-day-of-month month year)) year)))))) (defun diary-arch-diary-remind-date-extractor (sexp) "Return the last applicable date of a `diary-remind' SEXP. Return it in internal date form. The last applicable date of a `diary-remind' SEXP diary entry is the one of the reminded SEXP entry." (diary-arch-sexp-last-applicable-date (cadr (nth 1 sexp)))) (provide 'diary-arch) ;;; diary-arch.el ends here --=-=-=--