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