1 ;;; calendar.el --- calendar functions
3 ;; Copyright (C) 1988-1995, 1997, 2000-2012 Free Software Foundation, Inc.
5 ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
6 ;; Maintainer: Glenn Morris <rgm@gnu.org>
8 ;; Human-Keywords: calendar, Gregorian calendar, diary, holidays
10 ;; This file is part of GNU Emacs.
12 ;; GNU Emacs is free software: you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation, either version 3 of the License, or
15 ;; (at your option) any later version.
17 ;; GNU Emacs is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;; GNU General Public License for more details.
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
27 ;; This collection of functions implements a calendar window. It
28 ;; generates a calendar for the current month, together with the
29 ;; previous and coming months, or for any other three-month period.
30 ;; The calendar can be scrolled forward and backward in the window to
31 ;; show months in the past or future; the cursor can move forward and
32 ;; backward by days, weeks, or months, making it possible, for
33 ;; instance, to jump to the date a specified number of days, weeks, or
34 ;; months from the date under the cursor. The user can display a list
35 ;; of holidays and other notable days for the period shown; the
36 ;; notable days can be marked on the calendar, if desired. The user
37 ;; can also specify that dates having corresponding diary entries (in
38 ;; a file that the user specifies) be marked; the diary entries for
39 ;; any date can be viewed in a separate window. The diary and the
40 ;; notable days can be viewed independently of the calendar. Dates
41 ;; can be translated from the (usual) Gregorian calendar to the day of
42 ;; the year/days remaining in year, to the ISO commercial calendar, to
43 ;; the Julian (old style) calendar, to the Hebrew calendar, to the
44 ;; Islamic calendar, to the Bahá'í calendar, to the French
45 ;; Revolutionary calendar, to the Mayan calendar, to the Chinese
46 ;; calendar, to the Coptic calendar, to the Ethiopic calendar, and to
47 ;; the astronomical (Julian) day number. Times of sunrise/sunset can
48 ;; be displayed, as can the phases of the moon. Appointment
49 ;; notification for diary entries is available. Calendar printing via
50 ;; LaTeX is available.
52 ;; The following files are part of the calendar/diary code:
54 ;; appt.el Appointment notification
55 ;; cal-bahai.el Bahá'í calendar
56 ;; cal-china.el Chinese calendar
57 ;; cal-coptic.el Coptic/Ethiopic calendars
58 ;; cal-dst.el Daylight saving time rules
59 ;; cal-french.el French revolutionary calendar
60 ;; cal-hebrew.el Hebrew calendar
61 ;; cal-html.el Calendars in HTML
62 ;; cal-islam.el Islamic calendar
63 ;; cal-iso.el ISO calendar
64 ;; cal-julian.el Julian/astronomical calendars
65 ;; cal-mayan.el Mayan calendars
66 ;; cal-menu.el Menu support
67 ;; cal-move.el Movement in the calendar
68 ;; cal-persia.el Persian calendar
69 ;; cal-tex.el Calendars in LaTeX
70 ;; cal-x.el Dedicated frame functions
71 ;; calendar.el This file
72 ;; diary-lib.el Diary functions
73 ;; holidays.el Holiday functions
74 ;; lunar.el Phases of the moon
75 ;; solar.el Sunrise/sunset, equinoxes/solstices
77 ;; Technical details of all the calendrical calculations can be found in
78 ;; ``Calendrical Calculations: The Millennium Edition'' by Edward M. Reingold
79 ;; and Nachum Dershowitz, Cambridge University Press (2001).
81 ;; An earlier version of the technical details appeared in
82 ;; ``Calendrical Calculations'' by Nachum Dershowitz and Edward M. Reingold,
83 ;; Software--Practice and Experience, Volume 20, Number 9 (September, 1990),
84 ;; pages 899-928, and in ``Calendrical Calculations, Part II: Three Historical
85 ;; Calendars'' by E. M. Reingold, N. Dershowitz, and S. M. Clamen,
86 ;; Software--Practice and Experience, Volume 23, Number 4 (April, 1993),
89 ;; Hard copies of these two papers can be obtained by sending email to
90 ;; reingold@cs.uiuc.edu with the SUBJECT "send-paper-cal" (no quotes) and
91 ;; the message BODY containing your mailing address (snail).
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
115 (load "cal-loaddefs" nil t
)
117 ;; Avoid recursive load of calendar when loading cal-menu. Yuck.
121 (defgroup calendar nil
122 "Calendar and time management support."
124 :group
'applications
)
126 (defgroup calendar-hooks nil
131 (defgroup calendar-faces nil
136 (defcustom calendar-offset
0
137 "The offset of the principal month from the center of the calendar window.
138 0 means the principal month is in the center (default), -1 means on the left,
139 +1 means on the right. Larger (or smaller) values push the principal month off
144 (defcustom calendar-setup nil
145 "The frame setup of the calendar.
146 The choices are: `one-frame' (calendar and diary together in one separate,
147 dedicated frame); `two-frames' (calendar and diary in separate, dedicated
148 frames); `calendar-only' (calendar in a separate, dedicated frame); with
149 any other value the current frame is used. Using any of the first
150 three options overrides the value of `calendar-view-diary-initially-flag'."
152 (const :tag
"calendar and diary in separate frame" one-frame
)
153 (const :tag
"calendar and diary each in own frame" two-frames
)
154 (const :tag
"calendar in separate frame" calendar-only
)
155 (const :tag
"use current frame" nil
))
158 (defcustom calendar-minimum-window-height
8
159 "Minimum height `calendar-generate-window' should use for calendar window."
164 ;; See discussion in bug#1806.
165 (defcustom calendar-split-width-threshold nil
166 "Value to use for `split-width-threshold' when creating a calendar.
167 This only affects frames wider than the default value of
168 `split-width-threshold'."
169 :type
'(choice (const nil
)
174 (defcustom calendar-week-start-day
0
175 "The day of the week on which a week in the calendar begins.
176 0 means Sunday (default), 1 means Monday, and so on.
178 If you change this variable directly (without using customize)
179 after starting `calendar', you should call `calendar-redraw' to
180 update the calendar display to reflect the change, otherwise
181 movement commands will not work correctly."
183 ;; Change the initialize so that if you reload calendar.el, it will not
184 ;; cause a redraw (which may fail, e.g. with "invalid byte-code in
185 ;; calendar.elc" because of the "byte-compile-dynamic").
186 :initialize
'custom-initialize-default
187 :set
(lambda (sym val
)
192 (define-obsolete-variable-alias 'view-diary-entries-initially
193 'calendar-view-diary-initially-flag
"23.1")
195 (defcustom calendar-view-diary-initially-flag nil
196 "Non-nil means display current date's diary entries on entry to calendar.
197 The diary is displayed in another window when the calendar is first displayed,
198 if the current date is visible. The number of days of diary entries displayed
199 is governed by the variable `diary-number-of-entries'. This variable can
200 be overridden by the value of `calendar-setup'."
204 (define-obsolete-variable-alias 'mark-diary-entries-in-calendar
205 'calendar-mark-diary-entries-flag
"23.1")
208 (defcustom calendar-mark-diary-entries-flag nil
209 "Non-nil means mark dates with diary entries, in the calendar window.
210 The marking symbol is specified by the variable `diary-entry-marker'."
214 (defcustom calendar-remove-frame-by-deleting t
215 "Determine how the calendar mode removes a frame no longer needed.
216 If nil, make an icon of the frame. If non-nil, delete the frame."
218 :version
"23.1" ; changed from nil to t
222 (defface calendar-today
223 '((t (:underline t
)))
224 "Face for indicating today's date in the calendar.
225 See the variable `calendar-today-marker'."
226 :group
'calendar-faces
)
228 (define-obsolete-face-alias 'calendar-today-face
'calendar-today
"22.1")
231 '((((min-colors 88) (class color
) (background light
))
233 (((class color
) (background light
))
235 (((min-colors 88) (class color
) (background dark
))
236 :foreground
"yellow1")
237 (((class color
) (background dark
))
238 :foreground
"yellow")
241 "Face for highlighting diary entries.
242 Used to mark diary entries in the calendar (see `diary-entry-marker'),
243 and to highlight the date header in the fancy diary."
244 :group
'calendar-faces
)
246 (define-obsolete-face-alias 'diary-face
'diary
"22.1")
249 '((((class color
) (background light
))
251 (((class color
) (background dark
))
252 :background
"chocolate4")
255 "Face for indicating in the calendar dates that have holidays.
256 See `calendar-holiday-marker'."
257 :group
'calendar-faces
)
259 (define-obsolete-face-alias 'holiday-face
'holiday
"22.1")
261 ;; These briefly checked font-lock-mode, but that is broken, since it
262 ;; is a buffer-local variable, and which buffer happens to be current
263 ;; when this file is loaded shouldn't make a difference. One could
264 ;; perhaps check global-font-lock-mode, or font-lock-global-modes; but
265 ;; this feature doesn't use font-lock, so there's no real reason it
266 ;; should respect those either. See bug#2199.
267 ;; They also used to check display-color-p, but that is a problem if
268 ;; loaded from --daemon. Since BW displays are rare now, this was
269 ;; also taken out. The way to keep it would be to have nil mean do a
270 ;; runtime check whenever this variable is used.
271 (defcustom diary-entry-marker
'diary
272 "How to mark dates that have diary entries.
273 The value can be either a single-character string (e.g. \"+\") or a face."
274 :type
'(choice (string :tag
"Single character string") face
)
278 (defcustom calendar-today-marker
'calendar-today
279 "How to mark today's date in the calendar.
280 The value can be either a single-character string (e.g. \"=\") or a face.
281 Used by `calendar-mark-today'."
282 :type
'(choice (string :tag
"Single character string") face
)
286 (defcustom calendar-holiday-marker
'holiday
287 "How to mark notable dates in the calendar.
288 The value can be either a single-character string (e.g. \"*\") or a face."
289 :type
'(choice (string :tag
"Single character string") face
)
293 (define-obsolete-variable-alias 'view-calendar-holidays-initially
294 'calendar-view-holidays-initially-flag
"23.1")
296 (defcustom calendar-view-holidays-initially-flag nil
297 "Non-nil means display holidays for current three month period on entry.
298 The holidays are displayed in another window when the calendar is first
303 (define-obsolete-variable-alias 'mark-holidays-in-calendar
304 'calendar-mark-holidays-flag
"23.1")
307 (defcustom calendar-mark-holidays-flag nil
308 "Non-nil means mark dates of holidays in the calendar window.
309 The marking symbol is specified by the variable `calendar-holiday-marker'."
313 (defcustom calendar-mode-hook nil
314 "Hook run when entering `calendar-mode'."
316 :group
'calendar-hooks
)
318 (defcustom calendar-load-hook nil
319 "List of functions to be called after the calendar is first loaded.
320 This is the place to add key bindings to `calendar-mode-map'."
322 :group
'calendar-hooks
)
324 (define-obsolete-variable-alias 'initial-calendar-window-hook
325 'calendar-initial-window-hook
"23.1")
327 (defcustom calendar-initial-window-hook nil
328 "List of functions to be called when the calendar window is created.
329 Quitting the calendar and re-entering it will cause these functions
332 :group
'calendar-hooks
)
334 (define-obsolete-variable-alias 'today-visible-calendar-hook
335 'calendar-today-visible-hook
"23.1")
337 (defcustom calendar-today-visible-hook nil
338 "List of functions called whenever the current date is visible.
339 To mark today's date, add the function `calendar-mark-today'.
340 To replace the date with asterisks, add the function `calendar-star-date'.
341 See also `calendar-today-invisible-hook'.
343 In general, be careful about changing characters in the calendar buffer,
344 since it may cause the movement commands to fail."
346 :options
'(calendar-mark-today calendar-star-date
)
347 :group
'calendar-hooks
)
349 (define-obsolete-variable-alias 'today-invisible-calendar-hook
350 'calendar-today-invisible-hook
"23.1")
352 (defcustom calendar-today-invisible-hook nil
353 "List of functions called whenever the current date is not visible.
354 See also `calendar-today-visible-hook'."
356 :group
'calendar-hooks
)
358 (defcustom calendar-move-hook nil
359 "List of functions called whenever the cursor moves in the calendar.
362 (add-hook 'calendar-move-hook (lambda () (diary-view-entries 1)))
364 redisplays the diary for whatever date the cursor is moved to."
366 :options
'(calendar-update-mode-line)
367 :group
'calendar-hooks
)
369 (defcustom calendar-date-echo-text
370 "mouse-2: general menu\nmouse-3: menu for this date"
371 "String displayed when the cursor is over a date in the calendar.
372 Can be either a fixed string, or a lisp expression that returns one.
373 When this expression is evaluated, DAY, MONTH, and YEAR are
374 integers appropriate to the relevant date. For example, to
375 display the ISO date:
377 (setq calendar-date-echo-text '(format \"ISO date: %s\"
378 (calendar-iso-date-string
379 (list month day year))))
380 Changing this variable without using customize has no effect on
381 pre-existing calendar windows."
383 :initialize
'custom-initialize-default
385 :set
(lambda (sym val
)
388 :type
'(choice (string :tag
"Fixed string")
390 (format "ISO date: %s"
391 (calendar-iso-date-string
392 (list month day year
)))))
396 (defvar calendar-month-digit-width nil
397 "Width of the region with numbers in each month in the calendar.")
399 (defvar calendar-month-width nil
400 "Full width of each month in the calendar.")
402 (defvar calendar-right-margin nil
403 "Right margin of the calendar.")
405 (defvar calendar-month-edges nil
406 "Alist of month edge columns.
407 Each element has the form (N LEFT FIRST LAST RIGHT), where
408 LEFT is the leftmost column associated with month segment N,
409 FIRST and LAST are the first and last columns with day digits in,
410 and LAST is the rightmost column.")
412 (defun calendar-month-edges (segment)
413 "Compute the month edge columns for month SEGMENT.
414 Returns a list (LEFT FIRST LAST RIGHT), where LEFT is the
415 leftmost column associated with a month, FIRST and LAST are the
416 first and last columns with day digits in, and LAST is the
418 ;; The leftmost column with a digit in it in this month segment.
419 (let* ((first (+ calendar-left-margin
420 (* segment calendar-month-width
)))
421 ;; The rightmost column with a digit in it in this month segment.
422 (last (+ first
(1- calendar-month-digit-width
)))
423 (left (if (eq segment
0)
425 (+ calendar-left-margin
426 (* segment calendar-month-width
)
427 (- (/ calendar-intermonth-spacing
2)))))
428 ;; The rightmost edge of this month segment, dividing the
429 ;; space between months in two.
430 (right (+ calendar-left-margin
431 (* (1+ segment
) calendar-month-width
)
432 (- (/ calendar-intermonth-spacing
2)))))
433 (list left first last right
)))
435 (defun calendar-recompute-layout-variables ()
436 "Recompute some layout-related calendar \"constants\"."
437 (setq calendar-month-digit-width
(+ (* 6 calendar-column-width
)
438 calendar-day-digit-width
)
439 calendar-month-width
(+ (* 7 calendar-column-width
)
440 calendar-intermonth-spacing
)
441 calendar-right-margin
(+ calendar-left-margin
442 (* 3 (* 7 calendar-column-width
))
443 (* 2 calendar-intermonth-spacing
))
444 calendar-month-edges nil
)
446 (push (cons i
(calendar-month-edges i
)) calendar-month-edges
))
447 (setq calendar-month-edges
(reverse calendar-month-edges
)))
449 ;; FIXME add font-lock-keywords.
450 (defun calendar-set-layout-variable (symbol value
&optional minmax
)
451 "Set SYMBOL's value to VALUE, an integer.
452 A positive/negative MINMAX enforces a minimum/maximum value.
453 Then redraw the calendar, if necessary."
454 (let ((oldvalue (symbol-value symbol
)))
455 (custom-set-default symbol
(if minmax
457 (min value
(- minmax
))
460 (unless (equal value oldvalue
)
461 (calendar-recompute-layout-variables)
464 (defcustom calendar-left-margin
5
465 "Empty space to the left of the first month in the calendar."
467 :initialize
'custom-initialize-default
468 :set
'calendar-set-layout-variable
472 ;; Or you can view it as columns of width 2, with 1 space, no space
473 ;; after the last column, and a 5 space gap between month.
474 ;; FIXME check things work if this is odd.
475 (defcustom calendar-intermonth-spacing
4
476 "Space between months in the calendar. Minimum value is 1."
478 :initialize
'custom-initialize-default
479 :set
(lambda (sym val
)
480 (calendar-set-layout-variable sym val
1))
484 ;; FIXME calendar-month-column-width?
485 (defcustom calendar-column-width
3
486 "Width of each day column in the calendar. Minimum value is 3."
487 :initialize
'custom-initialize-default
488 :set
(lambda (sym val
)
489 (calendar-set-layout-variable sym val
3))
493 (defcustom calendar-day-header-width
2
494 "Width of the day column headers in the calendar.
495 Must be at least one less than `calendar-column-width'."
497 :initialize
'custom-initialize-default
498 :set
(lambda (sym val
)
499 (calendar-set-layout-variable sym val
(- 1 calendar-column-width
)))
503 ;; FIXME a format specifier instead?
504 (defcustom calendar-day-digit-width
2
505 "Width of the day digits in the calendar. Minimum value is 2."
507 :initialize
'custom-initialize-default
508 :set
(lambda (sym val
)
509 (calendar-set-layout-variable sym val
2))
513 (defcustom calendar-intermonth-header nil
514 "Header text to display in the space to the left of each calendar month.
515 See `calendar-intermonth-text'."
517 :initialize
'custom-initialize-default
519 :set
(lambda (sym val
)
522 :type
'(choice (const nil
:tag
"Nothing")
523 (string :tag
"Fixed string")
525 (propertize "WK" 'font-lock-face
526 'font-lock-function-name-face
)))
529 (defcustom calendar-intermonth-text nil
530 "Text to display in the space to the left of each calendar month.
531 Can be nil, a fixed string, or a lisp expression that returns a string.
532 When the expression is evaluated, the variables DAY, MONTH and YEAR
533 are integers appropriate for the first day in each week.
534 Will be truncated to the smaller of `calendar-left-margin' and
535 `calendar-intermonth-spacing'. The last character is forced to be a space.
536 For example, to display the ISO week numbers:
538 (setq calendar-week-start-day 1
539 calendar-intermonth-text
543 (calendar-iso-from-absolute
544 (calendar-absolute-from-gregorian (list month day year)))))
545 'font-lock-face 'font-lock-function-name-face))
547 See also `calendar-intermonth-header'."
549 :initialize
'custom-initialize-default
551 :set
(lambda (sym val
)
554 :type
'(choice (const nil
:tag
"Nothing")
555 (string :tag
"Fixed string")
560 (calendar-iso-from-absolute
561 (calendar-absolute-from-gregorian
562 (list month day year
)))))
563 'font-lock-face
'font-lock-function-name-face
)))
566 (defcustom diary-file
"~/diary"
567 "Name of the file in which one's personal diary of dates is kept.
569 The file's entries are lines beginning with any of the forms
570 specified by the variable `diary-date-forms', which by default
571 uses the forms of `diary-american-date-forms':
579 with the remainder of the line being the diary entry string for
580 that date. MONTH and DAY are one or two digit numbers, YEAR is a
581 number and may be written in full or abbreviated to the final two
582 digits (if `diary-abbreviated-year-flag' is non-nil). MONTHNAME
583 and DAYNAME can be spelled in full (as specified by the variables
584 `calendar-month-name-array' and `calendar-day-name-array'), or
585 abbreviated (as specified by `calendar-month-abbrev-array' and
586 `calendar-day-abbrev-array') with or without a period. Case is
587 ignored. Any of DAY, MONTH, or MONTHNAME, YEAR can be `*' which
588 matches any day, month, or year, respectively. If the date does
589 not contain a year, it is generic and applies to any year. A
590 DAYNAME entry applies to the appropriate day of the week in every week.
592 You can customize `diary-date-forms' to your preferred format.
593 Three default styles are provided: `diary-american-date-forms',
594 `diary-european-date-forms', and `diary-iso-date-forms'.
595 You can choose between these by setting `calendar-date-style' in your
596 init file, or by using `calendar-set-date-style' when in the calendar.
598 A diary entry can be preceded by the character `diary-nonmarking-symbol'
599 \(ordinarily `&') to make that entry nonmarking--that is, it will not be
600 marked on dates in the calendar window but will appear in a diary window.
602 Multiline diary entries are made by indenting lines after the first with
603 either a TAB or one or more spaces.
605 Lines not in one the above formats are ignored. Here are some sample diary
606 entries (in the default American style):
608 12/22/1988 Twentieth wedding anniversary!!
609 &1/1. Happy New Year!
610 10/22 Ruth's birthday.
612 Tuesday--weekly meeting with grad students at 10am
613 Supowit, Shen, Bitner, and Kapoor to attend.
614 1/13/89 Friday the thirteenth!!
615 &thu 4pm squash game with Lloyd.
616 mar 16 Dad's birthday
617 April 15, 1989 Income tax due.
618 &* 15 time cards due.
620 If the first line of a diary entry consists only of the date or day name with
621 no trailing blanks or punctuation, then that line is not displayed in the
622 diary window; only the continuation lines is shown. For example, the
626 Bill Blattner visits Princeton today
627 2pm Cognitive Studies Committee meeting
628 2:30-5:30 Lizzie at Lawrenceville for `Group Initiative'
629 4:00pm Jamie Tappenden
630 7:30pm Dinner at George and Ed's for Alan Ryan
631 7:30-10:00pm dance at Stewart Country Day School
633 will appear in the diary window without the date line at the beginning. This
634 facility allows the diary window to look neater, but can cause confusion if
635 used with more than one day's entries displayed.
637 Diary entries can be based on Lisp sexps. For example, the diary entry
639 %%(diary-block 11 1 1990 11 10 1990) Vacation
641 causes the diary entry \"Vacation\" to appear from November 1 through
642 November 10, 1990. See the documentation for the function
643 `diary-list-sexp-entries' for more details.
645 Diary entries based on the Hebrew, the Islamic and/or the Bahá'í
646 calendar are also possible, but because these are somewhat slow, they
647 are ignored unless you set the `diary-nongregorian-listing-hook' and
648 the `diary-nongregorian-marking-hook' appropriately. See the
649 documentation of these hooks for details.
651 Diary files can contain directives to include the contents of other files; for
652 details, see the documentation for the variable `diary-list-entries-hook'."
656 ;; FIXME do these have to be single characters?
657 (defcustom diary-nonmarking-symbol
"&"
658 "Symbol indicating that a diary entry is not to be marked in the calendar."
662 (define-obsolete-variable-alias 'hebrew-diary-entry-symbol
663 'diary-hebrew-entry-symbol
"23.1")
665 (defcustom diary-hebrew-entry-symbol
"H"
666 "Symbol indicating a diary entry according to the Hebrew calendar."
670 (define-obsolete-variable-alias 'islamic-diary-entry-symbol
671 'diary-islamic-entry-symbol
"23.1")
673 (defcustom diary-islamic-entry-symbol
"I"
674 "Symbol indicating a diary entry according to the Islamic calendar."
678 (define-obsolete-variable-alias 'bahai-diary-entry-symbol
679 'diary-bahai-entry-symbol
"23.1")
681 (defcustom diary-bahai-entry-symbol
"B"
682 "Symbol indicating a diary entry according to the Bahá'í calendar."
686 (defcustom european-calendar-style nil
687 "Non-nil means use the European style of dates in the diary and display.
688 In this case, a date like 1/2/1990 would be interpreted as
689 February 1, 1990. See `diary-european-date-forms' for the
690 default European diary date styles.
692 Setting this variable directly does not take effect (if the
693 calendar package is already loaded). Rather, use either
694 \\[customize] or the function `calendar-set-date-style'."
696 ;; Without :initialize (require 'calendar) throws an error because
697 ;; calendar-set-date-style is undefined at this point.
698 :initialize
'custom-initialize-default
699 :set
(lambda (symbol value
)
701 (calendar-set-date-style 'european
)
702 (calendar-set-date-style 'american
)))
705 (make-obsolete-variable 'european-calendar-style
'calendar-date-style
"23.1")
707 ;; If this is autoloaded, c-d-s gets set before any customization of e-c-s.
708 (defcustom calendar-date-style
(if european-calendar-style
'european
710 "Your preferred style for writing dates.
712 `american' - month/day/year
713 `european' - day/month/year
714 `iso' - year/month/day
715 This affects how dates written in your diary are interpreted.
716 It also affects date display, as well as those calendar and diary
717 functions that take a date as an argument, e.g. `diary-date', by
718 changing the order in which the arguments are interpreted.
720 Setting this variable directly does not take effect (if the
721 calendar package is already loaded). Rather, use either
722 \\[customize] or the function `calendar-set-date-style'."
724 :type
'(choice (const american
:tag
"Month/Day/Year")
725 (const european
:tag
"Day/Month/Year")
726 (const iso
:tag
"Year/Month/Day"))
727 :initialize
'custom-initialize-default
728 :set
(lambda (symbol value
)
729 (calendar-set-date-style value
))
732 ;; Next three are provided to aid in setting diary-date-forms.
733 ;; FIXME move to diary-lib?
734 (defcustom diary-iso-date-forms
735 '((month "[-/]" day
"[^-/0-9]")
736 (year "[-/]" month
"[-/]" day
"[^0-9]")
737 ;; Cannot allow [-/] as separators here, since it would also match
738 ;; the first element (bug#7377).
739 (monthname " *" day
"[^-0-9]")
740 (year " *" monthname
" *" day
"[^0-9]")
742 "List of pseudo-patterns describing the ISO style of dates.
743 The defaults are: MONTH[-/]DAY; YEAR[-/]MONTH[-/]DAY; MONTHNAME DAY;
744 YEAR MONTHNAME DAY; DAYNAME. Normally you should not customize this,
745 but `diary-date-forms' (which see)."
746 :version
"23.3" ; bug#7377
747 :type
'(repeat (choice (cons :tag
"Backup"
748 :value
(backup . nil
)
750 (repeat (list :inline t
:format
"%v"
751 (symbol :tag
"Keyword")
752 (choice symbol regexp
))))
753 (repeat (list :inline t
:format
"%v"
754 (symbol :tag
"Keyword")
755 (choice symbol regexp
)))))
758 (define-obsolete-variable-alias 'american-date-diary-pattern
759 'diary-american-date-forms
"23.1")
761 (defcustom diary-american-date-forms
762 '((month "/" day
"[^/0-9]")
763 (month "/" day
"/" year
"[^0-9]")
764 (monthname " *" day
"[^,0-9]")
765 (monthname " *" day
", *" year
"[^0-9]")
767 "List of pseudo-patterns describing the American style of dates.
768 The defaults are: MONTH/DAY; MONTH/DAY/YEAR; MONTHNAME DAY;
769 MONTHNAME DAY, YEAR; DAYNAME. Normally you should not customize this,
770 but `diary-date-forms' (which see)."
771 :type
'(repeat (choice (cons :tag
"Backup"
772 :value
(backup . nil
)
774 (repeat (list :inline t
:format
"%v"
775 (symbol :tag
"Keyword")
776 (choice symbol regexp
))))
777 (repeat (list :inline t
:format
"%v"
778 (symbol :tag
"Keyword")
779 (choice symbol regexp
)))))
782 (define-obsolete-variable-alias 'european-date-diary-pattern
783 'diary-european-date-forms
"23.1")
785 (defcustom diary-european-date-forms
786 '((day "/" month
"[^/0-9]")
787 (day "/" month
"/" year
"[^0-9]")
788 (backup day
" *" monthname
"\\W+\\<\\([^*0-9]\\|\\([0-9]+[:aApP]\\)\\)")
789 (day " *" monthname
" *" year
"[^0-9]")
791 "List of pseudo-patterns describing the European style of dates.
792 The defaults are: DAY/MONTH; DAY/MONTH/YEAR; DAY MONTHNAME;
793 DAY MONTHNAME YEAR; DAYNAME. Normally you should not customize this, but
794 `diary-date-forms' (which see)."
795 :type
'(repeat (choice (cons :tag
"Backup"
796 :value
(backup . nil
)
798 (repeat (list :inline t
:format
"%v"
799 (symbol :tag
"Keyword")
800 (choice symbol regexp
))))
801 (repeat (list :inline t
:format
"%v"
802 (symbol :tag
"Keyword")
803 (choice symbol regexp
)))))
806 (defvar diary-font-lock-keywords
)
808 (defcustom diary-date-forms
(cond ((eq calendar-date-style
'iso
)
809 diary-iso-date-forms
)
810 ((eq calendar-date-style
'european
)
811 diary-european-date-forms
)
812 (t diary-american-date-forms
))
813 "List of pseudo-patterns describing the forms of date used in the diary.
814 The patterns on the list must be MUTUALLY EXCLUSIVE and should not match
815 any portion of the diary entry itself, just the date component.
817 A pseudo-pattern is a list of regular expressions and the keywords `month',
818 `day', `year', `monthname', and `dayname'. The keyword `monthname' will
819 match the name of the month (see `calendar-month-name-array'), capitalized
820 or not, or its user-specified abbreviation (see `calendar-month-abbrev-array'),
821 followed by a period or not; it will also match `*'. Similarly, `dayname'
822 will match the name of the day (see `calendar-day-name-array'), capitalized or
823 not, or its user-specified abbreviation (see `calendar-day-abbrev-array'),
824 followed by a period or not. The keywords `month', `day', and `year' will
825 match those numerical values, preceded by arbitrarily many zeros; they will
828 The matching of the diary entries with the date forms is done with the
829 standard syntax table from Fundamental mode, but with the `*' changed so
830 that it is a word constituent.
832 If, to be mutually exclusive, a pseudo-pattern must match a portion of the
833 diary entry itself, the first element of the pattern MUST be `backup'. This
834 directive causes the date recognizer to back up to the beginning of the
835 current word of the diary entry, so in no case can the pattern match more than
836 a portion of the first word of the diary entry.
838 For examples of three common styles, see `diary-american-date-forms',
839 `diary-european-date-forms', and `diary-iso-date-forms'."
840 :type
'(repeat (choice (cons :tag
"Backup"
841 :value
(backup . nil
)
843 (repeat (list :inline t
:format
"%v"
844 (symbol :tag
"Keyword")
845 (choice symbol regexp
))))
846 (repeat (list :inline t
:format
"%v"
847 (symbol :tag
"Keyword")
848 (choice symbol regexp
)))))
849 :set-after
'(calendar-date-style diary-iso-date-forms
850 diary-european-date-forms
851 diary-american-date-forms
)
852 :initialize
'custom-initialize-default
853 :set
(lambda (symbol value
)
854 (unless (equal value
(eval symbol
))
855 (custom-set-default symbol value
)
856 (setq diary-font-lock-keywords
(diary-font-lock-keywords))
857 ;; Need to redraw not just to get new font-locking, but also
858 ;; to pick up any newly recognized entries.
863 ;; Next three are provided to aid in setting calendar-date-display-form.
864 (defcustom calendar-iso-date-display-form
'((format "%s-%.2d-%.2d" year
865 (string-to-number month
)
866 (string-to-number day
)))
867 "Pseudo-pattern governing the way a date appears in the ISO style.
868 Normally you should not customize this, but `calendar-date-display-form'
874 (define-obsolete-variable-alias 'european-calendar-display-form
875 'calendar-european-date-display-form
"23.1")
877 (defcustom calendar-european-date-display-form
878 '((if dayname
(concat dayname
", ")) day
" " monthname
" " year
)
879 "Pseudo-pattern governing the way a date appears in the European style.
880 Normally you should not customize this, but `calendar-date-display-form'
885 (define-obsolete-variable-alias 'american-calendar-display-form
886 'calendar-american-date-display-form
"23.1")
888 (defcustom calendar-american-date-display-form
889 '((if dayname
(concat dayname
", ")) monthname
" " day
", " year
)
890 "Pseudo-pattern governing the way a date appears in the American style.
891 Normally you should not customize this, but `calendar-date-display-form'
896 (defcustom calendar-date-display-form
897 (cond ((eq calendar-date-style
'iso
)
898 calendar-iso-date-display-form
)
899 ((eq calendar-date-style
'european
)
900 calendar-european-date-display-form
)
901 (t calendar-american-date-display-form
))
902 "Pseudo-pattern governing the way a calendar date appears.
903 Used by the function `calendar-date-string' (which see), a pseudo-pattern
904 is a list of expressions that can involve the keywords `month', `day',
905 and `year' (all numbers in string form), and `monthname' and `dayname'
906 \(both alphabetic strings). For example, a typical American form would be
908 '(month \"/\" day \"/\" (substring year -2))
912 '((format \"%9s, %9s %2s, %4s\" dayname monthname day year))
914 would give the usual American style in fixed-length fields. The variables
915 `calendar-iso-date-display-form', `calendar-european-date-display-form', and
916 `calendar-american-date-display-form' provide some defaults for three common
919 :set-after
'(calendar-date-style calendar-iso-date-display-form
920 calendar-european-date-display-form
921 calendar-american-date-display-form
)
924 (defcustom calendar-american-month-header
925 '(propertize (format "%s %d" (calendar-month-name month
) year
)
926 'font-lock-face
'font-lock-function-name-face
)
927 "Default format for calendar month headings with the American date style.
928 Normally you should not customize this, but `calender-month-header'."
934 (defcustom calendar-european-month-header
935 '(propertize (format "%s %d" (calendar-month-name month
) year
)
936 'font-lock-face
'font-lock-function-name-face
)
937 "Default format for calendar month headings with the European date style.
938 Normally you should not customize this, but `calender-month-header'."
944 (defcustom calendar-iso-month-header
945 '(propertize (format "%d %s" year
(calendar-month-name month
))
946 'font-lock-face
'font-lock-function-name-face
)
947 "Default format for calendar month headings with the ISO date style.
948 Normally you should not customize this, but `calender-month-header'."
954 (defcustom calendar-month-header
955 (cond ((eq calendar-date-style
'iso
)
956 calendar-iso-month-header
)
957 ((eq calendar-date-style
'european
)
958 calendar-european-month-header
)
959 (t calendar-american-month-header
))
960 "Expression to evaluate to return the calendar month headings.
961 When this expression is evaluated, the variables MONTH and YEAR are
962 integers appropriate to the relevant month. The result is padded
963 to the width of `calendar-month-digit-width'.
965 For examples of three common styles, see `calendar-american-month-header',
966 `calendar-european-month-header', and `calendar-iso-month-header'.
968 Changing this variable without using customize has no effect on
969 pre-existing calendar windows."
971 :initialize
'custom-initialize-default
973 :set
(lambda (sym val
)
976 :set-after
'(calendar-date-style calendar-american-month-header
977 calendar-european-month-header
978 calendar-iso-month-header
)
982 (defun calendar-set-date-style (style)
983 "Set the style of calendar and diary dates to STYLE (a symbol).
984 The valid styles are described in the documentation of `calendar-date-style'."
985 (interactive (list (intern
986 (completing-read "Date style: "
987 '("american" "european" "iso") nil t
988 nil nil
"american"))))
989 (or (memq style
'(american european iso
))
990 (setq style
'american
))
991 (setq calendar-date-style style
992 calendar-date-display-form
993 (symbol-value (intern-soft
994 (format "calendar-%s-date-display-form" style
)))
995 calendar-month-header
996 (symbol-value (intern-soft (format "calendar-%s-month-header" style
)))
998 (symbol-value (intern-soft (format "diary-%s-date-forms" style
))))
1000 (calendar-update-mode-line))
1002 (defun european-calendar ()
1003 "Set the interpretation and display of dates to the European style."
1004 (declare (obsolete calendar-set-date-style
"23.1"))
1006 (calendar-set-date-style 'european
))
1008 (defun american-calendar ()
1009 "Set the interpretation and display of dates to the American style."
1010 (declare (obsolete calendar-set-date-style
"23.1"))
1012 (calendar-set-date-style 'american
))
1014 (define-obsolete-variable-alias 'holidays-in-diary-buffer
1015 'diary-show-holidays-flag
"23.1")
1017 (defcustom diary-show-holidays-flag t
1018 "Non-nil means include holidays in the diary display.
1019 The holidays appear in the mode line of the diary buffer, or in the
1020 fancy diary buffer next to the date. This slows down the diary functions
1021 somewhat; setting it to nil makes the diary display faster."
1025 (defcustom calendar-debug-sexp nil
1026 "Turn debugging on when evaluating a sexp in the diary or holiday list."
1030 (define-obsolete-variable-alias 'all-hebrew-calendar-holidays
1031 'calendar-hebrew-all-holidays-flag
"23.1")
1033 (defcustom calendar-hebrew-all-holidays-flag nil
1034 "If nil, show only major holidays from the Hebrew calendar.
1035 This means only those Jewish holidays that appear on secular calendars.
1036 Otherwise, show all the holidays that would appear in a complete Hebrew
1041 (define-obsolete-variable-alias 'all-christian-calendar-holidays
1042 'calendar-christian-all-holidays-flag
"23.1")
1044 (defcustom calendar-christian-all-holidays-flag nil
1045 "If nil, show only major holidays from the Christian calendar.
1046 This means only those Christian holidays that appear on secular calendars.
1047 Otherwise, show all the holidays that would appear in a complete Christian
1052 (define-obsolete-variable-alias 'all-islamic-calendar-holidays
1053 'calendar-islamic-all-holidays-flag
"23.1")
1055 (defcustom calendar-islamic-all-holidays-flag nil
1056 "If nil, show only major holidays from the Islamic calendar.
1057 This means only those Islamic holidays that appear on secular calendars.
1058 Otherwise, show all the holidays that would appear in a complete Islamic
1063 (define-obsolete-variable-alias 'all-bahai-calendar-holidays
1064 'calendar-bahai-all-holidays-flag
"23.1")
1066 (defcustom calendar-bahai-all-holidays-flag nil
1067 "If nil, show only major holidays from the Bahá'í calendar.
1068 These are the days on which work and school must be suspended.
1069 Otherwise, show all the holidays that would appear in a complete Bahá'í
1074 (defcustom calendar-chinese-all-holidays-flag nil
1075 "If nil, show only the major holidays from the Chinese calendar."
1080 ;;; End of user options.
1082 (calendar-recompute-layout-variables)
1084 (defconst calendar-first-date-row
3
1085 "First row in the calendar with actual dates.")
1087 (defconst calendar-buffer
"*Calendar*"
1088 "Name of the buffer used for the calendar.")
1090 (defconst holiday-buffer
"*Holidays*"
1091 "Name of the buffer used for the displaying the holidays.")
1093 (defconst diary-fancy-buffer
"*Fancy Diary Entries*"
1094 "Name of the buffer used for the optional fancy display of the diary.")
1096 (define-obsolete-variable-alias 'fancy-diary-buffer
'diary-fancy-buffer
"23.1")
1098 (defconst calendar-other-calendars-buffer
"*Other Calendars*"
1099 "Name of the buffer used for the display of date on other calendars.")
1101 (defconst lunar-phases-buffer
"*Phases of Moon*"
1102 "Name of the buffer used for the lunar phases.")
1104 (defconst solar-sunrises-buffer
"*Sunrise/Sunset Times*"
1105 "Name of buffer used for sunrise/sunset times.")
1107 (defconst calendar-hebrew-yahrzeit-buffer
"*Yahrzeits*"
1108 "Name of the buffer used by `list-yahrzeit-dates'.")
1110 (defmacro calendar-increment-month
(mon yr n
&optional nmonths
)
1111 "Increment the variables MON and YR by N months.
1112 Forward if N is positive or backward if N is negative.
1113 A negative YR is interpreted as BC; -1 being 1 BC, and so on.
1114 Optional NMONTHS is the number of months per year (default 12)."
1115 ;; Can view this as a form of base-nmonths arithmetic, in which "a
1116 ;; year" = "ten", and we never bother to use hundreds.
1117 `(let ((nmonths (or ,nmonths
12))
1119 (if (< ,yr
0) (setq ,yr
(1+ ,yr
))) ; -1 BC -> 0 AD, etc
1120 (setq macro-y
(+ (* ,yr nmonths
) ,mon -
1 ,n
)
1121 ,mon
(1+ (mod macro-y nmonths
))
1122 ,yr
(/ macro-y nmonths
))
1124 ;;; (setq macro-y (+ (* ,yr nmonths) ,mon -1 ,n)
1125 ;;; ,yr (/ macro-y nmonths)
1126 ;;; ,mon (- macro-y (* ,yr nmonths)))
1127 (and (< macro-y
0) (> ,mon
1) (setq ,yr
(1- ,yr
)))
1128 (if (< ,yr
1) (setq ,yr
(1- ,yr
))))) ; 0 AD -> -1 BC, etc
1130 (define-obsolete-function-alias 'increment-calendar-month
1131 'calendar-increment-month
"23.1")
1133 (defvar displayed-month
)
1134 (defvar displayed-year
)
1136 (defun calendar-increment-month-cons (n &optional mon yr
)
1137 "Return the Nth month after MON/YR.
1138 The return value is a pair (MONTH . YEAR).
1139 MON defaults to `displayed-month'. YR defaults to `displayed-year'."
1140 (unless mon
(setq mon displayed-month
))
1141 (unless yr
(setq yr displayed-year
))
1142 (calendar-increment-month mon yr n
)
1145 (defmacro calendar-for-loop
(var from init to final do
&rest body
)
1146 "Execute a for loop.
1147 Evaluate BODY with VAR bound to successive integers from INIT to FINAL,
1148 inclusive. The standard macro `dotimes' is preferable in most cases."
1149 (declare (obsolete "use `dotimes' or `while' instead." "23.1")
1150 (debug (symbolp "from" form
"to" form
"do" body
))
1152 `(let ((,var
(1- ,init
)))
1153 (while (>= ,final
(setq ,var
(1+ ,var
)))
1156 (defmacro calendar-sum
(index initial condition expression
)
1157 "For INDEX = INITIAL, +1, ... (as long as CONDITION holds), sum EXPRESSION."
1158 (declare (debug (symbolp form form form
)))
1159 `(let ((,index
,initial
)
1162 (setq sum
(+ sum
,expression
)
1163 ,index
(1+ ,index
)))
1166 (defmacro calendar-in-read-only-buffer
(buffer &rest body
)
1167 "Switch to BUFFER and execute the forms in BODY.
1168 First creates or erases BUFFER as needed. Leaves BUFFER read-only,
1169 with disabled undo. Leaves point at point-min, displays BUFFER."
1170 (declare (indent 1) (debug t
))
1172 (set-buffer (get-buffer-create ,buffer
))
1173 (or (derived-mode-p 'special-mode
) (special-mode))
1174 (setq buffer-read-only nil
1178 (goto-char (point-min))
1179 (set-buffer-modified-p nil
)
1180 (setq buffer-read-only t
)
1181 (display-buffer ,buffer
)))
1183 ;; The following are in-line for speed; they can be called thousands of times
1184 ;; when looking up holidays or processing the diary. Here, for example, are
1185 ;; the numbers of calls to calendar/diary/holiday functions in preparing the
1186 ;; fancy diary display, for a moderately complex diary file, with functions
1187 ;; used instead of macros. There were a total of 10000 such calls:
1189 ;; 1934 calendar-extract-month
1190 ;; 1852 calendar-extract-year
1191 ;; 1819 calendar-extract-day
1192 ;; 845 calendar-leap-year-p
1193 ;; 837 calendar-day-number
1194 ;; 775 calendar-absolute-from-gregorian
1195 ;; 346 calendar-last-day-of-month
1196 ;; 286 calendar-hebrew-last-day-of-month
1197 ;; 188 calendar-hebrew-leap-year-p
1198 ;; 180 calendar-hebrew-elapsed-days
1199 ;; 163 calendar-hebrew-last-month-of-year
1200 ;; 66 calendar-date-compare
1201 ;; 65 calendar-hebrew-days-in-year
1202 ;; 60 calendar-julian-to-absolute
1203 ;; 50 calendar-hebrew-to-absolute
1204 ;; 43 calendar-date-equal
1205 ;; 38 calendar-gregorian-from-absolute
1208 ;; The use of these seven macros eliminates the overhead of 92% of the function
1209 ;; calls; it's faster this way.
1211 (defsubst calendar-extract-month
(date)
1212 "Extract the month part of DATE which has the form (month day year)."
1215 (define-obsolete-function-alias 'extract-calendar-month
1216 'calendar-extract-month
"23.1")
1218 ;; Note gives wrong answer for result of (calendar-read-date 'noday),
1219 ;; but that is only used by `calendar-other-month'.
1220 (defsubst calendar-extract-day
(date)
1221 "Extract the day part of DATE which has the form (month day year)."
1224 (define-obsolete-function-alias 'extract-calendar-day
1225 'calendar-extract-day
"23.1")
1227 (defsubst calendar-extract-year
(date)
1228 "Extract the year part of DATE which has the form (month day year)."
1231 (define-obsolete-function-alias 'extract-calendar-year
1232 'calendar-extract-year
"23.1")
1234 (defsubst calendar-leap-year-p
(year)
1235 "Return t if YEAR is a Gregorian leap year.
1236 A negative year is interpreted as BC; -1 being 1 BC, and so on."
1237 ;; 1 BC = 0 AD, 2 BC acts like 1 AD, etc.
1238 (if (< year
0) (setq year
(1- (abs year
))))
1239 (and (zerop (% year
4))
1240 (or (not (zerop (% year
100)))
1241 (zerop (% year
400)))))
1243 ;; The foregoing is a bit faster, but not as clear as the following:
1245 ;;(defsubst calendar-leap-year-p (year)
1246 ;; "Return t if YEAR is a Gregorian leap year."
1248 ;; (and (zerop (% year 4))
1249 ;; (not (zerop (% year 100))))
1250 ;; (zerop (% year 400)))
1252 (defsubst calendar-last-day-of-month
(month year
)
1253 "The last day in MONTH during YEAR."
1254 (if (and (= month
2) (calendar-leap-year-p year
))
1256 (aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month
))))
1258 ;; An explanation of the calculation can be found in PascAlgorithms by
1259 ;; Edward and Ruth Reingold, Scott-Foresman/Little, Brown, 1988.
1261 (defsubst calendar-day-number
(date)
1262 "Return the day number within the year of the date DATE.
1263 For example, (calendar-day-number '(1 1 1987)) returns the value 1,
1264 while (calendar-day-number '(12 31 1980)) returns 366."
1265 (let* ((month (calendar-extract-month date
))
1266 (day (calendar-extract-day date
))
1267 (year (calendar-extract-year date
))
1268 (day-of-year (+ day
(* 31 (1- month
)))))
1270 (setq day-of-year
(- day-of-year
(/ (+ 23 (* 4 month
)) 10)))
1271 (if (calendar-leap-year-p year
)
1272 (setq day-of-year
(1+ day-of-year
))))
1275 (defsubst calendar-absolute-from-gregorian
(date)
1276 "The number of days elapsed between the Gregorian date 12/31/1 BC and DATE.
1277 The Gregorian date Sunday, December 31, 1 BC is imaginary.
1278 DATE is a list of the form (month day year). A negative year is
1279 interpreted as BC; -1 being 1 BC, and so on. Dates before 12/31/1 BC
1280 return negative results."
1281 (let ((year (calendar-extract-year date
))
1284 (error "There was no year zero"))
1286 (setq offset-years
(1- year
))
1287 (+ (calendar-day-number date
) ; days this year
1288 (* 365 offset-years
) ; + days in prior years
1289 (/ offset-years
4) ; + Julian leap years
1290 (- (/ offset-years
100)) ; - century years
1291 (/ offset-years
400))) ; + Gregorian leap years
1293 ;; Years between date and 1 BC, excluding 1 BC (1 for 2 BC, etc).
1294 (setq offset-years
(abs (1+ year
)))
1295 (- (calendar-day-number date
)
1296 (* 365 offset-years
)
1298 (- (/ offset-years
100))
1299 (/ offset-years
400)
1300 (calendar-day-number '(12 31 -
1))))))) ; days in year 1 BC
1303 (defun calendar (&optional arg
)
1304 "Display a three-month Gregorian calendar.
1305 The three months appear side by side, with the current month in
1306 the middle surrounded by the previous and next months. The
1307 cursor is put on today's date. If optional prefix argument ARG
1308 is non-nil, prompts for the central month and year.
1310 Once in the calendar window, future or past months can be moved
1311 into view. Arbitrary months can be displayed, or the calendar
1312 can be scrolled forward or backward. The cursor can be moved
1313 forward or backward by one day, one week, one month, or one year.
1314 All of these commands take prefix arguments which, when negative,
1315 cause movement in the opposite direction. For convenience, the
1316 digit keys and the minus sign are automatically prefixes. Use
1317 \\[describe-mode] for details of the key bindings in the calendar
1320 Displays the calendar in a separate window, or optionally in a
1321 separate frame, depending on the value of `calendar-setup'.
1323 If `calendar-view-diary-initially-flag' is non-nil, also displays the
1324 diary entries for the current date (or however many days
1325 `diary-number-of-entries' specifies). This variable can be
1326 overridden by `calendar-setup'. As well as being displayed,
1327 diary entries can also be marked on the calendar (see
1328 `calendar-mark-diary-entries-flag').
1330 Runs the following hooks:
1332 `calendar-load-hook' - after loading calendar.el
1333 `calendar-today-visible-hook', `calendar-today-invisible-hook' - after
1334 generating a calendar, if today's date is visible or not, respectively
1335 `calendar-initial-window-hook' - after first creating a calendar
1337 This function is suitable for execution in an init file."
1339 ;; Avoid loading cal-x unless it will be used.
1340 (if (and (memq calendar-setup
'(one-frame two-frames calendar-only
))
1341 (display-multi-frame-p))
1342 (calendar-frame-setup calendar-setup arg
)
1343 (calendar-basic-setup arg
)))
1345 (defun calendar-basic-setup (&optional arg nodisplay
)
1346 "Create a three-month calendar.
1347 If optional prefix argument ARG is non-nil, prompts for the month
1348 and year, else uses the current date. If NODISPLAY is non-nil, don't
1349 display the generated calendar."
1351 (let ((buff (current-buffer)))
1352 (set-buffer (get-buffer-create calendar-buffer
))
1354 (let* ((pop-up-windows t
)
1355 ;; Not really needed now, but means we use exactly the same
1356 ;; behavior as before in the non-wide case (see below).
1357 (split-height-threshold 1000)
1358 (split-width-threshold calendar-split-width-threshold
)
1359 (date (if arg
(calendar-read-date t
)
1360 (calendar-current-date)))
1361 (month (calendar-extract-month date
))
1362 (year (calendar-extract-year date
)))
1363 (calendar-increment-month month year
(- calendar-offset
))
1364 ;; Display the buffer before calling calendar-generate-window so that it
1365 ;; can get a chance to adjust the window sizes to the frame size.
1367 ;; We want a window configuration that looks something like
1371 ;; where C is the calendar, and the LHS is the traditional,
1372 ;; non-wide frame, and the RHS is the wide frame case.
1373 ;; We should end up in the same state regardless of whether the
1374 ;; windows were initially split or not.
1375 ;; Previously, we only thought about the non-wide case.
1376 ;; We could just set split-height-threshold to 1000, relying on
1377 ;; the fact that the window splitting treated a single window as
1378 ;; a special case and would always split it (vertically). The
1379 ;; same thing does not work in the wide-frame case, so now we do
1380 ;; the splitting by hand.
1381 ;; See discussion in bug#1806.
1382 ;; Actually, this still does not do quite the right thing in the
1383 ;; wide frame case if started from a configuration like the LHS.
1384 ;; Eg if you start with a non-wide frame, call calendar, then
1385 ;; make the frame wider. This one is problematic because you
1386 ;; might need to split a totally unrelated window. Oh well, it
1387 ;; seems unlikely, and perhaps respecting the original layout is
1388 ;; the right thing in that case.
1390 ;; Is this a wide frame? If so, split it horizontally.
1391 (if (window-splittable-p t
) (split-window-right))
1392 (pop-to-buffer calendar-buffer
)
1393 ;; Has the window already been split vertically?
1394 (when (and (not (window-dedicated-p))
1395 (window-full-height-p))
1396 (let ((win (split-window-below)))
1397 ;; In the upper window, show whatever was visible before.
1398 ;; This looks better than using other-buffer.
1399 (switch-to-buffer buff
)
1400 ;; Switch to the lower window with the calendar buffer.
1401 (select-window win
))))
1402 (calendar-generate-window month year
)
1403 (if (and calendar-view-diary-initially-flag
1404 (calendar-date-is-visible-p date
))
1405 (diary-view-entries))))
1406 (if calendar-view-holidays-initially-flag
1407 (let* ((diary-buffer (get-file-buffer diary-file
))
1408 (diary-window (if diary-buffer
(get-buffer-window diary-buffer
)))
1409 (split-height-threshold (if diary-window
2 1000)))
1410 ;; FIXME display buffer?
1411 (calendar-list-holidays)))
1412 (run-hooks 'calendar-initial-window-hook
))
1414 (defun calendar-generate-window (&optional mon yr
)
1415 "Generate the calendar window for the current date.
1416 Optional integers MON and YR are used instead of today's date."
1417 (let* ((inhibit-read-only t
)
1418 (today (calendar-current-date))
1419 (month (calendar-extract-month today
))
1420 (day (calendar-extract-day today
))
1421 (year (calendar-extract-year today
))
1422 (today-visible (or (not mon
)
1423 (<= (abs (calendar-interval mon yr month year
)) 1)))
1424 (in-calendar-window (eq (window-buffer (selected-window))
1425 (get-buffer calendar-buffer
))))
1426 (calendar-generate (or mon month
) (or yr year
))
1427 (calendar-update-mode-line)
1428 (calendar-cursor-to-visible-date
1429 (if today-visible today
(list displayed-month
1 displayed-year
)))
1430 (set-buffer-modified-p nil
)
1431 ;; Don't do any window-related stuff if we weren't called from a
1432 ;; window displaying the calendar.
1433 (when in-calendar-window
1434 (if (window-combined-p)
1435 ;; Adjust the window to exactly fit the displayed calendar.
1436 (fit-window-to-buffer nil nil calendar-minimum-window-height
)
1437 ;; For a full height window or a window that is horizontally
1438 ;; combined don't fit height to that of its buffer.
1439 (set-window-vscroll nil
0))
1441 (and (bound-and-true-p font-lock-mode
)
1442 (font-lock-fontify-buffer))
1443 (and calendar-mark-holidays-flag
1444 ;;; (calendar-date-is-valid-p today) ; useful for BC dates
1445 (calendar-mark-holidays)
1446 (and in-calendar-window
(sit-for 0)))
1448 (if calendar-mark-diary-entries-flag
(diary-mark-entries))
1450 (run-hooks 'calendar-today-visible-hook
)
1451 (run-hooks 'calendar-today-invisible-hook
)))))
1453 (defun calendar-generate (month year
)
1454 "Generate a three-month Gregorian calendar centered around MONTH, YEAR."
1455 ;; A negative YEAR is interpreted as BC; -1 being 1 BC, and so on.
1456 ;; Note that while calendars for years BC could be displayed as it
1457 ;; stands, almost all other calendar functions (eg holidays) would
1458 ;; at best have unpredictable results for such dates.
1459 (if (< (+ month
(* 12 (1- year
))) 2)
1460 (error "Months before January, 1 AD cannot be displayed"))
1461 (setq displayed-month month
1462 displayed-year year
)
1464 (calendar-increment-month month year -
1)
1466 (calendar-generate-month month year
1467 (+ calendar-left-margin
1468 (* calendar-month-width i
)))
1469 (calendar-increment-month month year
1)))
1471 (defun calendar-move-to-column (indent)
1472 "Like `move-to-column', but indents if the line is too short."
1473 (if (< (move-to-column indent
) indent
)
1474 (indent-to indent
)))
1476 (defun calendar-ensure-newline ()
1477 "Move to the next line, adding a newline if necessary."
1478 (or (zerop (forward-line 1))
1481 (defun calendar-insert-at-column (indent string truncate
)
1482 "Move to column INDENT, adding spaces as needed.
1483 Inserts STRING so that it ends at INDENT. STRING is either a
1484 literal string, or a sexp to evaluate to return such. Truncates
1485 STRING to length TRUNCATE, and ensures a trailing space."
1486 (if (not (ignore-errors (stringp (setq string
(eval string
)))))
1487 (calendar-move-to-column indent
)
1488 (if (> (string-width string
) truncate
)
1489 (setq string
(truncate-string-to-width string truncate
)))
1490 (or (string-match " $" string
)
1491 (setq string
(concat (if (= (string-width string
) truncate
)
1492 (substring string
0 -
1)
1494 ;; Avoid inserting text properties unless
1495 ;; we have to (ie, non-unit-width chars).
1496 ;; This is by no means essential.
1497 (if (= (string-width string
) (length string
))
1499 ;; Cribbed from buff-menu.el.
1501 " " 'display
`(space :align-to
,indent
))))))
1502 (calendar-move-to-column (- indent
(string-width string
)))
1505 (defun calendar-generate-month (month year indent
)
1506 "Produce a calendar for MONTH, YEAR on the Gregorian calendar.
1507 The calendar is inserted at the top of the buffer in which point is currently
1508 located, but indented INDENT spaces. The indentation is done from the first
1509 character on the line and does not disturb the first INDENT characters on the
1511 (let ((blank-days ; at start of month
1513 (- (calendar-day-of-week (list month
1 year
))
1514 calendar-week-start-day
)
1516 (last (calendar-last-day-of-month month year
))
1517 (trunc (min calendar-intermonth-spacing
1518 (1- calendar-left-margin
)))
1521 (goto-char (point-min))
1522 (calendar-move-to-column indent
)
1524 (calendar-string-spread (list calendar-month-header
)
1525 ?\s calendar-month-digit-width
))
1526 (calendar-ensure-newline)
1527 (calendar-insert-at-column indent calendar-intermonth-header trunc
)
1528 ;; Use the first two characters of each day to head the columns.
1533 (calendar-day-name (mod (+ calendar-week-start-day i
) 7) nil t
))
1534 (if enable-multibyte-characters
1535 (truncate-string-to-width string calendar-day-header-width
)
1536 (substring string
0 calendar-day-header-width
)))
1537 (make-string (- calendar-column-width calendar-day-header-width
) ?\s
)))
1538 (calendar-ensure-newline)
1539 (calendar-insert-at-column indent calendar-intermonth-text trunc
)
1540 ;; Add blank days before the first of the month.
1541 (insert (make-string (* blank-days calendar-column-width
) ?\s
))
1542 ;; Put in the days of the month.
1545 ;; TODO should numbers be left-justified, centered...?
1546 (insert (format (format "%%%dd%%s" calendar-day-digit-width
) day
1548 (- calendar-column-width calendar-day-digit-width
) ?\s
)))
1549 ;; 'date property prevents intermonth text confusing re-searches.
1550 ;; (Tried intangible, it did not really work.)
1551 (set-text-properties
1552 (- (point) (1+ calendar-day-digit-width
)) (1- (point))
1553 `(mouse-face highlight help-echo
,(eval calendar-date-echo-text
)
1555 (when (and (zerop (mod (+ day blank-days
) 7))
1557 (calendar-ensure-newline)
1558 (setq day
(1+ day
)) ; first day of next week
1559 (calendar-insert-at-column indent calendar-intermonth-text trunc
)))))
1561 (defun calendar-redraw ()
1562 "Redraw the calendar display, if `calendar-buffer' is live."
1564 (if (get-buffer calendar-buffer
)
1565 (with-current-buffer calendar-buffer
1566 (let ((cursor-date (calendar-cursor-to-nearest-date)))
1567 (calendar-generate-window displayed-month displayed-year
)
1568 (calendar-cursor-to-visible-date cursor-date
)))))
1570 (defvar calendar-mode-map
1571 (let ((map (make-keymap)))
1572 (suppress-keymap map
)
1573 (dolist (c '(narrow-to-region mark-word mark-sexp mark-paragraph
1574 mark-defun
mark-whole-buffer mark-page
1575 downcase-region upcase-region kill-region
1576 copy-region-as-kill capitalize-region write-region
))
1577 (define-key map
(vector 'remap c
) 'calendar-not-implemented
))
1578 (define-key map
"<" 'calendar-scroll-right
)
1579 (define-key map
"\C-x<" 'calendar-scroll-right
)
1580 (define-key map
[prior] 'calendar-scroll-right-three-months)
1581 (define-key map "\ev" 'calendar-scroll-right-three-months)
1582 (define-key map ">" 'calendar-scroll-left)
1583 (define-key map "\C-x>" 'calendar-scroll-left)
1584 (define-key map [next] 'calendar-scroll-left-three-months)
1585 (define-key map "\C-v" 'calendar-scroll-left-three-months)
1586 (define-key map "\C-b" 'calendar-backward-day)
1587 (define-key map "\C-p" 'calendar-backward-week)
1588 (define-key map "\e{" 'calendar-backward-month)
1589 (define-key map "\C-x[" 'calendar-backward-year)
1590 (define-key map "\C-f" 'calendar-forward-day)
1591 (define-key map "\C-n" 'calendar-forward-week)
1592 (define-key map [left] 'calendar-backward-day)
1593 (define-key map [up] 'calendar-backward-week)
1594 (define-key map [right] 'calendar-forward-day)
1595 (define-key map [down] 'calendar-forward-week)
1596 (define-key map "\e}" 'calendar-forward-month)
1597 (define-key map "\C-x]" 'calendar-forward-year)
1598 (define-key map "\C-a" 'calendar-beginning-of-week)
1599 (define-key map "\C-e" 'calendar-end-of-week)
1600 (define-key map "\ea" 'calendar-beginning-of-month)
1601 (define-key map "\ee" 'calendar-end-of-month)
1602 (define-key map "\e<" 'calendar-beginning-of-year)
1603 (define-key map "\e>" 'calendar-end-of-year)
1604 (define-key map "\C-@" 'calendar-set-mark)
1605 ;; Many people are used to typing C-SPC and getting C-@.
1606 (define-key map [?\C-\s] 'calendar-set-mark)
1607 (define-key map "\C-x\C-x" 'calendar-exchange-point-and-mark)
1608 (define-key map "\e=" 'calendar-count-days-region)
1609 (define-key map "gd" 'calendar-goto-date)
1610 (define-key map "gD" 'calendar-goto-day-of-year)
1611 (define-key map "gj" 'calendar-julian-goto-date)
1612 (define-key map "ga" 'calendar-astro-goto-day-number)
1613 (define-key map "gh" 'calendar-hebrew-goto-date)
1614 (define-key map "gi" 'calendar-islamic-goto-date)
1615 (define-key map "gb" 'calendar-bahai-goto-date)
1616 (define-key map "gC" 'calendar-chinese-goto-date)
1617 (define-key map "gk" 'calendar-coptic-goto-date)
1618 (define-key map "ge" 'calendar-ethiopic-goto-date)
1619 (define-key map "gp" 'calendar-persian-goto-date)
1620 (define-key map "gc" 'calendar-iso-goto-date)
1621 (define-key map "gw" 'calendar-iso-goto-week)
1622 (define-key map "gf" 'calendar-french-goto-date)
1623 (define-key map "gml" 'calendar-mayan-goto-long-count-date)
1624 (define-key map "gmpc" 'calendar-mayan-previous-round-date)
1625 (define-key map "gmnc" 'calendar-mayan-next-round-date)
1626 (define-key map "gmph" 'calendar-mayan-previous-haab-date)
1627 (define-key map "gmnh" 'calendar-mayan-next-haab-date)
1628 (define-key map "gmpt" 'calendar-mayan-previous-tzolkin-date)
1629 (define-key map "gmnt" 'calendar-mayan-next-tzolkin-date)
1630 (define-key map "Aa" 'appt-add)
1631 (define-key map "Ad" 'appt-delete)
1632 (define-key map "S" 'calendar-sunrise-sunset)
1633 (define-key map "M" 'calendar-lunar-phases)
1634 (define-key map " " 'scroll-other-window)
1635 (define-key map "\d" 'scroll-other-window-down)
1636 (define-key map "\C-c\C-l" 'calendar-redraw)
1637 (define-key map "." 'calendar-goto-today)
1638 (define-key map "o" 'calendar-other-month)
1639 (define-key map "q" 'calendar-exit)
1640 (define-key map "a" 'calendar-list-holidays)
1641 (define-key map "h" 'calendar-cursor-holidays)
1642 (define-key map "x" 'calendar-mark-holidays)
1643 (define-key map "u" 'calendar-unmark)
1644 (define-key map "m" 'diary-mark-entries)
1645 (define-key map "d" 'diary-view-entries)
1646 (define-key map "D" 'diary-view-other-diary-entries)
1647 (define-key map "s" 'diary-show-all-entries)
1648 (define-key map "pd" 'calendar-print-day-of-year)
1649 (define-key map "pC" 'calendar-chinese-print-date)
1650 (define-key map "pk" 'calendar-coptic-print-date)
1651 (define-key map "pe" 'calendar-ethiopic-print-date)
1652 (define-key map "pp" 'calendar-persian-print-date)
1653 (define-key map "pc" 'calendar-iso-print-date)
1654 (define-key map "pj" 'calendar-julian-print-date)
1655 (define-key map "pa" 'calendar-astro-print-day-number)
1656 (define-key map "ph" 'calendar-hebrew-print-date)
1657 (define-key map "pi" 'calendar-islamic-print-date)
1658 (define-key map "pb" 'calendar-bahai-print-date)
1659 (define-key map "pf" 'calendar-french-print-date)
1660 (define-key map "pm" 'calendar-mayan-print-date)
1661 (define-key map "po" 'calendar-print-other-dates)
1662 (define-key map "id" 'diary-insert-entry)
1663 (define-key map "iw" 'diary-insert-weekly-entry)
1664 (define-key map "im" 'diary-insert-monthly-entry)
1665 (define-key map "iy" 'diary-insert-yearly-entry)
1666 (define-key map "ia" 'diary-insert-anniversary-entry)
1667 (define-key map "ib" 'diary-insert-block-entry)
1668 (define-key map "ic" 'diary-insert-cyclic-entry)
1669 (define-key map "ihd" 'diary-hebrew-insert-entry)
1670 (define-key map "ihm" 'diary-hebrew-insert-monthly-entry)
1671 (define-key map "ihy" 'diary-hebrew-insert-yearly-entry)
1672 (define-key map "iid" 'diary-islamic-insert-entry)
1673 (define-key map "iim" 'diary-islamic-insert-monthly-entry)
1674 (define-key map "iiy" 'diary-islamic-insert-yearly-entry)
1675 (define-key map "iBd" 'diary-bahai-insert-entry)
1676 (define-key map "iBm" 'diary-bahai-insert-monthly-entry)
1677 (define-key map "iBy" 'diary-bahai-insert-yearly-entry)
1678 (define-key map "?" 'calendar-goto-info-node)
1679 (define-key map "Hm" 'cal-html-cursor-month)
1680 (define-key map "Hy" 'cal-html-cursor-year)
1681 (define-key map "tm" 'cal-tex-cursor-month)
1682 (define-key map "tM" 'cal-tex-cursor-month-landscape)
1683 (define-key map "td" 'cal-tex-cursor-day)
1684 (define-key map "tw1" 'cal-tex-cursor-week)
1685 (define-key map "tw2" 'cal-tex-cursor-week2)
1686 (define-key map "tw3" 'cal-tex-cursor-week-iso) ; FIXME twi ?
1687 (define-key map "tw4" 'cal-tex-cursor-week-monday) ; twm ?
1688 (define-key map "twW" 'cal-tex-cursor-week2-summary)
1689 (define-key map "tfd" 'cal-tex-cursor-filofax-daily)
1690 (define-key map "tfw" 'cal-tex-cursor-filofax-2week)
1691 (define-key map "tfW" 'cal-tex-cursor-filofax-week)
1692 (define-key map "tfy" 'cal-tex-cursor-filofax-year)
1693 (define-key map "ty" 'cal-tex-cursor-year)
1694 (define-key map "tY" 'cal-tex-cursor-year-landscape)
1696 (define-key map [menu-bar edit] 'undefined)
1697 (define-key map [menu-bar search] 'undefined)
1699 (easy-menu-define nil map nil cal-menu-sunmoon-menu)
1700 (easy-menu-define nil map nil cal-menu-diary-menu)
1701 (easy-menu-define nil map nil cal-menu-holidays-menu)
1702 (easy-menu-define nil map nil cal-menu-goto-menu)
1703 (easy-menu-define nil map nil cal-menu-scroll-menu)
1705 ;; These are referenced in the default calendar-date-echo-text.
1706 (define-key map [down-mouse-3]
1707 (easy-menu-binding cal-menu-context-mouse-menu))
1708 (define-key map [down-mouse-2]
1709 (easy-menu-binding cal-menu-global-mouse-menu))
1711 ;; cf scroll-bar.el.
1712 (if (and (boundp 'x-toolkit-scroll-bars) x-toolkit-scroll-bars)
1713 (define-key map [vertical-scroll-bar mouse-1]
1714 'calendar-scroll-toolkit-scroll)
1715 ;; Left-click moves us forward in time, right-click backwards.
1716 (define-key map [vertical-scroll-bar mouse-1] 'calendar-scroll-left)
1717 (define-key map [vertical-scroll-bar drag-mouse-1] 'calendar-scroll-left)
1718 ;; down-mouse-2 stays as scroll-bar-drag.
1719 (define-key map [vertical-scroll-bar mouse-3] 'calendar-scroll-right)
1720 (define-key map [vertical-scroll-bar drag-mouse-3]
1721 'calendar-scroll-right))
1723 "Keymap for `calendar-mode'.")
1725 ;; Calendar mode is suitable only for specially formatted data.
1726 (put 'calendar-mode 'mode-class 'special)
1728 (defun calendar-mode-line-entry (command echo &optional key string)
1729 "Return a propertized string for `calendar-mode-line-format'.
1730 COMMAND is a command to run, ECHO is the help-echo text, KEY
1731 is COMMAND's keybinding, STRING describes the binding."
1733 (substitute-command-keys
1734 (format "\\<calendar-mode-map>\\[%s] %s" command string)))
1735 'help-echo (format "mouse-1: %s" echo)
1736 'mouse-face 'mode-line-highlight
1737 'keymap (make-mode-line-mouse-map 'mouse-1 command)))
1739 ;; After calendar-mode-map.
1740 (defcustom calendar-mode-line-format
1742 (calendar-mode-line-entry 'calendar-scroll-right "previous month" "<")
1745 (calendar-mode-line-entry 'calendar-goto-info-node "read Info on Calendar"
1748 (calendar-mode-line-entry 'calendar-other-month "choose another month"
1751 (calendar-mode-line-entry 'calendar-goto-today "go to today's date"
1753 '(calendar-date-string (calendar-current-date) t)
1754 (calendar-mode-line-entry 'calendar-scroll-left "next month" ">"))
1755 "The mode line of the calendar buffer.
1756 This is a list of items that evaluate to strings. The elements
1757 are evaluated and concatenated, evenly separated by blanks.
1758 During evaluation, the variable `date' is available as the date
1759 nearest the cursor (or today's date if that fails). To update
1760 the mode-line as the cursor moves, add `calendar-update-mode-line'
1761 to `calendar-move-hook'. Here is an example that has the Hebrew date,
1762 the day number/days remaining in the year, and the ISO week/year numbers:
1766 '(calendar-hebrew-date-string date)
1767 '(let* ((year (calendar-extract-year date))
1768 (d (calendar-day-number date))
1770 (- (calendar-day-number (list 12 31 year)) d)))
1771 (format \"%d/%d\" d days-remaining))
1772 '(let* ((d (calendar-absolute-from-gregorian date))
1773 (iso-date (calendar-iso-from-absolute d)))
1774 (format \"ISO week %d of %d\"
1775 (calendar-extract-month iso-date)
1776 (calendar-extract-year iso-date)))
1782 (defun calendar-goto-info-node ()
1783 "Go to the info node for the calendar."
1785 (info "(emacs)Calendar/Diary")
1786 (fit-window-to-buffer))
1788 (defvar calendar-mark-ring nil
1789 "Used by `calendar-set-mark'.")
1791 (define-derived-mode calendar-mode nil "Calendar"
1792 "A major mode for the calendar window.
1793 For a complete description, see the info node `Calendar/Diary'.
1795 \\<calendar-mode-map>\\{calendar-mode-map}"
1796 (setq buffer-read-only t
1798 indent-tabs-mode nil)
1799 (set (make-local-variable 'scroll-margin) 0) ; bug#10379
1800 (calendar-update-mode-line)
1801 (make-local-variable 'calendar-mark-ring)
1802 (make-local-variable 'displayed-month) ; month in middle of window
1803 (make-local-variable 'displayed-year) ; year in middle of window
1804 ;; Most functions only work if displayed-month and displayed-year are set,
1805 ;; so let's make sure they're always set. Most likely, this will be reset
1806 ;; soon in calendar-generate, but better safe than sorry.
1807 (unless (boundp 'displayed-month) (setq displayed-month 1))
1808 (unless (boundp 'displayed-year) (setq displayed-year 2001))
1809 (set (make-local-variable 'font-lock-defaults)
1810 '(calendar-font-lock-keywords t)))
1812 (defun calendar-string-spread (strings char length)
1813 "Concatenate list of STRINGS separated with copies of CHAR to fill LENGTH.
1814 The effect is like mapconcat but the separating pieces are as balanced as
1815 possible. Each item of STRINGS is evaluated before concatenation so it can
1816 actually be an expression that evaluates to a string. If LENGTH is too short,
1817 the STRINGS are just concatenated and the result truncated."
1818 ;; The algorithm is based on equation (3.25) on page 85 of Concrete
1819 ;; Mathematics by Ronald L. Graham, Donald E. Knuth, and Oren Patashnik,
1820 ;; Addison-Wesley, Reading, MA, 1989.
1821 (let* ((strings (mapcar 'eval
1822 (if (< (length strings) 2)
1823 (append (list "") strings (list ""))
1825 (n (- length (string-width (apply 'concat strings))))
1826 (m (* (1- (length strings)) (char-width char)))
1828 (strings (cdr strings))
1830 (dolist (string strings)
1832 (make-string (max 0 (/ (+ n i) m)) char)
1835 (truncate-string-to-width s length)))
1837 (defun calendar-update-mode-line ()
1838 "Update the calendar mode line with the current date and date style."
1839 (if (bufferp (get-buffer calendar-buffer))
1840 (with-current-buffer calendar-buffer
1841 (let ((start (- calendar-left-margin 2))
1842 (date (condition-case nil
1843 (calendar-cursor-to-nearest-date)
1844 (error (calendar-current-date)))))
1845 (setq mode-line-format
1846 (concat (make-string (max 0 (+ start
1847 (- (car (window-inside-edges))
1848 (car (window-edges))))) ?\s)
1849 (calendar-string-spread
1850 (mapcar 'eval calendar-mode-line-format)
1851 ?\s (- calendar-right-margin (1- start))))))
1852 (force-mode-line-update))))
1854 (defun calendar-buffer-list ()
1855 "List of all calendar-related buffers (as buffers, not strings)."
1857 (dolist (b (list calendar-hebrew-yahrzeit-buffer lunar-phases-buffer
1858 holiday-buffer diary-fancy-buffer solar-sunrises-buffer
1859 (get-file-buffer diary-file)
1860 calendar-buffer calendar-other-calendars-buffer))
1861 (and b (setq b (get-buffer b))
1865 (defun calendar-exit (&optional kill)
1866 "Get out of the calendar window and hide it and related buffers."
1868 (let ((diary-buffer (get-file-buffer diary-file))
1869 (calendar-buffers (calendar-buffer-list)))
1870 (when (or (not diary-buffer)
1871 (not (buffer-modified-p diary-buffer))
1873 "Diary modified; do you really want to exit the calendar? "))
1874 (if (and calendar-setup (display-multi-frame-p))
1875 ;; FIXME: replace this cruft with the `quit-restore' window property
1876 (dolist (w (window-list-1 nil nil t))
1877 (if (and (memq (window-buffer w) calendar-buffers)
1878 (window-dedicated-p w))
1879 (if (eq (window-deletable-p w) 'frame)
1880 (if calendar-remove-frame-by-deleting
1881 (delete-frame (window-frame w))
1882 (iconify-frame (window-frame w)))
1883 (quit-window kill w))))
1884 (dolist (b calendar-buffers)
1885 (quit-windows-on b kill))))))
1887 (define-obsolete-function-alias 'exit-calendar 'calendar-exit "23.1")
1889 (defun calendar-current-date (&optional offset)
1890 "Return the current date in a list (month day year).
1891 Optional integer OFFSET is a number of days from the current date."
1892 (let* ((now (decode-time))
1893 (now (list (nth 4 now) (nth 3 now) (nth 5 now))))
1894 (if (zerop (or offset 0))
1896 (calendar-gregorian-from-absolute
1897 (+ offset (calendar-absolute-from-gregorian now))))))
1899 (defun calendar-column-to-segment ()
1900 "Convert current column to calendar month \"segment\".
1901 The left-most month returns 0, the next right 1, and so on."
1902 (let ((col (max 0 (+ (current-column)
1903 (/ calendar-intermonth-spacing 2)
1904 (- calendar-left-margin)))))
1905 (/ col (+ (* 7 calendar-column-width) calendar-intermonth-spacing))))
1907 (defun calendar-cursor-to-date (&optional error event)
1908 "Return a list (month day year) of current cursor position.
1909 If cursor is not on a specific date, signals an error if optional parameter
1910 ERROR is non-nil, otherwise just returns nil.
1911 If EVENT is non-nil, it's an event indicating the buffer position to
1912 use instead of point."
1913 (with-current-buffer
1914 (if event (window-buffer (posn-window (event-start event)))
1917 (and event (setq event (event-start event))
1918 (goto-char (posn-point event)))
1919 (let* ((segment (calendar-column-to-segment))
1920 (month (% (+ displayed-month (1- segment)) 12)))
1921 ;; Call with point on either of the two digits in a 2-digit date,
1922 ;; or on or before the digit of a 1-digit date.
1923 (if (not (and (looking-at "[ 0-9]?[0-9][^0-9]")
1924 (get-text-property (point) 'date)))
1925 (if error (user-error "Not on a date!"))
1926 ;; Convert segment to real month and year.
1927 (if (zerop month) (setq month 12))
1928 ;; Go back to before the first date digit.
1929 (or (looking-at " ")
1930 (re-search-backward "[^0-9]"))
1933 (buffer-substring (1+ (point))
1934 (+ 1 calendar-day-digit-width (point))))
1936 ((and (= 12 month) (zerop segment)) (1- displayed-year))
1937 ((and (= 1 month) (= segment 2)) (1+ displayed-year))
1938 (t displayed-year))))))))
1940 ;; The following version of calendar-gregorian-from-absolute is preferred for
1941 ;; reasons of clarity, BUT it's much slower than the version that follows it.
1943 ;;(defun calendar-gregorian-from-absolute (date)
1944 ;; "Compute the list (month day year) corresponding to the absolute DATE.
1945 ;;The absolute date is the number of days elapsed since the (imaginary)
1946 ;;Gregorian date Sunday, December 31, 1 BC."
1947 ;; (let* ((approx (/ date 366)) ; approximation from below
1948 ;; (year ; search forward from the approximation
1950 ;; (calendar-sum y approx
1951 ;; (>= date (calendar-absolute-from-gregorian (list 1 1 (1+ y))))
1953 ;; (month ; search forward from January
1954 ;; (1+ (calendar-sum m 1
1956 ;; (calendar-absolute-from-gregorian
1957 ;; (list m (calendar-last-day-of-month m year) year)))
1959 ;; (day ; calculate the day by subtraction
1961 ;; (1- (calendar-absolute-from-gregorian (list month 1 year))))))
1962 ;; (list month day year)))
1964 (defun calendar-gregorian-from-absolute (date)
1965 "Compute the list (month day year) corresponding to the absolute DATE.
1966 The absolute date is the number of days elapsed since the (imaginary)
1967 Gregorian date Sunday, December 31, 1 BC. This function does not
1968 handle dates in years BC."
1969 ;; See the footnote on page 384 of ``Calendrical Calculations, Part II:
1970 ;; Three Historical Calendars'' by E. M. Reingold, N. Dershowitz, and S. M.
1971 ;; Clamen, Software--Practice and Experience, Volume 23, Number 4
1972 ;; (April, 1993), pages 383-404 for an explanation.
1973 (let* ((d0 (1- date))
1974 (n400 (/ d0 146097))
1981 (day (1+ (% d3 365)))
1982 (year (+ (* 400 n400) (* 100 n100) (* n4 4) n1))
1985 (if (or (= n100 4) (= n1 4))
1987 (setq year (1+ year))
1988 (while (< (setq mdays (calendar-last-day-of-month month year)) day)
1989 (setq day (- day mdays)
1991 (list month day year))))
1993 (defun calendar-other-month (month year &optional event)
1994 "Display a three-month calendar centered around MONTH and YEAR.
1995 EVENT is an event like `last-nonmenu-event'."
1996 (interactive (let ((event (list last-nonmenu-event)))
1997 (append (calendar-read-date 'noday) event)))
1998 (save-selected-window
2000 (setq event (event-start event))
2001 (select-window (posn-window event)))
2002 (unless (and (= month displayed-month)
2003 (= year displayed-year))
2004 (let ((old-date (calendar-cursor-to-date))
2005 (today (calendar-current-date)))
2006 (calendar-generate-window month year)
2007 (calendar-cursor-to-visible-date
2009 ((calendar-date-is-visible-p old-date) old-date)
2010 ((calendar-date-is-visible-p today) today)
2011 (t (list month 1 year))))))))
2013 (defun calendar-set-mark (arg &optional event)
2014 "Mark the date under the cursor, or jump to marked date.
2015 With no prefix argument, push current date onto marked date ring.
2016 With argument ARG, jump to mark, pop it, and put point at end of ring."
2018 (list current-prefix-arg last-nonmenu-event))
2019 (let ((date (calendar-cursor-to-date t event)))
2021 (if (null calendar-mark-ring)
2022 (error "No mark set in this buffer")
2023 (calendar-goto-date (car calendar-mark-ring))
2024 (setq calendar-mark-ring
2025 (cdr (nconc calendar-mark-ring (list date)))))
2026 (push date calendar-mark-ring)
2027 ;; Since the top of the mark ring is the marked date in the
2028 ;; calendar, the mark ring in the calendar is one longer than
2029 ;; in other buffers to get the same effect.
2030 (if (> (length calendar-mark-ring) (1+ mark-ring-max))
2031 (setcdr (nthcdr mark-ring-max calendar-mark-ring) nil))
2032 (message "Mark set"))))
2034 (defun calendar-exchange-point-and-mark ()
2035 "Exchange the current cursor position with the marked date."
2037 (let ((mark (car calendar-mark-ring))
2038 (date (calendar-cursor-to-date t)))
2040 (error "No mark set in this buffer")
2041 (setq calendar-mark-ring (cons date (cdr calendar-mark-ring)))
2042 (calendar-goto-date mark))))
2044 (defun calendar-count-days-region ()
2045 "Count the number of days (inclusive) between point and the mark."
2047 (let* ((days (- (calendar-absolute-from-gregorian
2048 (calendar-cursor-to-date t))
2049 (calendar-absolute-from-gregorian
2050 (or (car calendar-mark-ring)
2051 (error "No mark set in this buffer")))))
2052 (days (1+ (if (> days 0) days (- days)))))
2053 (message "Region has %d day%s (inclusive)"
2054 days (if (> days 1) "s" ""))))
2056 (defun calendar-not-implemented ()
2059 (error "%s not available in the calendar"
2060 (global-key-binding (this-command-keys))))
2062 (defun calendar-read (prompt acceptable &optional initial-contents)
2063 "Return an object read from the minibuffer.
2064 Prompt with the string PROMPT and use the function ACCEPTABLE to decide if
2065 entered item is acceptable. If non-nil, optional third arg INITIAL-CONTENTS
2066 is a string to insert in the minibuffer before reading."
2067 (let ((value (read-minibuffer prompt initial-contents)))
2068 (while (not (funcall acceptable value))
2069 (setq value (read-minibuffer prompt initial-contents)))
2073 (defun calendar-customized-p (symbol)
2074 "Return non-nil if SYMBOL has been customized."
2075 (and (default-boundp symbol)
2076 (let ((standard (get symbol 'standard-value)))
2078 (not (equal (eval (car standard)) (default-value symbol)))))))
2080 (defun calendar-abbrev-construct (full)
2081 "From sequence FULL, return a vector of abbreviations.
2082 Each abbreviation is no longer than `calendar-abbrev-length' characters."
2083 (apply 'vector (mapcar
2085 (substring f 0 (min calendar-abbrev-length (length f))))
2088 (defcustom calendar-day-name-array
2089 ["Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"]
2090 "Array of capitalized strings giving, in order from Sunday, the day names.
2091 The first two characters of each string will be used to head the
2092 day columns in the calendar.
2093 If you change this without using customize after the calendar has loaded,
2094 then you may also want to change `calendar-day-abbrev-array'."
2096 :initialize 'custom-initialize-default
2097 :set (lambda (symbol value)
2098 (let ((dcustomized (calendar-customized-p 'calendar-day-abbrev-array))
2099 (hcustomized (calendar-customized-p 'cal-html-day-abbrev-array)))
2102 (setq calendar-day-abbrev-array
2103 (calendar-abbrev-construct calendar-day-name-array)))
2104 (and (not hcustomized)
2105 (boundp 'cal-html-day-abbrev-array)
2106 (setq cal-html-day-abbrev-array calendar-day-abbrev-array))))
2107 :type '(vector (string :tag "Sunday")
2108 (string :tag "Monday")
2109 (string :tag "Tuesday")
2110 (string :tag "Wednesday")
2111 (string :tag "Thursday")
2112 (string :tag "Friday")
2113 (string :tag "Saturday")))
2115 (defcustom calendar-abbrev-length 3
2116 "Default length of abbreviations to use for day and month names.
2117 If you change this without using customize after the calendar has loaded,
2118 then you may also want to change `calendar-day-abbrev-array' and
2119 `calendar-month-abbrev-array'."
2121 :initialize 'custom-initialize-default
2122 :set (lambda (symbol value)
2123 (let ((dcustomized (calendar-customized-p 'calendar-day-abbrev-array))
2124 (mcustomized (calendar-customized-p
2125 'calendar-month-abbrev-array))
2126 (hcustomized (calendar-customized-p 'cal-html-day-abbrev-array)))
2129 (setq calendar-day-abbrev-array
2130 (calendar-abbrev-construct calendar-day-name-array)))
2132 (setq calendar-month-abbrev-array
2133 (calendar-abbrev-construct calendar-month-name-array)))
2134 (and (not hcustomized)
2135 (boundp 'cal-html-day-abbrev-array)
2136 (setq cal-html-day-abbrev-array calendar-day-abbrev-array))))
2139 (defcustom calendar-day-abbrev-array
2140 (calendar-abbrev-construct calendar-day-name-array)
2141 "Array of capitalized strings giving the abbreviated day names.
2142 The order should be the same as that of the full names specified
2143 in `calendar-day-name-array'. These abbreviations may be used
2144 instead of the full names in the diary file. Do not include a
2145 trailing `.' in the strings specified in this variable, though
2146 you may use such in the diary file. By default, each string is
2147 the first `calendar-abbrev-length' characters of the corresponding
2150 :initialize 'custom-initialize-default
2151 :set-after '(calendar-abbrev-length calendar-day-name-array)
2152 :set (lambda (symbol value)
2153 (let ((hcustomized (calendar-customized-p 'cal-html-day-abbrev-array)))
2155 (and (not hcustomized)
2156 (boundp 'cal-html-day-abbrev-array)
2157 (setq cal-html-day-abbrev-array calendar-day-abbrev-array))))
2158 :type '(vector (string :tag "Sun")
2164 (string :tag "Sat"))
2165 ;; Made defcustom, changed defaults from nil nil...
2168 (defcustom calendar-month-name-array
2169 ["January" "February" "March" "April" "May" "June"
2170 "July" "August" "September" "October" "November" "December"]
2171 "Array of capitalized strings giving, in order, the month names.
2172 If you change this without using customize after the calendar has loaded,
2173 then you may also want to change `calendar-month-abbrev-array'."
2175 :initialize 'custom-initialize-default
2176 :set (lambda (symbol value)
2177 (let ((mcustomized (calendar-customized-p
2178 'calendar-month-abbrev-array)))
2181 (setq calendar-month-abbrev-array
2182 (calendar-abbrev-construct calendar-month-name-array)))))
2183 :type '(vector (string :tag "January")
2184 (string :tag "February")
2185 (string :tag "March")
2186 (string :tag "April")
2188 (string :tag "June")
2189 (string :tag "July")
2190 (string :tag "August")
2191 (string :tag "September")
2192 (string :tag "October")
2193 (string :tag "November")
2194 (string :tag "December")))
2196 (defcustom calendar-month-abbrev-array
2197 (calendar-abbrev-construct calendar-month-name-array)
2198 "Array of capitalized strings giving the abbreviated month names.
2199 The order should be the same as that of the full names specified
2200 in `calendar-month-name-array'. These abbreviations are used in
2201 the calendar menu entries, and can also be used in the diary
2202 file. Do not include a trailing `.' in the strings specified in
2203 this variable, though you may use such in the diary file. By
2204 default, each string is the first ``calendar-abbrev-length'
2205 characters of the corresponding full name."
2207 :set-after '(calendar-abbrev-length calendar-month-name-array)
2208 :type '(vector (string :tag "Jan")
2219 (string :tag "Dec"))
2220 ;; Made defcustom, changed defaults from nil nil...
2223 (defun calendar-make-alist (sequence &optional start-index filter
2225 "Return an association list corresponding to SEQUENCE.
2226 Associates each element of SEQUENCE with an incremented integer,
2227 starting from START-INDEX (default 1). Applies the function FILTER,
2228 if provided, to each key in the alist. Repeats the process, with
2229 indices starting from START-INDEX each time, for any remaining
2230 arguments SEQUENCES."
2231 (or start-index (setq start-index 1))
2234 (setq index start-index)
2235 (mapc (lambda (elem)
2237 (cons (if filter (funcall filter elem) elem)
2242 (append (list sequence) sequences))
2245 (defun calendar-read-date (&optional noday)
2246 "Prompt for Gregorian date. Return a list (month day year).
2247 If optional NODAY is t, does not ask for day, but just returns
2248 \(month 1 year); if NODAY is any other non-nil value the value returned is
2250 (let* ((year (calendar-read
2252 (lambda (x) (> x 0))
2253 (number-to-string (calendar-extract-year
2254 (calendar-current-date)))))
2255 (month-array calendar-month-name-array)
2256 (completion-ignore-case t)
2257 (month (cdr (assoc-string
2260 (mapcar 'list (append month-array nil))
2262 (calendar-make-alist month-array 1) t)))
2263 (last (calendar-last-day-of-month month year)))
2269 (calendar-read (format "Day (1-%d): " last)
2270 (lambda (x) (and (< 0 x) (<= x last))))
2273 (defun calendar-interval (mon1 yr1 mon2 yr2)
2274 "The number of months difference between MON1, YR1 and MON2, YR2.
2275 The result is positive if the second date is later than the first.
2276 Negative years are interpreted as years BC; -1 being 1 BC, and so on."
2277 (if (< yr1 0) (setq yr1 (1+ yr1))) ; -1 BC -> 0 AD, etc
2278 (if (< yr2 0) (setq yr2 (1+ yr2)))
2279 (+ (* 12 (- yr2 yr1))
2282 (defvar calendar-font-lock-keywords
2283 ;; Month and year. Not really needed now that calendar-month-header
2284 ;; contains propertize, and not correct for non-american forms
2285 ;; of that variable.
2286 `((,(concat (regexp-opt (mapcar 'identity calendar-month-name-array) t)
2288 . font-lock-function-name-face)
2290 (list (substring (aref calendar-day-name-array 6)
2291 0 calendar-day-header-width)
2292 (substring (aref calendar-day-name-array 0)
2293 0 calendar-day-header-width)))
2294 ;; Saturdays and Sundays are highlighted differently.
2295 . font-lock-comment-face)
2296 ;; First two chars of each day are used in the calendar.
2297 (,(regexp-opt (mapcar (lambda (x) (substring x 0 calendar-day-header-width))
2298 calendar-day-name-array))
2299 . font-lock-constant-face))
2300 "Default keywords to highlight in Calendar mode.")
2302 (defun calendar-day-name (date &optional abbrev absolute)
2303 "Return a string with the name of the day of the week of DATE.
2304 DATE should be a list in the format (MONTH DAY YEAR), unless the
2305 optional argument ABSOLUTE is non-nil, in which case DATE should
2306 be an integer in the range 0 to 6 corresponding to the day of the
2307 week. Day names are taken from the variable `calendar-day-name-array',
2308 unless the optional argument ABBREV is non-nil, in which case
2309 the variable `calendar-day-abbrev-array' is used."
2310 (aref (if abbrev calendar-day-abbrev-array calendar-day-name-array)
2311 (if absolute date (calendar-day-of-week date))))
2313 (defun calendar-month-name (month &optional abbrev)
2314 "Return a string with the name of month number MONTH.
2315 Months are numbered from one. Month names are taken from the
2316 variable `calendar-month-name-array', unless the optional
2317 argument ABBREV is non-nil, in which case
2318 `calendar-month-abbrev-array' is used."
2319 (aref (if abbrev calendar-month-abbrev-array calendar-month-name-array)
2322 (defun calendar-day-of-week (date)
2323 "Return the day-of-the-week index of DATE, 0 for Sunday, 1 for Monday, etc.
2324 DATE is a list of the form (month day year). A negative year is
2325 interpreted as BC; -1 being 1 BC, and so on."
2326 (mod (calendar-absolute-from-gregorian date) 7))
2328 (defun calendar-week-end-day ()
2329 "Return the index (0 for Sunday, etc.) of the last day of the week."
2330 (mod (+ calendar-week-start-day 6) 7))
2332 (defun calendar-unmark ()
2333 "Delete all diary/holiday marks/highlighting from the calendar."
2335 (setq calendar-mark-holidays-flag nil
2336 calendar-mark-diary-entries-flag nil)
2337 (with-current-buffer calendar-buffer
2338 (mapc 'delete-overlay (overlays-in (point-min) (point-max)))))
2340 (defun calendar-date-is-visible-p (date)
2341 "Return non-nil if DATE is valid and is visible in the calendar window."
2342 (and (calendar-date-is-valid-p date)
2343 (< (abs (calendar-interval
2344 displayed-month displayed-year
2345 (calendar-extract-month date) (calendar-extract-year date)))
2348 ;; FIXME can this be generalized for holiday-chinese?
2349 (defun calendar-nongregorian-visible-p (month day toabs fromabs switch)
2350 "Return non-nil if MONTH, DAY is visible in the calendar window.
2351 MONTH and DAY are in some non-Gregorian calendar system. The
2352 functions TOABS and FROMABS convert that system to and from
2353 absolute, respectively. SWITCH is a function that takes a single
2354 argument (a local month number). It applies when the local year
2355 changes across the calendar window, and returns non-nil if the
2356 specified month should be associated with the higher year.
2357 Returns the corresponding Gregorian date."
2358 ;; We need to choose the local year associated with month and day
2359 ;; that might make them visible.
2360 (let* ((m1 displayed-month)
2362 (m2 displayed-month)
2364 ;; Absolute date of first/last dates in calendar window.
2366 (calendar-increment-month m1 y1 -1)
2367 (calendar-absolute-from-gregorian (list m1 1 y1))))
2369 (calendar-increment-month m2 y2 1)
2370 (calendar-absolute-from-gregorian
2371 (list m2 (calendar-last-day-of-month m2 y2) y2))))
2372 ;; Local date of first/last date in calendar window.
2373 (local-start (funcall fromabs start-date))
2374 (local-end (funcall fromabs end-date))
2375 ;; Local year of first/last dates.
2376 ;; Can only differ if displayed-month = 12, 1, 2.
2377 (local-y1 (calendar-extract-year local-start))
2378 (local-y2 (calendar-extract-year local-end))
2379 ;; Choose which year might be visible in the window.
2380 ;; Obviously it only matters when y1 and y2 differ, ie
2381 ;; when the _local_ new year is visible.
2382 (year (if (funcall switch month) local-y2 local-y1))
2383 (date (calendar-gregorian-from-absolute
2384 (funcall toabs (list month day year)))))
2385 (if (calendar-date-is-visible-p date)
2388 (defun calendar-date-is-valid-p (date)
2389 "Return t if DATE is a valid date."
2390 (let ((month (calendar-extract-month date))
2391 (day (calendar-extract-day date))
2392 (year (calendar-extract-year date)))
2393 (and (<= 1 month) (<= month 12)
2394 ;; (calendar-read-date t) used to return a date with day = nil.
2395 ;; Should not be valid (?), since many funcs prob assume integer.
2396 ;; (calendar-read-date 'noday) returns (month year), which
2397 ;; currently results in calendar-extract-year returning nil.
2398 day year (<= 1 day) (<= day (calendar-last-day-of-month month year))
2399 ;; BC dates left as non-valid, to suppress errors from
2400 ;; complex holiday algorithms not suitable for years BC.
2401 ;; Note there are side effects on calendar navigation.
2404 (define-obsolete-function-alias 'calendar-date-is-legal-p
2405 'calendar-date-is-valid-p "23.1")
2407 (defun calendar-date-equal (date1 date2)
2408 "Return t if the DATE1 and DATE2 are the same."
2410 (= (calendar-extract-month date1) (calendar-extract-month date2))
2411 (= (calendar-extract-day date1) (calendar-extract-day date2))
2412 (= (calendar-extract-year date1) (calendar-extract-year date2))))
2414 (defun calendar-make-temp-face (attrlist)
2415 "Return a temporary face based on the attributes in ATTRLIST.
2416 ATTRLIST is a list with elements of the form :face face :foreground color."
2417 (let ((attrs attrlist)
2418 faceinfo face temp-face)
2419 ;; Separate :face from the other attributes. Use the last :face
2420 ;; if there are more than one. FIXME is merging meaningful?
2422 (if (eq (car attrs) :face)
2423 (setq face (intern-soft (cadr attrs))
2425 (push (car attrs) faceinfo)
2426 (setq attrs (cdr attrs))))
2427 (or (facep face) (setq face 'default))
2429 ;; No attributes to apply, so just use an existing-face.
2431 ;; FIXME should we be using numbered temp-faces, re-using where poss?
2435 (mapconcat (lambda (sym)
2437 ((symbolp sym) (symbol-name sym))
2438 ((numberp sym) (number-to-string sym))
2441 (make-face temp-face)
2442 (copy-face face temp-face)
2443 ;; Apply the font aspects.
2444 (apply 'set-face-attribute temp-face nil (nreverse faceinfo))
2447 (defun calendar-mark-visible-date (date &optional mark)
2448 "Mark DATE in the calendar window with MARK.
2449 MARK is a single-character string, a list of face attributes/values, or a face.
2450 MARK defaults to `diary-entry-marker'."
2451 (if (calendar-date-is-valid-p date)
2452 (with-current-buffer calendar-buffer
2454 (calendar-cursor-to-visible-date date)
2456 (or (and (stringp mark) (= (length mark) 1) mark) ; single-char
2457 ;; The next two use to also check font-lock-mode.
2458 ;; See comments above diary-entry-marker for why
2459 ;; this was dropped.
2460 ;;; (and font-lock-mode
2462 (and (listp mark) (> (length mark) 0) mark) ; attrs
2463 (and (facep mark) mark) ; )) face-name
2464 diary-entry-marker))
2466 ;; Face or an attr-list that contained a face.
2469 (make-overlay (1- (point)) (1+ (point))) 'face mark))
2470 ;; Single-character mark, goes after the date.
2471 ((and (stringp mark) (= (length mark) 1))
2473 (make-overlay (1+ (point)) (+ 2 (point))) 'display mark))
2476 (make-overlay (1- (point)) (1+ (point))) 'face
2477 (calendar-make-temp-face mark))))))))
2479 (define-obsolete-function-alias 'mark-visible-calendar-date
2480 'calendar-mark-visible-date "23.1")
2482 (defun calendar-star-date ()
2483 "Replace the date under the cursor in the calendar window with asterisks.
2484 You might want to add this function to `calendar-today-visible-hook'."
2485 (unless (catch 'found
2486 (dolist (ol (overlays-at (point)))
2487 (and (overlay-get ol 'calendar-star)
2489 (let ((ol (make-overlay (1- (point)) (point))))
2490 (overlay-put ol 'display "*")
2491 (overlay-put ol 'calendar-star t)
2492 ;; Use copy-sequence to avoid merging of identical 'display props.
2493 ;; Use two overlays so as not to mess up
2494 ;; calendar-cursor-to-nearest-date (and calendar-forward-day).
2495 (overlay-put (setq ol (make-overlay (point) (1+ (point))))
2496 'display (copy-sequence "*"))
2497 (overlay-put ol 'calendar-star t))))
2499 (defun calendar-mark-today ()
2500 "Mark the date under the cursor in the calendar window.
2501 The date is marked with `calendar-today-marker'. You might want to add
2502 this function to `calendar-today-visible-hook'."
2503 (calendar-mark-visible-date (calendar-cursor-to-date) calendar-today-marker))
2505 ;; FIXME why the car? Almost every usage calls list on the args.
2506 (defun calendar-date-compare (date1 date2)
2507 "Return t if DATE1 is before DATE2, nil otherwise.
2508 The actual dates are in the car of DATE1 and DATE2."
2509 (< (calendar-absolute-from-gregorian (car date1))
2510 (calendar-absolute-from-gregorian (car date2))))
2512 (defun calendar-date-string (date &optional abbreviate nodayname)
2513 "A string form of DATE, driven by the variable `calendar-date-display-form'.
2514 An optional parameter ABBREVIATE, when non-nil, causes the month
2515 and day names to be abbreviated as specified by
2516 `calendar-month-abbrev-array' and `calendar-day-abbrev-array',
2517 respectively. An optional parameter NODAYNAME, when t, omits the
2518 name of the day of the week."
2519 (let* ((dayname (unless nodayname (calendar-day-name date abbreviate)))
2520 (month (calendar-extract-month date))
2521 (monthname (calendar-month-name month abbreviate))
2522 (day (number-to-string (calendar-extract-day date)))
2523 (month (number-to-string month))
2524 (year (number-to-string (calendar-extract-year date))))
2525 (mapconcat 'eval calendar-date-display-form "")))
2527 (defun calendar-dayname-on-or-before (dayname date)
2528 "Return the absolute date of the DAYNAME on or before absolute DATE.
2529 DAYNAME=0 means Sunday, DAYNAME=1 means Monday, and so on.
2531 Note: Applying this function to d+6 gives us the DAYNAME on or after an
2532 absolute day d. Similarly, applying it to d+3 gives the DAYNAME nearest to
2533 absolute date d, applying it to d-1 gives the DAYNAME previous to absolute
2534 date d, and applying it to d+7 gives the DAYNAME following absolute date d."
2535 (- date (% (- date dayname) 7)))
2537 (defun calendar-nth-named-absday (n dayname month year &optional day)
2538 "Absolute date of the Nth DAYNAME after/before MONTH YEAR DAY.
2539 A DAYNAME of 0 means Sunday, 1 means Monday, and so on.
2540 If N>0, return the Nth DAYNAME after MONTH DAY, YEAR (inclusive).
2541 If N<0, return the Nth DAYNAME before MONTH DAY, YEAR (inclusive).
2542 DAY defaults to 1 if N>0, and MONTH's last day otherwise."
2545 (calendar-dayname-on-or-before
2547 (+ 6 (calendar-absolute-from-gregorian
2548 (list month (or day 1) year)))))
2550 (calendar-dayname-on-or-before
2552 (calendar-absolute-from-gregorian
2554 (or day (calendar-last-day-of-month month year))
2557 (defun calendar-nth-named-day (n dayname month year &optional day)
2558 "Date of the Nth DAYNAME after/before MONTH YEAR DAY.
2559 Like `calendar-nth-named-absday', but returns a Gregorian date."
2560 (calendar-gregorian-from-absolute
2561 (calendar-nth-named-absday n dayname month year day)))
2563 (defun calendar-day-of-year-string (&optional date)
2564 "String of day number of year of Gregorian DATE.
2565 Defaults to today's date if DATE is not given."
2566 (let* ((d (or date (calendar-current-date)))
2567 (year (calendar-extract-year d))
2568 (day (calendar-day-number d))
2569 (days-remaining (- (calendar-day-number (list 12 31 year)) day)))
2570 (format "Day %d of %d; %d day%s remaining in the year"
2571 day year days-remaining (if (= days-remaining 1) "" "s"))))
2573 (defun calendar-other-dates (date)
2574 "Return a list of strings giving Gregorian DATE in other calendars.
2575 DATE is (month day year). Calendars that do not apply are omitted."
2579 (calendar-day-of-year-string date)
2580 (format "ISO date: %s" (calendar-iso-date-string date))
2581 (format "Julian date: %s"
2582 (calendar-julian-date-string date))
2583 (format "Astronomical (Julian) day number (at noon UTC): %s.0"
2584 (calendar-astro-date-string date))
2585 (format "Fixed (RD) date: %s"
2586 (calendar-absolute-from-gregorian date))
2587 (format "Hebrew date (before sunset): %s"
2588 (calendar-hebrew-date-string date))
2589 (format "Persian date: %s"
2590 (calendar-persian-date-string date))
2591 (unless (string-equal
2592 (setq odate (calendar-islamic-date-string date))
2594 (format "Islamic date (before sunset): %s" odate))
2595 (unless (string-equal
2596 (setq odate (calendar-bahai-date-string date))
2598 (format "Bahá'í date: %s" odate))
2599 (format "Chinese date: %s"
2600 (calendar-chinese-date-string date))
2601 (unless (string-equal
2602 (setq odate (calendar-coptic-date-string date))
2604 (format "Coptic date: %s" odate))
2605 (unless (string-equal
2606 (setq odate (calendar-ethiopic-date-string date))
2608 (format "Ethiopic date: %s" odate))
2609 (unless (string-equal
2610 (setq odate (calendar-french-date-string date))
2612 (format "French Revolutionary date: %s" odate))
2613 (format "Mayan date: %s"
2614 (calendar-mayan-date-string date))))))
2616 (declare-function x-popup-menu "menu.c" (position menu))
2618 (defun calendar-print-other-dates (&optional event)
2619 "Show dates on other calendars for date under the cursor.
2620 If called by a mouse-event, pops up a menu with the result."
2621 (interactive (list last-nonmenu-event))
2622 (let* ((date (calendar-cursor-to-date t event))
2623 (title (format "%s (Gregorian)" (calendar-date-string date)))
2624 (others (calendar-other-dates date))
2626 (if (mouse-event-p event)
2627 (and (setq selection (cal-menu-x-popup-menu event title
2628 (mapcar 'list others)))
2629 (call-interactively selection))
2630 (calendar-in-read-only-buffer calendar-other-calendars-buffer
2631 (calendar-set-mode-line title)
2632 (insert (mapconcat 'identity others "\n"))))))
2634 (defun calendar-print-day-of-year ()
2635 "Show day number in year/days remaining in year for date under the cursor."
2637 (message "%s" (calendar-day-of-year-string (calendar-cursor-to-date t))))
2639 (defun calendar-set-mode-line (str)
2640 "Set mode line to STR, centered, surrounded by dashes."
2641 (let* ((edges (window-edges))
2642 ;; As per doc of window-width, total visible mode-line length.
2643 (width (- (nth 2 edges) (car edges))))
2644 ;; Hack for --daemon. See bug #2199.
2645 ;; If no frame exists yet, we have no idea what width to use.
2648 (setq width (string-to-number (or (getenv "COLUMNS") "80"))))
2649 (setq mode-line-format
2650 (if buffer-file-name
2651 `("-" mode-line-modified
2652 ,(calendar-string-spread (list str) ?- (- width 6))
2654 (calendar-string-spread (list str) ?- width)))))
2656 (define-obsolete-function-alias 'calendar-version 'emacs-version "23.1")
2658 (run-hooks 'calendar-load-hook)
2663 ;; byte-compile-dynamic: t
2667 ;;; calendar.el ends here