-;;; calendar.el --- Calendar functions.
+;;; calendar.el --- calendar functions
-;; Copyright (C) 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1997
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1997,
+;; 2000, 2001, 2003 Free Software Foundation, Inc.
;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
;; Keywords: calendar
;;; Code:
+(eval-when-compile
+ (defvar displayed-month)
+ (defvar displayed-year)
+ (defvar calendar-month-name-array)
+ (defvar calendar-starred-day))
+
(defun calendar-version ()
(interactive)
(message "Version 6, October 12, 1995"))
;;;###autoload
(defcustom number-of-diary-entries 1
"*Specifies how many days of diary entries are to be displayed initially.
-This variable affects the diary display when the command M-x diary is used,
+This variable affects the diary display when the command \\[diary] is used,
or if the value of the variable `view-diary-entries-initially' is t. For
example, if the default value 1 is used, then only the current day's diary
entries will be displayed. If the value 2 is used, then both the current
:type 'boolean
:group 'diary)
-(when window-system
- (add-to-list 'facemenu-unlisted-faces 'diary-face)
- (defface diary-face
- '((((class color))
- (:foreground "red"))
- (t (:bold t)))
- "Face for highlighting diary entries."
- :group 'diary)
-
- (add-to-list 'facemenu-unlisted-faces 'calendar-today-face)
- (defface calendar-today-face
- '((t (:underline t)))
- "Face for indicating today's date."
- :group 'diary)
-
- (add-to-list 'facemenu-unlisted-faces 'holiday-face)
- (defface holiday-face
- '((((class color))
- (:background "pink"))
- (t (:inverse-video t)))
- "Face for indicating dates that have holidays."
- :group 'diary))
+;;;###autoload
+(defcustom calendar-remove-frame-by-deleting nil
+ "*Determine how the calendar mode removes a frame no longer needed.
+If nil, make an icon of the frame. If non-nil, delete the frame."
+ :type 'boolean
+ :group 'view)
+
+(defvar diary-face 'diary-face
+ "Face name to use for diary entries.")
+(defface diary-face
+ '((((class color) (background light))
+ :foreground "red")
+ (((class color) (background dark))
+ :foreground "yellow")
+ (t
+ :weight bold))
+ "Face for highlighting diary entries."
+ :group 'diary)
+
+(defface calendar-today-face
+ '((t (:underline t)))
+ "Face for indicating today's date."
+ :group 'diary)
+
+(defface holiday-face
+ '((((class color) (background light))
+ :background "pink")
+ (((class color) (background dark))
+ :background "chocolate4")
+ (t
+ :inverse-video t))
+ "Face for indicating dates that have holidays."
+ :group 'diary)
+
+(eval-after-load "facemenu"
+ '(progn
+ (add-to-list 'facemenu-unlisted-faces 'diary-face)
+ (add-to-list 'facemenu-unlisted-faces 'calendar-today-face)
+ (add-to-list 'facemenu-unlisted-faces 'holiday-face)))
(defcustom diary-entry-marker
- (if (not window-system)
+ (if (not (display-color-p))
"+"
'diary-face)
"*How to mark dates that have diary entries.
:group 'diary)
(defcustom calendar-today-marker
- (if (not window-system)
+ (if (not (display-color-p))
"="
'calendar-today-face)
"*How to mark today's date in the calendar.
:group 'calendar)
(defcustom calendar-holiday-marker
- (if (not window-system)
+ (if (not (display-color-p))
"*"
'holiday-face)
"*How to mark notable dates in the calendar.
:type 'boolean
:group 'holidays)
+(defcustom diary-file-name-prefix-function (function (lambda (str) str))
+ "*The function that will take a diary file name and return the desired prefix."
+ :type 'function
+ :group 'diary)
+
;;;###autoload
(defcustom calendar-load-hook nil
"*List of functions to be called after the calendar is first loaded.
:type 'hook
:group 'calendar-hooks)
+;;;###autoload
+(defcustom calendar-move-hook nil
+ "*List of functions called whenever the cursor moves in the calendar.
+
+For example,
+
+ (add-hook 'calendar-move-hook (lambda () (view-diary-entries 1)))
+
+redisplays the diary for whatever date the cursor is moved to."
+ :type 'hook
+ :group 'calendar-hooks)
+
;;;###autoload
(defcustom diary-file "~/diary"
"*Name of the file in which one's personal diary of dates is kept.
-The file's entries are lines in any of the forms
+The file's entries are lines beginning with any of the forms
+specified by the variable `american-date-diary-pattern', by default:
MONTH/DAY
MONTH/DAY/YEAR
MONTHNAME DAY, YEAR
DAYNAME
-at the beginning of the line; the remainder of the line is the diary entry
-string for that date. MONTH and DAY are one or two digit numbers, YEAR is
-a number and may be written in full or abbreviated to the final two digits.
-If the date does not contain a year, it is generic and applies to any year.
-DAYNAME entries apply to any date on which is on that day of the week.
-MONTHNAME and DAYNAME can be spelled in full, abbreviated to three
-characters (with or without a period), capitalized or not. Any of DAY,
-MONTH, or MONTHNAME, YEAR can be `*' which matches any day, month, or year,
-respectively.
-
-The European style (in which the day precedes the month) can be used
-instead, if you execute `european-calendar' when in the calendar, or set
-`european-calendar-style' to t in your .emacs file. The European forms are
+with the remainder of the line being the diary entry string for
+that date. MONTH and DAY are one or two digit numbers, YEAR is a
+number and may be written in full or abbreviated to the final two
+digits (if `abbreviated-calendar-year' is non-nil). MONTHNAME
+and DAYNAME can be spelled in full (as specified by the variables
+`calendar-month-name-array' and `calendar-day-name-array'),
+abbreviated (as specified by `calendar-month-abbrev-array' and
+`calendar-day-abbrev-array') with or without a period,
+capitalized or not. Any of DAY, MONTH, or MONTHNAME, YEAR can be
+`*' which matches any day, month, or year, respectively. If the
+date does not contain a year, it is generic and applies to any
+year. A DAYNAME entry applies to the appropriate day of the week
+in every week.
+
+The European style (in which the day precedes the month) can be
+used instead, if you execute `european-calendar' when in the
+calendar, or set `european-calendar-style' to t in your .emacs
+file. The European forms (see `european-date-diary-pattern') are
DAY/MONTH
DAY/MONTH/YEAR
:type 'string
:group 'diary)
+(defcustom diary-glob-file-regexp-prefix "^\\#"
+ "*The regular expression that gets pre-pended to each of the attribute-regexp's for file-wide specifiers."
+ :type 'regexp
+ :group 'diary)
+
+(defcustom diary-face-attrs
+ '((" *\\[foreground:\\([-a-z]+\\)\\]$" 1 :foreground string)
+ (" *\\[background:\\([-a-z]+\\)\\]$" 1 :background string)
+ (" *\\[width:\\([-a-z]+\\)\\]$" 1 :width symbol)
+ (" *\\[height:\\([-0-9a-z]+\\)\\]$" 1 :height int)
+ (" *\\[weight:\\([-a-z]+\\)\\]$" 1 :weight symbol)
+ (" *\\[slant:\\([-a-z]+\\)\\]$" 1 :slant symbol)
+ (" *\\[underline:\\([-a-z]+\\)\\]$" 1 :underline stringtnil)
+ (" *\\[overline:\\([-a-z]+\\)\\]$" 1 :overline stringtnil)
+ (" *\\[strike-through:\\([-a-z]+\\)\\]$" 1 :strike-through stringtnil)
+ (" *\\[inverse-video:\\([-a-z]+\\)\\]$" 1 :inverse-video tnil)
+ (" *\\[face:\\([-0-9a-z]+\\)\\]$" 1 :face string)
+ (" *\\[font:\\([-a-z0-9]+\\)\\]$" 1 :font string)
+ ;; Unsupported.
+;;; (" *\\[box:\\([-a-z]+\\)\\]$" 1 :box)
+;;; (" *\\[stipple:\\([-a-z]+\\)\\]$" 1 :stipple)
+ )
+ "*A list of (regexp regnum attr attrtype) lists where the
+regexp says how to find the tag, the regnum says which
+parenthetical sub-regexp this regexp looks for, and the attr says
+which attribute of the face (or that this _is_ a face) is being
+modified."
+ :type 'sexp
+ :group 'diary)
+
+(defcustom diary-file-name-prefix nil
+ "If non-nil each diary entry is prefixed with the name of the file where it is defined."
+ :type 'boolean
+ :group 'diary)
+
;;;###autoload
(defcustom sexp-diary-entry-symbol "%%"
- "*The string used to indicate a sexp diary entry in diary-file.
+ "*The string used to indicate a sexp diary entry in `diary-file'.
See the documentation for the function `list-sexp-diary-entries'."
:type 'string
:group 'diary)
(defcustom european-calendar-style nil
"*Use the European style of dates in the diary and in any displays.
If this variable is t, a date 1/2/1990 would be interpreted as February 1,
-1990. The accepted European date styles are
+1990. The default European date styles (see `european-date-diary-pattern')
+are
DAY/MONTH
DAY/MONTH/YEAR
DAY MONTHNAME YEAR
DAYNAME
-Names can be capitalized or not, written in full, or abbreviated to three
-characters with or without a period."
+Names can be capitalized or not, written in full (as specified by the
+variable `calendar-day-name-array'), or abbreviated (as specified by
+`calendar-day-abbrev-array') with or without a period."
:type 'boolean
:group 'diary)
(defcustom european-date-diary-pattern
'((day "/" month "[^/0-9]")
(day "/" month "/" year "[^0-9]")
- (backup day " *" monthname "\\W+\\<[^*0-9]")
+ (backup day " *" monthname "\\W+\\<\\([^*0-9]\\|\\([0-9]+[:aApP]\\)\\)")
(day " *" monthname " *" year "[^0-9]")
(dayname "\\W"))
"*List of pseudo-patterns describing the European patterns of date used.
european-date-diary-pattern
american-date-diary-pattern)
"*List of pseudo-patterns describing the forms of date used in the diary.
-The patterns on the list must be MUTUALLY EXCLUSIVE and must should not match
+The patterns on the list must be MUTUALLY EXCLUSIVE and should not match
any portion of the diary entry itself, just the date component.
A pseudo-pattern is a list of regular expressions and the keywords `month',
`day', `year', `monthname', and `dayname'. The keyword `monthname' will
-match the name of the month, capitalized or not, or its three-letter
-abbreviation, followed by a period or not; it will also match `*'.
-Similarly, `dayname' will match the name of the day, capitalized or not, or
-its three-letter abbreviation, followed by a period or not. The keywords
-`month', `day', and `year' will match those numerical values, preceded by
-arbitrarily many zeros; they will also match `*'.
+match the name of the month (see `calendar-month-name-array'), capitalized
+or not, or its user-specified abbreviation (see `calendar-month-abbrev-array'),
+followed by a period or not; it will also match `*'. Similarly, `dayname'
+will match the name of the day (see `calendar-day-name-array'), capitalized or
+not, or its user-specified abbreviation (see `calendar-day-abbrev-array'),
+followed by a period or not. The keywords `month', `day', and `year' will
+match those numerical values, preceded by arbitrarily many zeros; they will
+also match `*'.
The matching of the diary entries with the date forms is done with the
standard syntax table from Fundamental mode, but with the `*' changed so
(defcustom european-calendar-display-form
'((if dayname (concat dayname ", ")) day " " monthname " " year)
"*Pseudo-pattern governing the way a date appears in the European style.
-See the documentation of calendar-date-display-form for an explanation."
+See the documentation of `calendar-date-display-form' for an explanation."
:type 'sexp
:group 'calendar)
"*List of functions called after marking diary entries in the calendar.
A function `mark-included-diary-files' is also provided for use as the
-mark-diary-entries-hook; it enables you to use shared diary files together
+`mark-diary-entries-hook'; it enables you to use shared diary files together
with your own. The files included are specified in the diary file by lines
of the form
#include \"filename\"
(append general-holidays local-holidays other-holidays
christian-holidays hebrew-holidays islamic-holidays
oriental-holidays solar-holidays)
- "*List of notable days for the command M-x holidays.
+ "*List of notable days for the command \\[holidays].
Additional holidays are easy to add to the list, just put them in the list
`other-holidays' in your .emacs file. Similarly, by setting any of
(holiday-float MONTH DAYNAME K STRING &optional day) is the Kth DAYNAME in
MONTH on the Gregorian calendar (0 for Sunday,
etc.); K<0 means count back from the end of the
- month. An optional parameter DAY means the Kth
+ month. An optional parameter DAY means the Kth
DAYNAME after/before MONTH DAY.
(holiday-hebrew MONTH DAY STRING) a fixed date on the Hebrew calendar
(holiday-islamic MONTH DAY STRING) a fixed date on the Islamic calendar
(defmacro increment-calendar-month (mon yr n)
"Move the variables MON and YR to the month and year by N months.
Forward if N is positive or backward if N is negative."
- (` (let (( macro-y (+ (* (, yr) 12) (, mon) -1 (, n) )))
- (setq (, mon) (1+ (% macro-y 12) ))
- (setq (, yr) (/ macro-y 12)))))
+ `(let ((macro-y (+ (* ,yr 12) ,mon -1 ,n)))
+ (setq ,mon (1+ (% macro-y 12)))
+ (setq ,yr (/ macro-y 12))))
(defmacro calendar-for-loop (var from init to final do &rest body)
"Execute a for loop."
- (` (let (( (, var) (1- (, init)) ))
- (while (>= (, final) (setq (, var) (1+ (, var))))
- (,@ body)))))
+ `(let ((,var (1- ,init)))
+ (while (>= ,final (setq ,var (1+ ,var)))
+ ,@body)))
(defmacro calendar-sum (index initial condition expression)
"For INDEX = INITIAL et seq, as long as CONDITION holds, sum EXPRESSION."
- (` (let (( (, index) (, initial))
- (sum 0))
- (while (, condition)
- (setq sum (+ sum (, expression) ))
- (setq (, index) (1+ (, index))))
- sum)))
+ `(let ((,index ,initial)
+ (sum 0))
+ (while ,condition
+ (setq sum (+ sum ,expression))
+ (setq ,index (1+ ,index)))
+ sum))
;; The following are in-line for speed; they can be called thousands of times
;; when looking up holidays or processing the diary. Here, for example, are
(car (cdr (cdr date))))
(defsubst calendar-leap-year-p (year)
- "Returns t if YEAR is a Gregorian leap year."
+ "Return t if YEAR is a Gregorian leap year."
(and (zerop (% year 4))
(or (not (zerop (% year 100)))
(zerop (% year 400)))))
"Move cursor to DATE."
t)
+(autoload 'calendar-only-one-frame-setup "cal-x"
+ "Start calendar and display it in a dedicated frame.")
+
(autoload 'calendar-one-frame-setup "cal-x"
"Start calendar and display it in a dedicated frame together with the diary.")
(autoload 'calendar-two-frame-setup "cal-x"
"Start calendar and diary in separate, dedicated frames.")
-
+
;;;###autoload
(defvar calendar-setup nil
"The frame set up of the calendar.
The choices are `one-frame' (calendar and diary together in one separate,
-dedicated frame) or `two-frames' (calendar and diary in separate, dedicated
-frames); with any other value the current frame is used.")
+dedicated frame), `two-frames' (calendar and diary in separate, dedicated
+frames), `calendar-only' (calendar in a separate, dedicated frame); with
+any other value the current frame is used.")
;;;###autoload
(defun calendar (&optional arg)
"Choose between the one frame, two frame, or basic calendar displays.
-The original function `calendar' has been renamed `calendar-basic-setup'."
+If called with an optional prefix argument, prompts for month and year.
+
+The original function `calendar' has been renamed `calendar-basic-setup'.
+See the documentation of that function for more information."
(interactive "P")
(cond ((equal calendar-setup 'one-frame) (calendar-one-frame-setup arg))
((equal calendar-setup 'two-frames) (calendar-two-frame-setup arg))
+ ((equal calendar-setup 'calendar-only)
+ (calendar-only-one-frame-setup arg))
(t (calendar-basic-setup arg))))
(defun calendar-basic-setup (&optional arg)
`number-of-diary-entries' controls the number of days of diary entries
displayed upon initial display of the calendar.
-An optional prefix argument ARG causes the calendar displayed to be ARG
-months in the future if ARG is positive or in the past if ARG is negative;
-in this case the cursor goes on the first day of the month.
-
Once in the calendar window, future or past months can be moved into view.
Arbitrary months can be displayed, or the calendar can be scrolled forward
or backward.
Diary entries can be marked on the calendar or displayed in another window.
-Use M-x describe-mode for details of the key bindings in the calendar window.
+Use \\[describe-mode] for details of the key bindings in the calendar window.
The Gregorian calendar is assumed.
"String of Chinese date of Gregorian date."
t)
-(autoload 'calendar-absolute-from-astro
+(autoload 'calendar-absolute-from-astro "cal-julian"
"Absolute date of astronomical (Julian) day number D."
- "cal-julian")
+ t )
(autoload 'calendar-astro-from-absolute "cal-julian"
"Astronomical (Julian) day number of absolute date D.")
"String of astronomical (Julian) day number of Gregorian date."
t)
-(autoload 'calendar-goto-astro-date "cal-julian"
+(autoload 'calendar-goto-astro-day-number "cal-julian"
"Move cursor to astronomical (Julian) day number."
t)
+(autoload 'calendar-print-astro-day-number "cal-julian"
+ "Show the astro date equivalents of date."
+ t)
+
(autoload 'calendar-julian-from-absolute "cal-julian"
"Compute the Julian (month day year) corresponding to the absolute DATE.
The absolute date is the number of days elapsed since the (imaginary)
"String of ISO date of Gregorian date."
t)
+(autoload 'calendar-goto-islamic-date "cal-islam"
+ "Move cursor to Islamic date."
+ t)
+
(autoload 'calendar-print-islamic-date "cal-islam"
"Show the Islamic date equivalents of date."
t)
Optional prefix argument specifies number of weeks.
Holidays are included if `cal-tex-holidays' is t.")
-(autoload 'cal-tex-cursor-week2 "cal-tex"
+(autoload 'cal-tex-cursor-week2 "cal-tex"
"Make a buffer with LaTeX commands for a two-page one-week calendar.
It applies to the week that point is in.
Optional prefix argument specifies number of weeks.
(autoload 'cal-tex-cursor-filofax-week "cal-tex"
"One-week-at-a-glance Filofax style calendar for week indicated by cursor.
Optional prefix argument specifies number of weeks.
-Weeks start on Monday.
+Weeks start on Monday.
Diary entries are included if cal-tex-diary is t.
Holidays are included if `cal-tex-holidays' is t.")
(autoload 'cal-tex-cursor-filofax-daily "cal-tex"
"Day-per-page Filofax style calendar for week indicated by cursor.
-Optional prefix argument specifies number of weeks. Weeks start on Monday.
+Optional prefix argument specifies number of weeks. Weeks start on Monday.
Diary entries are included if `cal-tex-diary' is t.
Holidays are included if `cal-tex-holidays' is t.")
(calendar-cursor-to-visible-date
(if today-visible today (list displayed-month 1 displayed-year)))
(set-buffer-modified-p nil)
- (or (one-window-p t)
- (/= (frame-width) (window-width))
- (shrink-window (- (window-height) 9)))
+ (if (or (one-window-p t) (/= (frame-width) (window-width)))
+ ;; 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))
(sit-for 0)
+ (if (and (boundp 'font-lock-mode)
+ font-lock-mode)
+ (font-lock-fontify-buffer))
(and mark-holidays-in-calendar
(mark-calendar-holidays)
(sit-for 0))
(defun generate-calendar (month year)
"Generate a three-month Gregorian calendar centered around MONTH, YEAR."
(if (< (+ month (* 12 (1- year))) 2)
- (error "Months before February, 1 AD are not available."))
+ (error "Months before February, 1 AD are not available"))
(setq displayed-month month)
(setq displayed-year year)
(erase-buffer)
(defun generate-calendar-month (month year indent)
"Produce a calendar for MONTH, YEAR on the Gregorian calendar.
-The calendar is inserted in the buffer starting at the line on which point
-is currently located, but indented INDENT spaces. The indentation is done
-from the first character on the line and does not disturb the first INDENT
-characters on the line."
+The calendar is inserted at the top of the buffer in which point is currently
+located, but indented INDENT spaces. The indentation is done from the first
+character on the line and does not disturb the first INDENT characters on the
+line."
(let* ((blank-days;; at start of month
(mod
(- (calendar-day-of-week (list month 1 year))
(list (format "%s %d" (calendar-month-name month) year)) ? 20)
indent t)
(calendar-insert-indented "" indent);; Go to proper spot
+ ;; Use the first two characters of each day to head the columns.
(calendar-for-loop i from 0 to 6 do
- (insert (calendar-day-name (mod (+ calendar-week-start-day i) 7)
- 2 t))
- (insert " "))
+ (insert
+ (let ((string
+ (calendar-day-name (mod (+ calendar-week-start-day i) 7) nil t)))
+ (if enable-multibyte-characters
+ (truncate-string-to-width string 2)
+ (substring string 0 2)))
+ " "))
(calendar-insert-indented "" 0 t);; Force onto following line
(calendar-insert-indented "" indent);; Go to proper spot
;; Add blank days before the first of the month
;; Put in the days of the month
(calendar-for-loop i from 1 to last do
(insert (format "%2d " i))
- (put-text-property (- (point) 3) (1- (point))
- 'mouse-face 'highlight)
+ (add-text-properties
+ (- (point) 3) (1- (point))
+ '(mouse-face highlight
+ help-echo "mouse-2: menu of operations for this date"))
(and (zerop (mod (+ i blank-days) 7))
(/= i last)
(calendar-insert-indented "" 0 t) ;; Force onto following line
(defun redraw-calendar ()
"Redraw the calendar display."
(interactive)
- (let ((cursor-date (calendar-cursor-to-date)))
+ (let ((cursor-date (calendar-cursor-to-nearest-date)))
(generate-calendar-window displayed-month displayed-year)
(calendar-cursor-to-visible-date cursor-date)))
(if calendar-mode-map
nil
(setq calendar-mode-map (make-sparse-keymap))
- (if window-system (require 'cal-menu))
+ (require 'cal-menu)
(calendar-for-loop i from 0 to 9 do
(define-key calendar-mode-map (int-to-string i) 'digit-argument))
(let ((l (list 'narrow-to-region 'mark-word 'mark-sexp 'mark-paragraph
(define-key calendar-mode-map "gmnh" 'calendar-next-haab-date)
(define-key calendar-mode-map "gmpt" 'calendar-previous-tzolkin-date)
(define-key calendar-mode-map "gmnt" 'calendar-next-tzolkin-date)
- (define-key calendar-mode-map "A" 'appt-add)
- (define-key calendar-mode-map "D" 'appt-delete)
+ (define-key calendar-mode-map "Aa" 'appt-add)
+ (define-key calendar-mode-map "Ad" 'appt-delete)
(define-key calendar-mode-map "S" 'calendar-sunrise-sunset)
(define-key calendar-mode-map "M" 'calendar-phases-of-moon)
(define-key calendar-mode-map " " 'scroll-other-window)
(define-key calendar-mode-map "tY" 'cal-tex-cursor-year-landscape))
(defun describe-calendar-mode ()
- "Create a help buffer with a brief description of the calendar-mode."
+ "Create a help buffer with a brief description of the `calendar-mode'."
(interactive)
(with-output-to-temp-buffer "*Help*"
(princ
(defvar calendar-mode-line-format
(list
- (substitute-command-keys "\\<calendar-mode-map>\\[scroll-calendar-left]")
+ (propertize (substitute-command-keys
+ "\\<calendar-mode-map>\\[scroll-calendar-left]")
+ 'help-echo "mouse-2: scroll left"
+ 'keymap (make-mode-line-mouse-map 'mouse-2
+ 'mouse-scroll-calendar-left))
"Calendar"
- (substitute-command-keys "\\<calendar-mode-map>\\[calendar-goto-info-node] info/\\[calendar-other-month] other/\\[calendar-goto-today] today")
+ (concat
+ (propertize
+ (substitute-command-keys
+ "\\<calendar-mode-map>\\[calendar-goto-info-node] info")
+ 'help-echo "mouse-2: read Info on Calendar"
+ 'keymap (make-mode-line-mouse-map 'mouse-2 'calendar-goto-info-node))
+ "/"
+ (propertize
+ (substitute-command-keys
+ "\\<calendar-mode-map>\\[calendar-other-month] other")
+ 'help-echo "mouse-2: choose another month"
+ 'keymap (make-mode-line-mouse-map
+ 'mouse-2 'mouse-calendar-other-month))
+ "/"
+ (propertize
+ (substitute-command-keys
+ "\\<calendar-mode-map>\\[calendar-goto-today] today")
+ 'help-echo "mouse-2: go to today's date"
+ 'keymap (make-mode-line-mouse-map 'mouse-2 #'calendar-goto-today)))
'(calendar-date-string (calendar-current-date) t)
- (substitute-command-keys "\\<calendar-mode-map>\\[scroll-calendar-right]"))
- "The mode line of the calendar buffer.")
+ (propertize (substitute-command-keys
+ "\\<calendar-mode-map>\\[scroll-calendar-right]")
+ 'help-echo "mouse-2: scroll right"
+ 'keymap (make-mode-line-mouse-map
+ 'mouse-2 'mouse-scroll-calendar-right)))
+ "The mode line of the calendar buffer.
+
+This must be a list of items that evaluate to strings--those strings are
+evaluated and concatenated together, evenly separated by blanks. The variable
+`date' is available for use as the date under (or near) the cursor; `date'
+defaults to the current date if it is otherwise undefined. Here is an example
+value that has the Hebrew date, the day number/days remaining in the year,
+and the ISO week/year numbers in the mode. When calendar-move-hook is set to
+'update-calendar-mode-line, these mode line shows these values for the date
+under the cursor:
+
+ (list
+ \"\"
+ '(calendar-hebrew-date-string date)
+ '(let* ((year (extract-calendar-year date))
+ (d (calendar-day-number date))
+ (days-remaining
+ (- (calendar-day-number (list 12 31 year)) d)))
+ (format \"%d/%d\" d days-remaining))
+ '(let* ((d (calendar-absolute-from-gregorian date))
+ (iso-date (calendar-iso-from-absolute d)))
+ (format \"ISO week %d of %d\"
+ (extract-calendar-month iso-date)
+ (extract-calendar-year iso-date)))
+ \"\"))
+")
+
+(defun mouse-scroll-calendar-left (event)
+ "Scroll the displayed calendar left by one month.
+Maintains the relative position of the cursor
+with respect to the calendar as well as possible."
+ (interactive "e")
+ (save-selected-window
+ (select-window (posn-window (event-start event)))
+ (scroll-calendar-left 1)))
+
+(defun mouse-scroll-calendar-right (event)
+ "Scroll the displayed calendar right by one month.
+Maintains the relative position of the cursor
+with respect to the calendar as well as possible."
+ (interactive "e")
+ (save-selected-window
+ (select-window (posn-window (event-start event)))
+ (scroll-calendar-right 1)))
+
+(defun mouse-calendar-other-month (event)
+ "Display a three-month calendar centered around a specified month and year."
+ (interactive "e")
+ (save-selected-window
+ (select-window (posn-window (event-start event)))
+ (call-interactively 'calendar-other-month)))
(defun calendar-goto-info-node ()
"Go to the info node for the calendar."
(let ((where (save-window-excursion
(Info-find-emacs-command-nodes 'calendar))))
(if (not where)
- (error "Couldn't find documentation for the calendar.")
+ (error "Couldn't find documentation for the calendar")
(let (same-window-buffer-names)
(info))
(Info-find-node (car (car where)) (car (cdr (car where)))))))
+
+
(defun calendar-mode ()
"A major mode for the calendar window.
(setq buffer-read-only t)
(setq indent-tabs-mode nil)
(update-calendar-mode-line)
- (if window-system
- (progn
- (make-local-hook 'activate-menubar-hook)
- (add-hook 'activate-menubar-hook 'cal-menu-update nil t)))
+ (add-hook 'activate-menubar-hook 'cal-menu-update nil t)
(make-local-variable 'calendar-mark-ring)
(make-local-variable 'displayed-month);; Month in middle of window.
- (make-local-variable 'displayed-year));; Year in middle of window.
+ (make-local-variable 'displayed-year) ;; Year in middle of window.
+ (set (make-local-variable 'font-lock-defaults)
+ '(calendar-font-lock-keywords t)))
(defun calendar-string-spread (strings char length)
"Concatenate list of STRINGS separated with copies of CHAR to fill LENGTH.
(set-buffer calendar-buffer)
(setq mode-line-format
(calendar-string-spread
- calendar-mode-line-format ? (frame-width))))))
+ (let ((date (condition-case nil
+ (calendar-cursor-to-nearest-date)
+ (error (calendar-current-date)))))
+ (mapcar 'eval calendar-mode-line-format))
+ ? (frame-width)))
+ (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)
- (setq list (cons w list))))
+ (walk-windows (lambda (w)
+ (if (memq (window-buffer w) calendar-buffers)
+ (setq list (cons w list))))
nil t)
list))
(let ((buffer (if (window-live-p window) (window-buffer window))))
(if (memq buffer (calendar-buffer-list))
(cond
- ((and window-system
+ ((and (display-multi-frame-p)
(eq 'icon (cdr (assoc 'visibility
(frame-parameters
(window-frame window))))))
nil)
- ((and window-system (window-dedicated-p window))
- (iconify-frame (window-frame window)))
+ ((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 ()
- "Returns the current date in a list (month day year)."
+ "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-cursor-to-date (&optional error)
- "Returns a list (month day year) of current cursor position.
+ "Return a list (month day year) of current cursor position.
If cursor is not on a specific date, signals an error if optional parameter
ERROR is t, otherwise just returns nil."
(let* ((segment (/ (current-column) 25))
value))
(defun calendar-read-date (&optional noday)
- "Prompt for Gregorian date. Returns a list (month day year).
+ "Prompt for Gregorian date. Return a list (month day year).
If optional NODAY is t, does not ask for day, but just returns
\(month nil year); if NODAY is any other non-nil value the value returned is
-\(month year) "
+\(month year)"
(let* ((year (calendar-read
"Year (>0): "
- '(lambda (x) (> x 0))
+ (lambda (x) (> x 0))
(int-to-string (extract-calendar-year
(calendar-current-date)))))
(month-array calendar-month-name-array)
(list month year))
(list month
(calendar-read (format "Day (1-%d): " last)
- '(lambda (x) (and (< 0 x) (<= x last))))
+ (lambda (x) (and (< 0 x) (<= x last))))
year))))
(defun calendar-interval (mon1 yr1 mon2 yr2)
(+ (* 12 (- yr2 yr1))
(- mon2 mon1)))
-(defun calendar-day-name (date &optional width absolute)
- "Returns a string with the name of the day of the week of DATE.
-If WIDTH is non-nil, return just the first WIDTH characters of the name.
-If ABSOLUTE is non-nil, then DATE is actually the day-of-the-week
-rather than a date."
- (let ((string (aref calendar-day-name-array
- (if absolute date (calendar-day-of-week date)))))
- (cond ((null width) string)
- (enable-multibyte-characters (truncate-string-to-width string width))
- (t (substring string 0 width)))))
+(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'.")
(defvar 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, 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'.")
+
+(defvar calendar-day-abbrev-array
+ [nil nil nil nil nil nil nil]
+ "*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.")
(defvar 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.")
-
-(defun calendar-make-alist (sequence &optional start-index filter)
+ "*Array of capitalized strings giving, in order, the month names.
+See also the variable `calendar-month-abbrev-array'.")
+
+(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.
+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-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)
+ (dotimes (i (length full))
+ (setq elem (or (aref abbrev i)
+ (substring (aref full i) 0 calendar-abbrev-length))
+ 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]+")
+ . font-lock-function-name-face) ; month and year
+ (,(regexp-opt
+ (list (substring (aref calendar-day-name-array 6) 0 2)
+ (substring (aref calendar-day-name-array 0) 0 2)))
+ ;; Saturdays and Sundays are hilited differently.
+ . font-lock-comment-face)
+ ;; First two chars of each day are used in the calendar.
+ (,(regexp-opt (mapcar (lambda (x) (substring x 0 2)) calendar-day-name-array))
+ . font-lock-reference-face))
+ "Default keywords to highlight in Calendar mode.")
+
+(defun calendar-day-name (date &optional abbrev absolute)
+ "Return a string with the name of the day of the week of DATE.
+DATE should be a list in the format (MONTH DAY YEAR), unless the
+optional argument ABSOLUTE is non-nil, in which case DATE should
+be an integer in the range 0 to 6 corresponding to the day of the
+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)
+ (if absolute date (calendar-day-of-week date))))
+
+(defun calendar-make-alist (sequence &optional start-index filter abbrevs)
"Make an assoc list corresponding to SEQUENCE.
-Start at index 1, unless optional START-INDEX is provided.
-If FILTER is provided, apply it to each item in the list."
- (let ((index (if start-index (1- start-index) 0)))
- (mapcar
- '(lambda (x)
- (setq index (1+ index))
- (cons (if filter (funcall filter x) x)
- index))
- (append sequence nil))))
-
-(defun calendar-month-name (month &optional width)
- "The name of MONTH.
-If WIDTH is non-nil, return just the first WIDTH characters of the name."
- (let ((string (aref calendar-month-name-array (1- month))))
- (if width
- (let ((i 0) (result "") (pos 0))
- (while (< i width)
- (let ((chartext (char-to-string (sref string pos))))
- (setq pos (+ pos (length chartext)))
- (setq result (concat result chartext)))
- (setq i (1+ i)))
- result)
- string)))
+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 (1- (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))))))
+
+(defun calendar-month-name (month &optional abbrev)
+ "Return a string with the name of month number MONTH.
+Months are numbered from one. Month names are taken from the
+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)
+ (1- month)))
(defun calendar-day-of-week (date)
- "Returns the day-of-the-week index of DATE, 0 for Sunday, 1 for Monday, etc."
+ "Return the day-of-the-week index of DATE, 0 for Sunday, 1 for Monday, etc."
(% (calendar-absolute-from-gregorian date) 7))
(defun calendar-unmark ()
(redraw-calendar))
(defun calendar-date-is-visible-p (date)
- "Returns t if DATE is legal and is visible in the calendar window."
+ "Return t if DATE is legal and is visible in the calendar window."
(let ((gap (calendar-interval
displayed-month displayed-year
(extract-calendar-month date) (extract-calendar-year date))))
(and (calendar-date-is-legal-p date) (> 2 gap) (< -2 gap))))
(defun calendar-date-is-legal-p (date)
- "Returns t if DATE is a legal date."
+ "Return t if DATE is a legal date."
(let ((month (extract-calendar-month date))
(day (extract-calendar-day date))
(year (extract-calendar-year date)))
(<= 1 year))))
(defun calendar-date-equal (date1 date2)
- "Returns t if the DATE1 and DATE2 are the same."
+ "Return t if the DATE1 and DATE2 are the same."
(and
(= (extract-calendar-month date1) (extract-calendar-month date2))
(= (extract-calendar-day date1) (extract-calendar-day date2))
(defun mark-visible-calendar-date (date &optional mark)
"Mark DATE in the calendar window with MARK.
-MARK is either a single-character string or a face.
-MARK defaults to diary-entry-marker."
+MARK is a single-character string, a list of face attributes/values, or a face.
+MARK defaults to `diary-entry-marker'."
(if (calendar-date-is-legal-p date)
(save-excursion
(set-buffer calendar-buffer)
(calendar-cursor-to-visible-date date)
- (let ((mark (or mark diary-entry-marker)))
- (if (stringp mark)
- (let ((buffer-read-only nil))
- (forward-char 1)
- (delete-char 1)
- (insert mark)
- (forward-char -2))
- (overlay-put
- (make-overlay (1- (point)) (1+ (point))) 'face mark))))))
+ (let ((mark (or (and (stringp mark) (= (length mark) 1) mark) ; single-char
+ (and (listp mark) (> (length mark) 0) mark) ; attr list
+ (and (facep mark) mark) ; face-name
+ diary-entry-marker)))
+ (if (facep mark)
+ (progn ; face or an attr-list that contained a face
+ (overlay-put
+ (make-overlay (1- (point)) (1+ (point))) 'face mark))
+ (if (and (stringp mark)
+ (= (length mark) 1)) ; single-char
+ (let ((buffer-read-only nil))
+ (forward-char 1)
+ (delete-char 1)
+ (insert mark)
+ (forward-char -2))
+ (progn ; attr list
+ (setq temp-face
+ (make-symbol (apply 'concat "temp-face-"
+ (mapcar '(lambda (sym)
+ (cond ((symbolp sym) (symbol-name sym))
+ ((numberp sym) (int-to-string sym))
+ (t sym))) mark))))
+ (make-face temp-face)
+ ;; Remove :face info from the mark, copy the face info into temp-face
+ (setq faceinfo mark)
+ (while (setq faceinfo (memq :face faceinfo))
+ (copy-face (read (nth 1 faceinfo)) temp-face)
+ (setcar faceinfo nil)
+ (setcar (cdr faceinfo) nil))
+ (setq mark (delq nil mark))
+ ;; Apply the font aspects
+ (apply 'set-face-attribute temp-face nil mark)
+ (overlay-put
+ (make-overlay (1- (point)) (1+ (point))) 'face temp-face))))))))
(defun calendar-star-date ()
"Replace the date under the cursor in the calendar window with asterisks.
-This function can be used with the today-visible-calendar-hook run after the
+This function can be used with the `today-visible-calendar-hook' run after the
calendar window has been prepared."
- (let ((buffer-read-only nil))
- (make-variable-buffer-local 'calendar-starred-day)
+ (let ((inhibit-read-only t))
+ (make-local-variable 'calendar-starred-day)
(forward-char 1)
(setq calendar-starred-day
(string-to-int
(defun calendar-mark-today ()
"Mark the date under the cursor in the calendar window.
-The date is marked with calendar-today-marker. This function can be used with
-the today-visible-calendar-hook run after the calendar window has been
+The date is marked with `calendar-today-marker'. This function can be used with
+the `today-visible-calendar-hook' run after the calendar window has been
prepared."
(mark-visible-calendar-date
(calendar-cursor-to-date)
calendar-today-marker))
(defun calendar-date-compare (date1 date2)
- "Returns t if DATE1 is before DATE2, nil otherwise.
+ "Return t if DATE1 is before DATE2, nil otherwise.
The actual dates are in the car of DATE1 and DATE2."
(< (calendar-absolute-from-gregorian (car date1))
(calendar-absolute-from-gregorian (car date2))))
(defun calendar-date-string (date &optional abbreviate nodayname)
"A string form of DATE, driven by the variable `calendar-date-display-form'.
-An optional parameter ABBREVIATE, when t, causes the month and day names to be
-abbreviated to three characters. An optional parameter NODAYNAME, when t,
-omits the name of the day of the week."
+An optional parameter ABBREVIATE, when non-nil, causes the month
+and day names to be abbreviated as specified by
+`calendar-month-abbrev-array' and `calendar-day-abbrev-array',
+respectively. An optional parameter NODAYNAME, when t, omits the
+name of the day of the week."
(let* ((dayname
- (if nodayname
- nil
- (if abbreviate
- (calendar-day-name date 3)
- (calendar-day-name date))))
+ (unless nodayname
+ (calendar-day-name date abbreviate)))
(month (extract-calendar-month date))
- (monthname
- (if abbreviate
- (calendar-month-name month 3)
- (calendar-month-name month)))
+ (monthname (calendar-month-name month abbreviate))
(day (int-to-string (extract-calendar-day date)))
(month (int-to-string month))
(year (int-to-string (extract-calendar-year date))))
(mapconcat 'eval calendar-date-display-form "")))
(defun calendar-dayname-on-or-before (dayname date)
- "Returns the absolute date of the DAYNAME on or before absolute DATE.
+ "Return the absolute date of the DAYNAME on or before absolute DATE.
DAYNAME=0 means Sunday, DAYNAME=1 means Monday, and so on.
Note: Applying this function to d+6 gives us the DAYNAME on or after an