Mercurial > emacs
comparison lisp/calendar/calendar.el @ 96047:65c4c935e492
* calendar/calendar.el (calendar-cursor-to-date): Add argument `event'.
(calendar-set-mark):
* calendar/diary-lib.el (diary-insert-entry):
* calendar/solar.el (calendar-sunrise-sunset): Use it.
* calendar/cal-menu.el (calendar-mouse-sunrise/sunset)
(calendar-mouse-insert-diary-entry, calendar-mouse-set-mark): Delete.
(cal-menu-context-mouse-menu): Use calendar-set-mark, diary-insert-entry,
and calendar-sunrise-sunset instead, to get proper key-shortcuts.
author | Stefan Monnier <monnier@iro.umontreal.ca> |
---|---|
date | Tue, 17 Jun 2008 15:42:19 +0000 |
parents | edf0549afd4a |
children | 44b22c5bd2a9 |
comparison
equal
deleted
inserted
replaced
96046:422d57d537d7 | 96047:65c4c935e492 |
---|---|
1569 (defun calendar-current-date () | 1569 (defun calendar-current-date () |
1570 "Return the current date in a list (month day year)." | 1570 "Return the current date in a list (month day year)." |
1571 (let ((now (decode-time))) | 1571 (let ((now (decode-time))) |
1572 (list (nth 4 now) (nth 3 now) (nth 5 now)))) | 1572 (list (nth 4 now) (nth 3 now) (nth 5 now)))) |
1573 | 1573 |
1574 (defun calendar-cursor-to-date (&optional error) | 1574 (defun calendar-cursor-to-date (&optional error event) |
1575 "Return a list (month day year) of current cursor position. | 1575 "Return a list (month day year) of current cursor position. |
1576 If cursor is not on a specific date, signals an error if optional parameter | 1576 If cursor is not on a specific date, signals an error if optional parameter |
1577 ERROR is non-nil, otherwise just returns nil." | 1577 ERROR is non-nil, otherwise just returns nil. |
1578 If EVENT is non-nil, it's an event indicating the buffer position to | |
1579 use instead of point." | |
1580 (with-current-buffer | |
1581 (if event (window-buffer (posn-window (event-start event))) | |
1582 (current-buffer)) | |
1583 (save-excursion | |
1584 (if event (goto-char (posn-point (event-start event)))) | |
1578 (let* ((segment (/ (current-column) 25)) | 1585 (let* ((segment (/ (current-column) 25)) |
1579 (month (% (+ displayed-month segment -1) 12)) | 1586 (month (% (+ displayed-month segment -1) 12)) |
1580 (month (if (zerop month) 12 month)) | 1587 (month (if (zerop month) 12 month)) |
1581 (year | 1588 (year |
1582 (cond | 1589 (cond |
1583 ((and (= 12 month) (zerop segment)) (1- displayed-year)) | 1590 ((and (= 12 month) (zerop segment)) (1- displayed-year)) |
1584 ((and (= 1 month) (= segment 2)) (1+ displayed-year)) | 1591 ((and (= 1 month) (= segment 2)) (1+ displayed-year)) |
1585 (t displayed-year)))) | 1592 (t displayed-year)))) |
1586 (if (and (looking-at "[ 0-9]?[0-9][^0-9]") | 1593 (if (not (and (looking-at "[ 0-9]?[0-9][^0-9]") |
1587 (< 2 (count-lines (point-min) (point)))) | 1594 (< 2 (count-lines (point-min) (point))))) |
1588 (save-excursion | 1595 (if error (error "Not on a date!")) |
1589 (if (not (looking-at " ")) | 1596 (if (not (looking-at " ")) |
1590 (re-search-backward "[^0-9]")) | 1597 (re-search-backward "[^0-9]")) |
1591 (list month | 1598 (list month |
1592 (string-to-number (buffer-substring (1+ (point)) (+ 4 (point)))) | 1599 (string-to-number (buffer-substring (1+ (point)) (+ 4 (point)))) |
1593 year)) | 1600 year)))))) |
1594 (if error (error "Not on a date!"))))) | |
1595 | 1601 |
1596 (add-to-list 'debug-ignored-errors "Not on a date!") | 1602 (add-to-list 'debug-ignored-errors "Not on a date!") |
1597 | 1603 |
1598 ;; The following version of calendar-gregorian-from-absolute is preferred for | 1604 ;; The following version of calendar-gregorian-from-absolute is preferred for |
1599 ;; reasons of clarity, BUT it's much slower than the version that follows it. | 1605 ;; reasons of clarity, BUT it's much slower than the version that follows it. |
1666 (cond | 1672 (cond |
1667 ((calendar-date-is-visible-p old-date) old-date) | 1673 ((calendar-date-is-visible-p old-date) old-date) |
1668 ((calendar-date-is-visible-p today) today) | 1674 ((calendar-date-is-visible-p today) today) |
1669 (t (list month 1 year)))))))) | 1675 (t (list month 1 year)))))))) |
1670 | 1676 |
1671 (defun calendar-set-mark (arg) | 1677 (defun calendar-set-mark (arg &optional event) |
1672 "Mark the date under the cursor, or jump to marked date. | 1678 "Mark the date under the cursor, or jump to marked date. |
1673 With no prefix argument, push current date onto marked date ring. | 1679 With no prefix argument, push current date onto marked date ring. |
1674 With argument ARG, jump to mark, pop it, and put point at end of ring." | 1680 With argument ARG, jump to mark, pop it, and put point at end of ring." |
1675 (interactive "P") | 1681 (interactive |
1676 (let ((date (calendar-cursor-to-date t))) | 1682 (list current-prefix-arg last-nonmenu-event)) |
1683 (let ((date (calendar-cursor-to-date t event))) | |
1677 (if arg | 1684 (if arg |
1678 (if (null calendar-mark-ring) | 1685 (if (null calendar-mark-ring) |
1679 (error "No mark set in this buffer") | 1686 (error "No mark set in this buffer") |
1680 (calendar-goto-date (car calendar-mark-ring)) | 1687 (calendar-goto-date (car calendar-mark-ring)) |
1681 (setq calendar-mark-ring | 1688 (setq calendar-mark-ring |