Mercurial > hg > xemacs
diff shared/diary.el @ 0:107d592c5f4a
DICE versions, used by pers/common, recursive, I think/hope
author | Henry S. Thompson <ht@inf.ed.ac.uk> |
---|---|
date | Mon, 08 Feb 2021 11:44:37 +0000 |
parents | |
children | 0a81352bd7d0 |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/shared/diary.el Mon Feb 08 11:44:37 2021 +0000 @@ -0,0 +1,630 @@ +;; Last edited: Wed Oct 24 17:08:20 1990 +;; provide a simple diary facility on top of rmailsum +;; Copyright (C) 1990 Henry S. Thompson + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + +(provide 'diary) +(require 'mail-extras) + +(autoload 'sort-subr "sort") + +(defvar ht-diary-file-name "~/DIARY.babyl" + "default name of diary file") + +(defvar ht-Calendar-directory "~/Calendar") + +(defun xxx-date-lessp (date1 date2) + "Return T if DATE1 is earlyer than DATE2." + (string-lessp (gnus-comparable-date date1) + (gnus-comparable-date date2))) + +(defun xxx-comparable-date (date) + "Make comparable string by string-lessp from DATE." + (let ((month '(("JAN" . " 1")("FEB" . " 2")("MAR" . " 3") + ("APR" . " 4")("MAY" . " 5")("JUN" . " 6") + ("JUL" . " 7")("AUG" . " 8")("SEP" . " 9") + ("OCT" . "10")("NOV" . "11")("DEC" . "12"))) + (date (or date ""))) + ;; Can understand the following styles: + ;; (1) 14 Apr 89 03:20:12 GMT + ;; (2) Fri, 17 March 89 4:01:33 GMT + (if (string-match + "\\([0-9]+\\) \\([^ ,]+\\) \\([0-9]+\\) *\\([0-9:]*\\)" date) + (let ((year (substring date (match-beginning 3) (match-end 3))) + (mn (substring date + (match-beginning 2) + (+ 3 (match-beginning 2)))) + (day (substring date + (match-beginning 1) (match-end 1))) + (time (substring date (match-beginning 4) (match-end 4)))) + (concat + ;; Year + (if (= (length year) 2) + (if (string-match "^9" year) + (concat "19" year) + (concat "20" year)) + year) + ;; Month + (cdr + (assoc + (upcase mn) + month)) + ;; Day + (format "%2d" (string-to-int day)) + ;; Time + time)) + ;; Cannot understand DATE string. + date + ) + )) + +(defun update-default-diary (arg) "update a diary - with arg, the one for +this file. Without arg, the default (named in ht-diary-file-name)" + (interactive "P") + (if arg + (update-diary (current-buffer)) + (require-diary) + (update-diary (get-file-buffer ht-diary-file-name)))) + +(defun update-diary (buffer) +;; (setq rmail-summary-buffer (get-buffer-create "*Diary*")) + (let ((obuf (current-buffer))) + (set-buffer buffer) + (if (not has-diary-summary) + (progn (make-local-variable 'has-diary-summary) + (setq has-diary-summary t))) + (rmail-summary) + (set-buffer obuf))) + +(defun do-diary-update () "rmail-summary-mode-hook calls this" + (if (save-excursion (set-buffer rbuf) + has-diary-summary) + (progn + (make-local-variable 'diary-summary-buffer) + (setq diary-summary-buffer t) + (setq description (concat "Diary " description)) + (setq buffer-read-only nil) + (sort-diary-hdrs) + (format-diary-hdrs) + (setq buffer-read-only t) + (not-modified) + (beginning-of-buffer) + (setq mesg nil) ; to go to earliest, not first in file + ))) + +(defun require-diary () + (if (not (get-file-buffer ht-diary-file-name)) + (progn (rmail-input ht-diary-file-name) + (rmail-show-message 1)) + )) + +(defvar diary-summary-buffer nil "flag to identify diary summaries") +(defvar has-diary-summary nil "flag to identify buffers with diary summaries") + +(defun sort-diary-hdrs () + (interactive) + (goto-char (point-min)) + (sort-subr nil 'forward-line 'end-of-line 'get-diary-hdr-date nil)) + +(defun format-diary-hdrs () + (goto-char (point-min)) + (while (< (point)(point-max)) + (forward-char 5) + (delete-char 35) + (looking-at " *\\([0-9]*\\) *\\([a-zA-Z]*\\) *\\([0-9]*\\) *\\([0-9]*\\)") + (if (match-beginning 0) + (let ((day (buffer-substring (match-beginning 1)(match-end 1))) + (month (capitalize (buffer-substring (match-beginning 2) + (min (+ (match-beginning 2) + 3) + (match-end 2))))) + (year (buffer-substring (max + (- (match-end 3) 2) + (match-beginning 3)) + (match-end 3))) + (time (buffer-substring (match-beginning 4)(match-end 4)))) + (delete-char (+ 1 + (if (= (match-end 4) + (match-beginning 4)) + 0 ; fix for no time case + 1) + (- (match-end 4)(match-beginning 1)))) + (insert (format " %2s %3s %2s %4s " day month year time)))) + (forward-line 1)) + (goto-char (point-min))) + +(defun get-diary-hdr-date () + (looking-at " *[^ ]* *[^ ]* *[^ ]* *\\(.*\\)$") + (xxx-comparable-date (buffer-substring (match-beginning 1)(match-end 1)))) + + +(if (not (boundp 'rmail-edit-map)) + (load-library "rmailedit")) +(if (not (boundp 'rmail-summary-mode-map)) + (progn (load-library "rmailsum") + (rmail-summary-mode-fun1))) +(define-key rmail-edit-map "\C-c\C-c" 'ht-rmail-cease-edit) +(define-key rmail-edit-map "\C-c\C-]" 'ht-rmail-abort-edit) +;(defvar diary-mode-map (copy-keymap rmail-summary-mode-map)) +;(define-key diary-mode-map "s" 'diary-save) +(define-key rmail-mode-map "h" 'ht-rmail-summarise) +(setq rmail-summary-mode-hook 'do-diary-update) + +(defvar editing-diary-entry nil) + +(defun diary-save () + "save parent file and update" + (interactive) + (set-buffer rmail-buffer) + (rmail-expunge-and-save) + (if has-diary-summary (update-diary (current-buffer)))) + +(defun ht-rmail-summarise () + "Display a summary of all messages, one line per message. +If file is named as ht-diary-file-name, or the summary buffer is already +a diary summary, make it a Diary summary (see +\\[describe-mode] rmail-summary-mode for info)." + (interactive) + (if (eq (current-buffer) + (get-file-buffer ht-diary-file-name)) + (update-default-diary t) + (rmail-summary))) + +(defun edit-and-move-to-diary () + "try to add a date to subject field, move to diary on exit" + (interactive) + (make-local-variable 'editing-diary-entry) + (setq editing-diary-entry t) + (rmail-edit-current-message) + (goto-char (point-min)) + (search-forward "\n\n") + (let ((try-date (and + (re-search-forward + "[0-9][-0-9 ]*[- ][a-zA-Z][a-zA-Z]*[- 0-9]*" nil t) + (buffer-substring (match-beginning 0)(match-end 0)))) + sublp) + (goto-char (point-min)) + (setq sublp (search-forward "Subject: " nil t)) + (if try-date + (progn (set-mark (point)) + (insert try-date))))) + +(defun gnus-edit-and-move-to-diary (&optional no-delete) + "try to add a date to subject field, move to diary on exit" + (interactive "P") + (when (gnus-group-read-only-p) + (error "The current newsgroup does not support article editing")) + ;; Select article if needed. + (unless (eq (gnus-summary-article-number) + gnus-current-article) + (gnus-summary-select-article t)) + (gnus-article-date-original) + (message "About to forward. . .") + (gnus-summary-mail-forward 1) + (message "Begin forward. . .") + (goto-char (point-min)) + (search-forward "^To: " nil t) + (forward-char 4) + (insert "htcalendar@markup.co.uk") + (search-forward "------ Start of forwarded") + (let (sublp) + (save-excursion + (let ((try-date + (and + (or (re-search-forward "^\r?$" nil 1) t) + (re-search-forward + "[0-9][-0-9 ]*[- ][jfmasondJFMASOND][a-zA-Z]*[- 0-9]*" + (save-excursion (search-forward "\n--\n" nil t)) + t) + (buffer-substring (match-beginning 0)(match-end 0))))) + (goto-char (point-min)) + (setq sublp (search-forward "Subject: " nil t)) + (delete-region (point)(progn (search-forward "] " nil t))) + (message (format "date: |%s| %s" try-date sublp)) + (if (and sublp + try-date) + (progn (set-mark (point)) + (insert try-date))))) + (make-local-hook 'message-send-hook) + (if (and no-delete (equal (car no-delete) 16)) + (let ((hook '(lambda () + (ht-gnus-cease-edit nil) + nil t))) + (add-hook 'message-send-hook hook nil t) + + (message-send-and-exit) + (if (not (gnus-summary-next-unread-article)) + (gnus-summary-exit))) + (add-hook 'message-send-hook + `(lambda () + (ht-gnus-cease-edit ',no-delete) + ; (gnus-summary-edit-article-done + ; ,(or (mail-header-references gnus-current-headers) "") + ; ,(gnus-group-read-only-p) ,gnus-summary-buffer nil) + ; (switch-to-buffer gnus-summary-buffer))) + ; (goto-char (point-min)) + ; (search-forward "\nSubject: " nil t)) + ) + nil t) + (split-window-vertically 6) + (other-window 1) + (search-forward "\n\n" nil t) + (other-window 1) + (goto-char sublp) + (message "Exiting to buffer, we hope"))) + ) + +(defun ht-gnus-cease-edit (&optional no-delete) + "check if diary edit, move if so" + (interactive "P") + (message "ceasing. . .") + (ht-forward-to-Calendar) + (let ((rmail-summary-redo '(rmail-summary))) + (gnus-output-to-rmail ht-diary-file-name) + ) + (unless no-delete + (with-current-buffer gnus-summary-buffer + (gnus-summary-delete-article))) + (if (get-buffer "diary.babyl-summary") + (kill-buffer "diary.babyl-summary")) + (with-current-buffer "diary.babyl" + (rmail-mode) + (save-buffer) + (ht-rmail-summarise)) + (message "ceased")) + +(defun ht-gnus-summary-save-in-diary (&optional filename) + (gnus-eval-in-buffer-window gnus-save-article-buffer + (save-excursion + (save-restriction + (widen) + (gnus-output-to-rmail ht-diary-file-name))))) + +;; private copy to simulate hook +(defun ht-rmail-cease-edit () + "check if diary edit, move if so" + (interactive) + (rmail-cease-edit) + (if editing-diary-entry + (progn (setq editing-diary-entry nil) + (ht-forward-to-Calendar) + (rmail-output-to-rmail-file ht-diary-file-name 1) + (ht-rmail-delete-forward)))) + +;; try to add a diary subject field line to the appropriate calendar file +(defun ht-forward-to-Calendar () + (goto-char (point-min)) + (search-forward "Subject: ") + (or (looking-at + "\\([0-9]+\\) \\([A-Za-z]+\\) \\([0-9]+\\) \\([0-9:]*\\) ?\\(.*\\)\n") + (error "not a recognisable diary line")) + (let ((day (buffer-substring (match-beginning 1) (match-end 1))) + (month (buffer-substring (match-beginning 2) (match-end 2))) + (year (buffer-substring (match-beginning 3) (match-end 3))) + (time (buffer-substring (match-beginning 4) (match-end 4))) + (message (buffer-substring (match-beginning 5) (match-end 5))) + (mb (match-beginning 4)) + (me (match-end 5)) + ends e-day e-month fn) + (let ((year (if (string-match "^\\(19\\|20\\).." year) + year + (if (eq (length year) 2) + (concat "20" year) + (progn (if (and (equal time "")(eq (length year) 4)) + (setq time year)) + (format-time-string "%Y"))))) + (t-month (capitalize + (substring month 0 3)))) + (let* ((n-day (read day)) + (mon-table '((Jan . 1) + (Feb . 2) + (Mar . 3) + (Apr . 4) + (May . 5) + (Jun . 6) + (Jul . 7) + (Aug . 8) + (Sep . 9) + (Oct . 10) + (Nov . 11) + (Dec . 12))) + (a-month (assq (read t-month) + mon-table)) + (n-month (if a-month (cdr a-month) 0)) + (u-time (if (equal time "") "0" time)) + (hour (/ (read u-time) 100)) + (minute (mod (read u-time) 100)) + (nhour (if (> minute 29) + (+ 1 hour) + hour)) + (nminute (if (> minute 29) + (- minute 30) + (+ minute 30))) + (n-year (read year)) + (r-subj (mail-fetch-field "Subject")) + (body (save-excursion + (buffer-substring + (progn + (goto-char (point-min)) + (if (re-search-forward "^\r?$" nil 1) + (match-beginning 0) + (point-max))) + (point-max)))) + (subj-matches (string-match "^\\([^(]*\\)\\((\\(.*\\))\\)?" + message)) + (np-subj (match-string 1 message)) + (p-subj (or (match-string 3 message) "")) + (uid (or (mail-fetch-field "Message-id") + (let ((ct (current-time))) + (format "%d-%d-%d" + (car ct) + (cadr ct) + (caddr ct))))) + ) + (if (string-match " -- \\(.*\\)$" message) + (progn + (setq ends (substring message (match-beginning 1) + (match-end 1))) + (setq message (substring message 0 (match-beginning 0))) + (if (string-match "\\([0-9]+\\) \\([A-Za-z]+\\)" ends) + (progn + (setq e-day (substring ends (match-beginning 1) + (match-end 1))) + (setq e-month (assq + (read (capitalize + (substring + (substring ends (match-beginning 2) + (match-end 2)) + 0 3))) + mon-table)))))) + (setq fn (build-vcal-message (my-time-iso8601 + (encode-time + 0 minute + hour + n-day + n-month + n-year)) + (my-time-iso8601 + (if e-day + (encode-time + 0 (if (eq hour 0) 30 minute) ;nminute + (if (eq hour 0) 23 hour) ; nhour + (read e-day) + (if e-month (cdr e-month) 0) + n-year) + (encode-time + 0 minute ; nminute + (+ hour 1) ; nhour + n-day + n-month + n-year))) + "ORGANIZER;CN=\"Henry S. Thompson\":mailto:htcalendar@markup.co.uk" + ;(concat "ORGANIZER:" (mail-fetch-field "From")) + p-subj + body + np-subj + (concat "ht-vcal-" uid))) + (if fn + (progn + (goto-char (point-min)) + (if (search-forward "<#multipart " nil t) + (progn + (if (search-forward "<#multipart type=alternative" nil t) + (beginning-of-line) + (forward-line 2) + ;; now at beginning of forwarded text + (if (search-forward "<#part " nil t) + (progn + ;; now at beginning of _attachments_ + (beginning-of-line)) + ;; no attachments, probably never happens + (search-forward "<#/multipart>")))) + ;; plain text, make it multipart + (search-forward "-------- Start of forwarded") + (re-search-forward "^\r?$") + (forward-line 1) + (insert "<#multipart type=mixed>\n<#part type=text/plain charset=\"ISO-8859-1\" format=\"flowed\" disposition=inline nofile=yes>\n") + (search-forward "--------- End of forwarded") + (forward-line -1) + (insert "<#/multipart>\n") + (forward-line -1)) + (mml-attach-file fn "application/octet-stream" "diary event") +; (let ((res (shell-command-to-string +; (concat "updateCal.pl < " fn)))) +; (if (not (equal res "")) +; (message (format "update losing: %s" res)))) + ))) + (if (file-exists-p ht-Calendar-directory) + (let* ((dfn (concat ht-Calendar-directory + "/xy" + year + "/xc" + day + t-month + year)) + (buf (find-file-noselect dfn)) + ) + (save-excursion + (set-buffer buf) + (goto-char (point-max)) + (if (not (bolp)) + (insert "\n")) + (if time + (insert time " ")) + (insert message) + (let ((require-final-newline nil)) + (save-buffer))) + (if ends + ;; an end date also given + (if e-day + (let (t-e-month msg) + (setq msg (concat + (substring message 0 + (string-match " " message)) + " continues")) + (if (string-equal (setq t-e-month + (if e-month (car e-month) + t-month)) + t-month) + (fill-dates year t-month (1+ (car + (read-from-string day))) + (car + (read-from-string e-day)) + msg) + (fill-dates year t-month (1+ (car + (read-from-string day))) + (cdr (assoc t-month + '(("Jan" . 31) + ("Feb" . 28) + ("Mar" . 31) + ("Apr" . 30) + ("May" . 31) + ("Jun" . 30) + ("Jul" . 31) + ("Aug" . 31) + ("Sep" . 30) + ("Oct" . 31) + ("Nov" . 30) + ("Dec" . 31)))) + msg) + (fill-dates year t-e-month 1 + (car (read-from-string e-day)) + msg))) + (message "\C-g\C-gCouldn't parse end date: %s" ends))) + ))))) + +(defun fill-dates (year month start end mesg) + "fill the dates between start and end with message in the calendar" + (let ((day start)) + (while (<= day end) + (let* ((dfn (concat ht-Calendar-directory + "/xy" + year + "/xc" + (format "%d" day) + (format "%s" month) + year)) + (buf (find-file-noselect dfn))) + (save-excursion + (set-buffer buf) + (goto-char (point-max)) + (if (not (bolp)) + (insert "\n")) + (insert mesg) + (let ((require-final-newline nil)) + (save-buffer)))) + (setq day (1+ day))))) + +;; private copy +(defun ht-rmail-abort-edit () + "add a hook" + (interactive) + (setq editing-diary-entry nil) + (rmail-abort-edit)) + +(defun rmail-edit-current-message () + "Edit the contents of this message." + (interactive) + (rmail-edit-mode) + (make-local-variable 'rmail-old-text) + (setq rmail-old-text (buffer-substring (point-min) (point-max))) + (setq buffer-read-only nil) + (set-buffer-modified-p (buffer-modified-p)) + ;; Make mode line update. + (if (and (eq (key-binding "\C-c\C-c") 'ht-rmail-cease-edit) + (eq (key-binding "\C-c\C-]") 'ht-rmail-abort-edit)) + (if editing-diary-entry + (message "Editing: Type C-c C-c to move to diary and return to Rmail, C-c C-] to abort") + (message "Editing: Type C-c C-c to return to Rmail, C-c C-] to abort")) + (message (substitute-command-keys + "Editing: Type \\[rmail-cease-edit] to return to Rmail, \\[rmail-abort-edit] to abort")))) + + +(defun build-vcal-message (start end org location description summary uid) + (save-excursion + (let ((fn (concat "/tmp/" (make-temp-name "vcal") ".vcs"))) + (find-file fn) + (insert "BEGIN:VCALENDAR\nMETHOD:PUBLISH\nPRODID:-//Henry S. Thompson//gnus diary hack//EN\nVERSION:0.1\nBEGIN:VEVENT\n") + (insert "UID\n :")(insert uid)(insert "\n") + (insert "SUMMARY")(insert-encoded-maybe summary)(insert "\n") + (insert "DESCRIPTION")(insert-folded description)(insert "\r\n") + (insert "LOCATION")(insert-encoded-maybe location)(insert "\n") + (insert "DTSTART\n :")(insert start)(insert "Z\n") + (insert "DTEND\n :")(insert end)(insert "Z\n") + (insert "DTSTAMP\n :")(insert + (my-time-iso8601 (current-time))) + (insert "Z\n") + ;(insert "ORGANIZER")(insert-encoded-maybe org) + (insert org) + (insert "\n") + (insert "BEGIN:VALARM\nTRIGGER:-PT15M\nACTION:DISPLAY\nDESCRIPTION:Reminder\nEND:VALARM\n") + (insert "BEGIN:VALARM\nTRIGGER:-PT15M\nACTION:AUDIO\nDESCRIPTION:Reminder\nEND:VALARM\n") + (insert "END:VEVENT\nEND:VCALENDAR\n") + (save-buffer) + fn))) + +(defun insert-encoded-maybe (string) + (if (string-match "[\000-\007\n\013\015-\037\200-\377=]" string) + (progn + (insert ";ENCODING=QUOTED-PRINTABLE:") + (let ((beg (point))) + (insert string) + (message (format "%d;%d" beg (point))) + (quoted-printable-encode-region + beg + (point) + t + "^\000-\007\n\013\015-\037\200-\377=")) + (goto-char (point-max))) + (insert "\n :") + (insert string))) + +(defun insert-folded (string) + (insert "\n :") + (let ((beg (point))) + (insert string) + (narrow-to-region beg (point)) + (goto-char (point-min)) + (replace-string "\n" "\\n") + (goto-char (point-min)) + (replace-string "\r" "") + (goto-char (point-min)) + (replace-string "," "\\,") + (goto-char (point-min)) + (while (> (- (point-max) (point)) 72) + (forward-char 70) + (insert "\n ")) + (goto-char (point-max)) + (insert "\r\n") + (widen))) + +(defun my-time-iso8601 (time) + (let ((tzo (car (current-time-zone time))) + (hi (car time)) + (lo (cadr time)) + (ignore (cddr time))) + (gnus-time-iso8601 + (if (>= lo tzo) + (cons hi + (cons (- lo tzo) + ignore)) + (cons (- hi 1) + (cons (- (+ lo 65536) tzo) + ignore))) + )))