Mercurial > hg > lib > markup

comparison emacs/diary.el @ 0:509549c55989

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
from elsewhere
author Henry S. Thompson <ht@inf.ed.ac.uk>
date Tue, 25 May 2021 13:57:42 -0400
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:509549c55989
1 ;; Last edited: Wed Oct 24 17:08:20 1990
2 ;; provide a simple diary facility on top of rmailsum
3 ;; Copyright (C) 1990 Henry S. Thompson
4
5 ;; This file is part of GNU Emacs.
6
7 ;; GNU Emacs is distributed in the hope that it will be useful,
8 ;; but WITHOUT ANY WARRANTY. No author or distributor
9 ;; accepts responsibility to anyone for the consequences of using it
10 ;; or for whether it serves any particular purpose or works at all,
11 ;; unless he says so in writing. Refer to the GNU Emacs General Public
12 ;; License for full details.
13
14 ;; Everyone is granted permission to copy, modify and redistribute
15 ;; GNU Emacs, but only under the conditions described in the
16 ;; GNU Emacs General Public License. A copy of this license is
17 ;; supposed to have been given to you along with GNU Emacs so you
18 ;; can know your rights and responsibilities. It should be in a
19 ;; file named COPYING. Among other things, the copyright notice
20 ;; and this notice must be preserved on all copies.
21
22 (provide 'diary)
23 (require 'mail-extras)
24
25 (autoload 'sort-subr "sort")
26
27 (defvar ht-diary-file-name "~/DIARY.babyl"
28 "default name of diary file")
29
30 (defvar ht-Calendar-directory "~/Calendar")
31
32 (defun xxx-date-lessp (date1 date2)
33 "Return T if DATE1 is earlyer than DATE2."
34 (string-lessp (gnus-comparable-date date1)
35 (gnus-comparable-date date2)))
36
37 (defun xxx-comparable-date (date)
38 "Make comparable string by string-lessp from DATE."
39 (let ((month '(("JAN" . " 1")("FEB" . " 2")("MAR" . " 3")
40 ("APR" . " 4")("MAY" . " 5")("JUN" . " 6")
41 ("JUL" . " 7")("AUG" . " 8")("SEP" . " 9")
42 ("OCT" . "10")("NOV" . "11")("DEC" . "12")))
43 (date (or date "")))
44 ;; Can understand the following styles:
45 ;; (1) 14 Apr 89 03:20:12 GMT
46 ;; (2) Fri, 17 March 89 4:01:33 GMT
47 (if (string-match
48 "\\([0-9]+\\) \\([^ ,]+\\) \\([0-9]+\\) *\\([0-9:]*\\)" date)
49 (concat
50 ;; Year
51 (substring date (match-beginning 3) (match-end 3))
52 ;; Month
53 (cdr
54 (assoc
55 (upcase (substring date
56 (match-beginning 2)
57 (+ 3 (match-beginning 2))))
58 month))
59 ;; Day
60 (format "%2d" (string-to-int
61 (substring date
62 (match-beginning 1) (match-end 1))))
63 ;; Time
64 (substring date (match-beginning 4) (match-end 4)))
65 ;; Cannot understand DATE string.
66 date
67 )
68 ))
69
70 (defun update-default-diary (arg) "update a diary - with arg, the one for
71 this file. Without arg, the default (named in ht-diary-file-name)"
72 (interactive "P")
73 (if arg
74 (update-diary (current-buffer))
75 (require-diary)
76 (update-diary (get-file-buffer ht-diary-file-name))))
77
78 (defun update-diary (buffer)
79 ;; (setq rmail-summary-buffer (get-buffer-create "*Diary*"))
80 (let ((obuf (current-buffer)))
81 (set-buffer buffer)
82 (if (not has-diary-summary)
83 (progn (make-local-variable 'has-diary-summary)
84 (setq has-diary-summary t)))
85 (rmail-summary)
86 (set-buffer obuf)))
87
88 (defun do-diary-update () "rmail-summary-mode-hook calls this"
89 (if (save-excursion (set-buffer rbuf)
90 has-diary-summary)
91 (progn
92 (make-local-variable 'diary-summary-buffer)
93 (setq diary-summary-buffer t)
94 (setq description (concat "Diary " description))
95 (setq buffer-read-only nil)
96 (sort-diary-hdrs)
97 (format-diary-hdrs)
98 (setq buffer-read-only t)
99 (not-modified)
100 (beginning-of-buffer)
101 (setq mesg nil) ; to go to earliest, not first in file
102 )))
103
104 (defun require-diary ()
105 (if (not (get-file-buffer ht-diary-file-name))
106 (progn (rmail-input ht-diary-file-name)
107 (rmail-show-message 1))
108 ))
109
110 (defvar diary-summary-buffer nil "flag to identify diary summaries")
111 (defvar has-diary-summary nil "flag to identify buffers with diary summaries")
112
113 (defun sort-diary-hdrs ()
114 (interactive)
115 (goto-char (point-min))
116 (sort-subr nil 'forward-line 'end-of-line 'get-diary-hdr-date nil))
117
118 (defun format-diary-hdrs ()
119 (goto-char (point-min))
120 (while (< (point)(point-max))
121 (forward-char 5)
122 (delete-char 35)
123 (looking-at " *\\([0-9]*\\) *\\([a-zA-Z]*\\) *\\([0-9]*\\) *\\([0-9]*\\)")
124 (if (match-beginning 0)
125 (let ((day (buffer-substring (match-beginning 1)(match-end 1)))
126 (month (capitalize (buffer-substring (match-beginning 2)
127 (min (+ (match-beginning 2)
128 3)
129 (match-end 2)))))
130 (year (buffer-substring (max
131 (- (match-end 3) 2)
132 (match-beginning 3))
133 (match-end 3)))
134 (time (buffer-substring (match-beginning 4)(match-end 4))))
135 (delete-char (+ 1
136 (if (= (match-end 4)
137 (match-beginning 4))
138 0 ; fix for no time case
139 1)
140 (- (match-end 4)(match-beginning 1))))
141 (insert (format " %2s %3s %2s %4s " day month year time))))
142 (forward-line 1))
143 (goto-char (point-min)))
144
145 (defun get-diary-hdr-date ()
146 (looking-at " *[^ ]* *[^ ]* *[^ ]* *\\(.*\\)$")
147 (xxx-comparable-date (buffer-substring (match-beginning 1)(match-end 1))))
148
149
150 (if (not (boundp 'rmail-edit-map))
151 (load-library "rmailedit"))
152 (if (not (boundp 'rmail-summary-mode-map))
153 (progn (load-library "rmailsum")
154 (rmail-summary-mode-fun1)))
155 (define-key rmail-edit-map "\C-c\C-c" 'ht-rmail-cease-edit)
156 (define-key rmail-edit-map "\C-c\C-]" 'ht-rmail-abort-edit)
157 ;(defvar diary-mode-map (copy-keymap rmail-summary-mode-map))
158 ;(define-key diary-mode-map "s" 'diary-save)
159 (define-key rmail-mode-map "h" 'ht-rmail-summarise)
160 (setq rmail-summary-mode-hook 'do-diary-update)
161
162 (defvar editing-diary-entry nil)
163
164 (defun diary-save ()
165 "save parent file and update"
166 (interactive)
167 (set-buffer rmail-buffer)
168 (rmail-expunge-and-save)
169 (if has-diary-summary (update-diary (current-buffer))))
170
171 (defun ht-rmail-summarise ()
172 "Display a summary of all messages, one line per message.
173 If file is named as ht-diary-file-name, or the summary buffer is already
174 a diary summary, make it a Diary summary (see
175 \\[describe-mode] rmail-summary-mode for info)."
176 (interactive)
177 (if (eq (current-buffer)
178 (get-file-buffer ht-diary-file-name))
179 (update-default-diary t)
180 (rmail-summary)))
181
182 (defun edit-and-move-to-diary ()
183 "try to add a date to subject field, move to diary on exit"
184 (interactive)
185 (make-local-variable 'editing-diary-entry)
186 (setq editing-diary-entry t)
187 (rmail-edit-current-message)
188 (goto-char (point-min))
189 (search-forward "\n\n")
190 (let ((try-date (and
191 (re-search-forward
192 "[0-9][-0-9 ]*[- ][a-zA-Z][a-zA-Z]*[- 0-9]*" nil t)
193 (buffer-substring (match-beginning 0)(match-end 0)))))
194 (goto-char (point-min))
195 (if (and (search-forward "Subject: " nil t)
196 try-date)
197 (progn (set-mark (point))
198 (insert try-date)))))
199
200 ;; private copy to simulate hook
201 (defun ht-rmail-cease-edit ()
202 "check if diary edit, move if so"
203 (interactive)
204 (rmail-cease-edit)
205 (if editing-diary-entry
206 (progn (setq editing-diary-entry nil)
207 (ht-output-to-Calendar)
208 (rmail-output-to-rmail-file ht-diary-file-name 1)
209 (ht-rmail-delete-forward))))
210
211 ;; try to add a diary subject field line to the appropriate caleendar file
212 (defun ht-output-to-Calendar ()
213 (goto-char (point-min))
214 (search-forward "Subject: ")
215 (or (looking-at
216 "\\([0-9]+\\) \\([A-Za-z]+\\) \\([0-9]+\\) \\([0-9:]*\\) ?\\(.*\\)\n")
217 (error "not a recognisable diary line"))
218 (let ((day (buffer-substring (match-beginning 1) (match-end 1)))
219 (month (buffer-substring (match-beginning 2) (match-end 2)))
220 (year (buffer-substring (match-beginning 3) (match-end 3)))
221 (time (buffer-substring (match-beginning 4) (match-end 4)))
222 (message (buffer-substring (match-beginning 5) (match-end 5)))
223 (mb (match-beginning 4))
224 (me (match-end 5))
225 t-month ends)
226 (if (file-exists-p ht-Calendar-directory)
227 (let* ((year (if (string-match "^19" year)
228 year
229 (concat "19" year)))
230 (dfn (concat ht-Calendar-directory
231 "/xy"
232 year
233 "/xc"
234 day
235 (setq t-month (capitalize
236 (substring month 0 3)))
237 year))
238 (buf (find-file-noselect dfn)))
239 (save-excursion
240 (set-buffer buf)
241 (goto-char (point-max))
242 (if (not (bolp))
243 (insert "\n"))
244 (if time
245 (insert time " "))
246 (if (string-match " -- \\(.*\\)$" message)
247 (progn
248 (setq ends (substring message (match-beginning 1)
249 (match-end 1)))
250 (setq message (substring message 0 (match-beginning 0)))))
251 (insert message)
252 (let ((require-final-newline nil))
253 (save-buffer)))
254 (if ends
255 ;; an end date also given
256 (if (string-match "\\([0-9]+\\) \\([A-Za-z]+\\)" ends)
257 (let ((e-day (substring ends (match-beginning 1)
258 (match-end 1)))
259 (e-month (substring ends (match-beginning 2)
260 (match-end 2)))
261 t-e-month msg)
262 (setq msg (concat
263 (substring message 0
264 (string-match " " message))
265 " continues"))
266 (if (string-equal (setq t-e-month
267 (capitalize
268 (substring e-month 0 3)))
269 t-month)
270 (fill-dates year t-month (1+ (car
271 (read-from-string day)))
272 (car
273 (read-from-string e-day))
274 msg)
275 (fill-dates year t-month (1+ (car
276 (read-from-string day)))
277 (cdr (assoc t-month
278 '(("Jan" . 31)
279 ("Feb" . 28)
280 ("Mar" . 31)
281 ("Apr" . 30)
282 ("May" . 31)
283 ("Jun" . 30)
284 ("Jul" . 31)
285 ("Aug" . 31)
286 ("Sep" . 30)
287 ("Oct" . 31)
288 ("Nov" . 30)
289 ("Dec" . 31))))
290 msg)
291 (fill-dates year t-e-month 1
292 (car (read-from-string e-day))
293 msg)))
294 (message "\C-g\C-gCouldn't parse end date: %s" ends)))
295 ))))
296
297 (defun fill-dates (year month start end mesg)
298 "fill the dates between start and end with message in the calendar"
299 (let ((day start))
300 (while (<= day end)
301 (let* ((dfn (concat ht-Calendar-directory
302 "/xy"
303 year
304 "/xc"
305 day
306 month
307 year))
308 (buf (find-file-noselect dfn)))
309 (save-excursion
310 (set-buffer buf)
311 (goto-char (point-max))
312 (if (not (bolp))
313 (insert "\n"))
314 (insert mesg)
315 (let ((require-final-newline nil))
316 (save-buffer))))
317 (setq day (1+ day)))))
318
319 ;; private copy
320 (defun ht-rmail-abort-edit ()
321 "add a hook"
322 (interactive)
323 (setq editing-diary-entry nil)
324 (rmail-abort-edit))
325
326 (defun rmail-edit-current-message ()
327 "Edit the contents of this message."
328 (interactive)
329 (rmail-edit-mode)
330 (make-local-variable 'rmail-old-text)
331 (setq rmail-old-text (buffer-substring (point-min) (point-max)))
332 (setq buffer-read-only nil)
333 (set-buffer-modified-p (buffer-modified-p))
334 ;; Make mode line update.
335 (if (and (eq (key-binding "\C-c\C-c") 'ht-rmail-cease-edit)
336 (eq (key-binding "\C-c\C-]") 'ht-rmail-abort-edit))
337 (if editing-diary-entry
338 (message "Editing: Type C-c C-c to move to diary and return to Rmail, C-c C-] to abort")
339 (message "Editing: Type C-c C-c to return to Rmail, C-c C-] to abort"))
340 (message (substitute-command-keys
341 "Editing: Type \\[rmail-cease-edit] to return to Rmail, \\[rmail-abort-edit] to abort"))))