;;; calendar.el --- calendar functions
-;; Copyright (C) 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1997,
-;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1988-1995, 1997, 2000-2012 Free Software Foundation, Inc.
;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
;; Maintainer: Glenn Morris <rgm@gnu.org>
;; can be translated from the (usual) Gregorian calendar to the day of
;; the year/days remaining in year, to the ISO commercial calendar, to
;; the Julian (old style) calendar, to the Hebrew calendar, to the
-;; Islamic calendar, to the Baha'i calendar, to the French
+;; Islamic calendar, to the Bahá'í calendar, to the French
;; Revolutionary calendar, to the Mayan calendar, to the Chinese
;; calendar, to the Coptic calendar, to the Ethiopic calendar, and to
;; the astronomical (Julian) day number. Times of sunrise/sunset can
;; The following files are part of the calendar/diary code:
;; appt.el Appointment notification
-;; cal-bahai.el Baha'i calendar
+;; cal-bahai.el Bahá'í calendar
;; cal-china.el Chinese calendar
;; cal-coptic.el Coptic/Ethiopic calendars
;; cal-dst.el Daylight saving time rules
;;; Code:
-(require 'cal-loaddefs)
+(load "cal-loaddefs" nil t)
;; Avoid recursive load of calendar when loading cal-menu. Yuck.
(provide 'calendar)
:version "22.1"
:group 'calendar)
+;; See discussion in bug#1806.
+(defcustom calendar-split-width-threshold nil
+ "Value to use for `split-width-threshold' when creating a calendar.
+This only affects frames wider than the default value of
+`split-width-threshold'."
+ :type '(choice (const nil)
+ (integer))
+ :version "23.2"
+ :group 'calendar)
+
(defcustom calendar-week-start-day 0
"The day of the week on which a week in the calendar begins.
0 means Sunday (default), 1 means Monday, and so on.
(define-obsolete-variable-alias 'mark-diary-entries-in-calendar
'calendar-mark-diary-entries-flag "23.1")
+;; FIXME :set
(defcustom calendar-mark-diary-entries-flag nil
"Non-nil means mark dates with diary entries, in the calendar window.
The marking symbol is specified by the variable `diary-entry-marker'."
(defface calendar-today
'((t (:underline t)))
"Face for indicating today's date in the calendar.
-See `calendar-today-marker'."
+See the variable `calendar-today-marker'."
:group 'calendar-faces)
-;; Backward-compatibility alias. FIXME make obsolete.
-(put 'calendar-today-face 'face-alias 'calendar-today)
+
+(define-obsolete-face-alias 'calendar-today-face 'calendar-today "22.1")
(defface diary
'((((min-colors 88) (class color) (background light))
Used to mark diary entries in the calendar (see `diary-entry-marker'),
and to highlight the date header in the fancy diary."
:group 'calendar-faces)
-;; Backward-compatibility alias. FIXME make obsolete.
-(put 'diary-face 'face-alias 'diary)
+
+(define-obsolete-face-alias 'diary-face 'diary "22.1")
(defface holiday
'((((class color) (background light))
"Face for indicating in the calendar dates that have holidays.
See `calendar-holiday-marker'."
:group 'calendar-faces)
-;; Backward-compatibility alias. FIXME make obsolete.
-(put 'holiday-face 'face-alias 'holiday)
-;; These don't respect changes in font-lock-mode after loading.
-(defcustom diary-entry-marker (if (and font-lock-mode (display-color-p))
- 'diary
- "+")
+(define-obsolete-face-alias 'holiday-face 'holiday "22.1")
+
+;; These briefly checked font-lock-mode, but that is broken, since it
+;; is a buffer-local variable, and which buffer happens to be current
+;; when this file is loaded shouldn't make a difference. One could
+;; perhaps check global-font-lock-mode, or font-lock-global-modes; but
+;; this feature doesn't use font-lock, so there's no real reason it
+;; should respect those either. See bug#2199.
+;; They also used to check display-color-p, but that is a problem if
+;; loaded from --daemon. Since BW displays are rare now, this was
+;; also taken out. The way to keep it would be to have nil mean do a
+;; runtime check whenever this variable is used.
+(defcustom diary-entry-marker 'diary
"How to mark dates that have diary entries.
-The value can be either a single-character string or a face."
- :type '(choice string face)
- :group 'diary)
+The value can be either a single-character string (e.g. \"+\") or a face."
+ :type '(choice (string :tag "Single character string") face)
+ :group 'diary
+ :version "23.1")
-(defcustom calendar-today-marker (if (and font-lock-mode (display-color-p))
- 'calendar-today
- "=")
+(defcustom calendar-today-marker 'calendar-today
"How to mark today's date in the calendar.
-The value can be either a single-character string or a face.
+The value can be either a single-character string (e.g. \"=\") or a face.
Used by `calendar-mark-today'."
- :type '(choice string face)
- :group 'calendar)
+ :type '(choice (string :tag "Single character string") face)
+ :group 'calendar
+ :version "23.1")
-(defcustom calendar-holiday-marker (if (and font-lock-mode (display-color-p))
- 'holiday
- "*")
+(defcustom calendar-holiday-marker 'holiday
"How to mark notable dates in the calendar.
-The value can be either a single-character string or a face."
- :type '(choice string face)
- :group 'holidays)
+The value can be either a single-character string (e.g. \"*\") or a face."
+ :type '(choice (string :tag "Single character string") face)
+ :group 'holidays
+ :version "23.1")
(define-obsolete-variable-alias 'view-calendar-holidays-initially
'calendar-view-holidays-initially-flag "23.1")
(define-obsolete-variable-alias 'mark-holidays-in-calendar
'calendar-mark-holidays-flag "23.1")
+;; FIXME :set
(defcustom calendar-mark-holidays-flag nil
"Non-nil means mark dates of holidays in the calendar window.
The marking symbol is specified by the variable `calendar-holiday-marker'."
(defcustom calendar-date-echo-text
"mouse-2: general menu\nmouse-3: menu for this date"
"String displayed when the cursor is over a date in the calendar.
-When this variable is evaluated, DAY, MONTH, and YEAR are
+Can be either a fixed string, or a lisp expression that returns one.
+When this expression is evaluated, DAY, MONTH, and YEAR are
integers appropriate to the relevant date. For example, to
-display the ISO week:
-
- (require 'cal-iso)
- (setq calendar-date-echo-text '(format \"ISO week: %2d \"
- (car
- (calendar-iso-from-absolute
- (calendar-absolute-from-gregorian
- (list month day year))))))
+display the ISO date:
+
+ (setq calendar-date-echo-text '(format \"ISO date: %s\"
+ (calendar-iso-date-string
+ (list month day year))))
Changing this variable without using customize has no effect on
pre-existing calendar windows."
:group 'calendar
:set (lambda (sym val)
(set sym val)
(calendar-redraw))
- :type '(choice (string :tag "Literal string")
- (sexp :tag "Lisp expression"))
+ :type '(choice (string :tag "Fixed string")
+ (sexp :value
+ (format "ISO date: %s"
+ (calendar-iso-date-string
+ (list month day year)))))
:version "23.1")
(defvar calendar-right-margin nil
"Right margin of the calendar.")
+(defvar calendar-month-edges nil
+ "Alist of month edge columns.
+Each element has the form (N LEFT FIRST LAST RIGHT), where
+LEFT is the leftmost column associated with month segment N,
+FIRST and LAST are the first and last columns with day digits in,
+and LAST is the rightmost column.")
+
+(defun calendar-month-edges (segment)
+ "Compute the month edge columns for month SEGMENT.
+Returns a list (LEFT FIRST LAST RIGHT), where LEFT is the
+leftmost column associated with a month, FIRST and LAST are the
+first and last columns with day digits in, and LAST is the
+rightmost column."
+ ;; The leftmost column with a digit in it in this month segment.
+ (let* ((first (+ calendar-left-margin
+ (* segment calendar-month-width)))
+ ;; The rightmost column with a digit in it in this month segment.
+ (last (+ first (1- calendar-month-digit-width)))
+ (left (if (eq segment 0)
+ 0
+ (+ calendar-left-margin
+ (* segment calendar-month-width)
+ (- (/ calendar-intermonth-spacing 2)))))
+ ;; The rightmost edge of this month segment, dividing the
+ ;; space between months in two.
+ (right (+ calendar-left-margin
+ (* (1+ segment) calendar-month-width)
+ (- (/ calendar-intermonth-spacing 2)))))
+ (list left first last right)))
+
(defun calendar-recompute-layout-variables ()
"Recompute some layout-related calendar \"constants\"."
(setq calendar-month-digit-width (+ (* 6 calendar-column-width)
calendar-intermonth-spacing)
calendar-right-margin (+ calendar-left-margin
(* 3 (* 7 calendar-column-width))
- (* 2 calendar-intermonth-spacing))))
+ (* 2 calendar-intermonth-spacing))
+ calendar-month-edges nil)
+ (dotimes (i 3)
+ (push (cons i (calendar-month-edges i)) calendar-month-edges))
+ (setq calendar-month-edges (reverse calendar-month-edges)))
;; FIXME add font-lock-keywords.
(defun calendar-set-layout-variable (symbol value &optional minmax)
:type 'integer
:version "23.1")
+;; FIXME calendar-month-column-width?
(defcustom calendar-column-width 3
"Width of each day column in the calendar. Minimum value is 3."
:initialize 'custom-initialize-default
:type 'integer
:version "23.1")
+(defcustom calendar-intermonth-header nil
+ "Header text display in the space to the left of each calendar month.
+See `calendar-intermonth-text'."
+ :group 'calendar
+ :initialize 'custom-initialize-default
+ :risky t
+ :set (lambda (sym val)
+ (set sym val)
+ (calendar-redraw))
+ :type '(choice (const nil :tag "Nothing")
+ (string :tag "Fixed string")
+ (sexp :value
+ (propertize "WK" 'font-lock-face
+ 'font-lock-function-name-face)))
+ :version "23.1")
+
+(defcustom calendar-intermonth-text nil
+ "Text to display in the space to the left of each calendar month.
+Can be nil, a fixed string, or a lisp expression that returns a string.
+When the expression is evaluated, the variables DAY, MONTH and YEAR
+are integers appropriate for the first day in each week.
+Will be truncated to the smaller of `calendar-left-margin' and
+`calendar-intermonth-spacing'. The last character is forced to be a space.
+For example, to display the ISO week numbers:
+
+ (setq calendar-week-start-day 1
+ calendar-intermonth-text
+ '(propertize
+ (format \"%2d\"
+ (car
+ (calendar-iso-from-absolute
+ (calendar-absolute-from-gregorian (list month day year)))))
+ 'font-lock-face 'font-lock-function-name-face))
+
+See also `calendar-intermonth-header'."
+ :group 'calendar
+ :initialize 'custom-initialize-default
+ :risky t
+ :set (lambda (sym val)
+ (set sym val)
+ (calendar-redraw))
+ :type '(choice (const nil :tag "Nothing")
+ (string :tag "Fixed string")
+ (sexp :value
+ (propertize
+ (format "%2d"
+ (car
+ (calendar-iso-from-absolute
+ (calendar-absolute-from-gregorian
+ (list month day year)))))
+ 'font-lock-face 'font-lock-function-name-face)))
+ :version "23.1")
(defcustom diary-file "~/diary"
"Name of the file in which one's personal diary of dates is kept.
November 10, 1990. See the documentation for the function
`diary-list-sexp-entries' for more details.
-Diary entries based on the Hebrew, the Islamic and/or the Baha'i
+Diary entries based on the Hebrew, the Islamic and/or the Bahá'í
calendar are also possible, but because these are somewhat slow, they
are ignored unless you set the `diary-nongregorian-listing-hook' and
the `diary-nongregorian-marking-hook' appropriately. See the
'diary-bahai-entry-symbol "23.1")
(defcustom diary-bahai-entry-symbol "B"
- "Symbol indicating a diary entry according to the Baha'i calendar."
+ "Symbol indicating a diary entry according to the Bahá'í calendar."
:type 'string
:group 'diary)
(defcustom diary-iso-date-forms
'((month "[-/]" day "[^-/0-9]")
(year "[-/]" month "[-/]" day "[^0-9]")
- (monthname "-" day "[^-0-9]")
- (year "-" monthname "-" day "[^0-9]")
+ ;; Cannot allow [-/] as separators here, since it would also match
+ ;; the first element (bug#7377).
+ (monthname " *" day "[^-0-9]")
+ (year " *" monthname " *" day "[^0-9]")
(dayname "\\W"))
"List of pseudo-patterns describing the ISO style of dates.
-The defaults are: MONTH[-/]DAY; YEAR[-/]MONTH[-/]DAY; MONTHNAME-DAY;
-YEAR-MONTHNAME-DAY; DAYNAME. Normally you should not customize this,
+The defaults are: MONTH[-/]DAY; YEAR[-/]MONTH[-/]DAY; MONTHNAME DAY;
+YEAR MONTHNAME DAY; DAYNAME. Normally you should not customize this,
but `diary-date-forms' (which see)."
- :version "23.1"
+ :version "23.3" ; bug#7377
:type '(repeat (choice (cons :tag "Backup"
:value (backup . nil)
(const backup)
(repeat (list :inline t :format "%v"
(symbol :tag "Keyword")
(choice symbol regexp)))))
+ :set-after '(calendar-date-style diary-iso-date-forms
+ diary-european-date-forms
+ diary-american-date-forms)
:initialize 'custom-initialize-default
:set (lambda (symbol value)
(unless (equal value (eval symbol))
`calendar-american-date-display-form' provide some defaults for three common
styles."
:type 'sexp
+ :set-after '(calendar-date-style calendar-iso-date-display-form
+ calendar-european-date-display-form
+ calendar-american-date-display-form)
:group 'calendar)
(defun calendar-set-date-style (style)
'calendar-bahai-all-holidays-flag "23.1")
(defcustom calendar-bahai-all-holidays-flag nil
- "If nil, show only major holidays from the Baha'i calendar.
+ "If nil, show only major holidays from the Bahá'í calendar.
These are the days on which work and school must be suspended.
-Otherwise, show all the holidays that would appear in a complete Baha'i
+Otherwise, show all the holidays that would appear in a complete Bahá'í
calendar."
:type 'boolean
:group 'holidays)
(defconst lunar-phases-buffer "*Phases of Moon*"
"Name of the buffer used for the lunar phases.")
+(defconst solar-sunrises-buffer "*Sunrise/Sunset Times*"
+ "Name of buffer used for sunrise/sunset times.")
+
(defconst calendar-hebrew-yahrzeit-buffer "*Yahrzeits*"
"Name of the buffer used by `list-yahrzeit-dates'.")
,index (1+ ,index)))
sum))
-;; FIXME bind q to bury-buffer?
(defmacro calendar-in-read-only-buffer (buffer &rest body)
- "Switch to BUFFER and executes the forms in BODY.
+ "Switch to BUFFER and execute the forms in BODY.
First creates or erases BUFFER as needed. Leaves BUFFER read-only,
with disabled undo. Leaves point at point-min, displays BUFFER."
(declare (indent 1) (debug t))
`(progn
(set-buffer (get-buffer-create ,buffer))
+ (or (derived-mode-p 'special-mode) (special-mode))
(setq buffer-read-only nil
buffer-undo-list t)
(erase-buffer)
and year, else uses the current date. If NODISPLAY is non-nil, don't
display the generated calendar."
(interactive "P")
- (set-buffer (get-buffer-create calendar-buffer))
- (calendar-mode)
- (let* ((pop-up-windows t)
- (split-height-threshold 1000)
- (date (if arg (calendar-read-date t)
- (calendar-current-date)))
- (month (calendar-extract-month date))
- (year (calendar-extract-year date)))
- (calendar-increment-month month year (- calendar-offset))
- ;; Display the buffer before calling calendar-generate-window so that it
- ;; can get a chance to adjust the window sizes to the frame size.
- (or nodisplay (pop-to-buffer calendar-buffer))
- (calendar-generate-window month year)
- (if (and calendar-view-diary-initially-flag
- (calendar-date-is-visible-p date))
- (diary-view-entries)))
+ (let ((buff (current-buffer)))
+ (set-buffer (get-buffer-create calendar-buffer))
+ (calendar-mode)
+ (let* ((pop-up-windows t)
+ ;; Not really needed now, but means we use exactly the same
+ ;; behavior as before in the non-wide case (see below).
+ (split-height-threshold 1000)
+ (split-width-threshold calendar-split-width-threshold)
+ (date (if arg (calendar-read-date t)
+ (calendar-current-date)))
+ (month (calendar-extract-month date))
+ (year (calendar-extract-year date)))
+ (calendar-increment-month month year (- calendar-offset))
+ ;; Display the buffer before calling calendar-generate-window so that it
+ ;; can get a chance to adjust the window sizes to the frame size.
+ (unless nodisplay
+ ;; We want a window configuration that looks something like
+ ;; X X | Y
+ ;; - -----
+ ;; C Z | C
+ ;; where C is the calendar, and the LHS is the traditional,
+ ;; non-wide frame, and the RHS is the wide frame case.
+ ;; We should end up in the same state regardless of whether the
+ ;; windows were initially split or not.
+ ;; Previously, we only thought about the non-wide case.
+ ;; We could just set split-height-threshold to 1000, relying on
+ ;; the fact that the window splitting treated a single window as
+ ;; a special case and would always split it (vertically). The
+ ;; same thing does not work in the wide-frame case, so now we do
+ ;; the splitting by hand.
+ ;; See discussion in bug#1806.
+ ;; Actually, this still does not do quite the right thing in the
+ ;; wide frame case if started from a configuration like the LHS.
+ ;; Eg if you start with a non-wide frame, call calendar, then
+ ;; make the frame wider. This one is problematic because you
+ ;; might need to split a totally unrelated window. Oh well, it
+ ;; seems unlikely, and perhaps respecting the original layout is
+ ;; the right thing in that case.
+ ;;
+ ;; Is this a wide frame? If so, split it horizontally.
+ (if (window-splittable-p t) (split-window-right))
+ (pop-to-buffer calendar-buffer)
+ ;; Has the window already been split vertically?
+ (when (and (not (window-dedicated-p))
+ (window-full-height-p))
+ (let ((win (split-window-below)))
+ ;; In the upper window, show whatever was visible before.
+ ;; This looks better than using other-buffer.
+ (switch-to-buffer buff)
+ ;; Switch to the lower window with the calendar buffer.
+ (select-window win))))
+ (calendar-generate-window month year)
+ (if (and calendar-view-diary-initially-flag
+ (calendar-date-is-visible-p date))
+ (diary-view-entries))))
(if calendar-view-holidays-initially-flag
(let* ((diary-buffer (get-file-buffer diary-file))
(diary-window (if diary-buffer (get-buffer-window diary-buffer)))
(year (calendar-extract-year today))
(today-visible (or (not mon)
(<= (abs (calendar-interval mon yr month year)) 1)))
- (day-in-week (calendar-day-of-week today))
(in-calendar-window (eq (window-buffer (selected-window))
(get-buffer calendar-buffer))))
(calendar-generate (or mon month) (or yr year))
;; Don't do any window-related stuff if we weren't called from a
;; window displaying the calendar.
(when in-calendar-window
- (if (or (one-window-p t) (not (window-full-width-p)))
- ;; Don't mess with the window size, but ensure that the first
- ;; line is fully visible.
- (set-window-vscroll nil 0)
- ;; Adjust the window to exactly fit the displayed calendar.
- (fit-window-to-buffer nil nil calendar-minimum-window-height))
+ (if (window-combined-p)
+ ;; Adjust the window to exactly fit the displayed calendar.
+ (fit-window-to-buffer nil nil calendar-minimum-window-height)
+ ;; For a full height window or a window that is horizontally
+ ;; combined don't fit height to that of its buffer.
+ (set-window-vscroll nil 0))
(sit-for 0))
(and (bound-and-true-p font-lock-mode)
(font-lock-fontify-buffer))
(or (zerop (forward-line 1))
(insert "\n")))
+(defun calendar-insert-at-column (indent string truncate)
+ "Move to column INDENT, adding spaces as needed.
+Inserts STRING so that it ends at INDENT. STRING is either a
+literal string, or a sexp to evaluate to return such. Truncates
+STRING to length TRUNCATE, and ensures a trailing space."
+ (if (not (ignore-errors (stringp (setq string (eval string)))))
+ (calendar-move-to-column indent)
+ (if (> (string-width string) truncate)
+ (setq string (truncate-string-to-width string truncate)))
+ (or (string-match " $" string)
+ (setq string (concat (if (= (string-width string) truncate)
+ (substring string 0 -1)
+ string)
+ ;; Avoid inserting text properties unless
+ ;; we have to (ie, non-unit-width chars).
+ ;; This is by no means essential.
+ (if (= (string-width string) (length string))
+ " "
+ ;; Cribbed from buff-menu.el.
+ (propertize
+ " " 'display `(space :align-to ,indent))))))
+ (calendar-move-to-column (- indent (string-width string)))
+ (insert string)))
+
(defun calendar-generate-month (month year indent)
"Produce a calendar for MONTH, YEAR on the Gregorian calendar.
The calendar is inserted at the top of the buffer in which point is currently
calendar-week-start-day)
7))
(last (calendar-last-day-of-month month year))
- string day)
+ (trunc (min calendar-intermonth-spacing
+ (1- calendar-left-margin)))
+ (day 1)
+ string)
(goto-char (point-min))
(calendar-move-to-column indent)
(insert
(list (format "%s %d" (calendar-month-name month) year))
?\s calendar-month-digit-width))
(calendar-ensure-newline)
- (calendar-move-to-column indent) ; go to proper spot
+ (calendar-insert-at-column indent calendar-intermonth-header trunc)
;; Use the first two characters of each day to head the columns.
(dotimes (i 7)
(insert
(substring string 0 calendar-day-header-width)))
(make-string (- calendar-column-width calendar-day-header-width) ?\s)))
(calendar-ensure-newline)
- (calendar-move-to-column indent)
+ (calendar-insert-at-column indent calendar-intermonth-text trunc)
;; Add blank days before the first of the month.
(insert (make-string (* blank-days calendar-column-width) ?\s))
;; Put in the days of the month.
(dotimes (i last)
(setq day (1+ i))
- ;; TODO should numbers be left-justified, centred...?
+ ;; TODO should numbers be left-justified, centered...?
(insert (format (format "%%%dd%%s" calendar-day-digit-width) day
(make-string
(- calendar-column-width calendar-day-digit-width) ?\s)))
- ;; FIXME set-text-properties?
- (add-text-properties
+ ;; 'date property prevents intermonth text confusing re-searches.
+ ;; (Tried intangible, it did not really work.)
+ (set-text-properties
(- (point) (1+ calendar-day-digit-width)) (1- (point))
- `(mouse-face highlight help-echo ,(eval calendar-date-echo-text)))
- (and (zerop (mod (+ day blank-days) 7))
- (/= day last)
- (progn
- (calendar-ensure-newline)
- (calendar-move-to-column indent))))))
+ `(mouse-face highlight help-echo ,(eval calendar-date-echo-text)
+ date t))
+ (when (and (zerop (mod (+ day blank-days) 7))
+ (/= day last))
+ (calendar-ensure-newline)
+ (setq day (1+ day)) ; first day of next week
+ (calendar-insert-at-column indent calendar-intermonth-text trunc)))))
(defun calendar-redraw ()
"Redraw the calendar display, if `calendar-buffer' is live."
(define-key map "Aa" 'appt-add)
(define-key map "Ad" 'appt-delete)
(define-key map "S" 'calendar-sunrise-sunset)
- (define-key map "M" 'calendar-phases-of-moon)
+ (define-key map "M" 'calendar-lunar-phases)
(define-key map " " 'scroll-other-window)
(define-key map "\d" 'scroll-other-window-down)
(define-key map "\C-c\C-l" 'calendar-redraw)
(define-key map [menu-bar edit] 'undefined)
(define-key map [menu-bar search] 'undefined)
- (easy-menu-define nil map nil cal-menu-moon-menu)
+ (easy-menu-define nil map nil cal-menu-sunmoon-menu)
(easy-menu-define nil map nil cal-menu-diary-menu)
(easy-menu-define nil map nil cal-menu-holidays-menu)
(easy-menu-define nil map nil cal-menu-goto-menu)
(define-key map [down-mouse-2]
(easy-menu-binding cal-menu-global-mouse-menu))
+ ;; cf scroll-bar.el.
+ (if (and (boundp 'x-toolkit-scroll-bars) x-toolkit-scroll-bars)
+ (define-key map [vertical-scroll-bar mouse-1]
+ 'calendar-scroll-toolkit-scroll)
+ ;; Left-click moves us forward in time, right-click backwards.
+ (define-key map [vertical-scroll-bar mouse-1] 'calendar-scroll-left)
+ (define-key map [vertical-scroll-bar drag-mouse-1] 'calendar-scroll-left)
+ ;; down-mouse-2 stays as scroll-bar-drag.
+ (define-key map [vertical-scroll-bar mouse-3] 'calendar-scroll-right)
+ (define-key map [vertical-scroll-bar drag-mouse-3]
+ 'calendar-scroll-right))
map)
"Keymap for `calendar-mode'.")
(setq buffer-read-only t
buffer-undo-list t
indent-tabs-mode nil)
+ (set (make-local-variable 'scroll-margin) 0) ; bug#10379
(calendar-update-mode-line)
(make-local-variable 'calendar-mark-ring)
(make-local-variable 'displayed-month) ; month in middle of window
(if (< (length strings) 2)
(append (list "") strings (list ""))
strings)))
- (n (- length (length (apply 'concat strings))))
- (m (1- (length strings)))
+ (n (- length (string-width (apply 'concat strings))))
+ (m (* (1- (length strings)) (char-width char)))
(s (car strings))
(strings (cdr strings))
(i 0))
(make-string (max 0 (/ (+ n i) m)) char)
string)
i (1+ i)))
- (substring s 0 length)))
+ (truncate-string-to-width s length)))
(defun calendar-update-mode-line ()
"Update the calendar mode line with the current date and date style."
?\s (- calendar-right-margin (1- start))))))
(force-mode-line-update))))
-(defun calendar-window-list ()
- "List of all calendar-related windows."
- (let ((calendar-buffers (calendar-buffer-list))
- list)
- (walk-windows (lambda (w)
- (if (memq (window-buffer w) calendar-buffers)
- (push w list)))
- nil t)
- list))
-
(defun calendar-buffer-list ()
"List of all calendar-related buffers (as buffers, not strings)."
(let (buffs)
(dolist (b (list calendar-hebrew-yahrzeit-buffer lunar-phases-buffer
- holiday-buffer diary-fancy-buffer
+ holiday-buffer diary-fancy-buffer solar-sunrises-buffer
(get-file-buffer diary-file)
calendar-buffer calendar-other-calendars-buffer))
(and b (setq b (get-buffer b))
(push b buffs)))
buffs))
-(defun calendar-exit ()
+(defun calendar-exit (&optional kill)
"Get out of the calendar window and hide it and related buffers."
- (interactive)
- (let ((diary-buffer (get-file-buffer diary-file)))
- (if (or (not diary-buffer)
- (not (buffer-modified-p diary-buffer))
- (yes-or-no-p
- "Diary modified; do you really want to exit the calendar? "))
- ;; Need to do this multiple times because one time can replace some
- ;; calendar-related buffers with other calendar-related buffers.
- (mapc (lambda (x)
- (mapc 'calendar-hide-window (calendar-window-list)))
- (calendar-window-list)))))
+ (interactive "P")
+ (let ((diary-buffer (get-file-buffer diary-file))
+ (calendar-buffers (calendar-buffer-list)))
+ (when (or (not diary-buffer)
+ (not (buffer-modified-p diary-buffer))
+ (yes-or-no-p
+ "Diary modified; do you really want to exit the calendar? "))
+ (if (and calendar-setup (display-multi-frame-p))
+ ;; FIXME: replace this cruft with the `quit-restore' window property
+ (dolist (w (window-list-1 nil nil t))
+ (if (and (memq (window-buffer w) calendar-buffers)
+ (window-dedicated-p w))
+ (if (eq (window-deletable-p w) 'frame)
+ (if calendar-remove-frame-by-deleting
+ (delete-frame (window-frame w))
+ (iconify-frame (window-frame w)))
+ (quit-window kill w))))
+ (dolist (b calendar-buffers)
+ (quit-windows-on b kill))))))
(define-obsolete-function-alias 'exit-calendar 'calendar-exit "23.1")
-(defun calendar-hide-window (window)
- "Hide WINDOW if it is calendar-related."
- (let ((buffer (if (window-live-p window) (window-buffer window))))
- (if (memq buffer (calendar-buffer-list))
- (cond
- ((and (display-multi-frame-p)
- (eq 'icon (cdr (assoc 'visibility
- (frame-parameters
- (window-frame window))))))
- nil)
- ((and (display-multi-frame-p) (window-dedicated-p window))
- (if calendar-remove-frame-by-deleting
- (delete-frame (window-frame window))
- (iconify-frame (window-frame window))))
- ((not (and (select-window window) (one-window-p window)))
- (delete-window window))
- (t (set-buffer buffer)
- (bury-buffer))))))
-
-(defun calendar-current-date ()
- "Return the current date in a list (month day year)."
- (let ((now (decode-time)))
- (list (nth 4 now) (nth 3 now) (nth 5 now))))
-
-(defun calendar-column-to-month (&optional real)
- "Convert current column to calendar month offset number (leftmost is 0).
-If the cursor is in the right margin (i.e. beyond the last digit) of
-month N, returns -(N+1). If optional REAL is non-nil, return a
-cons (month year), where month is the real month number (1-12)."
- (let* ((ccol (current-column))
- (col (max 0 (+ ccol (/ calendar-intermonth-spacing 2)
- (- calendar-left-margin))))
- (segment (/ col (+ (* 7 calendar-column-width)
- calendar-intermonth-spacing)))
- month year lastdigit edge)
- (if real
- (progn
- ;; NB assumes 3 month display.
- (if (zerop (setq month (% (+ displayed-month segment -1) 12)))
- (setq month 12))
- (setq year (cond
- ((and (= 12 month) (zerop segment)) (1- displayed-year))
- ((and (= 1 month) (= segment 2)) (1+ displayed-year))
- (t displayed-year)))
- (cons month year))
- ;; The rightmost column with a digit in it in this month segment.
- (setq lastdigit (+ calendar-left-margin
- calendar-month-digit-width -1
- (* segment calendar-month-width))
- ;; The rightmost edge of this month segment, dividing the
- ;; space between months in two.
- edge (+ calendar-left-margin
- (* (1+ segment) calendar-month-width)
- (- (/ calendar-intermonth-spacing 2))))
- (if (and (> ccol lastdigit) (< ccol edge))
- (- (1+ segment))
- segment))))
+(defun calendar-current-date (&optional offset)
+ "Return the current date in a list (month day year).
+Optional integer OFFSET is a number of days from the current date."
+ (let* ((now (decode-time))
+ (now (list (nth 4 now) (nth 3 now) (nth 5 now))))
+ (if (zerop (or offset 0))
+ now
+ (calendar-gregorian-from-absolute
+ (+ offset (calendar-absolute-from-gregorian now))))))
+
+(defun calendar-column-to-segment ()
+ "Convert current column to calendar month \"segment\".
+The left-most month returns 0, the next right 1, and so on."
+ (let ((col (max 0 (+ (current-column)
+ (/ calendar-intermonth-spacing 2)
+ (- calendar-left-margin)))))
+ (/ col (+ (* 7 calendar-column-width) calendar-intermonth-spacing))))
(defun calendar-cursor-to-date (&optional error event)
"Return a list (month day year) of current cursor position.
(if event (window-buffer (posn-window (event-start event)))
(current-buffer))
(save-excursion
- (if event (goto-char (posn-point (event-start event))))
- (let* ((month (calendar-column-to-month t))
- (year (cdr month))
- (month (car month)))
+ (and event (setq event (event-start event))
+ (goto-char (posn-point event)))
+ (let* ((segment (calendar-column-to-segment))
+ (month (% (+ displayed-month (1- segment)) 12)))
;; Call with point on either of the two digits in a 2-digit date,
;; or on or before the digit of a 1-digit date.
(if (not (and (looking-at "[ 0-9]?[0-9][^0-9]")
- (>= (count-lines (point-min) (point))
- calendar-first-date-row)))
- (if error (error "Not on a date!"))
+ (get-text-property (point) 'date)))
+ (if error (user-error "Not on a date!"))
+ ;; Convert segment to real month and year.
+ (if (zerop month) (setq month 12))
;; Go back to before the first date digit.
(or (looking-at " ")
(re-search-backward "[^0-9]"))
(string-to-number
(buffer-substring (1+ (point))
(+ 1 calendar-day-digit-width (point))))
- year))))))
-
-(add-to-list 'debug-ignored-errors "Not on a date!")
+ (cond
+ ((and (= 12 month) (zerop segment)) (1- displayed-year))
+ ((and (= 1 month) (= segment 2)) (1+ displayed-year))
+ (t displayed-year))))))))
;; The following version of calendar-gregorian-from-absolute is preferred for
;; reasons of clarity, BUT it's much slower than the version that follows it.
value))
-(defvar calendar-abbrev-length 3
- "*Length of abbreviations to be used for day and month names.
-See also `calendar-day-abbrev-array' and `calendar-month-abbrev-array'.")
+(defun calendar-customized-p (symbol)
+ "Return non-nil if SYMBOL has been customized."
+ (and (default-boundp symbol)
+ (let ((standard (get symbol 'standard-value)))
+ (and standard
+ (not (equal (eval (car standard)) (default-value symbol)))))))
+
+(defun calendar-abbrev-construct (full)
+ "From sequence FULL, return a vector of abbreviations.
+Each abbreviation is no longer than `calendar-abbrev-length' characters."
+ (apply 'vector (mapcar
+ (lambda (f)
+ (substring f 0 (min calendar-abbrev-length (length f))))
+ full)))
-;; FIXME does it have to start from Sunday?
(defcustom calendar-day-name-array
["Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"]
- "Array of capitalized strings giving, in order, the day names.
+ "Array of capitalized strings giving, in order from Sunday, the day names.
The first two characters of each string will be used to head the
-day columns in the calendar. See also the variable
-`calendar-day-abbrev-array'."
+day columns in the calendar.
+If you change this without using customize after the calendar has loaded,
+then you may also want to change `calendar-day-abbrev-array'."
:group 'calendar
+ :initialize 'custom-initialize-default
+ :set (lambda (symbol value)
+ (let ((dcustomized (calendar-customized-p 'calendar-day-abbrev-array))
+ (hcustomized (calendar-customized-p 'cal-html-day-abbrev-array)))
+ (set symbol value)
+ (or dcustomized
+ (setq calendar-day-abbrev-array
+ (calendar-abbrev-construct calendar-day-name-array)))
+ (and (not hcustomized)
+ (boundp 'cal-html-day-abbrev-array)
+ (setq cal-html-day-abbrev-array calendar-day-abbrev-array))))
:type '(vector (string :tag "Sunday")
(string :tag "Monday")
(string :tag "Tuesday")
(string :tag "Friday")
(string :tag "Saturday")))
-(defvar calendar-day-abbrev-array
- [nil nil nil nil nil nil nil]
- "*Array of capitalized strings giving the abbreviated day names.
+(defcustom calendar-abbrev-length 3
+ "Default length of abbreviations to use for day and month names.
+If you change this without using customize after the calendar has loaded,
+then you may also want to change `calendar-day-abbrev-array' and
+`calendar-month-abbrev-array'."
+ :group 'calendar
+ :initialize 'custom-initialize-default
+ :set (lambda (symbol value)
+ (let ((dcustomized (calendar-customized-p 'calendar-day-abbrev-array))
+ (mcustomized (calendar-customized-p
+ 'calendar-month-abbrev-array))
+ (hcustomized (calendar-customized-p 'cal-html-day-abbrev-array)))
+ (set symbol value)
+ (or dcustomized
+ (setq calendar-day-abbrev-array
+ (calendar-abbrev-construct calendar-day-name-array)))
+ (or mcustomized
+ (setq calendar-month-abbrev-array
+ (calendar-abbrev-construct calendar-month-name-array)))
+ (and (not hcustomized)
+ (boundp 'cal-html-day-abbrev-array)
+ (setq cal-html-day-abbrev-array calendar-day-abbrev-array))))
+ :type 'integer)
+
+(defcustom calendar-day-abbrev-array
+ (calendar-abbrev-construct calendar-day-name-array)
+ "Array of capitalized strings giving the abbreviated day names.
The order should be the same as that of the full names specified
in `calendar-day-name-array'. These abbreviations may be used
instead of the full names in the diary file. Do not include a
trailing `.' in the strings specified in this variable, though
-you may use such in the diary file. If any element of this array
-is nil, then the abbreviation will be constructed as the first
-`calendar-abbrev-length' characters of the corresponding full name.")
+you may use such in the diary file. By default, each string is
+the first `calendar-abbrev-length' characters of the corresponding
+full name."
+ :group 'calendar
+ :initialize 'custom-initialize-default
+ :set-after '(calendar-abbrev-length calendar-day-name-array)
+ :set (lambda (symbol value)
+ (let ((hcustomized (calendar-customized-p 'cal-html-day-abbrev-array)))
+ (set symbol value)
+ (and (not hcustomized)
+ (boundp 'cal-html-day-abbrev-array)
+ (setq cal-html-day-abbrev-array calendar-day-abbrev-array))))
+ :type '(vector (string :tag "Sun")
+ (string :tag "Mon")
+ (string :tag "Tue")
+ (string :tag "Wed")
+ (string :tag "Thu")
+ (string :tag "Fri")
+ (string :tag "Sat"))
+ ;; Made defcustom, changed defaults from nil nil...
+ :version "24.1")
(defcustom calendar-month-name-array
["January" "February" "March" "April" "May" "June"
"July" "August" "September" "October" "November" "December"]
"Array of capitalized strings giving, in order, the month names.
-See also the variable `calendar-month-abbrev-array'."
+If you change this without using customize after the calendar has loaded,
+then you may also want to change `calendar-month-abbrev-array'."
:group 'calendar
+ :initialize 'custom-initialize-default
+ :set (lambda (symbol value)
+ (let ((mcustomized (calendar-customized-p
+ 'calendar-month-abbrev-array)))
+ (set symbol value)
+ (or mcustomized
+ (setq calendar-month-abbrev-array
+ (calendar-abbrev-construct calendar-month-name-array)))))
:type '(vector (string :tag "January")
(string :tag "February")
(string :tag "March")
(string :tag "November")
(string :tag "December")))
-(defvar calendar-month-abbrev-array
- [nil nil nil nil nil nil nil nil nil nil nil nil]
- "*Array of capitalized strings giving the abbreviated month names.
+(defcustom calendar-month-abbrev-array
+ (calendar-abbrev-construct calendar-month-name-array)
+ "Array of capitalized strings giving the abbreviated month names.
The order should be the same as that of the full names specified
in `calendar-month-name-array'. These abbreviations are used in
the calendar menu entries, and can also be used in the diary
file. Do not include a trailing `.' in the strings specified in
-this variable, though you may use such in the diary file. If any
-element of this array is nil, then the abbreviation will be
-constructed as the first `calendar-abbrev-length' characters of the
-corresponding full name.")
-
-(defun calendar-make-alist (sequence &optional start-index filter abbrevs)
- "Make an assoc list corresponding to SEQUENCE.
-Each element of sequence will be associated with an integer, starting
-from 1, or from START-INDEX if that is non-nil. If a sequence ABBREVS
-is supplied, the function `calendar-abbrev-construct' is used to
-construct abbreviations corresponding to the elements in SEQUENCE.
-Each abbreviation is entered into the alist with the same
-association index as the full name it represents.
-If FILTER is provided, apply it to each key in the alist."
- (let ((index 0)
- (offset (or start-index 1))
- (aseq (if abbrevs (calendar-abbrev-construct abbrevs sequence)))
- (aseqp (if abbrevs (calendar-abbrev-construct abbrevs sequence
- 'period)))
- alist elem)
- (dotimes (i (length sequence) (reverse alist))
- (setq index (+ i offset)
- elem (elt sequence i)
- alist
- (cons (cons (if filter (funcall filter elem) elem) index) alist))
- (if aseq
- (setq elem (elt aseq i)
- alist (cons (cons (if filter (funcall filter elem) elem)
- index) alist)))
- (if aseqp
- (setq elem (elt aseqp i)
- alist (cons (cons (if filter (funcall filter elem) elem)
- index) alist))))))
+this variable, though you may use such in the diary file. By
+default, each string is the first ``calendar-abbrev-length'
+characters of the corresponding full name."
+ :group 'calendar
+ :set-after '(calendar-abbrev-length calendar-month-name-array)
+ :type '(vector (string :tag "Jan")
+ (string :tag "Feb")
+ (string :tag "Mar")
+ (string :tag "Apr")
+ (string :tag "May")
+ (string :tag "Jun")
+ (string :tag "Jul")
+ (string :tag "Aug")
+ (string :tag "Sep")
+ (string :tag "Oct")
+ (string :tag "Nov")
+ (string :tag "Dec"))
+ ;; Made defcustom, changed defaults from nil nil...
+ :version "24.1")
+
+(defun calendar-make-alist (sequence &optional start-index filter
+ &rest sequences)
+ "Return an association list corresponding to SEQUENCE.
+Associates each element of SEQUENCE with an incremented integer,
+starting from START-INDEX (default 1). Applies the function FILTER,
+if provided, to each key in the alist. Repeats the process, with
+indices starting from START-INDEX each time, for any remaining
+arguments SEQUENCES."
+ (or start-index (setq start-index 1))
+ (let (index alist)
+ (mapc (lambda (seq)
+ (setq index start-index)
+ (mapc (lambda (elem)
+ (setq alist (cons
+ (cons (if filter (funcall filter elem) elem)
+ index)
+ alist)
+ index (1+ index)))
+ seq))
+ (append (list sequence) sequences))
+ (reverse alist)))
(defun calendar-read-date (&optional noday)
"Prompt for Gregorian date. Return a list (month day year).
(+ (* 12 (- yr2 yr1))
(- mon2 mon1)))
-(defun calendar-abbrev-construct (abbrev full &optional period)
- "Internal calendar function to return a complete abbreviation array.
-ABBREV is an array of abbreviations, FULL the corresponding array
-of full names. The return value is the ABBREV array, with any nil
-elements replaced by the first three characters taken from the
-corresponding element of FULL. If optional argument PERIOD is non-nil,
-each element returned has a final `.' character."
- (let (elem array name)
- (dotimes (i (length full))
- (setq name (aref full i)
- elem (or (aref abbrev i)
- (substring name 0
- (min calendar-abbrev-length (length name))))
- elem (format "%s%s" elem (if period "." ""))
- array (append array (list elem))))
- (vconcat array)))
-
(defvar calendar-font-lock-keywords
`((,(concat (regexp-opt (mapcar 'identity calendar-month-name-array) t)
" -?[0-9]+")
week. Day names are taken from the variable `calendar-day-name-array',
unless the optional argument ABBREV is non-nil, in which case
the variable `calendar-day-abbrev-array' is used."
- (aref (if abbrev
- (calendar-abbrev-construct calendar-day-abbrev-array
- calendar-day-name-array)
- calendar-day-name-array)
+ (aref (if abbrev calendar-day-abbrev-array calendar-day-name-array)
(if absolute date (calendar-day-of-week date))))
(defun calendar-month-name (month &optional abbrev)
variable `calendar-month-name-array', unless the optional
argument ABBREV is non-nil, in which case
`calendar-month-abbrev-array' is used."
- (aref (if abbrev
- (calendar-abbrev-construct calendar-month-abbrev-array
- calendar-month-name-array)
- calendar-month-name-array)
+ (aref (if abbrev calendar-month-abbrev-array calendar-month-name-array)
(1- month)))
(defun calendar-day-of-week (date)
interpreted as BC; -1 being 1 BC, and so on."
(mod (calendar-absolute-from-gregorian date) 7))
+(defun calendar-week-end-day ()
+ "Return the index (0 for Sunday, etc.) of the last day of the week."
+ (mod (+ calendar-week-start-day 6) 7))
+
(defun calendar-unmark ()
"Delete all diary/holiday marks/highlighting from the calendar."
(interactive)
(calendar-cursor-to-visible-date date)
(setq mark
(or (and (stringp mark) (= (length mark) 1) mark) ; single-char
- (and font-lock-mode
- (or
+ ;; The next two use to also check font-lock-mode.
+ ;; See comments above diary-entry-marker for why
+ ;; this was dropped.
+;;; (and font-lock-mode
+;;; (or
(and (listp mark) (> (length mark) 0) mark) ; attrs
- (and (facep mark) mark))) ; face-name
- diary-entry-marker))
+ (and (facep mark) mark) ; )) face-name
+ diary-entry-marker))
(cond
;; Face or an attr-list that contained a face.
((facep mark)
this function to `calendar-today-visible-hook'."
(calendar-mark-visible-date (calendar-cursor-to-date) calendar-today-marker))
+;; FIXME why the car? Almost every usage calls list on the args.
(defun calendar-date-compare (date1 date2)
"Return t if DATE1 is before DATE2, nil otherwise.
The actual dates are in the car of DATE1 and DATE2."
(unless (string-equal
(setq odate (calendar-bahai-date-string date))
"")
- (format "Baha'i date: %s" odate))
+ (format "Bahá'í date: %s" odate))
(format "Chinese date: %s"
(calendar-chinese-date-string date))
(unless (string-equal
(format "Mayan date: %s"
(calendar-mayan-date-string date))))))
-(defun calendar-print-other-dates ()
- "Show dates on other calendars for date under the cursor."
- (interactive)
- (let ((date (calendar-cursor-to-date t)))
- (calendar-in-read-only-buffer calendar-other-calendars-buffer
- (calendar-set-mode-line (format "%s (Gregorian)"
- (calendar-date-string date)))
- (insert (mapconcat 'identity (calendar-other-dates date) "\n")))))
+(declare-function x-popup-menu "menu.c" (position menu))
+
+(defun calendar-print-other-dates (&optional event)
+ "Show dates on other calendars for date under the cursor.
+If called by a mouse-event, pops up a menu with the result."
+ (interactive (list last-nonmenu-event))
+ (let* ((date (calendar-cursor-to-date t event))
+ (title (format "%s (Gregorian)" (calendar-date-string date)))
+ (others (calendar-other-dates date))
+ selection)
+ (if (mouse-event-p event)
+ (and (setq selection (cal-menu-x-popup-menu event title
+ (mapcar 'list others)))
+ (call-interactively selection))
+ (calendar-in-read-only-buffer calendar-other-calendars-buffer
+ (calendar-set-mode-line title)
+ (insert (mapconcat 'identity others "\n"))))))
(defun calendar-print-day-of-year ()
"Show day number in year/days remaining in year for date under the cursor."
(let* ((edges (window-edges))
;; As per doc of window-width, total visible mode-line length.
(width (- (nth 2 edges) (car edges))))
+ ;; Hack for --daemon. See bug #2199.
+ ;; If no frame exists yet, we have no idea what width to use.
+ (and (= width 10)
+ (not window-system)
+ (setq width (string-to-number (or (getenv "COLUMNS") "80"))))
(setq mode-line-format
(if buffer-file-name
`("-" mode-line-modified
;; Local variables:
;; byte-compile-dynamic: t
+;; coding: utf-8
;; End:
-;; arch-tag: 19c61596-c8fb-4c69-bcf1-7dd739919cd8
;;; calendar.el ends here