Add \eqref to RefTeX's reference styles (Bug#32203)
[emacs.git] / lisp / calendar / calendar.el
blob71fb76ce2139217d69a0742d632f5991b0e227b7
1 ;;; calendar.el --- calendar functions -*- lexical-binding:t -*-
3 ;; Copyright (C) 1988-1995, 1997, 2000-2018 Free Software Foundation,
4 ;; Inc.
6 ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
7 ;; Maintainer: Glenn Morris <rgm@gnu.org>
8 ;; Keywords: calendar
9 ;; Human-Keywords: calendar, Gregorian calendar, diary, holidays
11 ;; This file is part of GNU Emacs.
13 ;; GNU Emacs is free software: you can redistribute it and/or modify
14 ;; it under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation, either version 3 of the License, or
16 ;; (at your option) any later version.
18 ;; GNU Emacs is distributed in the hope that it will be useful,
19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;; GNU General Public License for more details.
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
26 ;;; Commentary:
28 ;; This collection of functions implements a calendar window. It
29 ;; generates a calendar for the current month, together with the
30 ;; previous and coming months, or for any other three-month period.
31 ;; The calendar can be scrolled forward and backward in the window to
32 ;; show months in the past or future; the cursor can move forward and
33 ;; backward by days, weeks, or months, making it possible, for
34 ;; instance, to jump to the date a specified number of days, weeks, or
35 ;; months from the date under the cursor. The user can display a list
36 ;; of holidays and other notable days for the period shown; the
37 ;; notable days can be marked on the calendar, if desired. The user
38 ;; can also specify that dates having corresponding diary entries (in
39 ;; a file that the user specifies) be marked; the diary entries for
40 ;; any date can be viewed in a separate window. The diary and the
41 ;; notable days can be viewed independently of the calendar. Dates
42 ;; can be translated from the (usual) Gregorian calendar to the day of
43 ;; the year/days remaining in year, to the ISO commercial calendar, to
44 ;; the Julian (old style) calendar, to the Hebrew calendar, to the
45 ;; Islamic calendar, to the Bahá’í calendar, to the French
46 ;; Revolutionary calendar, to the Mayan calendar, to the Chinese
47 ;; calendar, to the Coptic calendar, to the Ethiopic calendar, and to
48 ;; the astronomical (Julian) day number. Times of sunrise/sunset can
49 ;; be displayed, as can the phases of the moon. Appointment
50 ;; notification for diary entries is available. Calendar printing via
51 ;; LaTeX is available.
53 ;; The following files are part of the calendar/diary code:
55 ;; appt.el Appointment notification
56 ;; cal-bahai.el Bahá’í calendar
57 ;; cal-china.el Chinese calendar
58 ;; cal-coptic.el Coptic/Ethiopic calendars
59 ;; cal-dst.el Daylight saving time rules
60 ;; cal-french.el French revolutionary calendar
61 ;; cal-hebrew.el Hebrew calendar
62 ;; cal-html.el Calendars in HTML
63 ;; cal-islam.el Islamic calendar
64 ;; cal-iso.el ISO calendar
65 ;; cal-julian.el Julian/astronomical calendars
66 ;; cal-mayan.el Mayan calendars
67 ;; cal-menu.el Menu support
68 ;; cal-move.el Movement in the calendar
69 ;; cal-persia.el Persian calendar
70 ;; cal-tex.el Calendars in LaTeX
71 ;; cal-x.el Dedicated frame functions
72 ;; calendar.el This file
73 ;; diary-lib.el Diary functions
74 ;; holidays.el Holiday functions
75 ;; lunar.el Phases of the moon
76 ;; solar.el Sunrise/sunset, equinoxes/solstices
78 ;; Technical details of all the calendrical calculations can be found in
79 ;; "Calendrical Calculations: The Ultimate Edition" by Edward M. Reingold
80 ;; and Nachum Dershowitz, Cambridge University Press (2018).
82 ;; An earlier version of the technical details appeared in "Calendrical
83 ;; Calculations" by Nachum Dershowitz and Edward M. Reingold,
84 ;; Software--Practice and Experience, Volume 20, Number 9 (September, 1990),
85 ;; pages 899-928 <https://doi.org/10.1002/spe.4380200905>
86 ;; <https://pdfs.semanticscholar.org/83b1/14f570002a7a8e1d4e3730cd0e4cdbcad212.pdf>,
87 ;; and in "Calendrical Calculations, Part II: Three Historical Calendars" by
88 ;; E. M. Reingold, N. Dershowitz, and S. M. Clamen, Software--Practice and
89 ;; Experience, Volume 23, Number 4 (April, 1993), pages 383-404
90 ;; <https://doi.org/10.1002/spe.4380230404>
91 ;; <http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.42.6421&rep=rep1&type=pdf>
94 ;; A note on free variables:
96 ;; The calendar passes around a few dynamically bound variables, which
97 ;; unfortunately have rather common names. They are meant to be
98 ;; available for external functions, so the names can't be changed.
100 ;; displayed-month, displayed-year: bound in calendar-generate, the
101 ;; central month of the 3 month calendar window
102 ;; original-date, number: bound in diary-list-entries, the arguments
103 ;; with which that function was called.
104 ;; date, entry: bound in diary-list-sexp-entries (qv)
106 ;; Bound in diary-list-entries:
107 ;; diary-entries-list: use in d-l, appt.el, and by diary-add-to-list
108 ;; diary-saved-point: only used in diary-lib.el, passed to the display func
109 ;; date-string: only used in diary-lib.el
110 ;; list-only: don't modify the diary-buffer, just return a list of entries
111 ;; file-glob-attrs: yuck
113 ;;; Code:
115 (load "cal-loaddefs" nil t)
117 ;; Calendar has historically relied heavily on dynamic scoping.
118 ;; Concretely, this manifests in the use of references to let-bound variables
119 ;; in Custom vars as well as code in diary files.
120 ;; `eval` is hence the core of the culprit. It's used on:
121 ;; - calendar-date-display-form
122 ;; - calendar-time-display-form
123 ;; - calendar-chinese-time-zone
124 ;; - in cal-dst's there are various calls to `eval' but they seem not to refer
125 ;; to let-bound variables, surprisingly.
126 ;; - calendar-date-echo-text
127 ;; - calendar-mode-line-format
128 ;; - cal-tex-daily-string
129 ;; - diary-date-forms
130 ;; - diary-remind-message
131 ;; - calendar-holidays
132 ;; - calendar-location-name
133 ;; - whatever is passed to calendar-string-spread
134 ;; - whatever is passed to calendar-insert-at-column
135 ;; - whatever is passed to diary-sexp-entry
136 ;; - whatever is passed to diary-remind
138 (defmacro calendar-dlet* (binders &rest body)
139 "Like `let*' but using dynamic scoping."
140 (declare (indent 1) (debug let))
141 `(progn
142 (with-no-warnings ;Silence "lacks a prefix" warnings!
143 ,@(mapcar (lambda (binder)
144 `(defvar ,(if (consp binder) (car binder) binder)))
145 binders))
146 (let* ,binders ,@body)))
148 ;; Avoid recursive load of calendar when loading cal-menu. Yuck.
149 (provide 'calendar)
150 (require 'cal-menu)
152 (defgroup calendar nil
153 "Calendar and time management support."
154 :prefix "calendar-"
155 :group 'applications)
157 (defgroup calendar-hooks nil
158 "Calendar hooks."
159 :prefix "calendar-"
160 :group 'calendar)
162 (defgroup calendar-faces nil
163 "Calendar faces."
164 :prefix "calendar-"
165 :group 'calendar)
167 (defcustom calendar-offset 0
168 "The offset of the principal month from the center of the calendar window.
169 0 means the principal month is in the center (default), -1 means on the left,
170 +1 means on the right. Larger (or smaller) values push the principal month off
171 the screen."
172 :type 'integer
173 :group 'calendar)
175 (defcustom calendar-setup nil
176 "The frame setup of the calendar.
177 The choices are: `one-frame' (calendar and diary together in one separate,
178 dedicated frame); `two-frames' (calendar and diary in separate, dedicated
179 frames); `calendar-only' (calendar in a separate, dedicated frame); with
180 any other value the current frame is used. Using any of the first
181 three options overrides the value of `calendar-view-diary-initially-flag'."
182 :type '(choice
183 (const :tag "calendar and diary in separate frame" one-frame)
184 (const :tag "calendar and diary each in own frame" two-frames)
185 (const :tag "calendar in separate frame" calendar-only)
186 (const :tag "use current frame" nil))
187 :group 'calendar)
189 (defcustom calendar-minimum-window-height 8
190 "Minimum height `calendar-generate-window' should use for calendar window."
191 :type 'integer
192 :version "22.1"
193 :group 'calendar)
195 ;; See discussion in bug#1806.
196 (defcustom calendar-split-width-threshold nil
197 "Value to use for `split-width-threshold' when creating a calendar.
198 This only affects frames wider than the default value of
199 `split-width-threshold'."
200 :type '(choice (const nil)
201 (integer))
202 :version "23.2"
203 :group 'calendar)
205 (defcustom calendar-week-start-day 0
206 "The day of the week on which a week in the calendar begins.
207 0 means Sunday (default), 1 means Monday, and so on.
209 If you change this variable directly (without using customize)
210 after starting `calendar', you should call `calendar-redraw' to
211 update the calendar display to reflect the change, otherwise
212 movement commands will not work correctly."
213 :type 'integer
214 ;; Change the initialize so that if you reload calendar.el, it will not
215 ;; cause a redraw (which may fail, e.g. with "invalid byte-code in
216 ;; calendar.elc" because of the "byte-compile-dynamic").
217 :initialize 'custom-initialize-default
218 :set (lambda (sym val)
219 (set sym val)
220 (calendar-redraw))
221 :group 'calendar)
223 (defcustom calendar-weekend-days '(0 6)
224 "Days of the week considered weekend days.
225 0 means Sunday, 1 means Monday, and so on.
227 Determines which day headers are fontified with
228 `calendar-weekend-header'."
229 :type '(repeat integer)
230 :version "25.1"
231 :group 'calendar)
233 (defcustom calendar-view-diary-initially-flag nil
234 "Non-nil means display current date's diary entries on entry to calendar.
235 The diary is displayed in another window when the calendar is first displayed,
236 if the current date is visible. The number of days of diary entries displayed
237 is governed by the variable `diary-number-of-entries'. This variable can
238 be overridden by the value of `calendar-setup'."
239 :type 'boolean
240 :group 'diary)
242 ;; FIXME :set
243 (defcustom calendar-mark-diary-entries-flag nil
244 "Non-nil means mark dates with diary entries, in the calendar window.
245 The marking symbol is specified by the variable `diary-entry-marker'."
246 :type 'boolean
247 :group 'diary)
249 (defcustom calendar-remove-frame-by-deleting t
250 "Determine how the calendar mode removes a frame no longer needed.
251 If nil, make an icon of the frame. If non-nil, delete the frame."
252 :type 'boolean
253 :version "23.1" ; changed from nil to t
254 :group 'view
255 :group 'calendar)
257 (defface calendar-today
258 '((t (:underline t)))
259 "Face for indicating today's date in the calendar.
260 See the variable `calendar-today-marker'."
261 :group 'calendar-faces)
263 (defface diary
264 '((((min-colors 88) (class color) (background light))
265 :foreground "red1")
266 (((class color) (background light))
267 :foreground "red")
268 (((min-colors 88) (class color) (background dark))
269 :foreground "yellow1")
270 (((class color) (background dark))
271 :foreground "yellow")
273 :weight bold))
274 "Face for highlighting diary entries.
275 Used to mark diary entries in the calendar (see `diary-entry-marker'),
276 and to highlight the date header in the fancy diary."
277 :group 'calendar-faces)
279 (defface holiday
280 '((((class color) (background light))
281 :background "pink")
282 (((class color) (background dark))
283 :background "chocolate4")
285 :inverse-video t))
286 "Face for indicating in the calendar dates that have holidays.
287 See `calendar-holiday-marker'."
288 :group 'calendar-faces)
290 (defface calendar-weekday-header '((t :inherit font-lock-constant-face))
291 "Face used for weekday column headers in the calendar.
292 See also the face `calendar-weekend-header'."
293 :version "24.4"
294 :group 'calendar-faces)
296 (defface calendar-weekend-header '((t :inherit font-lock-comment-face))
297 "Face used for weekend column headers in the calendar.
298 See also the face `calendar-weekday-header'."
299 :version "24.4"
300 :group 'calendar-faces)
302 (defface calendar-month-header '((t :inherit font-lock-function-name-face))
303 "Face used for month headers in the calendar."
304 :version "24.4"
305 :group 'calendar-faces)
307 ;; These briefly checked font-lock-mode, but that is broken, since it
308 ;; is a buffer-local variable, and which buffer happens to be current
309 ;; when this file is loaded shouldn't make a difference. One could
310 ;; perhaps check global-font-lock-mode, or font-lock-global-modes; but
311 ;; this feature doesn't use font-lock, so there's no real reason it
312 ;; should respect those either. See bug#2199.
313 ;; They also used to check display-color-p, but that is a problem if
314 ;; loaded from --daemon. Since BW displays are rare now, this was
315 ;; also taken out. The way to keep it would be to have nil mean do a
316 ;; runtime check whenever this variable is used.
317 (defcustom diary-entry-marker 'diary
318 "How to mark dates that have diary entries.
319 The value can be either a single-character string (e.g. \"+\") or a face."
320 :type '(choice (string :tag "Single character string") face)
321 :group 'diary
322 :version "23.1")
324 (defcustom calendar-today-marker 'calendar-today
325 "How to mark today's date in the calendar.
326 The value can be either a single-character string (e.g. \"=\") or a face.
327 Used by `calendar-mark-today'."
328 :type '(choice (string :tag "Single character string") face)
329 :group 'calendar
330 :version "23.1")
332 (defcustom calendar-holiday-marker 'holiday
333 "How to mark notable dates in the calendar.
334 The value can be either a single-character string (e.g. \"*\") or a face."
335 :type '(choice (string :tag "Single character string") face)
336 :group 'holidays
337 :version "23.1")
339 (defcustom calendar-view-holidays-initially-flag nil
340 "Non-nil means display holidays for current three month period on entry.
341 The holidays are displayed in another window when the calendar is first
342 displayed."
343 :type 'boolean
344 :group 'holidays)
346 ;; FIXME :set
347 (defcustom calendar-mark-holidays-flag nil
348 "Non-nil means mark dates of holidays in the calendar window.
349 The marking symbol is specified by the variable `calendar-holiday-marker'."
350 :type 'boolean
351 :group 'holidays)
353 (defcustom calendar-mode-hook nil
354 "Hook run when entering `calendar-mode'."
355 :type 'hook
356 :group 'calendar-hooks)
358 (defcustom calendar-load-hook nil
359 "List of functions to be called after the calendar is first loaded.
360 This is the place to add key bindings to `calendar-mode-map'."
361 :type 'hook
362 :group 'calendar-hooks)
363 (make-obsolete-variable 'calendar-load-hook
364 "use `with-eval-after-load' instead." "26.1")
366 (defcustom calendar-initial-window-hook nil
367 "List of functions to be called when the calendar window is created.
368 Quitting the calendar and re-entering it will cause these functions
369 to be called again."
370 :type 'hook
371 :group 'calendar-hooks)
373 (defcustom calendar-today-visible-hook nil
374 "List of functions called whenever the current date is visible.
375 To mark today's date, add the function `calendar-mark-today'.
376 To replace the date with asterisks, add the function `calendar-star-date'.
377 See also `calendar-today-invisible-hook'.
379 In general, be careful about changing characters in the calendar buffer,
380 since it may cause the movement commands to fail."
381 :type 'hook
382 :options '(calendar-mark-today calendar-star-date)
383 :group 'calendar-hooks)
385 (defcustom calendar-today-invisible-hook nil
386 "List of functions called whenever the current date is not visible.
387 See also `calendar-today-visible-hook'."
388 :type 'hook
389 :group 'calendar-hooks)
391 (defcustom calendar-move-hook nil
392 "List of functions called whenever the cursor moves in the calendar.
393 For example,
395 (add-hook \\='calendar-move-hook (lambda () (diary-view-entries 1)))
397 redisplays the diary for whatever date the cursor is moved to."
398 :type 'hook
399 :options '(calendar-update-mode-line)
400 :group 'calendar-hooks)
402 (defcustom calendar-date-echo-text
403 "mouse-2: general menu\nmouse-3: menu for this date"
404 "String displayed when the cursor is over a date in the calendar.
405 Can be either a fixed string, or a Lisp expression that returns one.
406 When this expression is evaluated, DAY, MONTH, and YEAR are
407 integers appropriate to the relevant date. For example, to
408 display the ISO date:
410 (setq calendar-date-echo-text \\='(format \"ISO date: %s\"
411 (calendar-iso-date-string
412 (list month day year))))
413 Changing this variable without using customize has no effect on
414 pre-existing calendar windows."
415 :group 'calendar
416 :initialize 'custom-initialize-default
417 :risky t
418 :set (lambda (sym val)
419 (set sym val)
420 (calendar-redraw))
421 :type '(choice (string :tag "Fixed string")
422 (sexp :value
423 (format "ISO date: %s"
424 (calendar-iso-date-string
425 (list month day year)))))
426 :version "23.1")
429 (defvar calendar-month-digit-width nil
430 "Width of the region with numbers in each month in the calendar.")
432 (defvar calendar-month-width nil
433 "Full width of each month in the calendar.")
435 (defvar calendar-right-margin nil
436 "Right margin of the calendar.")
438 (defvar calendar-month-edges nil
439 "Alist of month edge columns.
440 Each element has the form (N LEFT FIRST LAST RIGHT), where
441 LEFT is the leftmost column associated with month segment N,
442 FIRST and LAST are the first and last columns with day digits in,
443 and LAST is the rightmost column.")
445 (defun calendar-month-edges (segment)
446 "Compute the month edge columns for month SEGMENT.
447 Returns a list (LEFT FIRST LAST RIGHT), where LEFT is the
448 leftmost column associated with a month, FIRST and LAST are the
449 first and last columns with day digits in, and LAST is the
450 rightmost column."
451 ;; The leftmost column with a digit in it in this month segment.
452 (let* ((first (+ calendar-left-margin
453 (* segment calendar-month-width)))
454 ;; The rightmost column with a digit in it in this month segment.
455 (last (+ first (1- calendar-month-digit-width)))
456 (left (if (eq segment 0)
458 (+ calendar-left-margin
459 (* segment calendar-month-width)
460 (- (/ calendar-intermonth-spacing 2)))))
461 ;; The rightmost edge of this month segment, dividing the
462 ;; space between months in two.
463 (right (+ calendar-left-margin
464 (* (1+ segment) calendar-month-width)
465 (- (/ calendar-intermonth-spacing 2)))))
466 (list left first last right)))
468 (defun calendar-recompute-layout-variables ()
469 "Recompute some layout-related calendar \"constants\"."
470 (setq calendar-month-digit-width (+ (* 6 calendar-column-width)
471 calendar-day-digit-width)
472 calendar-month-width (+ (* 7 calendar-column-width)
473 calendar-intermonth-spacing)
474 calendar-right-margin (+ calendar-left-margin
475 (* 3 (* 7 calendar-column-width))
476 (* 2 calendar-intermonth-spacing))
477 calendar-month-edges nil)
478 (dotimes (i 3)
479 (push (cons i (calendar-month-edges i)) calendar-month-edges))
480 (setq calendar-month-edges (reverse calendar-month-edges)))
482 (defun calendar-set-layout-variable (symbol value &optional minmax)
483 "Set SYMBOL's value to VALUE, an integer.
484 A positive/negative MINMAX enforces a minimum/maximum value.
485 Then redraw the calendar, if necessary."
486 (let ((oldvalue (symbol-value symbol)))
487 (custom-set-default symbol (if minmax
488 (if (< minmax 0)
489 (min value (- minmax))
490 (max value minmax))
491 value))
492 (unless (equal value oldvalue)
493 (calendar-recompute-layout-variables)
494 (calendar-redraw))))
496 (defcustom calendar-left-margin 5
497 "Empty space to the left of the first month in the calendar."
498 :group 'calendar
499 :initialize #'custom-initialize-default
500 :set #'calendar-set-layout-variable
501 :type 'integer
502 :version "23.1")
504 ;; Or you can view it as columns of width 2, with 1 space, no space
505 ;; after the last column, and a 5 space gap between month.
506 ;; FIXME check things work if this is odd.
507 (defcustom calendar-intermonth-spacing 4
508 "Space between months in the calendar. Minimum value is 1."
509 :group 'calendar
510 :initialize #'custom-initialize-default
511 :set (lambda (sym val)
512 (calendar-set-layout-variable sym val 1))
513 :type 'integer
514 :version "23.1")
516 ;; FIXME calendar-month-column-width?
517 (defcustom calendar-column-width 3
518 "Width of each day column in the calendar. Minimum value is 3."
519 :initialize #'custom-initialize-default
520 :set (lambda (sym val)
521 (calendar-set-layout-variable sym val 3))
522 :type 'integer
523 :version "23.1")
525 (defun calendar-day-header-construct (&optional width)
526 "Return the default value for `calendar-day-header-array'.
527 WIDTH defaults to `calendar-day-header-width'."
528 (or width (setq width calendar-day-header-width))
529 (calendar-abbrev-construct (if (<= width calendar-abbrev-length)
530 calendar-day-abbrev-array
531 calendar-day-name-array)
532 width))
534 ;; FIXME better to use a format spec?
535 (defcustom calendar-day-header-width 2
536 "Width of the day column headers in the calendar.
537 Must be at least one less than `calendar-column-width'."
538 :group 'calendar
539 :initialize #'custom-initialize-default
540 :set (lambda (sym val)
541 (or (calendar-customized-p 'calendar-day-header-array)
542 (setq calendar-day-header-array
543 (calendar-day-header-construct val)))
544 (calendar-set-layout-variable sym val (- 1 calendar-column-width)))
545 :type 'integer
546 :version "23.1")
548 ;; FIXME a format specifier instead?
549 (defcustom calendar-day-digit-width 2
550 "Width of the day digits in the calendar. Minimum value is 2."
551 :group 'calendar
552 :initialize #'custom-initialize-default
553 :set (lambda (sym val)
554 (calendar-set-layout-variable sym val 2))
555 :type 'integer
556 :version "23.1")
558 (defcustom calendar-intermonth-header nil
559 "Header text to display in the space to the left of each calendar month.
560 See `calendar-intermonth-text'."
561 :group 'calendar
562 :initialize 'custom-initialize-default
563 :risky t
564 :set (lambda (sym val)
565 (set sym val)
566 (calendar-redraw))
567 :type '(choice (const nil :tag "Nothing")
568 (string :tag "Fixed string")
569 (sexp :value
570 (propertize "WK" 'font-lock-face
571 'font-lock-function-name-face)))
572 :version "23.1")
574 (defcustom calendar-intermonth-text nil
575 "Text to display in the space to the left of each calendar month.
576 Can be nil, a fixed string, or a Lisp expression that returns a string.
577 When the expression is evaluated, the variables `day', `month' and `year'
578 are integers appropriate for the first day in each week.
579 Will be truncated to the smaller of `calendar-left-margin' and
580 `calendar-intermonth-spacing'. The last character is forced to be a space.
581 For example, to display the ISO week numbers:
583 (setq calendar-week-start-day 1
584 calendar-intermonth-text
585 \\='(propertize
586 (format \"%2d\"
587 (car
588 (calendar-iso-from-absolute
589 (calendar-absolute-from-gregorian (list month day year)))))
590 \\='font-lock-face \\='font-lock-function-name-face))
592 See also `calendar-intermonth-header'."
593 :group 'calendar
594 :initialize 'custom-initialize-default
595 :risky t
596 :set (lambda (sym val)
597 (set sym val)
598 (calendar-redraw))
599 :type '(choice (const nil :tag "Nothing")
600 (string :tag "Fixed string")
601 (sexp :value
602 (propertize
603 (format "%2d"
604 (car
605 (calendar-iso-from-absolute
606 (calendar-absolute-from-gregorian
607 (list month day year)))))
608 'font-lock-face 'font-lock-function-name-face)))
609 :version "23.1")
611 (defcustom diary-file (locate-user-emacs-file "diary" "diary")
612 "Name of the file in which one's personal diary of dates is kept.
614 The file's entries are lines beginning with any of the forms
615 specified by the variable `diary-date-forms', which by default
616 uses the forms of `diary-american-date-forms':
618 MONTH/DAY
619 MONTH/DAY/YEAR
620 MONTHNAME DAY
621 MONTHNAME DAY, YEAR
622 DAYNAME
624 with the remainder of the line being the diary entry string for
625 that date. MONTH and DAY are one or two digit numbers, YEAR is a
626 number and may be written in full or abbreviated to the final two
627 digits (if `diary-abbreviated-year-flag' is non-nil). MONTHNAME
628 and DAYNAME can be spelled in full (as specified by the variables
629 `calendar-month-name-array' and `calendar-day-name-array'), or
630 abbreviated (as specified by `calendar-month-abbrev-array' and
631 `calendar-day-abbrev-array') with or without a period. Case is
632 ignored. Any of DAY, MONTH, or MONTHNAME, YEAR can be `*' which
633 matches any day, month, or year, respectively. If the date does
634 not contain a year, it is generic and applies to any year. A
635 DAYNAME entry applies to the appropriate day of the week in every week.
637 You can customize `diary-date-forms' to your preferred format.
638 Three default styles are provided: `diary-american-date-forms',
639 `diary-european-date-forms', and `diary-iso-date-forms'.
640 You can choose between these by setting `calendar-date-style' in your
641 init file, or by using `calendar-set-date-style' when in the calendar.
643 A diary entry can be preceded by the character `diary-nonmarking-symbol'
644 \(ordinarily `&') to make that entry nonmarking--that is, it will not be
645 marked on dates in the calendar window but will appear in a diary window.
647 Multiline diary entries are made by indenting lines after the first with
648 either a TAB or one or more spaces.
650 Lines not in one the above formats are ignored. Here are some sample diary
651 entries (in the default American style):
653 12/22/1988 Twentieth wedding anniversary!!
654 &1/1. Happy New Year!
655 10/22 Ruth's birthday.
656 21: Payday
657 Tuesday--weekly meeting with grad students at 10am
658 Supowit, Shen, Bitner, and Kapoor to attend.
659 1/13/89 Friday the thirteenth!!
660 &thu 4pm squash game with Lloyd.
661 mar 16 Dad's birthday
662 April 15, 1989 Income tax due.
663 &* 15 time cards due.
665 If the first line of a diary entry consists only of the date or day name with
666 no trailing blanks or punctuation, then that line is not displayed in the
667 diary window; only the continuation lines is shown. For example, the
668 single diary entry
670 02/11/1989
671 Bill Blattner visits Princeton today
672 2pm Cognitive Studies Committee meeting
673 2:30-5:30 Lizzie at Lawrenceville for `Group Initiative'
674 4:00pm Jamie Tappenden
675 7:30pm Dinner at George and Ed's for Alan Ryan
676 7:30-10:00pm dance at Stewart Country Day School
678 will appear in the diary window without the date line at the beginning. This
679 facility allows the diary window to look neater, but can cause confusion if
680 used with more than one day's entries displayed.
682 Diary entries can be based on Lisp sexps. For example, the diary entry
684 %%(diary-block 11 1 1990 11 10 1990) Vacation
686 causes the diary entry \"Vacation\" to appear from November 1 through
687 November 10, 1990. See the documentation for the function
688 `diary-list-sexp-entries' for more details.
690 Diary entries based on the Hebrew, the Islamic and/or the Bahá’í
691 calendar are also possible, but because these are somewhat slow, they
692 are ignored unless you set the `diary-nongregorian-listing-hook' and
693 the `diary-nongregorian-marking-hook' appropriately. See the
694 documentation of these hooks for details.
696 Diary files can contain directives to include the contents of other files; for
697 details, see the documentation for the variable `diary-list-entries-hook'."
698 :version "25.1" ; ~/diary -> locate-user-emacs-file
699 :type 'file
700 :group 'diary)
702 ;; FIXME do these have to be single characters?
703 (defcustom diary-nonmarking-symbol "&"
704 "Symbol indicating that a diary entry is not to be marked in the calendar."
705 :type 'string
706 :group 'diary)
708 (defcustom diary-chinese-entry-symbol "C"
709 "Symbol indicating a diary entry according to the Chinese calendar."
710 :type 'string
711 :group 'diary
712 :version "25.1")
714 (defcustom diary-hebrew-entry-symbol "H"
715 "Symbol indicating a diary entry according to the Hebrew calendar."
716 :type 'string
717 :group 'diary)
719 (defcustom diary-islamic-entry-symbol "I"
720 "Symbol indicating a diary entry according to the Islamic calendar."
721 :type 'string
722 :group 'diary)
724 (defcustom diary-bahai-entry-symbol "B"
725 "Symbol indicating a diary entry according to the Bahá’í calendar."
726 :type 'string
727 :group 'diary)
729 (defcustom calendar-date-style 'american
730 "Your preferred style for writing dates.
731 The options are:
732 `american' - month/day/year
733 `european' - day/month/year
734 `iso' - year/month/day
735 This affects how dates written in your diary are interpreted.
736 It also affects date display, as well as those calendar and diary
737 functions that take a date as an argument, e.g. `diary-date', by
738 changing the order in which the arguments are interpreted.
740 Setting this variable directly does not take effect (if the
741 calendar package is already loaded). Rather, use either
742 \\[customize] or the function `calendar-set-date-style'."
743 :version "23.1"
744 :type '(choice (const american :tag "Month/Day/Year")
745 (const european :tag "Day/Month/Year")
746 (const iso :tag "Year/Month/Day"))
747 :initialize 'custom-initialize-default
748 :set (lambda (_symbol value)
749 (calendar-set-date-style value))
750 :group 'calendar)
752 ;; Next three are provided to aid in setting diary-date-forms.
753 ;; FIXME move to diary-lib?
754 (defcustom diary-iso-date-forms
755 '((month "[-/]" day "[^-/0-9]")
756 (year "[-/]" month "[-/]" day "[^0-9]")
757 ;; Cannot allow [-/] as separators here, since it would also match
758 ;; the first element (bug#7377).
759 (monthname " *" day "[^-0-9]")
760 (year " *" monthname " *" day "[^0-9]")
761 (dayname "\\W"))
762 "List of pseudo-patterns describing the ISO style of dates.
763 The defaults are: MONTH[-/]DAY; YEAR[-/]MONTH[-/]DAY; MONTHNAME DAY;
764 YEAR MONTHNAME DAY; DAYNAME. Normally you should not customize this,
765 but `diary-date-forms' (which see)."
766 :version "23.3" ; bug#7377
767 :type '(repeat (choice (cons :tag "Backup"
768 :value (backup . nil)
769 (const backup)
770 (repeat (list :inline t :format "%v"
771 (symbol :tag "Keyword")
772 (choice symbol regexp))))
773 (repeat (list :inline t :format "%v"
774 (symbol :tag "Keyword")
775 (choice symbol regexp)))))
776 :group 'diary)
778 (defcustom diary-american-date-forms
779 '((month "/" day "[^/0-9]")
780 (month "/" day "/" year "[^0-9]")
781 (monthname " *" day "[^,0-9]")
782 (monthname " *" day ", *" year "[^0-9]")
783 (dayname "\\W"))
784 "List of pseudo-patterns describing the American style of dates.
785 The defaults are: MONTH/DAY; MONTH/DAY/YEAR; MONTHNAME DAY;
786 MONTHNAME DAY, YEAR; DAYNAME. Normally you should not customize this,
787 but `diary-date-forms' (which see)."
788 :type '(repeat (choice (cons :tag "Backup"
789 :value (backup . nil)
790 (const backup)
791 (repeat (list :inline t :format "%v"
792 (symbol :tag "Keyword")
793 (choice symbol regexp))))
794 (repeat (list :inline t :format "%v"
795 (symbol :tag "Keyword")
796 (choice symbol regexp)))))
797 :group 'diary)
799 (defcustom diary-european-date-forms
800 '((day "/" month "[^/0-9]")
801 (day "/" month "/" year "[^0-9]")
802 (backup day " *" monthname "\\W+\\<\\([^*0-9]\\|\\([0-9]+[:aApP]\\)\\)")
803 (day " *" monthname " *" year "[^0-9]")
804 (dayname "\\W"))
805 "List of pseudo-patterns describing the European style of dates.
806 The defaults are: DAY/MONTH; DAY/MONTH/YEAR; DAY MONTHNAME;
807 DAY MONTHNAME YEAR; DAYNAME. Normally you should not customize this, but
808 `diary-date-forms' (which see)."
809 :type '(repeat (choice (cons :tag "Backup"
810 :value (backup . nil)
811 (const backup)
812 (repeat (list :inline t :format "%v"
813 (symbol :tag "Keyword")
814 (choice symbol regexp))))
815 (repeat (list :inline t :format "%v"
816 (symbol :tag "Keyword")
817 (choice symbol regexp)))))
818 :group 'diary)
820 (defvar diary-font-lock-keywords)
822 (defcustom diary-date-forms (cond ((eq calendar-date-style 'iso)
823 diary-iso-date-forms)
824 ((eq calendar-date-style 'european)
825 diary-european-date-forms)
826 (t diary-american-date-forms))
827 "List of pseudo-patterns describing the forms of date used in the diary.
828 The patterns on the list must be MUTUALLY EXCLUSIVE and should not match
829 any portion of the diary entry itself, just the date component.
831 A pseudo-pattern is a list of regular expressions and the keywords `month',
832 `day', `year', `monthname', and `dayname'. The keyword `monthname' will
833 match the name of the month (see `calendar-month-name-array'), capitalized
834 or not, or its user-specified abbreviation (see `calendar-month-abbrev-array'),
835 followed by a period or not; it will also match `*'. Similarly, `dayname'
836 will match the name of the day (see `calendar-day-name-array'), capitalized or
837 not, or its user-specified abbreviation (see `calendar-day-abbrev-array'),
838 followed by a period or not. The keywords `month', `day', and `year' will
839 match those numerical values, preceded by arbitrarily many zeros; they will
840 also match `*'.
842 The matching of the diary entries with the date forms is done with the
843 standard syntax table from Fundamental mode, but with the `*' changed so
844 that it is a word constituent.
846 If, to be mutually exclusive, a pseudo-pattern must match a portion of the
847 diary entry itself, the first element of the pattern MUST be `backup'. This
848 directive causes the date recognizer to back up to the beginning of the
849 current word of the diary entry, so in no case can the pattern match more than
850 a portion of the first word of the diary entry.
852 For examples of three common styles, see `diary-american-date-forms',
853 `diary-european-date-forms', and `diary-iso-date-forms'."
854 :type '(repeat (choice (cons :tag "Backup"
855 :value (backup . nil)
856 (const backup)
857 (repeat (list :inline t :format "%v"
858 (symbol :tag "Keyword")
859 (choice symbol regexp))))
860 (repeat (list :inline t :format "%v"
861 (symbol :tag "Keyword")
862 (choice symbol regexp)))))
863 :set-after '(calendar-date-style diary-iso-date-forms
864 diary-european-date-forms
865 diary-american-date-forms)
866 :initialize 'custom-initialize-default
867 :set (lambda (symbol value)
868 (unless (equal value (default-value symbol))
869 (custom-set-default symbol value)
870 (setq diary-font-lock-keywords (diary-font-lock-keywords))
871 ;; Need to redraw not just to get new font-locking, but also
872 ;; to pick up any newly recognized entries.
873 (and (diary-live-p)
874 (diary))))
875 :group 'diary)
877 ;; Next three are provided to aid in setting calendar-date-display-form.
878 (defcustom calendar-iso-date-display-form '((format "%s-%.2d-%.2d" year
879 (string-to-number month)
880 (string-to-number day)))
881 "Pseudo-pattern governing the way a date appears in the ISO style.
882 Normally you should not customize this, but `calendar-date-display-form'
883 \(which see)."
884 :type 'sexp
885 :risky t
886 :version "23.1"
887 :group 'calendar)
889 (defcustom calendar-european-date-display-form
890 '((if dayname (concat dayname ", ")) day " " monthname " " year)
891 "Pseudo-pattern governing the way a date appears in the European style.
892 Normally you should not customize this, but `calendar-date-display-form'
893 \(which see)."
894 :type 'sexp
895 :risky t
896 :group 'calendar)
898 (defcustom calendar-american-date-display-form
899 '((if dayname (concat dayname ", ")) monthname " " day ", " year)
900 "Pseudo-pattern governing the way a date appears in the American style.
901 Normally you should not customize this, but `calendar-date-display-form'
902 \(which see)."
903 :type 'sexp
904 :risky t
905 :group 'calendar)
907 (defcustom calendar-date-display-form
908 (cond ((eq calendar-date-style 'iso)
909 calendar-iso-date-display-form)
910 ((eq calendar-date-style 'european)
911 calendar-european-date-display-form)
912 (t calendar-american-date-display-form))
913 "Pseudo-pattern governing the way a calendar date appears.
914 Used by the function `calendar-date-string' (which see), a pseudo-pattern
915 is a list of expressions that can involve the keywords `month', `day',
916 and `year' (all numbers in string form), and `monthname' and `dayname'
917 \(both alphabetic strings). For example, a typical American form would be
919 (month \"/\" day \"/\" (substring year -2))
921 whereas
923 ((format \"%9s, %9s %2s, %4s\" dayname monthname day year))
925 would give the usual American style in fixed-length fields. The variables
926 `calendar-iso-date-display-form', `calendar-european-date-display-form', and
927 `calendar-american-date-display-form' provide some defaults for three common
928 styles."
929 :type 'sexp
930 :risky t
931 :set-after '(calendar-date-style calendar-iso-date-display-form
932 calendar-european-date-display-form
933 calendar-american-date-display-form)
934 :group 'calendar)
936 (defcustom calendar-american-month-header
937 '(propertize (format "%s %d" (calendar-month-name month) year)
938 'font-lock-face 'calendar-month-header)
939 "Default format for calendar month headings with the American date style.
940 Normally you should not customize this, but `calendar-month-header'."
941 :group 'calendar
942 :risky t
943 :type 'sexp
944 :version "24.4") ; font-lock-function-name-face -> calendar-month-header
946 (defcustom calendar-european-month-header
947 '(propertize (format "%s %d" (calendar-month-name month) year)
948 'font-lock-face 'calendar-month-header)
949 "Default format for calendar month headings with the European date style.
950 Normally you should not customize this, but `calendar-month-header'."
951 :group 'calendar
952 :risky t
953 :type 'sexp
954 :version "24.4") ; font-lock-function-name-face -> calendar-month-header
956 (defcustom calendar-iso-month-header
957 '(propertize (format "%d %s" year (calendar-month-name month))
958 'font-lock-face 'calendar-month-header)
959 "Default format for calendar month headings with the ISO date style.
960 Normally you should not customize this, but `calendar-month-header'."
961 :group 'calendar
962 :risky t
963 :type 'sexp
964 :version "24.4") ; font-lock-function-name-face -> calendar-month-header
966 (defcustom calendar-month-header
967 (cond ((eq calendar-date-style 'iso)
968 calendar-iso-month-header)
969 ((eq calendar-date-style 'european)
970 calendar-european-month-header)
971 (t calendar-american-month-header))
972 "Expression to evaluate to return the calendar month headings.
973 When this expression is evaluated, the variables `month' and `year' are
974 integers appropriate to the relevant month. The result is padded
975 to the width of `calendar-month-digit-width'.
977 For examples of three common styles, see `calendar-american-month-header',
978 `calendar-european-month-header', and `calendar-iso-month-header'.
980 Changing this variable without using customize has no effect on
981 pre-existing calendar windows."
982 :group 'calendar
983 :initialize 'custom-initialize-default
984 :risky t
985 :set (lambda (sym val)
986 (set sym val)
987 (calendar-redraw))
988 :set-after '(calendar-date-style calendar-american-month-header
989 calendar-european-month-header
990 calendar-iso-month-header)
991 :type 'sexp
992 :version "24.3")
994 (defun calendar-set-date-style (style)
995 "Set the style of calendar and diary dates to STYLE (a symbol).
996 The valid styles are described in the documentation of `calendar-date-style'."
997 (interactive (list (intern
998 (completing-read "Date style: "
999 '("american" "european" "iso") nil t
1000 nil nil "american"))))
1001 (or (memq style '(american european iso))
1002 (setq style 'american))
1003 (setq calendar-date-style style
1004 calendar-date-display-form
1005 (symbol-value (intern-soft
1006 (format "calendar-%s-date-display-form" style)))
1007 calendar-month-header
1008 (symbol-value (intern-soft (format "calendar-%s-month-header" style)))
1009 diary-date-forms
1010 (symbol-value (intern-soft (format "diary-%s-date-forms" style))))
1011 (calendar-redraw)
1012 (calendar-update-mode-line))
1014 (defcustom diary-show-holidays-flag t
1015 "Non-nil means include holidays in the diary display.
1016 The holidays appear in the mode line of the diary buffer, or in the
1017 fancy diary buffer next to the date. This slows down the diary functions
1018 somewhat; setting it to nil makes the diary display faster."
1019 :type 'boolean
1020 :group 'holidays)
1022 (defcustom calendar-debug-sexp nil
1023 "Turn debugging on when evaluating a sexp in the diary or holiday list."
1024 :type 'boolean
1025 :group 'calendar)
1027 (defcustom calendar-hebrew-all-holidays-flag nil
1028 "If nil, show only major holidays from the Hebrew calendar.
1029 This means only those Jewish holidays that appear on secular calendars.
1030 Otherwise, show all the holidays that would appear in a complete Hebrew
1031 calendar."
1032 :type 'boolean
1033 :group 'holidays)
1035 (defcustom calendar-christian-all-holidays-flag nil
1036 "If nil, show only major holidays from the Christian calendar.
1037 This means only those Christian holidays that appear on secular calendars.
1038 Otherwise, show all the holidays that would appear in a complete Christian
1039 calendar."
1040 :type 'boolean
1041 :group 'holidays)
1043 (defcustom calendar-islamic-all-holidays-flag nil
1044 "If nil, show only major holidays from the Islamic calendar.
1045 This means only those Islamic holidays that appear on secular calendars.
1046 Otherwise, show all the holidays that would appear in a complete Islamic
1047 calendar."
1048 :type 'boolean
1049 :group 'holidays)
1051 (defcustom calendar-bahai-all-holidays-flag nil
1052 "If nil, show only major holidays from the Bahá’í calendar.
1053 These are the days on which work and school must be suspended.
1054 Otherwise, show all the holidays that would appear in a complete Bahá’í
1055 calendar."
1056 :type 'boolean
1057 :group 'holidays)
1059 (defcustom calendar-chinese-all-holidays-flag nil
1060 "If nil, show only the major holidays from the Chinese calendar."
1061 :version "23.1"
1062 :type 'boolean
1063 :group 'holidays)
1065 ;;; End of user options.
1067 (calendar-recompute-layout-variables)
1069 (defconst calendar-first-date-row 3
1070 "First row in the calendar with actual dates.")
1072 (defconst calendar-buffer "*Calendar*"
1073 "Name of the buffer used for the calendar.")
1075 (defconst holiday-buffer "*Holidays*"
1076 "Name of the buffer used for the displaying the holidays.")
1078 (defconst diary-fancy-buffer "*Fancy Diary Entries*"
1079 "Name of the buffer used for the optional fancy display of the diary.")
1081 (defconst calendar-other-calendars-buffer "*Other Calendars*"
1082 "Name of the buffer used for the display of date on other calendars.")
1084 (defconst lunar-phases-buffer "*Phases of Moon*"
1085 "Name of the buffer used for the lunar phases.")
1087 (defconst solar-sunrises-buffer "*Sunrise/Sunset Times*"
1088 "Name of buffer used for sunrise/sunset times.")
1090 (defconst calendar-hebrew-yahrzeit-buffer "*Yahrzeits*"
1091 "Name of the buffer used by `list-yahrzeit-dates'.")
1093 (defmacro calendar-increment-month (mon yr n &optional nmonths)
1094 "Increment the variables MON and YR by N months.
1095 Forward if N is positive or backward if N is negative.
1096 A negative YR is interpreted as BC; -1 being 1 BC, and so on.
1097 Optional NMONTHS is the number of months per year (default 12)."
1098 ;; Can view this as a form of base-nmonths arithmetic, in which "a
1099 ;; year" = "ten", and we never bother to use hundreds.
1100 `(let ((nmonths (or ,nmonths 12))
1101 macro-y)
1102 (if (< ,yr 0) (setq ,yr (1+ ,yr))) ; -1 BC -> 0 AD, etc
1103 (setq macro-y (+ (* ,yr nmonths) ,mon -1 ,n)
1104 ,mon (1+ (mod macro-y nmonths))
1105 ,yr (/ macro-y nmonths))
1106 ;; Alternative:
1107 ;;; (setq macro-y (+ (* ,yr nmonths) ,mon -1 ,n)
1108 ;;; ,yr (/ macro-y nmonths)
1109 ;;; ,mon (- macro-y (* ,yr nmonths)))
1110 (and (< macro-y 0) (> ,mon 1) (setq ,yr (1- ,yr)))
1111 (if (< ,yr 1) (setq ,yr (1- ,yr))))) ; 0 AD -> -1 BC, etc
1113 (defvar displayed-month)
1114 (defvar displayed-year)
1116 (defun calendar-increment-month-cons (n &optional mon yr)
1117 "Return the Nth month after MON/YR.
1118 The return value is a pair (MONTH . YEAR).
1119 MON defaults to `displayed-month'. YR defaults to `displayed-year'."
1120 (unless mon (setq mon displayed-month))
1121 (unless yr (setq yr displayed-year))
1122 (calendar-increment-month mon yr n)
1123 (cons mon yr))
1125 (defmacro calendar-sum (index initial condition expression)
1126 "For INDEX = INITIAL, +1, ... (as long as CONDITION holds), sum EXPRESSION."
1127 (declare (debug (symbolp form form form)))
1128 `(let ((,index ,initial)
1129 (sum 0))
1130 (while ,condition
1131 (setq sum (+ sum ,expression)
1132 ,index (1+ ,index)))
1133 sum))
1135 (defmacro calendar-in-read-only-buffer (buffer &rest body)
1136 "Switch to BUFFER and execute the forms in BODY.
1137 First creates or erases BUFFER as needed. Leaves BUFFER read-only,
1138 with disabled undo. Leaves point at `point-min', displays BUFFER."
1139 (declare (indent 1) (debug t))
1140 `(progn
1141 (set-buffer (get-buffer-create ,buffer))
1142 (or (derived-mode-p 'special-mode) (special-mode))
1143 (setq buffer-read-only nil
1144 buffer-undo-list t)
1145 (erase-buffer)
1146 (display-buffer ,buffer)
1147 ,@body
1148 (goto-char (point-min))
1149 (set-buffer-modified-p nil)
1150 (setq buffer-read-only t)))
1152 ;; The following are in-line for speed; they can be called thousands of times
1153 ;; when looking up holidays or processing the diary. Here, for example, are
1154 ;; the numbers of calls to calendar/diary/holiday functions in preparing the
1155 ;; fancy diary display, for a moderately complex diary file, with functions
1156 ;; used instead of macros. There were a total of 10000 such calls:
1158 ;; 1934 calendar-extract-month
1159 ;; 1852 calendar-extract-year
1160 ;; 1819 calendar-extract-day
1161 ;; 845 calendar-leap-year-p
1162 ;; 837 calendar-day-number
1163 ;; 775 calendar-absolute-from-gregorian
1164 ;; 346 calendar-last-day-of-month
1165 ;; 286 calendar-hebrew-last-day-of-month
1166 ;; 188 calendar-hebrew-leap-year-p
1167 ;; 180 calendar-hebrew-elapsed-days
1168 ;; 163 calendar-hebrew-last-month-of-year
1169 ;; 66 calendar-date-compare
1170 ;; 65 calendar-hebrew-days-in-year
1171 ;; 60 calendar-julian-to-absolute
1172 ;; 50 calendar-hebrew-to-absolute
1173 ;; 43 calendar-date-equal
1174 ;; 38 calendar-gregorian-from-absolute
1175 ;; .
1177 ;; The use of these seven macros eliminates the overhead of 92% of the function
1178 ;; calls; it's faster this way.
1180 (defsubst calendar-extract-month (date)
1181 "Extract the month part of DATE which has the form (month day year)."
1182 (car date))
1184 ;; Note gives wrong answer for result of (calendar-read-date 'noday),
1185 ;; but that is only used by `calendar-other-month'.
1186 (defsubst calendar-extract-day (date)
1187 "Extract the day part of DATE which has the form (month day year)."
1188 (cadr date))
1190 (defsubst calendar-extract-year (date)
1191 "Extract the year part of DATE which has the form (month day year)."
1192 (nth 2 date))
1194 (defsubst calendar-leap-year-p (year)
1195 "Return t if YEAR is a Gregorian leap year.
1196 A negative year is interpreted as BC; -1 being 1 BC, and so on."
1197 ;; 1 BC = 0 AD, 2 BC acts like 1 AD, etc.
1198 (if (< year 0) (setq year (1- (abs year))))
1199 (and (zerop (% year 4))
1200 (or (not (zerop (% year 100)))
1201 (zerop (% year 400)))))
1203 ;; The foregoing is a bit faster, but not as clear as the following:
1205 ;;(defsubst calendar-leap-year-p (year)
1206 ;; "Return t if YEAR is a Gregorian leap year."
1207 ;; (or
1208 ;; (and (zerop (% year 4))
1209 ;; (not (zerop (% year 100))))
1210 ;; (zerop (% year 400)))
1212 (defsubst calendar-last-day-of-month (month year)
1213 "The last day in MONTH during YEAR."
1214 (if (and (= month 2) (calendar-leap-year-p year))
1216 (aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month))))
1218 ;; An explanation of the calculation can be found in PascAlgorithms by
1219 ;; Edward and Ruth Reingold, Scott-Foresman/Little, Brown, 1988.
1221 (defsubst calendar-day-number (date)
1222 "Return the day number within the year of the date DATE.
1223 For example, (calendar-day-number \\='(1 1 1987)) returns the value 1,
1224 while (calendar-day-number \\='(12 31 1980)) returns 366."
1225 (let* ((month (calendar-extract-month date))
1226 (day (calendar-extract-day date))
1227 (year (calendar-extract-year date))
1228 (day-of-year (+ day (* 31 (1- month)))))
1229 (when (> month 2)
1230 (setq day-of-year (- day-of-year (/ (+ 23 (* 4 month)) 10)))
1231 (if (calendar-leap-year-p year)
1232 (setq day-of-year (1+ day-of-year))))
1233 day-of-year))
1235 (defsubst calendar-absolute-from-gregorian (date)
1236 "The number of days elapsed between the Gregorian date 12/31/1 BC and DATE.
1237 The Gregorian date Sunday, December 31, 1 BC is imaginary.
1238 DATE is a list of the form (month day year). A negative year is
1239 interpreted as BC; -1 being 1 BC, and so on. Dates before 12/31/1 BC
1240 return negative results."
1241 (let ((year (calendar-extract-year date))
1242 offset-years)
1243 (cond ((zerop year)
1244 (user-error "There was no year zero"))
1245 ((> year 0)
1246 (setq offset-years (1- year))
1247 (+ (calendar-day-number date) ; days this year
1248 (* 365 offset-years) ; + days in prior years
1249 (/ offset-years 4) ; + Julian leap years
1250 (- (/ offset-years 100)) ; - century years
1251 (/ offset-years 400))) ; + Gregorian leap years
1253 ;; Years between date and 1 BC, excluding 1 BC (1 for 2 BC, etc).
1254 (setq offset-years (abs (1+ year)))
1255 (- (calendar-day-number date)
1256 (* 365 offset-years)
1257 (/ offset-years 4)
1258 (- (/ offset-years 100))
1259 (/ offset-years 400)
1260 (calendar-day-number '(12 31 -1))))))) ; days in year 1 BC
1262 ;;;###autoload
1263 (defun calendar (&optional arg)
1264 "Display a three-month Gregorian calendar.
1265 The three months appear side by side, with the current month in
1266 the middle surrounded by the previous and next months. The
1267 cursor is put on today's date. If optional prefix argument ARG
1268 is non-nil, prompts for the central month and year.
1270 Once in the calendar window, future or past months can be moved
1271 into view. Arbitrary months can be displayed, or the calendar
1272 can be scrolled forward or backward. The cursor can be moved
1273 forward or backward by one day, one week, one month, or one year.
1274 All of these commands take prefix arguments which, when negative,
1275 cause movement in the opposite direction. For convenience, the
1276 digit keys and the minus sign are automatically prefixes. Use
1277 \\[describe-mode] for details of the key bindings in the calendar
1278 window.
1280 Displays the calendar in a separate window, or optionally in a
1281 separate frame, depending on the value of `calendar-setup'.
1283 If `calendar-view-diary-initially-flag' is non-nil, also displays the
1284 diary entries for the current date (or however many days
1285 `diary-number-of-entries' specifies). This variable can be
1286 overridden by `calendar-setup'. As well as being displayed,
1287 diary entries can also be marked on the calendar (see
1288 `calendar-mark-diary-entries-flag').
1290 Runs the following hooks:
1292 `calendar-today-visible-hook', `calendar-today-invisible-hook' - after
1293 generating a calendar, if today's date is visible or not, respectively
1294 `calendar-initial-window-hook' - after first creating a calendar
1296 This function is suitable for execution in an init file."
1297 (interactive "P")
1298 ;; Avoid loading cal-x unless it will be used.
1299 (if (and (memq calendar-setup '(one-frame two-frames calendar-only))
1300 (display-multi-frame-p))
1301 (calendar-frame-setup calendar-setup arg)
1302 (calendar-basic-setup arg)))
1304 (defun calendar-basic-setup (&optional arg nodisplay)
1305 "Create a three-month calendar.
1306 If optional prefix argument ARG is non-nil, prompts for the month
1307 and year, else uses the current date. If NODISPLAY is non-nil, don't
1308 display the generated calendar."
1309 (interactive "P")
1310 (let ((buff (current-buffer)))
1311 (set-buffer (get-buffer-create calendar-buffer))
1312 (calendar-mode)
1313 (let* ((pop-up-windows t)
1314 ;; Not really needed now, but means we use exactly the same
1315 ;; behavior as before in the non-wide case (see below).
1316 (split-height-threshold 1000)
1317 (split-width-threshold calendar-split-width-threshold)
1318 (date (if arg (calendar-read-date t)
1319 (calendar-current-date)))
1320 (month (calendar-extract-month date))
1321 (year (calendar-extract-year date)))
1322 (calendar-increment-month month year (- calendar-offset))
1323 ;; Display the buffer before calling calendar-generate-window so that it
1324 ;; can get a chance to adjust the window sizes to the frame size.
1325 (unless nodisplay
1326 ;; We want a window configuration that looks something like
1327 ;; X X | Y
1328 ;; - -----
1329 ;; C Z | C
1330 ;; where C is the calendar, and the LHS is the traditional,
1331 ;; non-wide frame, and the RHS is the wide frame case.
1332 ;; We should end up in the same state regardless of whether the
1333 ;; windows were initially split or not.
1334 ;; Previously, we only thought about the non-wide case.
1335 ;; We could just set split-height-threshold to 1000, relying on
1336 ;; the fact that the window splitting treated a single window as
1337 ;; a special case and would always split it (vertically). The
1338 ;; same thing does not work in the wide-frame case, so now we do
1339 ;; the splitting by hand.
1340 ;; See discussion in bug#1806.
1341 ;; Actually, this still does not do quite the right thing in the
1342 ;; wide frame case if started from a configuration like the LHS.
1343 ;; Eg if you start with a non-wide frame, call calendar, then
1344 ;; make the frame wider. This one is problematic because you
1345 ;; might need to split a totally unrelated window. Oh well, it
1346 ;; seems unlikely, and perhaps respecting the original layout is
1347 ;; the right thing in that case.
1349 ;; Is this a wide frame? If so, split it horizontally.
1351 ;; The following doesn't sound useful: If we split horizontally
1352 ;; here, the subsequent `pop-to-buffer' will likely split again
1353 ;; horizontally and we end up with three side-by-side windows.
1354 (when (window-splittable-p (selected-window) t)
1355 (split-window-right))
1356 (pop-to-buffer calendar-buffer)
1357 ;; Has the window already been split vertically?
1358 (when (and (not (window-dedicated-p))
1359 (window-splittable-p (selected-window))
1360 (window-full-height-p))
1361 (let ((win (split-window-below)))
1362 ;; In the upper window, show whatever was visible before.
1363 ;; This looks better than using other-buffer.
1364 (switch-to-buffer buff)
1365 ;; Switch to the lower window with the calendar buffer.
1366 (select-window win))))
1367 (calendar-generate-window month year)
1368 (if (and calendar-view-diary-initially-flag
1369 (calendar-date-is-visible-p date))
1370 ;; Do not clobber the calendar with the diary, if the diary
1371 ;; has previously been shown in the window that now shows the
1372 ;; calendar (bug#18381).
1373 (let ((display-buffer-overriding-action
1374 '(nil . ((inhibit-same-window . t)))))
1375 (diary-view-entries)))))
1376 (if calendar-view-holidays-initially-flag
1377 (let* ((diary-buffer (diary-live-p))
1378 (diary-window (if diary-buffer (get-buffer-window diary-buffer)))
1379 (split-height-threshold (if diary-window 2 1000)))
1380 ;; FIXME display buffer?
1381 (calendar-list-holidays)))
1382 (run-hooks 'calendar-initial-window-hook))
1384 (defun calendar-generate-window (&optional mon yr)
1385 "Generate the calendar window for the current date.
1386 Optional integers MON and YR are used instead of today's date."
1387 (let* ((inhibit-read-only t)
1388 (today (calendar-current-date))
1389 (month (calendar-extract-month today))
1390 ;; (day (calendar-extract-day today))
1391 (year (calendar-extract-year today))
1392 (today-visible (or (not mon)
1393 (<= (abs (calendar-interval mon yr month year)) 1)))
1394 (in-calendar-window (eq (window-buffer)
1395 (get-buffer calendar-buffer))))
1396 (calendar-generate (or mon month) (or yr year))
1397 (calendar-update-mode-line)
1398 (calendar-cursor-to-visible-date
1399 (if today-visible today (list displayed-month 1 displayed-year)))
1400 (set-buffer-modified-p nil)
1401 ;; Don't do any window-related stuff if we weren't called from a
1402 ;; window displaying the calendar.
1403 (when in-calendar-window
1404 (if (window-combined-p)
1405 ;; Adjust the window to exactly fit the displayed calendar.
1406 (fit-window-to-buffer nil nil calendar-minimum-window-height)
1407 ;; For a full height window or a window that is horizontally
1408 ;; combined don't fit height to that of its buffer.
1409 (set-window-vscroll nil 0))
1410 (sit-for 0))
1411 (and calendar-mark-holidays-flag
1412 ;; (calendar-date-is-valid-p today) ; useful for BC dates
1413 (calendar-mark-holidays)
1414 (and in-calendar-window (sit-for 0)))
1415 (unwind-protect
1416 (if calendar-mark-diary-entries-flag (diary-mark-entries))
1417 (run-hooks (if today-visible
1418 'calendar-today-visible-hook
1419 'calendar-today-invisible-hook)))))
1421 (defun calendar-generate (month year)
1422 "Generate a three-month Gregorian calendar centered around MONTH, YEAR."
1423 ;; A negative YEAR is interpreted as BC; -1 being 1 BC, and so on.
1424 ;; Note that while calendars for years BC could be displayed as it
1425 ;; stands, almost all other calendar functions (eg holidays) would
1426 ;; at best have unpredictable results for such dates.
1427 (if (< (+ month (* 12 (1- year))) 2)
1428 (user-error "Months before January, 1 AD cannot be displayed"))
1429 (setq displayed-month month
1430 displayed-year year)
1431 (erase-buffer)
1432 (calendar-increment-month month year -1)
1433 (dotimes (i 3)
1434 (calendar-generate-month month year
1435 (+ calendar-left-margin
1436 (* calendar-month-width i)))
1437 (calendar-increment-month month year 1)))
1439 (defun calendar-move-to-column (indent)
1440 "Like `move-to-column', but indents if the line is too short."
1441 (if (< (move-to-column indent) indent)
1442 (indent-to indent)))
1444 (defun calendar-ensure-newline ()
1445 "Move to the next line, adding a newline if necessary."
1446 (or (zerop (forward-line 1))
1447 (insert "\n")))
1449 (defun calendar-insert-at-column (indent string truncate)
1450 "Move to column INDENT, adding spaces as needed.
1451 Inserts STRING so that it ends at INDENT. STRING is either a
1452 literal string, or a sexp to evaluate to return such. Truncates
1453 STRING to length TRUNCATE, and ensures a trailing space."
1454 (if (not (ignore-errors (stringp (setq string (eval string)))))
1455 (calendar-move-to-column indent)
1456 (if (> (string-width string) truncate)
1457 (setq string (truncate-string-to-width string truncate)))
1458 (or (string-match " $" string)
1459 (setq string (concat (if (= (string-width string) truncate)
1460 (substring string 0 -1)
1461 string)
1462 ;; Avoid inserting text properties unless
1463 ;; we have to (ie, non-unit-width chars).
1464 ;; This is by no means essential.
1465 (if (= (string-width string) (length string))
1467 ;; Cribbed from buff-menu.el.
1468 (propertize
1469 " " 'display `(space :align-to ,indent))))))
1470 (calendar-move-to-column (- indent (string-width string)))
1471 (insert string)))
1473 (defun calendar-generate-month (month year indent)
1474 "Produce a calendar for MONTH, YEAR on the Gregorian calendar.
1475 The calendar is inserted at the top of the buffer in which point is currently
1476 located, but indented INDENT spaces. The indentation is done from the first
1477 character on the line and does not disturb the first INDENT characters on the
1478 line."
1479 (let ((blank-days ; at start of month
1480 (mod
1481 (- (calendar-day-of-week (list month 1 year))
1482 calendar-week-start-day)
1484 (last (calendar-last-day-of-month month year))
1485 (trunc (min calendar-intermonth-spacing
1486 (1- calendar-left-margin)))
1487 (day 1)
1489 (goto-char (point-min))
1490 (calendar-move-to-column indent)
1491 (insert
1492 (calendar-dlet* ((month month) (year year))
1493 (calendar-string-spread (list calendar-month-header)
1494 ?\s calendar-month-digit-width)))
1495 (calendar-ensure-newline)
1496 (calendar-insert-at-column indent calendar-intermonth-header trunc)
1497 ;; Use the first N characters of each day to head the columns.
1498 (dotimes (i 7)
1499 (setq j (mod (+ calendar-week-start-day i) 7))
1500 (insert
1501 (truncate-string-to-width
1502 (propertize (calendar-day-name j 'header t)
1503 'font-lock-face (if (memq j calendar-weekend-days)
1504 'calendar-weekend-header
1505 'calendar-weekday-header))
1506 calendar-day-header-width nil ?\s)
1507 (make-string (- calendar-column-width calendar-day-header-width) ?\s)))
1508 (calendar-ensure-newline)
1509 (calendar-dlet* ((day day) (month month) (year year))
1510 (calendar-insert-at-column indent calendar-intermonth-text trunc))
1511 ;; Add blank days before the first of the month.
1512 (insert (make-string (* blank-days calendar-column-width) ?\s))
1513 ;; Put in the days of the month.
1514 (dotimes (i last)
1515 (setq day (1+ i))
1516 ;; TODO should numbers be left-justified, centered...?
1517 (insert (propertize
1518 (format (format "%%%dd" calendar-day-digit-width) day)
1519 'mouse-face 'highlight
1520 'help-echo (calendar-dlet* ((day day) (month month) (year year))
1521 (eval calendar-date-echo-text))
1522 ;; 'date property prevents intermonth text confusing re-searches.
1523 ;; (Tried intangible, it did not really work.)
1524 'date t)
1525 (make-string
1526 (- calendar-column-width calendar-day-digit-width) ?\s))
1527 (when (and (zerop (mod (+ day blank-days) 7))
1528 (/= day last))
1529 (calendar-ensure-newline)
1530 (setq day (1+ day)) ; first day of next week
1531 (calendar-dlet* ((day day) (month month) (year year))
1532 (calendar-insert-at-column indent calendar-intermonth-text trunc))))))
1534 (defun calendar-redraw ()
1535 "Redraw the calendar display, if `calendar-buffer' is live."
1536 (interactive)
1537 (when (get-buffer calendar-buffer)
1538 (with-current-buffer calendar-buffer
1539 (let ((cursor-date (calendar-cursor-to-nearest-date)))
1540 (calendar-generate-window displayed-month displayed-year)
1541 (calendar-cursor-to-visible-date cursor-date))
1542 (when (window-live-p (get-buffer-window))
1543 (set-window-point (get-buffer-window) (point))))))
1545 (defvar calendar-mode-map
1546 (let ((map (make-keymap)))
1547 (suppress-keymap map)
1548 (dolist (c '(narrow-to-region mark-word mark-sexp mark-paragraph
1549 mark-defun mark-whole-buffer mark-page
1550 downcase-region upcase-region kill-region
1551 copy-region-as-kill capitalize-region write-region))
1552 (define-key map (vector 'remap c) 'calendar-not-implemented))
1553 (define-key map "<" 'calendar-scroll-right)
1554 (define-key map "\C-x<" 'calendar-scroll-right)
1555 (define-key map [prior] 'calendar-scroll-right-three-months)
1556 (define-key map "\ev" 'calendar-scroll-right-three-months)
1557 (define-key map ">" 'calendar-scroll-left)
1558 (define-key map "\C-x>" 'calendar-scroll-left)
1559 (define-key map [next] 'calendar-scroll-left-three-months)
1560 (define-key map "\C-v" 'calendar-scroll-left-three-months)
1561 (define-key map "\C-b" 'calendar-backward-day)
1562 (define-key map "\C-p" 'calendar-backward-week)
1563 (define-key map "\e{" 'calendar-backward-month)
1564 (define-key map "\C-x[" 'calendar-backward-year)
1565 (define-key map "\C-f" 'calendar-forward-day)
1566 (define-key map "\C-n" 'calendar-forward-week)
1567 (define-key map [left] 'calendar-backward-day)
1568 (define-key map [up] 'calendar-backward-week)
1569 (define-key map [right] 'calendar-forward-day)
1570 (define-key map [down] 'calendar-forward-week)
1571 (define-key map "\e}" 'calendar-forward-month)
1572 (define-key map "\C-x]" 'calendar-forward-year)
1573 (define-key map "\C-a" 'calendar-beginning-of-week)
1574 (define-key map "\C-e" 'calendar-end-of-week)
1575 (define-key map "\ea" 'calendar-beginning-of-month)
1576 (define-key map "\ee" 'calendar-end-of-month)
1577 (define-key map "\e<" 'calendar-beginning-of-year)
1578 (define-key map "\e>" 'calendar-end-of-year)
1579 (define-key map "\C-@" 'calendar-set-mark)
1580 ;; Many people are used to typing C-SPC and getting C-@.
1581 (define-key map [?\C-\s] 'calendar-set-mark)
1582 (define-key map "\C-x\C-x" 'calendar-exchange-point-and-mark)
1583 (define-key map "\e=" 'calendar-count-days-region)
1584 (define-key map "gd" 'calendar-goto-date)
1585 (define-key map "gD" 'calendar-goto-day-of-year)
1586 (define-key map "gj" 'calendar-julian-goto-date)
1587 (define-key map "ga" 'calendar-astro-goto-day-number)
1588 (define-key map "gh" 'calendar-hebrew-goto-date)
1589 (define-key map "gi" 'calendar-islamic-goto-date)
1590 (define-key map "gb" 'calendar-bahai-goto-date)
1591 (define-key map "gC" 'calendar-chinese-goto-date)
1592 (define-key map "gk" 'calendar-coptic-goto-date)
1593 (define-key map "ge" 'calendar-ethiopic-goto-date)
1594 (define-key map "gp" 'calendar-persian-goto-date)
1595 (define-key map "gc" 'calendar-iso-goto-date)
1596 (define-key map "gw" 'calendar-iso-goto-week)
1597 (define-key map "gf" 'calendar-french-goto-date)
1598 (define-key map "gml" 'calendar-mayan-goto-long-count-date)
1599 (define-key map "gmpc" 'calendar-mayan-previous-round-date)
1600 (define-key map "gmnc" 'calendar-mayan-next-round-date)
1601 (define-key map "gmph" 'calendar-mayan-previous-haab-date)
1602 (define-key map "gmnh" 'calendar-mayan-next-haab-date)
1603 (define-key map "gmpt" 'calendar-mayan-previous-tzolkin-date)
1604 (define-key map "gmnt" 'calendar-mayan-next-tzolkin-date)
1605 (define-key map "Aa" 'appt-add)
1606 (define-key map "Ad" 'appt-delete)
1607 (define-key map "S" 'calendar-sunrise-sunset)
1608 (define-key map "M" 'calendar-lunar-phases)
1609 (define-key map " " 'scroll-other-window)
1610 (define-key map [?\S-\ ] 'scroll-other-window-down)
1611 (define-key map "\d" 'scroll-other-window-down)
1612 (define-key map "\C-c\C-l" 'calendar-redraw)
1613 (define-key map "." 'calendar-goto-today)
1614 (define-key map "o" 'calendar-other-month)
1615 (define-key map "q" 'calendar-exit)
1616 (define-key map "a" 'calendar-list-holidays)
1617 (define-key map "h" 'calendar-cursor-holidays)
1618 (define-key map "x" 'calendar-mark-holidays)
1619 (define-key map "u" 'calendar-unmark)
1620 (define-key map "m" 'diary-mark-entries)
1621 (define-key map "d" 'diary-view-entries)
1622 (define-key map "D" 'diary-view-other-diary-entries)
1623 (define-key map "s" 'diary-show-all-entries)
1624 (define-key map "pd" 'calendar-print-day-of-year)
1625 (define-key map "pC" 'calendar-chinese-print-date)
1626 (define-key map "pk" 'calendar-coptic-print-date)
1627 (define-key map "pe" 'calendar-ethiopic-print-date)
1628 (define-key map "pp" 'calendar-persian-print-date)
1629 (define-key map "pc" 'calendar-iso-print-date)
1630 (define-key map "pj" 'calendar-julian-print-date)
1631 (define-key map "pa" 'calendar-astro-print-day-number)
1632 (define-key map "ph" 'calendar-hebrew-print-date)
1633 (define-key map "pi" 'calendar-islamic-print-date)
1634 (define-key map "pb" 'calendar-bahai-print-date)
1635 (define-key map "pf" 'calendar-french-print-date)
1636 (define-key map "pm" 'calendar-mayan-print-date)
1637 (define-key map "po" 'calendar-print-other-dates)
1638 (define-key map "id" 'diary-insert-entry)
1639 (define-key map "iw" 'diary-insert-weekly-entry)
1640 (define-key map "im" 'diary-insert-monthly-entry)
1641 (define-key map "iy" 'diary-insert-yearly-entry)
1642 (define-key map "ia" 'diary-insert-anniversary-entry)
1643 (define-key map "ib" 'diary-insert-block-entry)
1644 (define-key map "ic" 'diary-insert-cyclic-entry)
1645 (define-key map "ihd" 'diary-hebrew-insert-entry)
1646 (define-key map "ihm" 'diary-hebrew-insert-monthly-entry)
1647 (define-key map "ihy" 'diary-hebrew-insert-yearly-entry)
1648 (define-key map "iid" 'diary-islamic-insert-entry)
1649 (define-key map "iim" 'diary-islamic-insert-monthly-entry)
1650 (define-key map "iiy" 'diary-islamic-insert-yearly-entry)
1651 (define-key map "iBd" 'diary-bahai-insert-entry)
1652 (define-key map "iBm" 'diary-bahai-insert-monthly-entry)
1653 (define-key map "iBy" 'diary-bahai-insert-yearly-entry)
1654 (define-key map "iCd" 'diary-chinese-insert-entry)
1655 (define-key map "iCm" 'diary-chinese-insert-monthly-entry)
1656 (define-key map "iCy" 'diary-chinese-insert-yearly-entry)
1657 (define-key map "iCa" 'diary-chinese-insert-anniversary-entry)
1658 (define-key map "?" 'calendar-goto-info-node)
1659 (define-key map "Hm" 'cal-html-cursor-month)
1660 (define-key map "Hy" 'cal-html-cursor-year)
1661 (define-key map "tm" 'cal-tex-cursor-month)
1662 (define-key map "tM" 'cal-tex-cursor-month-landscape)
1663 (define-key map "td" 'cal-tex-cursor-day)
1664 (define-key map "tw1" 'cal-tex-cursor-week)
1665 (define-key map "tw2" 'cal-tex-cursor-week2)
1666 (define-key map "tw3" 'cal-tex-cursor-week-iso) ; FIXME twi ?
1667 (define-key map "tw4" 'cal-tex-cursor-week-monday) ; twm ?
1668 (define-key map "twW" 'cal-tex-cursor-week2-summary)
1669 (define-key map "tfd" 'cal-tex-cursor-filofax-daily)
1670 (define-key map "tfw" 'cal-tex-cursor-filofax-2week)
1671 (define-key map "tfW" 'cal-tex-cursor-filofax-week)
1672 (define-key map "tfy" 'cal-tex-cursor-filofax-year)
1673 (define-key map "ty" 'cal-tex-cursor-year)
1674 (define-key map "tY" 'cal-tex-cursor-year-landscape)
1676 (define-key map [menu-bar edit] 'undefined)
1677 (define-key map [menu-bar search] 'undefined)
1679 (easy-menu-define nil map nil cal-menu-sunmoon-menu)
1680 (easy-menu-define nil map nil cal-menu-diary-menu)
1681 (easy-menu-define nil map nil cal-menu-holidays-menu)
1682 (easy-menu-define nil map nil cal-menu-goto-menu)
1683 (easy-menu-define nil map nil cal-menu-scroll-menu)
1685 ;; These are referenced in the default calendar-date-echo-text.
1686 (define-key map [down-mouse-3]
1687 (easy-menu-binding cal-menu-context-mouse-menu))
1688 (define-key map [down-mouse-2]
1689 (easy-menu-binding cal-menu-global-mouse-menu))
1691 ;; cf scroll-bar.el.
1692 (if (and (boundp 'x-toolkit-scroll-bars) x-toolkit-scroll-bars)
1693 (define-key map [vertical-scroll-bar mouse-1]
1694 'calendar-scroll-toolkit-scroll)
1695 ;; Left-click moves us forward in time, right-click backwards.
1696 (define-key map [vertical-scroll-bar mouse-1] 'calendar-scroll-left)
1697 (define-key map [vertical-scroll-bar drag-mouse-1] 'calendar-scroll-left)
1698 ;; down-mouse-2 stays as scroll-bar-drag.
1699 (define-key map [vertical-scroll-bar mouse-3] 'calendar-scroll-right)
1700 (define-key map [vertical-scroll-bar drag-mouse-3]
1701 'calendar-scroll-right))
1702 map)
1703 "Keymap for `calendar-mode'.")
1705 ;; Calendar mode is suitable only for specially formatted data.
1706 (put 'calendar-mode 'mode-class 'special)
1708 (defun calendar-mode-line-entry (command echo &optional key string)
1709 "Return a propertized string for `calendar-mode-line-format'.
1710 COMMAND is a command to run, ECHO is the help-echo text, KEY
1711 is COMMAND's keybinding, STRING describes the binding."
1712 (propertize (or key
1713 (substitute-command-keys
1714 (format "\\<calendar-mode-map>\\[%s] %s" command string)))
1715 'help-echo (format "mouse-1: %s" echo)
1716 'mouse-face 'mode-line-highlight
1717 'keymap (make-mode-line-mouse-map 'mouse-1 command)))
1719 ;; After calendar-mode-map.
1720 (defcustom calendar-mode-line-format
1721 (list
1722 (calendar-mode-line-entry 'calendar-scroll-right "previous month" "<")
1723 "Calendar"
1724 (concat
1725 (calendar-mode-line-entry 'calendar-goto-info-node "read Info on Calendar"
1726 nil "info")
1727 " / "
1728 (calendar-mode-line-entry 'calendar-other-month "choose another month"
1729 nil "other")
1730 " / "
1731 (calendar-mode-line-entry 'calendar-goto-today "go to today's date"
1732 nil "today"))
1733 '(calendar-date-string (calendar-current-date) t)
1734 (calendar-mode-line-entry 'calendar-scroll-left "next month" ">"))
1735 "If non-nil, the mode line of the calendar buffer.
1736 This is a list of items that evaluate to strings. The elements
1737 are evaluated and concatenated, evenly separated by blanks.
1738 During evaluation, the variable `date' is available as the date
1739 nearest the cursor (or today's date if that fails). To update
1740 the mode-line as the cursor moves, add
1741 `calendar-update-mode-line' to `calendar-move-hook'.
1743 If nil, do not modify the mode line at all.
1745 Here is an example that has the Hebrew date, the day number/days
1746 remaining in the year, and the ISO week/year numbers:
1748 (list
1749 \"\"
1750 \\='(calendar-hebrew-date-string date)
1751 \\='(let* ((year (calendar-extract-year date))
1752 (d (calendar-day-number date))
1753 (days-remaining
1754 (- (calendar-day-number (list 12 31 year)) d)))
1755 (format \"%d/%d\" d days-remaining))
1756 \\='(let* ((d (calendar-absolute-from-gregorian date))
1757 (iso-date (calendar-iso-from-absolute d)))
1758 (format \"ISO week %d of %d\"
1759 (calendar-extract-month iso-date)
1760 (calendar-extract-year iso-date)))
1761 \"\"))"
1762 :risky t
1763 :type 'sexp
1764 :group 'calendar)
1766 (defun calendar-goto-info-node ()
1767 "Go to the info node for the calendar."
1768 (interactive)
1769 (info "(emacs)Calendar/Diary")
1770 (fit-window-to-buffer))
1772 (defvar calendar-mark-ring nil
1773 "Used by `calendar-set-mark'.")
1775 (define-derived-mode calendar-mode nil "Calendar"
1776 "A major mode for the calendar window.
1777 For a complete description, see the info node `Calendar/Diary'.
1779 \\<calendar-mode-map>\\{calendar-mode-map}"
1780 (setq buffer-read-only t
1781 buffer-undo-list t
1782 indent-tabs-mode nil)
1783 (set (make-local-variable 'scroll-margin) 0) ; bug#10379
1784 (calendar-update-mode-line)
1785 (make-local-variable 'calendar-mark-ring)
1786 (make-local-variable 'displayed-month) ; month in middle of window
1787 (make-local-variable 'displayed-year) ; year in middle of window
1788 ;; Most functions only work if displayed-month and displayed-year are set,
1789 ;; so let's make sure they're always set. Most likely, this will be reset
1790 ;; soon in calendar-generate, but better safe than sorry.
1791 (unless (boundp 'displayed-month) (setq displayed-month 1))
1792 (unless (boundp 'displayed-year) (setq displayed-year 2001)))
1794 (defun calendar-string-spread (strings char length)
1795 "Concatenate list of STRINGS separated with copies of CHAR to fill LENGTH.
1796 The effect is like `mapconcat' but the separating pieces are as balanced as
1797 possible. Each item of STRINGS is evaluated before concatenation so it can
1798 actually be an expression that evaluates to a string. If LENGTH is too short,
1799 the STRINGS are just concatenated and the result truncated."
1800 ;; The algorithm is based on equation (3.25) on page 85 of Concrete
1801 ;; Mathematics by Ronald L. Graham, Donald E. Knuth, and Oren Patashnik,
1802 ;; Addison-Wesley, Reading, MA, 1989.
1803 (let* ((strings (mapcar #'eval
1804 (if (< (length strings) 2)
1805 (append (list "") strings (list ""))
1806 strings)))
1807 (n (- length (string-width (apply #'concat strings))))
1808 (m (* (1- (length strings)) (char-width char)))
1809 (s (car strings))
1810 (strings (cdr strings))
1811 (i 0))
1812 (dolist (string strings)
1813 (setq s (concat s
1814 (make-string (max 0 (/ (+ n i) m)) char)
1815 string)
1816 i (1+ i)))
1817 (truncate-string-to-width s length)))
1819 (defun calendar-update-mode-line ()
1820 "Update the calendar mode line with the current date and date style."
1821 (if (and calendar-mode-line-format
1822 (bufferp (get-buffer calendar-buffer)))
1823 (with-current-buffer calendar-buffer
1824 (let ((start (- calendar-left-margin 2)))
1825 (calendar-dlet* ((date (condition-case nil
1826 (calendar-cursor-to-nearest-date)
1827 (error (calendar-current-date)))))
1828 (setq mode-line-format
1829 (concat (make-string (max 0 (+ start
1830 (- (car (window-inside-edges))
1831 (car (window-edges)))))
1832 ?\s)
1833 (calendar-string-spread
1834 calendar-mode-line-format
1835 ?\s (- calendar-right-margin (1- start)))))))
1836 (force-mode-line-update))))
1838 (defun calendar-buffer-list ()
1839 "List of all calendar-related buffers (as buffers, not strings)."
1840 (let (buffs)
1841 (dolist (b (list calendar-hebrew-yahrzeit-buffer lunar-phases-buffer
1842 holiday-buffer diary-fancy-buffer solar-sunrises-buffer
1843 (get-file-buffer diary-file)
1844 calendar-buffer calendar-other-calendars-buffer))
1845 (and b (setq b (get-buffer b))
1846 (push b buffs)))
1847 buffs))
1849 (defun calendar-exit (&optional kill)
1850 "Get out of the calendar window and hide it and related buffers."
1851 (interactive "P")
1852 (let ((diary-buffer (get-file-buffer diary-file))
1853 (calendar-buffers (calendar-buffer-list)))
1854 (when (or (not diary-buffer)
1855 (not (buffer-modified-p diary-buffer))
1856 (yes-or-no-p
1857 "Diary modified; do you really want to exit the calendar? "))
1858 (if (and calendar-setup (display-multi-frame-p))
1859 ;; FIXME: replace this cruft with the `quit-restore' window property
1860 (dolist (w (window-list-1 nil nil t))
1861 (if (and (memq (window-buffer w) calendar-buffers)
1862 (window-dedicated-p w))
1863 (if (eq (window-deletable-p w) 'frame)
1864 (if calendar-remove-frame-by-deleting
1865 (delete-frame (window-frame w))
1866 (iconify-frame (window-frame w)))
1867 (quit-window kill w))))
1868 (dolist (b calendar-buffers)
1869 (quit-windows-on b kill))))))
1871 (defun calendar-current-date (&optional offset)
1872 "Return the current date in a list (month day year).
1873 Optional integer OFFSET is a number of days from the current date."
1874 (let* ((now (decode-time))
1875 (now (list (nth 4 now) (nth 3 now) (nth 5 now))))
1876 (if (zerop (or offset 0))
1878 (calendar-gregorian-from-absolute
1879 (+ offset (calendar-absolute-from-gregorian now))))))
1881 (defun calendar-column-to-segment ()
1882 "Convert current column to calendar month \"segment\".
1883 The left-most month returns 0, the next right 1, and so on."
1884 (let ((col (max 0 (+ (current-column)
1885 (/ calendar-intermonth-spacing 2)
1886 (- calendar-left-margin)))))
1887 (/ col (+ (* 7 calendar-column-width) calendar-intermonth-spacing))))
1889 (defun calendar-cursor-to-date (&optional error event)
1890 "Return a list (month day year) of current cursor position.
1891 If cursor is not on a specific date, signals an error if optional parameter
1892 ERROR is non-nil, otherwise just returns nil.
1893 If EVENT is non-nil, it's an event indicating the buffer position to
1894 use instead of point."
1895 (with-current-buffer
1896 (if event (window-buffer (posn-window (event-start event)))
1897 (current-buffer))
1898 (save-excursion
1899 (and event (setq event (event-start event))
1900 (goto-char (posn-point event)))
1901 (let* ((segment (calendar-column-to-segment))
1902 (month (% (+ displayed-month (1- segment)) 12)))
1903 ;; Call with point on either of the two digits in a 2-digit date,
1904 ;; or on or before the digit of a 1-digit date.
1905 (if (not (and (looking-at "[ 0-9]?[0-9][^0-9]")
1906 (get-text-property (point) 'date)))
1907 (if error (user-error "Not on a date!"))
1908 ;; Convert segment to real month and year.
1909 (if (zerop month) (setq month 12))
1910 ;; Go back to before the first date digit.
1911 (or (looking-at " ")
1912 (re-search-backward "[^0-9]"))
1913 (list month
1914 (string-to-number
1915 (buffer-substring (1+ (point))
1916 (+ 1 calendar-day-digit-width (point))))
1917 (cond
1918 ((and (= 12 month) (zerop segment)) (1- displayed-year))
1919 ((and (= 1 month) (= segment 2)) (1+ displayed-year))
1920 (t displayed-year))))))))
1922 ;; The following version of calendar-gregorian-from-absolute is preferred for
1923 ;; reasons of clarity, BUT it's much slower than the version that follows it.
1925 ;;(defun calendar-gregorian-from-absolute (date)
1926 ;; "Compute the list (month day year) corresponding to the absolute DATE.
1927 ;;The absolute date is the number of days elapsed since the (imaginary)
1928 ;;Gregorian date Sunday, December 31, 1 BC."
1929 ;; (let* ((approx (/ date 366)) ; approximation from below
1930 ;; (year ; search forward from the approximation
1931 ;; (+ approx
1932 ;; (calendar-sum y approx
1933 ;; (>= date (calendar-absolute-from-gregorian (list 1 1 (1+ y))))
1934 ;; 1)))
1935 ;; (month ; search forward from January
1936 ;; (1+ (calendar-sum m 1
1937 ;; (> date
1938 ;; (calendar-absolute-from-gregorian
1939 ;; (list m (calendar-last-day-of-month m year) year)))
1940 ;; 1)))
1941 ;; (day ; calculate the day by subtraction
1942 ;; (- date
1943 ;; (1- (calendar-absolute-from-gregorian (list month 1 year))))))
1944 ;; (list month day year)))
1946 (defun calendar-gregorian-from-absolute (date)
1947 "Compute the list (month day year) corresponding to the absolute DATE.
1948 The absolute date is the number of days elapsed since the (imaginary)
1949 Gregorian date Sunday, December 31, 1 BC. This function does not
1950 handle dates in years BC."
1951 ;; For an explanation, see the footnote on page 384 of "Calendrical
1952 ;; Calculations, Part II: Three Historical Calendars" by
1953 ;; E. M. Reingold, N. Dershowitz, and S. M. Clamen,
1954 ;; Software--Practice and Experience, Volume 23, Number 4 (April,
1955 ;; 1993), pages 383-404 <https://doi.org/10.1002/spe.4380230404>
1956 ;; <http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.42.6421&rep=rep1&type=pdf>.
1957 (let* ((d0 (1- date))
1958 (n400 (/ d0 146097))
1959 (d1 (% d0 146097))
1960 (n100 (/ d1 36524))
1961 (d2 (% d1 36524))
1962 (n4 (/ d2 1461))
1963 (d3 (% d2 1461))
1964 (n1 (/ d3 365))
1965 (day (1+ (% d3 365)))
1966 (year (+ (* 400 n400) (* 100 n100) (* n4 4) n1))
1967 (month 1)
1968 mdays)
1969 (if (or (= n100 4) (= n1 4))
1970 (list 12 31 year)
1971 (setq year (1+ year))
1972 (while (< (setq mdays (calendar-last-day-of-month month year)) day)
1973 (setq day (- day mdays)
1974 month (1+ month)))
1975 (list month day year))))
1977 (defun calendar-other-month (month year &optional event)
1978 "Display a three-month calendar centered around MONTH and YEAR.
1979 EVENT is an event like `last-nonmenu-event'."
1980 (interactive (let ((event (list last-nonmenu-event)))
1981 (append (calendar-read-date 'noday) event)))
1982 (save-selected-window
1983 (and event
1984 (setq event (event-start event))
1985 (select-window (posn-window event)))
1986 (unless (and (= month displayed-month)
1987 (= year displayed-year))
1988 (let ((old-date (calendar-cursor-to-date))
1989 (today (calendar-current-date)))
1990 (calendar-generate-window month year)
1991 (calendar-cursor-to-visible-date
1992 (cond
1993 ((calendar-date-is-visible-p old-date) old-date)
1994 ((calendar-date-is-visible-p today) today)
1995 (t (list month 1 year))))))))
1997 (defun calendar-set-mark (arg &optional event)
1998 "Mark the date under the cursor, or jump to marked date.
1999 With no prefix argument, push current date onto marked date ring.
2000 With argument ARG, jump to mark, pop it, and put point at end of ring."
2001 (interactive
2002 (list current-prefix-arg last-nonmenu-event))
2003 (let ((date (calendar-cursor-to-date t event)))
2004 (if arg
2005 (if (null calendar-mark-ring)
2006 (error "No mark set in this buffer")
2007 (calendar-goto-date (car calendar-mark-ring))
2008 (setq calendar-mark-ring
2009 (cdr (nconc calendar-mark-ring (list date)))))
2010 (push date calendar-mark-ring)
2011 ;; Since the top of the mark ring is the marked date in the
2012 ;; calendar, the mark ring in the calendar is one longer than
2013 ;; in other buffers to get the same effect.
2014 (if (> (length calendar-mark-ring) (1+ mark-ring-max))
2015 (setcdr (nthcdr mark-ring-max calendar-mark-ring) nil))
2016 (message "Mark set"))))
2018 (defun calendar-exchange-point-and-mark ()
2019 "Exchange the current cursor position with the marked date."
2020 (interactive)
2021 (let ((mark (car calendar-mark-ring))
2022 (date (calendar-cursor-to-date t)))
2023 (if (null mark)
2024 (error "No mark set in this buffer")
2025 (setq calendar-mark-ring (cons date (cdr calendar-mark-ring)))
2026 (calendar-goto-date mark))))
2028 (defun calendar-count-days-region ()
2029 "Count the number of days (inclusive) between point and the mark."
2030 (interactive)
2031 (let* ((days (- (calendar-absolute-from-gregorian
2032 (calendar-cursor-to-date t))
2033 (calendar-absolute-from-gregorian
2034 (or (car calendar-mark-ring)
2035 (error "No mark set in this buffer")))))
2036 (days (1+ (if (> days 0) days (- days)))))
2037 (message "Region has %d day%s (inclusive)"
2038 days (if (> days 1) "s" ""))))
2040 (defun calendar-not-implemented ()
2041 "Not implemented."
2042 (interactive)
2043 (error "%s not available in the calendar"
2044 (global-key-binding (this-command-keys))))
2046 (defun calendar-read (prompt acceptable &optional initial-contents)
2047 "Return an object read from the minibuffer.
2048 Prompt with the string PROMPT and use the function ACCEPTABLE to decide if
2049 entered item is acceptable. If non-nil, optional third arg INITIAL-CONTENTS
2050 is a string to insert in the minibuffer before reading."
2051 (let ((value (read-minibuffer prompt initial-contents)))
2052 (while (not (funcall acceptable value))
2053 (setq value (read-minibuffer prompt initial-contents)))
2054 value))
2057 (defun calendar-customized-p (symbol)
2058 "Return non-nil if SYMBOL has been customized."
2059 (and (default-boundp symbol)
2060 (let ((standard (get symbol 'standard-value)))
2061 (and standard
2062 (not (equal (eval (car standard)) (default-value symbol)))))))
2064 (defun calendar-abbrev-construct (full &optional maxlen)
2065 "From sequence FULL, return a vector of abbreviations.
2066 Each abbreviation is no longer than MAXLEN (default `calendar-abbrev-length')
2067 characters."
2068 (or maxlen (setq maxlen calendar-abbrev-length))
2069 (apply #'vector (mapcar
2070 (lambda (f)
2071 ;; TODO? truncate-string-to-width?
2072 (substring f 0 (min maxlen (length f))))
2073 full)))
2075 (defcustom calendar-day-name-array
2076 ["Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"]
2077 "Array of capitalized strings giving, in order from Sunday, the day names.
2078 If you change this without using customize after the calendar has loaded,
2079 then you may also want to change `calendar-day-abbrev-array'
2080 and `calendar-day-header-array'."
2081 :group 'calendar
2082 :initialize 'custom-initialize-default
2083 :set (lambda (symbol value)
2084 (let ((dcustomized (calendar-customized-p 'calendar-day-abbrev-array))
2085 (hcustomized (calendar-customized-p 'cal-html-day-abbrev-array))
2086 (ccustomized (calendar-customized-p 'calendar-day-header-array)))
2087 (set symbol value)
2088 (or dcustomized
2089 (setq calendar-day-abbrev-array
2090 (calendar-abbrev-construct calendar-day-name-array)))
2091 (and (not hcustomized)
2092 (boundp 'cal-html-day-abbrev-array)
2093 (setq cal-html-day-abbrev-array calendar-day-abbrev-array))
2094 (or ccustomized
2095 (equal calendar-day-header-array
2096 (setq calendar-day-header-array
2097 (calendar-day-header-construct)))
2098 (calendar-redraw))))
2099 :type '(vector (string :tag "Sunday")
2100 (string :tag "Monday")
2101 (string :tag "Tuesday")
2102 (string :tag "Wednesday")
2103 (string :tag "Thursday")
2104 (string :tag "Friday")
2105 (string :tag "Saturday")))
2107 (defcustom calendar-abbrev-length 3
2108 "Default length of abbreviations to use for day and month names.
2109 If you change this without using customize after the calendar has loaded,
2110 then you may also want to change `calendar-day-abbrev-array' and
2111 `calendar-month-abbrev-array'."
2112 :group 'calendar
2113 :initialize 'custom-initialize-default
2114 :set (lambda (symbol value)
2115 (let ((dcustomized (calendar-customized-p 'calendar-day-abbrev-array))
2116 (mcustomized (calendar-customized-p
2117 'calendar-month-abbrev-array))
2118 (hcustomized (calendar-customized-p 'cal-html-day-abbrev-array))
2119 (ccustomized (calendar-customized-p 'calendar-day-header-array)))
2120 (set symbol value)
2121 (or dcustomized
2122 (setq calendar-day-abbrev-array
2123 (calendar-abbrev-construct calendar-day-name-array)))
2124 (or mcustomized
2125 (setq calendar-month-abbrev-array
2126 (calendar-abbrev-construct calendar-month-name-array)))
2127 (and (not hcustomized)
2128 (boundp 'cal-html-day-abbrev-array)
2129 (setq cal-html-day-abbrev-array calendar-day-abbrev-array))
2130 (or ccustomized
2131 (equal calendar-day-header-array
2132 (setq calendar-day-header-array
2133 (calendar-day-header-construct)))
2134 (calendar-redraw))))
2135 :type 'integer)
2137 (defcustom calendar-day-abbrev-array
2138 (calendar-abbrev-construct calendar-day-name-array)
2139 "Array of capitalized strings giving the abbreviated day names.
2140 The order should be the same as that of the full names specified
2141 in `calendar-day-name-array'. These abbreviations may be used
2142 instead of the full names in the diary file. Do not include a
2143 trailing `.' in the strings specified in this variable, though
2144 you may use such in the diary file. By default, each string is
2145 the first `calendar-abbrev-length' characters of the corresponding
2146 full name."
2147 :group 'calendar
2148 :initialize 'custom-initialize-default
2149 :set-after '(calendar-abbrev-length calendar-day-name-array)
2150 :set (lambda (symbol value)
2151 (let ((hcustomized (calendar-customized-p 'cal-html-day-abbrev-array))
2152 (ccustomized (calendar-customized-p 'calendar-day-header-array)))
2153 (set symbol value)
2154 (and (not hcustomized)
2155 (boundp 'cal-html-day-abbrev-array)
2156 (setq cal-html-day-abbrev-array calendar-day-abbrev-array))
2157 (or ccustomized
2158 (equal calendar-day-header-array
2159 (setq calendar-day-header-array
2160 (calendar-day-header-construct)))
2161 (calendar-redraw))))
2162 :type '(vector (string :tag "Sun")
2163 (string :tag "Mon")
2164 (string :tag "Tue")
2165 (string :tag "Wed")
2166 (string :tag "Thu")
2167 (string :tag "Fri")
2168 (string :tag "Sat"))
2169 ;; Made defcustom, changed defaults from nil nil...
2170 :version "24.1")
2172 (defcustom calendar-day-header-array (calendar-day-header-construct)
2173 "Array of strings to use for the headers of the calendar's day columns.
2174 The order should be the same as in `calendar-day-name-array'.
2175 In use, the calendar truncates elements to no more than
2176 `calendar-day-header-width' columns wide.
2177 Emacs constructs the default from either `calendar-day-name-array'
2178 \(if `calendar-day-header-width' is more than `calendar-abbrev-length'),
2179 or from `calendar-day-abbrev-array' (assuming that the abbreviated
2180 name are more likely to be unique when truncated)."
2181 :group 'calendar
2182 :initialize 'custom-initialize-default
2183 :set-after '(calendar-day-header-width
2184 calendar-abbrev-length calendar-day-name-array
2185 calendar-day-abbrev-array)
2186 :set (lambda (symbol value)
2187 (or (equal calendar-day-header-array
2188 (set symbol value))
2189 (calendar-redraw)))
2190 :type '(vector (string :tag "Su")
2191 (string :tag "Mo")
2192 (string :tag "Tu")
2193 (string :tag "We")
2194 (string :tag "Th")
2195 (string :tag "Fr")
2196 (string :tag "Sa"))
2197 :version "24.4")
2199 (defcustom calendar-month-name-array
2200 ["January" "February" "March" "April" "May" "June"
2201 "July" "August" "September" "October" "November" "December"]
2202 "Array of capitalized strings giving, in order, the month names.
2203 If you change this without using customize after the calendar has loaded,
2204 then you may also want to change `calendar-month-abbrev-array'."
2205 :group 'calendar
2206 :initialize 'custom-initialize-default
2207 :set (lambda (symbol value)
2208 (let ((mcustomized (calendar-customized-p
2209 'calendar-month-abbrev-array)))
2210 (set symbol value)
2211 (or mcustomized
2212 (setq calendar-month-abbrev-array
2213 (calendar-abbrev-construct calendar-month-name-array)))))
2214 :type '(vector (string :tag "January")
2215 (string :tag "February")
2216 (string :tag "March")
2217 (string :tag "April")
2218 (string :tag "May")
2219 (string :tag "June")
2220 (string :tag "July")
2221 (string :tag "August")
2222 (string :tag "September")
2223 (string :tag "October")
2224 (string :tag "November")
2225 (string :tag "December")))
2227 (defcustom calendar-month-abbrev-array
2228 (calendar-abbrev-construct calendar-month-name-array)
2229 "Array of capitalized strings giving the abbreviated month names.
2230 The order should be the same as that of the full names specified
2231 in `calendar-month-name-array'. These abbreviations are used in
2232 the calendar menu entries, and can also be used in the diary
2233 file. Do not include a trailing `.' in the strings specified in
2234 this variable, though you may use such in the diary file. By
2235 default, each string is the first `calendar-abbrev-length'
2236 characters of the corresponding full name."
2237 :group 'calendar
2238 :set-after '(calendar-abbrev-length calendar-month-name-array)
2239 :type '(vector (string :tag "Jan")
2240 (string :tag "Feb")
2241 (string :tag "Mar")
2242 (string :tag "Apr")
2243 (string :tag "May")
2244 (string :tag "Jun")
2245 (string :tag "Jul")
2246 (string :tag "Aug")
2247 (string :tag "Sep")
2248 (string :tag "Oct")
2249 (string :tag "Nov")
2250 (string :tag "Dec"))
2251 ;; Made defcustom, changed defaults from nil nil...
2252 :version "24.1")
2254 (defun calendar-make-alist (sequence &optional start-index filter
2255 &rest sequences)
2256 "Return an association list corresponding to SEQUENCE.
2257 Associates each element of SEQUENCE with an incremented integer,
2258 starting from START-INDEX (default 1). Applies the function FILTER,
2259 if provided, to each key in the alist. Repeats the process, with
2260 indices starting from START-INDEX each time, for any remaining
2261 arguments SEQUENCES."
2262 (or start-index (setq start-index 1))
2263 (let (index alist)
2264 (mapc (lambda (seq)
2265 (setq index start-index)
2266 (mapc (lambda (elem)
2267 (setq alist (cons
2268 (cons (if filter (funcall filter elem) elem)
2269 index)
2270 alist)
2271 index (1+ index)))
2272 seq))
2273 (append (list sequence) sequences))
2274 (reverse alist)))
2276 (defun calendar-read-date (&optional noday)
2277 "Prompt for Gregorian date. Return a list (month day year).
2278 If optional NODAY is t, does not ask for day, but just returns
2279 \(month 1 year); if NODAY is any other non-nil value the value returned is
2280 \(month year)"
2281 (let* ((year (calendar-read
2282 "Year (>0): "
2283 (lambda (x) (> x 0))
2284 (number-to-string (calendar-extract-year
2285 (calendar-current-date)))))
2286 (month-array calendar-month-name-array)
2287 (completion-ignore-case t)
2288 (month (cdr (assoc-string
2289 (completing-read
2290 "Month name: "
2291 (mapcar #'list (append month-array nil))
2292 nil t)
2293 (calendar-make-alist month-array 1) t)))
2294 (last (calendar-last-day-of-month month year)))
2295 (if noday
2296 (if (eq noday t)
2297 (list month 1 year)
2298 (list month year))
2299 (list month
2300 (calendar-read (format "Day (1-%d): " last)
2301 (lambda (x) (and (< 0 x) (<= x last))))
2302 year))))
2304 (defun calendar-interval (mon1 yr1 mon2 yr2)
2305 "The number of months difference between MON1, YR1 and MON2, YR2.
2306 The result is positive if the second date is later than the first.
2307 Negative years are interpreted as years BC; -1 being 1 BC, and so on."
2308 (if (< yr1 0) (setq yr1 (1+ yr1))) ; -1 BC -> 0 AD, etc
2309 (if (< yr2 0) (setq yr2 (1+ yr2)))
2310 (+ (* 12 (- yr2 yr1))
2311 (- mon2 mon1)))
2313 (defun calendar-day-name (date &optional abbrev absolute)
2314 "Return a string with the name of the day of the week of DATE.
2315 DATE should be a list in the format (MONTH DAY YEAR), unless the
2316 optional argument ABSOLUTE is non-nil, in which case DATE should
2317 be an integer in the range 0 to 6 corresponding to the day of the
2318 week. Day names are taken from the variable `calendar-day-name-array',
2319 unless the optional argument ABBREV is non-nil:
2320 `header' means to use `calendar-day-header-array';
2321 t to use `calendar-day-abbrev-array'."
2322 (aref (cond ((eq abbrev 'header) calendar-day-header-array)
2323 (abbrev calendar-day-abbrev-array)
2324 (t calendar-day-name-array))
2325 (if absolute date (calendar-day-of-week date))))
2327 (defun calendar-month-name (month &optional abbrev)
2328 "Return a string with the name of month number MONTH.
2329 Months are numbered from one. Month names are taken from the
2330 variable `calendar-month-name-array', unless the optional
2331 argument ABBREV is non-nil, in which case
2332 `calendar-month-abbrev-array' is used."
2333 (aref (if abbrev calendar-month-abbrev-array calendar-month-name-array)
2334 (1- month)))
2336 (defun calendar-day-of-week (date)
2337 "Return the day-of-the-week index of DATE, 0 for Sunday, 1 for Monday, etc.
2338 DATE is a list of the form (month day year). A negative year is
2339 interpreted as BC; -1 being 1 BC, and so on."
2340 (mod (calendar-absolute-from-gregorian date) 7))
2342 (defun calendar-week-end-day ()
2343 "Return the index (0 for Sunday, etc.) of the last day of the week."
2344 (mod (+ calendar-week-start-day 6) 7))
2346 (defun calendar-unmark ()
2347 "Delete all diary/holiday marks/highlighting from the calendar."
2348 (interactive)
2349 (setq calendar-mark-holidays-flag nil
2350 calendar-mark-diary-entries-flag nil)
2351 (with-current-buffer calendar-buffer
2352 (mapc #'delete-overlay (overlays-in (point-min) (point-max)))))
2354 (defun calendar-date-is-visible-p (date)
2355 "Return non-nil if DATE is valid and is visible in the calendar window."
2356 (and (calendar-date-is-valid-p date)
2357 (< (abs (calendar-interval
2358 displayed-month displayed-year
2359 (calendar-extract-month date) (calendar-extract-year date)))
2360 2)))
2362 ;; FIXME can this be generalized for holiday-chinese?
2363 (defun calendar-nongregorian-visible-p (month day toabs fromabs switch)
2364 "Return non-nil if MONTH, DAY is visible in the calendar window.
2365 MONTH and DAY are in some non-Gregorian calendar system. The
2366 functions TOABS and FROMABS convert that system to and from
2367 absolute, respectively. SWITCH is a function that takes a single
2368 argument (a local month number). It applies when the local year
2369 changes across the calendar window, and returns non-nil if the
2370 specified month should be associated with the higher year.
2371 Returns the corresponding Gregorian date."
2372 ;; We need to choose the local year associated with month and day
2373 ;; that might make them visible.
2374 (let* ((m1 displayed-month)
2375 (y1 displayed-year)
2376 (m2 displayed-month)
2377 (y2 displayed-year)
2378 ;; Absolute date of first/last dates in calendar window.
2379 (start-date (progn
2380 (calendar-increment-month m1 y1 -1)
2381 (calendar-absolute-from-gregorian (list m1 1 y1))))
2382 (end-date (progn
2383 (calendar-increment-month m2 y2 1)
2384 (calendar-absolute-from-gregorian
2385 (list m2 (calendar-last-day-of-month m2 y2) y2))))
2386 ;; Local date of first/last date in calendar window.
2387 (local-start (funcall fromabs start-date))
2388 (local-end (funcall fromabs end-date))
2389 ;; Local year of first/last dates.
2390 ;; Can only differ if displayed-month = 12, 1, 2.
2391 (local-y1 (calendar-extract-year local-start))
2392 (local-y2 (calendar-extract-year local-end))
2393 ;; Choose which year might be visible in the window.
2394 ;; Obviously it only matters when y1 and y2 differ, ie
2395 ;; when the _local_ new year is visible.
2396 (year (if (funcall switch month) local-y2 local-y1))
2397 (date (calendar-gregorian-from-absolute
2398 (funcall toabs (list month day year)))))
2399 (if (calendar-date-is-visible-p date)
2400 date)))
2402 (defun calendar-date-is-valid-p (date)
2403 "Return t if DATE is a valid date."
2404 (let ((month (calendar-extract-month date))
2405 (day (calendar-extract-day date))
2406 (year (calendar-extract-year date)))
2407 (and (<= 1 month) (<= month 12)
2408 ;; (calendar-read-date t) used to return a date with day = nil.
2409 ;; Should not be valid (?), since many funcs prob assume integer.
2410 ;; (calendar-read-date 'noday) returns (month year), which
2411 ;; currently results in calendar-extract-year returning nil.
2412 day year (<= 1 day) (<= day (calendar-last-day-of-month month year))
2413 ;; BC dates left as non-valid, to suppress errors from
2414 ;; complex holiday algorithms not suitable for years BC.
2415 ;; Note there are side effects on calendar navigation.
2416 (<= 1 year))))
2418 (defun calendar-date-equal (date1 date2)
2419 "Return t if the DATE1 and DATE2 are the same."
2420 (and
2421 (= (calendar-extract-month date1) (calendar-extract-month date2))
2422 (= (calendar-extract-day date1) (calendar-extract-day date2))
2423 (= (calendar-extract-year date1) (calendar-extract-year date2))))
2425 (defun calendar-make-temp-face (attrlist)
2426 "Return a temporary face based on the attributes in ATTRLIST.
2427 ATTRLIST is a list with elements of the form :face face :foreground color."
2428 (let ((attrs attrlist)
2429 faceinfo face temp-face)
2430 ;; Separate :face from the other attributes. Use the last :face
2431 ;; if there are more than one. FIXME is merging meaningful?
2432 (while attrs
2433 (if (eq (car attrs) :face)
2434 (setq face (intern-soft (cadr attrs))
2435 attrs (cddr attrs))
2436 (push (car attrs) faceinfo)
2437 (setq attrs (cdr attrs))))
2438 (or (facep face) (setq face 'default))
2439 (if (not faceinfo)
2440 ;; No attributes to apply, so just use an existing-face.
2441 face
2442 ;; FIXME should we be using numbered temp-faces, re-using where poss?
2443 (setq temp-face
2444 (make-symbol
2445 (concat ":caltemp"
2446 (mapconcat (lambda (sym)
2447 (cond
2448 ((symbolp sym) (symbol-name sym))
2449 ((numberp sym) (number-to-string sym))
2450 (t sym)))
2451 attrlist ""))))
2452 (make-face temp-face)
2453 (copy-face face temp-face)
2454 ;; Apply the font aspects.
2455 (apply #'set-face-attribute temp-face nil (nreverse faceinfo))
2456 temp-face)))
2458 (defun calendar-mark-visible-date (date &optional mark)
2459 "Mark DATE in the calendar window with MARK.
2460 MARK is a single-character string, a list of face attributes/values, or a face.
2461 MARK defaults to `diary-entry-marker'."
2462 (if (calendar-date-is-valid-p date)
2463 (with-current-buffer calendar-buffer
2464 (save-excursion
2465 (calendar-cursor-to-visible-date date)
2466 (setq mark
2467 (or (and (stringp mark) (= (length mark) 1) mark) ; single-char
2468 ;; The next two use to also check font-lock-mode.
2469 ;; See comments above diary-entry-marker for why
2470 ;; this was dropped.
2471 ;;; (and font-lock-mode
2472 ;;; (or
2473 (and (listp mark) (> (length mark) 0) mark) ; attrs
2474 (and (facep mark) mark) ; )) face-name
2475 diary-entry-marker))
2476 (cond
2477 ;; Face or an attr-list that contained a face.
2478 ((facep mark)
2479 (overlay-put
2480 (make-overlay (1- (point)) (1+ (point))) 'face mark))
2481 ;; Single-character mark, goes after the date.
2482 ((and (stringp mark) (= (length mark) 1))
2483 (overlay-put
2484 (make-overlay (1+ (point)) (+ 2 (point))) 'display mark))
2485 (t ; attr list
2486 (overlay-put
2487 (make-overlay (1- (point)) (1+ (point))) 'face
2488 (calendar-make-temp-face mark))))))))
2490 (defun calendar-star-date ()
2491 "Replace the date under the cursor in the calendar window with asterisks.
2492 You might want to add this function to `calendar-today-visible-hook'."
2493 (unless (catch 'found
2494 (dolist (ol (overlays-at (point)))
2495 (and (overlay-get ol 'calendar-star)
2496 (throw 'found t))))
2497 (let ((ol (make-overlay (1- (point)) (point))))
2498 (overlay-put ol 'display "*")
2499 (overlay-put ol 'calendar-star t)
2500 ;; Use copy-sequence to avoid merging of identical 'display props.
2501 ;; Use two overlays so as not to mess up
2502 ;; calendar-cursor-to-nearest-date (and calendar-forward-day).
2503 (overlay-put (setq ol (make-overlay (point) (1+ (point))))
2504 'display (copy-sequence "*"))
2505 (overlay-put ol 'calendar-star t))))
2507 (defun calendar-mark-today ()
2508 "Mark the date under the cursor in the calendar window.
2509 The date is marked with `calendar-today-marker'. You might want to add
2510 this function to `calendar-today-visible-hook'."
2511 (calendar-mark-visible-date (calendar-cursor-to-date) calendar-today-marker))
2513 ;; FIXME why the car? Almost every usage calls list on the args.
2514 (defun calendar-date-compare (date1 date2)
2515 "Return t if DATE1 is before DATE2, nil otherwise.
2516 The actual dates are in the car of DATE1 and DATE2."
2517 (< (calendar-absolute-from-gregorian (car date1))
2518 (calendar-absolute-from-gregorian (car date2))))
2520 (defun calendar-date-string (date &optional abbreviate nodayname)
2521 "A string form of DATE, driven by the variable `calendar-date-display-form'.
2522 An optional parameter ABBREVIATE, when non-nil, causes the month
2523 and day names to be abbreviated as specified by
2524 `calendar-month-abbrev-array' and `calendar-day-abbrev-array',
2525 respectively. An optional parameter NODAYNAME, when t, omits the
2526 name of the day of the week."
2527 (let ((month (calendar-extract-month date)))
2528 (calendar-dlet*
2529 ((dayname (unless nodayname (calendar-day-name date abbreviate)))
2530 (monthname (calendar-month-name month abbreviate))
2531 (day (number-to-string (calendar-extract-day date)))
2532 (month (number-to-string month))
2533 (year (number-to-string (calendar-extract-year date))))
2534 (mapconcat #'eval calendar-date-display-form ""))))
2536 (defun calendar-dayname-on-or-before (dayname date)
2537 "Return the absolute date of the DAYNAME on or before absolute DATE.
2538 DAYNAME=0 means Sunday, DAYNAME=1 means Monday, and so on.
2540 Note: Applying this function to d+6 gives us the DAYNAME on or after an
2541 absolute day d. Similarly, applying it to d+3 gives the DAYNAME nearest to
2542 absolute date d, applying it to d-1 gives the DAYNAME previous to absolute
2543 date d, and applying it to d+7 gives the DAYNAME following absolute date d."
2544 (- date (% (- date dayname) 7)))
2546 (defun calendar-nth-named-absday (n dayname month year &optional day)
2547 "Absolute date of the Nth DAYNAME after/before MONTH YEAR DAY.
2548 A DAYNAME of 0 means Sunday, 1 means Monday, and so on.
2549 If N>0, return the Nth DAYNAME after MONTH DAY, YEAR (inclusive).
2550 If N<0, return the Nth DAYNAME before MONTH DAY, YEAR (inclusive).
2551 DAY defaults to 1 if N>0, and MONTH's last day otherwise."
2552 (if (> n 0)
2553 (+ (* 7 (1- n))
2554 (calendar-dayname-on-or-before
2555 dayname
2556 (+ 6 (calendar-absolute-from-gregorian
2557 (list month (or day 1) year)))))
2558 (+ (* 7 (1+ n))
2559 (calendar-dayname-on-or-before
2560 dayname
2561 (calendar-absolute-from-gregorian
2562 (list month
2563 (or day (calendar-last-day-of-month month year))
2564 year))))))
2566 (defun calendar-nth-named-day (n dayname month year &optional day)
2567 "Date of the Nth DAYNAME after/before MONTH YEAR DAY.
2568 Like `calendar-nth-named-absday', but returns a Gregorian date."
2569 (calendar-gregorian-from-absolute
2570 (calendar-nth-named-absday n dayname month year day)))
2572 (defun calendar-day-of-year-string (&optional date)
2573 "String of day number of year of Gregorian DATE.
2574 Defaults to today's date if DATE is not given."
2575 (let* ((d (or date (calendar-current-date)))
2576 (year (calendar-extract-year d))
2577 (day (calendar-day-number d))
2578 (days-remaining (- (calendar-day-number (list 12 31 year)) day)))
2579 (format "Day %d of %d; %d day%s remaining in the year"
2580 day year days-remaining (if (= days-remaining 1) "" "s"))))
2582 (defun calendar-other-dates (date)
2583 "Return a list of strings giving Gregorian DATE in other calendars.
2584 DATE is (month day year). Calendars that do not apply are omitted."
2585 (let (odate)
2586 (delq nil
2587 (list
2588 (calendar-day-of-year-string date)
2589 (format "ISO date: %s" (calendar-iso-date-string date))
2590 (format "Julian date: %s"
2591 (calendar-julian-date-string date))
2592 (format "Astronomical (Julian) day number (at noon UTC): %s.0"
2593 (calendar-astro-date-string date))
2594 (format "Fixed (RD) date: %s"
2595 (calendar-absolute-from-gregorian date))
2596 (format "Hebrew date (before sunset): %s"
2597 (calendar-hebrew-date-string date))
2598 (format "Persian date: %s"
2599 (calendar-persian-date-string date))
2600 (unless (string-equal
2601 (setq odate (calendar-islamic-date-string date))
2603 (format "Islamic date (before sunset): %s" odate))
2604 (unless (string-equal
2605 (setq odate (calendar-bahai-date-string date))
2607 (format "Bahá’í date: %s" odate))
2608 (format "Chinese date: %s"
2609 (calendar-chinese-date-string date))
2610 (unless (string-equal
2611 (setq odate (calendar-coptic-date-string date))
2613 (format "Coptic date: %s" odate))
2614 (unless (string-equal
2615 (setq odate (calendar-ethiopic-date-string date))
2617 (format "Ethiopic date: %s" odate))
2618 (unless (string-equal
2619 (setq odate (calendar-french-date-string date))
2621 (format "French Revolutionary date: %s" odate))
2622 (format "Mayan date: %s"
2623 (calendar-mayan-date-string date))))))
2625 (declare-function x-popup-menu "menu.c" (position menu))
2627 (defun calendar-print-other-dates (&optional event)
2628 "Show dates on other calendars for date under the cursor.
2629 If called by a mouse-event, pops up a menu with the result."
2630 (interactive (list last-nonmenu-event))
2631 (let* ((date (calendar-cursor-to-date t event))
2632 (title (format "%s (Gregorian)" (calendar-date-string date)))
2633 (others (calendar-other-dates date))
2634 selection)
2635 (if (mouse-event-p event)
2636 (and (setq selection (cal-menu-x-popup-menu event title
2637 (mapcar #'list others)))
2638 (call-interactively selection))
2639 (calendar-in-read-only-buffer calendar-other-calendars-buffer
2640 (calendar-set-mode-line title)
2641 (insert (mapconcat #'identity others "\n"))))))
2643 (defun calendar-print-day-of-year ()
2644 "Show day number in year/days remaining in year for date under the cursor."
2645 (interactive)
2646 (message "%s" (calendar-day-of-year-string (calendar-cursor-to-date t))))
2648 (defun calendar-set-mode-line (str)
2649 "Set mode line to STR, centered, surrounded by dashes."
2650 (let* ((edges (window-edges))
2651 ;; As per doc of window-width, total visible mode-line length.
2652 (width (- (nth 2 edges) (car edges))))
2653 ;; Hack for --daemon. See bug #2199.
2654 ;; If no frame exists yet, we have no idea what width to use.
2655 (and (= width 10)
2656 (not window-system)
2657 (setq width (string-to-number (or (getenv "COLUMNS") "80"))))
2658 (setq mode-line-format
2659 (if buffer-file-name
2660 `("-" mode-line-modified
2661 ,(calendar-string-spread (list str) ?- (- width 6))
2662 "---")
2663 (calendar-string-spread (list str) ?- width)))))
2665 (run-hooks 'calendar-load-hook)
2667 (provide 'calendar)
2669 ;; Local variables:
2670 ;; byte-compile-dynamic: t
2671 ;; End:
2673 ;;; calendar.el ends here