X-Git-Url: https://git.hcoop.net/bpt/emacs.git/blobdiff_plain/10979c74669477d58347a20ebec04a7a2fd902b1..114f9c96795aff3b51b9060d7c9c1b77debcc99a:/lisp/calendar/calendar.el diff --git a/lisp/calendar/calendar.el b/lisp/calendar/calendar.el index e43132fd4e..d92942d003 100644 --- a/lisp/calendar/calendar.el +++ b/lisp/calendar/calendar.el @@ -1,7 +1,7 @@ ;;; calendar.el --- calendar functions ;; Copyright (C) 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1997, -;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 +;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 ;; Free Software Foundation, Inc. ;; Author: Edward M. Reingold @@ -114,7 +114,7 @@ ;;; Code: -(require 'cal-loaddefs) +(load "cal-loaddefs" nil t) ;; Avoid recursive load of calendar when loading cal-menu. Yuck. (provide 'calendar) @@ -163,6 +163,16 @@ three options overrides the value of `calendar-view-diary-initially-flag'." :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. @@ -196,6 +206,7 @@ be overridden by the value of `calendar-setup'." (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'." @@ -213,10 +224,10 @@ If nil, make an icon of the frame. If non-nil, delete the frame." (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)) @@ -233,8 +244,8 @@ See `calendar-today-marker'." 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)) @@ -246,34 +257,40 @@ and to highlight the date header in the fancy diary." "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") @@ -288,6 +305,7 @@ displayed." (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'." @@ -353,16 +371,14 @@ redisplays the diary for whatever date the cursor is moved to." (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 @@ -371,8 +387,182 @@ pre-existing calendar windows." :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-month-digit-width nil + "Width of the region with numbers in each month in the calendar.") + +(defvar calendar-month-width nil + "Full width of each month in the calendar.") + +(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-day-digit-width) + calendar-month-width (+ (* 7 calendar-column-width) + calendar-intermonth-spacing) + calendar-right-margin (+ calendar-left-margin + (* 3 (* 7 calendar-column-width)) + (* 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) + "Set SYMBOL's value to VALUE, an integer. +A positive/negative MINMAX enforces a minimum/maximum value. +Then redraw the calendar, if necessary." + (let ((oldvalue (symbol-value symbol))) + (custom-set-default symbol (if minmax + (if (< minmax 0) + (min value (- minmax)) + (max value minmax)) + value)) + (unless (equal value oldvalue) + (calendar-recompute-layout-variables) + (calendar-redraw)))) + +(defcustom calendar-left-margin 5 + "Empty space to the left of the first month in the calendar." + :group 'calendar + :initialize 'custom-initialize-default + :set 'calendar-set-layout-variable + :type 'integer + :version "23.1") + +;; Or you can view it as columns of width 2, with 1 space, no space +;; after the last column, and a 5 space gap between month. +;; FIXME check things work if this is odd. +(defcustom calendar-intermonth-spacing 4 + "Space between months in the calendar. Minimum value is 1." + :group 'calendar + :initialize 'custom-initialize-default + :set (lambda (sym val) + (calendar-set-layout-variable sym val 1)) + :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 + :set (lambda (sym val) + (calendar-set-layout-variable sym val 3)) + :type 'integer + :version "23.1") + +(defcustom calendar-day-header-width 2 + "Width of the day column headers in the calendar. +Must be at least one less than `calendar-column-width'." + :group 'calendar + :initialize 'custom-initialize-default + :set (lambda (sym val) + (calendar-set-layout-variable sym val (- 1 calendar-column-width))) + :type 'integer + :version "23.1") + +;; FIXME a format specifier instead? +(defcustom calendar-day-digit-width 2 + "Width of the day digits in the calendar. Minimum value is 2." + :group 'calendar + :initialize 'custom-initialize-default + :set (lambda (sym val) + (calendar-set-layout-variable sym val 2)) + :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" @@ -656,6 +846,9 @@ For examples of three common styles, see `diary-american-date-forms', (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)) @@ -723,6 +916,9 @@ would give the usual American style in fixed-length fields. The variables `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) @@ -824,6 +1020,11 @@ calendar." ;;; End of user options. +(calendar-recompute-layout-variables) + +(defconst calendar-first-date-row 3 + "First row in the calendar with actual dates.") + (defconst calendar-buffer "*Calendar*" "Name of the buffer used for the calendar.") @@ -841,6 +1042,9 @@ calendar." (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'.") @@ -1086,22 +1290,61 @@ If optional prefix argument ARG is non-nil, prompts for the month 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-horizontally)) + (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-vertically))) + ;; 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))) @@ -1131,7 +1374,12 @@ Optional integers MON and YR are used instead of today's date." ;; 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))) + ;; The second test used to be window-full-width-p. + ;; Not sure what it was/is for, except perhaps some way of saying + ;; "try not to mess with existing configurations". + ;; If did the wrong thing on wide frames, where we have done a + ;; horizontal split in calendar-basic-setup. + (if (or (one-window-p t) (not (window-safely-shrinkable-p))) ;; Don't mess with the window size, but ensure that the first ;; line is fully visible. (set-window-vscroll nil 0) @@ -1163,9 +1411,37 @@ Optional integers MON and YR are used instead of today's date." (erase-buffer) (calendar-increment-month month year -1) (dotimes (i 3) - (calendar-generate-month month year (+ 5 (* 25 i))) + (calendar-generate-month month year + (+ calendar-left-margin + (* calendar-month-width i))) (calendar-increment-month month year 1))) +(defun calendar-move-to-column (indent) + "Like `move-to-column', but indents if the line is too short." + (if (< (move-to-column indent) indent) + (indent-to indent))) + +(defun calendar-ensure-newline () + "Move to the next line, adding a newline if necessary." + (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, ensure a trailing space." + (if (not (ignore-errors (stringp (setq string (eval string))))) + (calendar-move-to-column indent) + (if (> (length string) truncate) + (setq string (substring string 0 truncate))) + (or (string-match " $" string) + (if (= (length string) truncate) + (aset string (1- truncate) ?\s) + (setq string (concat string " ")))) + (calendar-move-to-column (- indent (length 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 @@ -1178,13 +1454,18 @@ line." 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-insert-indented + (calendar-move-to-column indent) + (insert (calendar-string-spread - (list (format "%s %d" (calendar-month-name month) year)) ?\s 20) - indent t) - (calendar-insert-indented "" indent) ; go to proper spot + (list (format "%s %d" (calendar-month-name month) year)) + ?\s calendar-month-digit-width)) + (calendar-ensure-newline) + (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 @@ -1192,43 +1473,31 @@ line." (setq 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 + (truncate-string-to-width string calendar-day-header-width) + (substring string 0 calendar-day-header-width))) + (make-string (- calendar-column-width calendar-day-header-width) ?\s))) + (calendar-ensure-newline) + (calendar-insert-at-column indent calendar-intermonth-text trunc) ;; Add blank days before the first of the month. - (dotimes (idummy blank-days) (insert " ")) + (insert (make-string (* blank-days calendar-column-width) ?\s)) ;; Put in the days of the month. (dotimes (i last) (setq day (1+ i)) - (insert (format "%2d " day)) - ;; FIXME set-text-properties? - (add-text-properties - (- (point) 3) (1- (point)) - `(mouse-face highlight help-echo ,(eval calendar-date-echo-text))) - (and (zerop (mod (+ day blank-days) 7)) - (/= day last) - (calendar-insert-indented "" 0 t) ; force onto following line - (calendar-insert-indented "" indent))))) ; go to proper spot - -(defun calendar-insert-indented (string indent &optional newline) - "Insert STRING at column INDENT. -If the optional parameter NEWLINE is non-nil, leave point at start of next -line, inserting a newline if there was no next line; otherwise, leave point -after the inserted text. Returns t." - ;; Try to move to that column. - (move-to-column indent) - ;; If line is too short, indent out to that column. - (if (< (current-column) indent) - (indent-to indent)) - (insert string) - ;; Advance to next line, if requested. - (when newline - (end-of-line) - (or (zerop (forward-line 1)) - (insert "\n"))) - t) + ;; 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))) + ;; '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) + 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." @@ -1302,7 +1571,7 @@ after the inserted text. Returns t." (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) @@ -1367,7 +1636,7 @@ after the inserted text. Returns t." (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) @@ -1379,6 +1648,14 @@ after the inserted text. Returns t." (define-key map [down-mouse-2] (easy-menu-binding cal-menu-global-mouse-menu)) + ;; Left-click moves us forward in time, right-click backwards. + ;; cf scroll-bar.el. + (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'.") @@ -1497,34 +1774,37 @@ the STRINGS are just concatenated and the result truncated." "Update the calendar mode line with the current date and date style." (if (bufferp (get-buffer calendar-buffer)) (with-current-buffer calendar-buffer - (setq mode-line-format - ;; The magic numbers are based on the fixed calendar layout. - (concat (make-string (+ 3 - (- (car (window-inside-edges)) - (car (window-edges)))) ?\s) - (calendar-string-spread - (let ((date (condition-case nil - (calendar-cursor-to-nearest-date) - (error (calendar-current-date))))) - (mapcar 'eval calendar-mode-line-format)) - ?\s 74))) + (let ((start (- calendar-left-margin 2)) + (date (condition-case nil + (calendar-cursor-to-nearest-date) + (error (calendar-current-date))))) + (setq mode-line-format + (concat (make-string (max 0 (+ start + (- (car (window-inside-edges)) + (car (window-edges))))) ?\s) + (calendar-string-spread + (mapcar 'eval calendar-mode-line-format) + ?\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) + ;; Using 0 rather than t for last argument - see bug#2199. + ;; This is only used with calendar-hide-window, which ignores + ;; iconified frames anyway, so could use 'visible rather than 0. (walk-windows (lambda (w) (if (memq (window-buffer w) calendar-buffers) (push w list))) - nil t) + nil 0) 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)) @@ -1566,10 +1846,23 @@ the STRINGS are just concatenated and the result truncated." (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-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. @@ -1581,23 +1874,28 @@ use instead of point." (if event (window-buffer (posn-window (event-start event))) (current-buffer)) (save-excursion - (if event (goto-char (posn-point (event-start event)))) - (let* ((segment (/ (current-column) 25)) - (month (% (+ displayed-month segment -1) 12)) - (month (if (zerop month) 12 month)) - (year - (cond - ((and (= 12 month) (zerop segment)) (1- displayed-year)) - ((and (= 1 month) (= segment 2)) (1+ displayed-year)) - (t displayed-year)))) + (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]") - (< 2 (count-lines (point-min) (point))))) + (get-text-property (point) 'date))) (if error (error "Not on a date!")) - (if (not (looking-at " ")) + ;; 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]")) (list month - (string-to-number (buffer-substring (1+ (point)) (+ 4 (point)))) - year)))))) + (string-to-number + (buffer-substring (1+ (point)) + (+ 1 calendar-day-digit-width (point)))) + (cond + ((and (= 12 month) (zerop segment)) (1- displayed-year)) + ((and (= 1 month) (= segment 2)) (1+ displayed-year)) + (t displayed-year)))))))) (add-to-list 'debug-ignored-errors "Not on a date!") @@ -1884,12 +2182,14 @@ each element returned has a final `.' character." " -?[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))) + (list (substring (aref calendar-day-name-array 6) + 0 calendar-day-header-width) + (substring (aref calendar-day-name-array 0) + 0 calendar-day-header-width))) ;; Saturdays and Sundays are highlighted 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)) + (,(regexp-opt (mapcar (lambda (x) (substring x 0 calendar-day-header-width)) calendar-day-name-array)) . font-lock-reference-face)) "Default keywords to highlight in Calendar mode.") @@ -2051,11 +2351,14 @@ MARK defaults to `diary-entry-marker'." (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) @@ -2096,6 +2399,7 @@ The date is marked with `calendar-today-marker'. You might want to add 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." @@ -2206,14 +2510,23 @@ DATE is (month day year). Calendars that do not apply are omitted." (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." @@ -2225,6 +2538,11 @@ DATE is (month day year). Calendars that do not apply are omitted." (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 (or (getenv "COLUMNS") 80))) (setq mode-line-format (if buffer-file-name `("-" mode-line-modified