Mercurial > emacs
changeset 87831:24a61b9ca04c
New file
| author | Carsten Dominik <dominik@science.uva.nl> |
|---|---|
| date | Fri, 18 Jan 2008 15:12:19 +0000 |
| parents | f2c7a4c1771d |
| children | 3b07855f66ef |
| files | lisp/textmodes/org-mouse.el |
| diffstat | 1 files changed, 1108 insertions(+), 0 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/textmodes/org-mouse.el Fri Jan 18 15:12:19 2008 +0000 @@ -0,0 +1,1108 @@ +;;; org-mouse.el --- Better mouse support for org-mode + +;; Copyright (c) 2006 Piotr Zielinski, 2007, 2008 Free Software Foundation +;; +;; Author: Piotr Zielinski <piotr dot zielinski at gmail dot com> +;; Maintainer: Carsten Dominik <carsten at orgmode dot org> +;; Version: 5.19 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: +;; +;; Org-mouse provides mouse support for org-mode. +;; +;; http://orgmode.org +;; +;; Org-mouse implements the following features: +;; * following links with the left mouse button (in Emacs 22) +;; * subtree expansion/collapse (org-cycle) with the left mouse button +;; * several context menus on the right mouse button: +;; + general text +;; + headlines +;; + timestamps +;; + priorities +;; + links +;; + tags +;; * promoting/demoting/moving subtrees with mouse-3 +;; + if the drag starts and ends in the same line then promote/demote +;; + otherwise move the subtree +;; +;; Use +;; --- +;; +;; To use this package, put the following line in your .emacs: +;; +;; (require 'org-mouse) +;; + +;; Fixme: +;; + deal with folding / unfolding issues + +;; TODO (This list is only theoretical, if you'd like to have some +;; feature implemented or a bug fix please send me an email, even if +;; something similar appears in the list below. This will help me get +;; the priorities right.): +;; +;; + org-store-link, insert link +;; + org tables +;; + occur with the current word/tag (same menu item) +;; + ctrl-c ctrl-c, for example, renumber the current list +;; + internal links + +;; Please email the maintainer with new feature suggestions / bugs + +;; History: +;; +;; SInce version 5.10: Changes are listed in the general org-mode docs. +;; +;; Version 5.09 +;; + Version number synchronization with Org-mode. +;; +;; Version 0.25 +;; + made compatible with org-mode 4.70 (thanks to Carsten for the patch) +;; +;; Version 0.24 +;; + minor changes to the table menu +;; +;; Version 0.23 +;; + preliminary support for tables and calculation marks +;; + context menu support for org-agenda-undo & org-sort-entries +;; +;; Version 0.22 +;; + handles undo support for the agenda buffer (requires org-mode >=4.58) +;; +;; Version 0.21 +;; + selected text activates its context menu +;; + shift-middleclick or right-drag inserts the text from the clipboard in the form of a link +;; +;; Version 0.20 +;; + the new "TODO Status" submenu replaces the "Cycle TODO" menu item +;; + the TODO menu can now list occurrences of a specific TODO keyword +;; + #+STARTUP line is now recognized +;; +;; Version 0.19 +;; + added support for dragging URLs to the org-buffer +;; +;; Version 0.18 +;; + added support for agenda blocks +;; +;; Version 0.17 +;; + toggle checkboxes with a single click +;; +;; Version 0.16 +;; + added support for checkboxes +;; +;; Version 0.15 +;; + org-mode now works with the Agenda buffer as well +;; +;; Version 0.14 +;; + added a menu option that converts plain list items to outline items +;; +;; Version 0.13 +;; + "Insert Heading" now inserts a sibling heading if the point is +;; on "***" and a child heading otherwise +;; +;; Version 0.12 +;; + compatible with Emacs 21 +;; + custom agenda commands added to the main menu +;; + moving trees should now work between windows in the same frame +;; +;; Version 0.11 +;; + fixed org-mouse-at-link (thanks to Carsten) +;; + removed [follow-link] bindings +;; +;; Version 0.10 +;; + added a menu option to remove highlights +;; + compatible with org-mode 4.21 now +;; +;; Version 0.08: +;; + trees can be moved/promoted/demoted by dragging with the right +;; mouse button (mouse-3) +;; + small changes in the above function +;; +;; Versions 0.01 -- 0.07: (I don't remember) + +(eval-when-compile (require 'cl)) +(require 'org) + +(defvar org-mouse-plain-list-regexp "\\([ \t]*\\)\\([-+*]\\|[0-9]+[.)]\\) " + "Regular expression that matches a plain list.") +(defvar org-mouse-direct t + "Internal variable indicating whether the current action is direct. + +If t, then the current action has been invoked directly through the buffer +it is intended to operate on. If nil, then the action has been invoked +indirectly, for example, through the agenda buffer.") + +(defgroup org-mouse nil + "Mouse support for org-mode." + :tag "Org Mouse" + :group 'org) + +(defcustom org-mouse-punctuation ":" + "Punctuation used when inserting text by drag and drop." + :group 'org-mouse + :type 'string) + + +(defun org-mouse-re-search-line (regexp) + "Search the current line for a given regular expression." + (beginning-of-line) + (re-search-forward regexp (point-at-eol) t)) + +(defun org-mouse-end-headline () + "Go to the end of current headline (ignoring tags)." + (interactive) + (end-of-line) + (skip-chars-backward "\t ") + (when (looking-back ":[A-Za-z]+:") + (skip-chars-backward ":A-Za-z") + (skip-chars-backward "\t "))) + +(defvar org-mouse-context-menu-function nil + "Function to create the context menu. +The value of this variable is the function invoked by +`org-mouse-context-menu' as the context menu.") +(make-variable-buffer-local 'org-mouse-context-menu-function) + +(defun org-mouse-show-context-menu (event prefix) + "Invoke the context menu. + +If the value of `org-mouse-context-menu-function' is a function, then +this function is called. Otherwise, the current major mode menu is used." + (interactive "@e \nP") + (if (and (= (event-click-count event) 1) + (or (not mark-active) + (sit-for (/ double-click-time 1000.0)))) + (progn + (select-window (posn-window (event-start event))) + (when (not (org-mouse-mark-active)) + (goto-char (posn-point (event-start event))) + (when (not (eolp)) (save-excursion (run-hooks 'post-command-hook))) + (let ((redisplay-dont-pause t)) + (sit-for 0))) + (if (functionp org-mouse-context-menu-function) + (funcall org-mouse-context-menu-function event) + (mouse-major-mode-menu event prefix))) + (setq this-command 'mouse-save-then-kill) + (mouse-save-then-kill event))) + + +(defun org-mouse-line-position () + "Returns `:beginning' or `:middle' or `:end', depending on the point position. + +If the point is at the end of the line, return `:end'. +If the point is separated from the beginning of the line only by white +space and *'s (`org-mouse-bolp'), return `:beginning'. Otherwise, +return `:middle'." + (cond + ((eolp) :end) + ((org-mouse-bolp) :beginning) + (t :middle))) + +(defun org-mouse-empty-line () + "Return non-nil iff the line contains only white space." + (save-excursion (beginning-of-line) (looking-at "[ \t]*$"))) + +(defun org-mouse-next-heading () + "Go to the next heading. +If there is none, ensure that the point is at the beginning of an empty line." + (unless (outline-next-heading) + (beginning-of-line) + (unless (org-mouse-empty-line) + (end-of-line) + (newline)))) + +(defun org-mouse-insert-heading () + "Insert a new heading, as `org-insert-heading'. + +If the point is at the :beginning (`org-mouse-line-position') of the line, +insert the new heading before the current line. Otherwise, insert it +after the current heading." + (interactive) + (case (org-mouse-line-position) + (:beginning (beginning-of-line) + (org-insert-heading)) + (t (org-mouse-next-heading) + (org-insert-heading)))) + +(defun org-mouse-timestamp-today (&optional shift units) + "Change the timestamp into SHIFT UNITS in the future. + +For the acceptable UNITS, see `org-timestamp-change'." + (interactive) + (flet ((org-read-date (&rest rest) (current-time))) + (org-time-stamp nil)) + (when shift + (org-timestamp-change shift units))) + +(defun org-mouse-keyword-menu (keywords function &optional selected itemformat) + "A helper function. + +Returns a menu fragment consisting of KEYWORDS. When a keyword +is selected by the user, FUNCTION is called with the selected +keyword as the only argument. + +If SELECTED is nil, then all items are normal menu items. If +SELECTED is a function, then each item is a checkbox, which is +enabled for a given keyword iff (funcall SELECTED keyword) return +non-nil. If SELECTED is neither nil nor a function, then the +items are radio buttons. A radio button is enabled for the +keyword `equal' to SELECTED. + +ITEMFORMAT governs formatting of the elements of KEYWORDS. If it +is a function, it is invoked with the keyword as the only +argument. If it is a string, it is interpreted as the format +string to (format ITEMFORMAT keyword). If it is neither a string +nor a function, elements of KEYWORDS are used directly. " + (mapcar + `(lambda (keyword) + (vector (cond + ((functionp ,itemformat) (funcall ,itemformat keyword)) + ((stringp ,itemformat) (format ,itemformat keyword)) + (t keyword)) + (list 'funcall ,function keyword) + :style (cond + ((null ,selected) t) + ((functionp ,selected) 'toggle) + (t 'radio)) + :selected (if (functionp ,selected) + (and (funcall ,selected keyword) t) + (equal ,selected keyword)))) + keywords)) + +(defun org-mouse-remove-match-and-spaces () + "Remove the match, make just one space around the point." + (interactive) + (replace-match "") + (just-one-space)) + +(defvar rest) +(defun org-mouse-replace-match-and-surround (newtext &optional fixedcase + literal string subexp) + "The same as `replace-match', but surrounds the replacement with spaces." + (apply 'replace-match rest) + (save-excursion + (goto-char (match-beginning (or subexp 0))) + (just-one-space) + (goto-char (match-end (or subexp 0))) + (just-one-space))) + + +(defun org-mouse-keyword-replace-menu (keywords &optional group itemformat + nosurround) + "A helper function. + +Returns a menu fragment consisting of KEYWORDS. When a keyword +is selected, group GROUP of the current match is replaced by the +keyword. The method ensures that both ends of the replacement +are separated from the rest of the text in the buffer by +individual spaces (unless NOSURROND is non-nil). + +The final entry of the menu is always \"None\", which removes the +match. + +ITEMFORMAT governs formatting of the elements of KEYWORDS. If it +is a function, it is invoked with the keyword as the only +argument. If it is a string, it is interpreted as the format +string to (format ITEMFORMAT keyword). If it is neither a string +nor a function, elements of KEYWORDS are used directly. +" + (setq group (or group 0)) + (let ((replace (org-mouse-match-closure + (if nosurround 'replace-match + 'org-mouse-replace-match-and-surround)))) + (append + (org-mouse-keyword-menu + keywords + `(lambda (keyword) (funcall ,replace keyword t t nil ,group)) + (match-string group) + itemformat) + `(["None" org-mouse-remove-match-and-spaces + :style radio + :selected ,(not (member (match-string group) keywords))])))) + +(defun org-mouse-show-headlines () + "Change the visibility of the current org buffer to only show headlines." + (interactive) + (let ((this-command 'org-cycle) + (last-command 'org-cycle) + (org-cycle-global-status nil)) + (org-cycle '(4)) + (org-cycle '(4)))) + +(defun org-mouse-show-overview () + "Change visibility of current org buffer to first-level headlines only." + (interactive) + (let ((org-cycle-global-status nil)) + (org-cycle '(4)))) + +(defun org-mouse-set-priority (priority) + "Set the priority of the current headline to PRIORITY." + (flet ((read-char-exclusive () priority)) + (org-priority))) + +(defvar org-mouse-priority-regexp "\\[#\\([A-Z]\\)\\]" + "Regular expression matching the priority indicator. +Differs from `org-priority-regexp' in that it doesn't contain the +leading '.*?'.") + +(defun org-mouse-get-priority (&optional default) + "Return the priority of the current headline. +DEFAULT is returned if no priority is given in the headline." + (save-excursion + (if (org-mouse-re-search-line org-mouse-priority-regexp) + (match-string 1) + (when default (char-to-string org-default-priority))))) + +;; (defun org-mouse-at-link () +;; (and (eq (get-text-property (point) 'face) 'org-link) +;; (save-excursion +;; (goto-char (previous-single-property-change (point) 'face)) +;; (or (looking-at org-bracket-link-regexp) +;; (looking-at org-angle-link-re) +;; (looking-at org-plain-link-re))))) + + +(defun org-mouse-delete-timestamp () + "Deletes the current timestamp as well as the preceding keyword. +SCHEDULED: or DEADLINE: or ANYTHINGLIKETHIS:" + (when (or (org-at-date-range-p) (org-at-timestamp-p)) + (replace-match "") ; delete the timestamp + (skip-chars-backward " :A-Z") + (when (looking-at " *[A-Z][A-Z]+:") + (replace-match "")))) + +(defun org-mouse-looking-at (regexp skipchars &optional movechars) + (save-excursion + (let ((point (point))) + (if (looking-at regexp) t + (skip-chars-backward skipchars) + (forward-char (or movechars 0)) + (when (looking-at regexp) + (> (match-end 0) point)))))) + +(defun org-mouse-priority-list () + (loop for priority from ?A to org-lowest-priority + collect (char-to-string priority))) + +(defun org-mouse-tag-menu () ;todo + (append + (let ((tags (org-split-string (org-get-tags) ":"))) + (org-mouse-keyword-menu + (sort (mapcar 'car (org-get-buffer-tags)) 'string-lessp) + `(lambda (tag) + (org-mouse-set-tags + (sort (if (member tag (quote ,tags)) + (delete tag (quote ,tags)) + (cons tag (quote ,tags))) + 'string-lessp))) + `(lambda (tag) (member tag (quote ,tags))) + )) + '("--" + ["Align Tags Here" (org-set-tags nil t) t] + ["Align Tags in Buffer" (org-set-tags t t) t] + ["Set Tags ..." (org-set-tags) t]))) + + + +(defun org-mouse-set-tags (tags) + (save-excursion + ;; remove existing tags first + (beginning-of-line) + (when (org-mouse-re-search-line ":\\(\\([A-Za-z_]+:\\)+\\)") + (replace-match "")) + + ;; set new tags if any + (when tags + (end-of-line) + (insert " :" (mapconcat 'identity tags ":") ":") + (org-set-tags nil t)))) + +(defun org-mouse-insert-checkbox () + (interactive) + (and (org-at-item-p) + (goto-char (match-end 0)) + (unless (org-at-item-checkbox-p) + (delete-horizontal-space) + (insert " [ ] ")))) + +(defun org-mouse-agenda-type (type) + (case type + ('tags "Tags: ") + ('todo "TODO: ") + ('tags-tree "Tags tree: ") + ('todo-tree "TODO tree: ") + ('occur-tree "Occur tree: ") + (t "Agenda command ???"))) + + +(defun org-mouse-list-options-menu (alloptions &optional function) + (let ((options (save-match-data + (split-string (match-string-no-properties 1))))) + (print options) + (loop for name in alloptions + collect + (vector name + `(progn + (replace-match + (mapconcat 'identity + (sort (if (member ',name ',options) + (delete ',name ',options) + (cons ',name ',options)) + 'string-lessp) + " ") + nil nil nil 1) + (when (functionp ',function) (funcall ',function))) + :style 'toggle + :selected (and (member name options) t))))) + +(defun org-mouse-clip-text (text maxlength) + (if (> (length text) maxlength) + (concat (substring text 0 (- maxlength 3)) "...") + text)) + +(defun org-mouse-popup-global-menu () + (popup-menu + `("Main Menu" + ["Show Overview" org-mouse-show-overview t] + ["Show Headlines" org-mouse-show-headlines t] + ["Show All" show-all t] + ["Remove Highlights" org-remove-occur-highlights + :visible org-occur-highlights] + "--" + ["Check Deadlines" + (if (functionp 'org-check-deadlines-and-todos) + (org-check-deadlines-and-todos org-deadline-warning-days) + (org-check-deadlines org-deadline-warning-days)) t] + ["Check TODOs" org-show-todo-tree t] + ("Check Tags" + ,@(org-mouse-keyword-menu + (sort (mapcar 'car (org-get-buffer-tags)) 'string-lessp) + '(lambda (tag) (org-tags-sparse-tree nil tag))) + "--" + ["Custom Tag ..." org-tags-sparse-tree t]) + ["Check Phrase ..." org-occur] + "--" + ["Display Agenda" org-agenda-list t] + ["Display Timeline" org-timeline t] + ["Display TODO List" org-todo-list t] + ("Display Tags" + ,@(org-mouse-keyword-menu + (sort (mapcar 'car (org-get-buffer-tags)) 'string-lessp) + '(lambda (tag) (org-tags-view nil tag))) + "--" + ["Custom Tag ..." org-tags-view t]) + ["Display Calendar" org-goto-calendar t] + "--" + ,@(org-mouse-keyword-menu + (mapcar 'car org-agenda-custom-commands) + '(lambda (key) + (eval `(flet ((read-char-exclusive () (string-to-char ,key))) + (org-agenda nil)))) + nil + '(lambda (key) + (let ((entry (assoc key org-agenda-custom-commands))) + (org-mouse-clip-text + (cond + ((stringp (nth 1 entry)) (nth 1 entry)) + ((stringp (nth 2 entry)) + (concat (org-mouse-agenda-type (nth 1 entry)) + (nth 2 entry))) + (t "Agenda Command '%s'")) + 30)))) + "--" + ["Delete Blank Lines" delete-blank-lines + :visible (org-mouse-empty-line)] + ["Insert Checkbox" org-mouse-insert-checkbox + :visible (and (org-at-item-p) (not (org-at-item-checkbox-p)))] + ["Insert Checkboxes" + (org-mouse-for-each-item 'org-mouse-insert-checkbox) + :visible (and (org-at-item-p) (not (org-at-item-checkbox-p)))] + ["Plain List to Outline" org-mouse-transform-to-outline + :visible (org-at-item-p)]))) + + +(defun org-mouse-get-context (contextlist context) + (let ((contextdata (assq context contextlist))) + (when contextdata + (save-excursion + (goto-char (second contextdata)) + (re-search-forward ".*" (third contextdata)))))) + +(defun org-mouse-for-each-item (function) + (save-excursion + (ignore-errors + (while t (org-previous-item))) + (ignore-errors + (while t + (funcall function) + (org-next-item))))) + +(defun org-mouse-bolp () + "Returns true if there only spaces, tabs, and '*', between the beginning of line and the point" + (save-excursion + (skip-chars-backward " \t*") (bolp))) + +(defun org-mouse-insert-item (text) + (case (org-mouse-line-position) + (:beginning ; insert before + (beginning-of-line) + (looking-at "[ \t]*") + (open-line 1) + (indent-to (- (match-end 0) (match-beginning 0))) + (insert "+ ")) + + (:middle ; insert after + (end-of-line) + (newline t) + (indent-relative) + (insert "+ ")) + + (:end ; insert text here + (skip-chars-backward " \t") + (kill-region (point) (point-at-eol)) + (unless (looking-back org-mouse-punctuation) + (insert (concat org-mouse-punctuation " "))))) + + (insert text) + (beginning-of-line)) + +(defadvice dnd-insert-text (around org-mouse-dnd-insert-text activate) + (if (eq major-mode 'org-mode) + (org-mouse-insert-item text) + ad-do-it)) + +(defadvice dnd-open-file (around org-mouse-dnd-open-file activate) + (if (eq major-mode 'org-mode) + (org-mouse-insert-item uri) + ad-do-it)) + +(defun org-mouse-match-closure (function) + (let ((match (match-data t))) + `(lambda (&rest rest) + (save-match-data + (set-match-data ',match) + (apply ',function rest))))) + +(defun org-mouse-todo-keywords () + (if (boundp 'org-todo-keywords-1) org-todo-keywords-1 org-todo-keywords)) + +(defun org-mouse-match-todo-keyword () + (save-excursion + (org-back-to-heading) + (if (looking-at outline-regexp) (goto-char (match-end 0))) + (or (looking-at (concat " +" org-todo-regexp " *")) + (looking-at " \\( *\\)")))) + +(defun org-mouse-yank-link (click) + (interactive "e") + ;; Give temporary modes such as isearch a chance to turn off. + (run-hooks 'mouse-leave-buffer-hook) + (mouse-set-point click) + (setq mouse-selection-click-count 0) + (delete-horizontal-space) + (insert-for-yank (concat " [[" (current-kill 0) "]] "))) + +(defun org-mouse-context-menu (&optional event) + (let ((stamp-prefixes (list org-deadline-string org-scheduled-string)) + (contextlist (org-context))) + (flet ((get-context (context) (org-mouse-get-context contextlist context))) + (cond + ((org-mouse-mark-active) + (let ((region-string (buffer-substring (region-beginning) (region-end)))) + (popup-menu + `(nil + ["Sparse Tree" (org-occur ',region-string)] + ["Find in Buffer" (occur ',region-string)] + ["Grep in Current Dir" + (grep (format "grep -rnH -e '%s' *" ',region-string))] + ["Grep in Parent Dir" + (grep (format "grep -rnH -e '%s' ../*" ',region-string))] + "--" + ["Convert to Link" + (progn (save-excursion (goto-char (region-beginning)) (insert "[[")) + (save-excursion (goto-char (region-end)) (insert "]]")))] + ["Insert Link Here" (org-mouse-yank-link ',event)])))) + + ((save-excursion (beginning-of-line) (looking-at "#\\+STARTUP: \\(.*\\)")) + (popup-menu + `(nil + ,@(org-mouse-list-options-menu (mapcar 'car org-startup-options) + 'org-mode-restart)))) + ((or (eolp) + (and (looking-at "\\( \\|\t\\)\\(+:[0-9a-zA-Z_:]+\\)?\\( \\|\t\\)+$") + (looking-back " \\|\t"))) + (org-mouse-popup-global-menu)) + ((get-context :checkbox) + (popup-menu + '(nil + ["Toggle" org-toggle-checkbox t] + ["Remove" org-mouse-remove-match-and-spaces t] + "" + ["All Clear" (org-mouse-for-each-item + (lambda () + (when (save-excursion (org-at-item-checkbox-p)) + (replace-match "[ ]"))))] + ["All Set" (org-mouse-for-each-item + (lambda () + (when (save-excursion (org-at-item-checkbox-p)) + (replace-match "[X]"))))] + ["All Toggle" (org-mouse-for-each-item 'org-toggle-checkbox) t] + ["All Remove" (org-mouse-for-each-item + (lambda () + (when (save-excursion (org-at-item-checkbox-p)) + (org-mouse-remove-match-and-spaces))))] + ))) + ((and (org-mouse-looking-at "\\b\\w+" "a-zA-Z0-9_") + (member (match-string 0) (org-mouse-todo-keywords))) + (popup-menu + `(nil + ,@(org-mouse-keyword-replace-menu (org-mouse-todo-keywords)) + "--" + ["Check TODOs" org-show-todo-tree t] + ["List all TODO keywords" org-todo-list t] + [,(format "List only %s" (match-string 0)) + (org-todo-list (match-string 0)) t] + ))) + ((and (org-mouse-looking-at "\\b[A-Z]+:" "A-Z") + (member (match-string 0) stamp-prefixes)) + (popup-menu + `(nil + ,@(org-mouse-keyword-replace-menu stamp-prefixes) + "--" + ["Check Deadlines" org-check-deadlines t] + ))) + ((org-mouse-looking-at org-mouse-priority-regexp "[]A-Z#") ; priority + (popup-menu `(nil ,@(org-mouse-keyword-replace-menu + (org-mouse-priority-list) 1 "Priority %s" t)))) + ((get-context :link) + (popup-menu + '(nil + ["Open" org-open-at-point t] + ["Open in Emacs" (org-open-at-point t) t] + "--" + ["Copy link" (kill-new (match-string 0))] + ["Cut link" + (progn + (kill-region (match-beginning 0) (match-end 0)) + (just-one-space))] + "--" + ["Grep for TODOs" + (grep (format "grep -nH -i 'todo\\|fixme' %s*" (match-string 2)))] +; ["Paste file link" ((insert "file:") (yank))] + ))) + ((org-mouse-looking-at ":\\([A-Za-z0-9_]+\\):" "A-Za-z0-9_" -1) ;tags + (popup-menu + `(nil + [,(format "Display '%s'" (match-string 1)) + (org-tags-view nil ,(match-string 1))] + [,(format "Sparse Tree '%s'" (match-string 1)) + (org-tags-sparse-tree nil ,(match-string 1))] + "--" + ,@(org-mouse-tag-menu)))) + ((org-at-timestamp-p) + (popup-menu + '(nil + ["Show Day" org-open-at-point t] + ["Change Timestamp" org-time-stamp t] + ["Delete Timestamp" (org-mouse-delete-timestamp) t] + ["Compute Time Range" org-evaluate-time-range (org-at-date-range-p)] + "--" + ["Set for Today" org-mouse-timestamp-today] + ["Set for Tomorrow" (org-mouse-timestamp-today 1 'day)] + ["Set in 1 Week" (org-mouse-timestamp-today 7 'day)] + ["Set in 2 Weeks" (org-mouse-timestamp-today 14 'day)] + ["Set in a Month" (org-mouse-timestamp-today 1 'month)] + "--" + ["+ 1 Day" (org-timestamp-change 1 'day)] + ["+ 1 Week" (org-timestamp-change 7 'day)] + ["+ 1 Month" (org-timestamp-change 1 'month)] + "--" + ["- 1 Day" (org-timestamp-change -1 'day)] + ["- 1 Week" (org-timestamp-change -7 'day)] + ["- 1 Month" (org-timestamp-change -1 'month)]))) + ((get-context :table-special) + (let ((mdata (match-data))) + (incf (car mdata) 2) + (store-match-data mdata)) + (message "match: %S" (match-string 0)) + (popup-menu `(nil ,@(org-mouse-keyword-replace-menu + '(" " "!" "^" "_" "$" "#" "*" "'") 0 + (lambda (mark) + (case (string-to-char mark) + (? "( ) Nothing Special") + (?! "(!) Column Names") + (?^ "(^) Field Names Above") + (?_ "(^) Field Names Below") + (?$ "($) Formula Parameters") + (?# "(#) Recalculation: Auto") + (?* "(*) Recalculation: Manual") + (?' "(') Recalculation: None"))) t)))) + ((assq :table contextlist) + (popup-menu + '(nil + ["Align Table" org-ctrl-c-ctrl-c] + ["Blank Field" org-table-blank-field] + ["Edit Field" org-table-edit-field] + "--" + ("Column" + ["Move Column Left" org-metaleft] + ["Move Column Right" org-metaright] + ["Delete Column" org-shiftmetaleft] + ["Insert Column" org-shiftmetaright] + "--" + ["Enable Narrowing" (setq org-table-limit-column-width (not org-table-limit-column-width)) :selected org-table-limit-column-width :style toggle]) + ("Row" + ["Move Row Up" org-metaup] + ["Move Row Down" org-metadown] + ["Delete Row" org-shiftmetaup] + ["Insert Row" org-shiftmetadown] + ["Sort lines in region" org-table-sort-lines (org-at-table-p)] + "--" + ["Insert Hline" org-table-insert-hline]) + ("Rectangle" + ["Copy Rectangle" org-copy-special] + ["Cut Rectangle" org-cut-special] + ["Paste Rectangle" org-paste-special] + ["Fill Rectangle" org-table-wrap-region]) + "--" + ["Set Column Formula" org-table-eval-formula] + ["Set Field Formula" (org-table-eval-formula '(4))] + ["Edit Formulas" org-table-edit-formulas] + "--" + ["Recalculate Line" org-table-recalculate] + ["Recalculate All" (org-table-recalculate '(4))] + ["Iterate All" (org-table-recalculate '(16))] + "--" + ["Toggle Recalculate Mark" org-table-rotate-recalc-marks] + ["Sum Column/Rectangle" org-table-sum + :active (or (org-at-table-p) (org-region-active-p))] + ["Field Info" org-table-field-info] + ["Debug Formulas" + (setq org-table-formula-debug (not org-table-formula-debug)) + :style toggle :selected org-table-formula-debug] + ))) + ((and (assq :headline contextlist) (not (eolp))) + (let ((priority (org-mouse-get-priority t))) + (popup-menu + `("Headline Menu" + ("Tags and Priorities" + ,@(org-mouse-keyword-menu + (org-mouse-priority-list) + '(lambda (keyword) + (org-mouse-set-priority (string-to-char keyword))) + priority "Priority %s") + "--" + ,@(org-mouse-tag-menu)) + ("TODO Status" + ,@(progn (org-mouse-match-todo-keyword) + (org-mouse-keyword-replace-menu (org-mouse-todo-keywords) + 1))) + ["Show Tags" + (with-current-buffer org-mouse-main-buffer (org-agenda-show-tags)) + :visible (not org-mouse-direct)] + ["Show Priority" + (with-current-buffer org-mouse-main-buffer (org-agenda-show-priority)) + :visible (not org-mouse-direct)] + ,@(if org-mouse-direct '("--") nil) + ["New Heading" org-mouse-insert-heading :visible org-mouse-direct] + ["Set Deadline" + (progn (org-mouse-end-headline) (insert " ") (org-deadline)) + :active (not (save-excursion + (org-mouse-re-search-line org-deadline-regexp)))] + ["Schedule Task" + (progn (org-mouse-end-headline) (insert " ") (org-schedule)) + :active (not (save-excursion + (org-mouse-re-search-line org-scheduled-regexp)))] + ["Insert Timestamp" + (progn (org-mouse-end-headline) (insert " ") (org-time-stamp nil)) t] +; ["Timestamp (inactive)" org-time-stamp-inactive t] + "--" + ["Archive Subtree" org-archive-subtree] + ["Cut Subtree" org-cut-special] + ["Copy Subtree" org-copy-special] + ["Paste Subtree" org-paste-special :visible org-mouse-direct] + ("Sort Children" + ["Alphabetically" (org-sort-entries nil ?a)] + ["Numerically" (org-sort-entries nil ?n)] + ["By Time/Date" (org-sort-entries nil ?t)] + "--" + ["Reverse Alphabetically" (org-sort-entries nil ?A)] + ["Reverse Numerically" (org-sort-entries nil ?N)] + ["Reverse By Time/Date" (org-sort-entries nil ?T)]) + "--" + ["Move Trees" org-mouse-move-tree :active nil] + )))) + (t + (org-mouse-popup-global-menu)))))) + +;; (defun org-mouse-at-regexp (regexp) +;; (save-excursion +;; (let ((point (point)) +;; (bol (progn (beginning-of-line) (point))) +;; (eol (progn (end-of-line) (point)))) +;; (goto-char point) +;; (re-search-backward regexp bol 1) +;; (and (not (eolp)) +;; (progn (forward-char) +;; (re-search-forward regexp eol t)) +;; (<= (match-beginning 0) point))))) + +(defun org-mouse-mark-active () + (and mark-active transient-mark-mode)) + +(defun org-mouse-in-region-p (pos) + (and (org-mouse-mark-active) + (>= pos (region-beginning)) + (< pos (region-end)))) + +(defun org-mouse-down-mouse (event) + (interactive "e") + (setq this-command last-command) + (unless (and (= 1 (event-click-count event)) + (org-mouse-in-region-p (posn-point (event-start event)))) + (mouse-drag-region event))) + +(add-hook 'org-mode-hook + '(lambda () + (setq org-mouse-context-menu-function 'org-mouse-context-menu) + +; (define-key org-mouse-map [follow-link] 'mouse-face) + (define-key org-mouse-map (if (featurep 'xemacs) [button3] [mouse-3]) nil) + (define-key org-mode-map [mouse-3] 'org-mouse-show-context-menu) + (define-key org-mode-map [down-mouse-1] 'org-mouse-down-mouse) + (define-key org-mouse-map [C-drag-mouse-1] 'org-mouse-move-tree) + (define-key org-mouse-map [C-down-mouse-1] 'org-mouse-move-tree-start) + (define-key org-mode-map [S-mouse-2] 'org-mouse-yank-link) + (define-key org-mode-map [drag-mouse-3] 'org-mouse-yank-link) + (define-key org-mouse-map [drag-mouse-3] 'org-mouse-move-tree) + (define-key org-mouse-map [down-mouse-3] 'org-mouse-move-tree-start) + + (font-lock-add-keywords nil + `((,outline-regexp + 0 `(face org-link mouse-face highlight keymap ,org-mouse-map) + 'prepend) + ("^[ \t]*\\([-+*]\\|[0-9]+[.)]\\) +" + (1 `(face org-link keymap ,org-mouse-map mouse-face highlight) 'prepend)) + ("^[ \t]*\\([-+*]\\|[0-9]+[.)]\\) +\\(\\[[ X]\\]\\)" + (2 `(face bold keymap ,org-mouse-map mouse-face highlight) t))) + t) + + (defadvice org-open-at-point (around org-mouse-open-at-point activate) + (let ((context (org-context))) + (cond + ((assq :headline-stars context) (org-cycle)) + ((assq :checkbox context) (org-toggle-checkbox)) + ((assq :item-bullet context) + (let ((org-cycle-include-plain-lists t)) (org-cycle))) + (t ad-do-it)))))) + +(defun org-mouse-move-tree-start (event) + (interactive "e") + (message "Same line: promote/demote, (***):move before, (text): make a child")) + + +(defun org-mouse-make-marker (position) + (with-current-buffer (window-buffer (posn-window position)) + (copy-marker (posn-point position)))) + +(defun org-mouse-move-tree (event) + ;; todo: handle movements between different buffers + (interactive "e") + (save-excursion + (let* ((start (org-mouse-make-marker (event-start event))) + (end (org-mouse-make-marker (event-end event))) + (sbuf (marker-buffer start)) + (ebuf (marker-buffer end))) + + (when (and sbuf ebuf) + (set-buffer sbuf) + (goto-char start) + (org-back-to-heading) + (if (and (eq sbuf ebuf) + (equal + (point) + (save-excursion (goto-char end) (org-back-to-heading) (point)))) + ;; if the same line then promote/demote + (if (>= end start) (org-demote-subtree) (org-promote-subtree)) + ;; if different lines then move + (org-cut-subtree) + + (set-buffer ebuf) + (goto-char end) + (org-back-to-heading) + (when (and (eq sbuf ebuf) + (equal + (point) + (save-excursion (goto-char start) + (org-back-to-heading) (point)))) + (outline-end-of-subtree) + (end-of-line) + (if (eobp) (newline) (forward-char))) + + (when (looking-at outline-regexp) + (let ((level (- (match-end 0) (match-beginning 0)))) + (when (> end (match-end 0)) + (outline-end-of-subtree) + (end-of-line) + (if (eobp) (newline) (forward-char)) + (setq level (1+ level))) + (org-paste-subtree level) + (save-excursion + (outline-end-of-subtree) + (when (bolp) (delete-char -1)))))))))) + + +(defun org-mouse-transform-to-outline () + (interactive) + (org-back-to-heading) + (let ((minlevel 1000) + (replace-text (concat (match-string 0) "* "))) + (beginning-of-line 2) + (save-excursion + (while (not (or (eobp) (looking-at outline-regexp))) + (when (looking-at org-mouse-plain-list-regexp) + (setq minlevel (min minlevel (- (match-end 1) (match-beginning 1))))) + (forward-line))) + (while (not (or (eobp) (looking-at outline-regexp))) + (when (and (looking-at org-mouse-plain-list-regexp) + (eq minlevel (- (match-end 1) (match-beginning 1)))) + (replace-match replace-text)) + (forward-line)))) + +(defvar _cmd) ;dynamically scoped from `org-with-remote-undo'. + +(defun org-mouse-do-remotely (command) +; (org-agenda-check-no-diary) + (when (get-text-property (point) 'org-marker) + (let* ((anticol (- (point-at-eol) (point))) + (marker (get-text-property (point) 'org-marker)) + (buffer (marker-buffer marker)) + (pos (marker-position marker)) + (hdmarker (get-text-property (point) 'org-hd-marker)) + (buffer-read-only nil) + (newhead "--- removed ---") + (org-mouse-direct nil) + (org-mouse-main-buffer (current-buffer))) + (when (eq (with-current-buffer buffer major-mode) 'org-mode) + (let ((endmarker (save-excursion + (set-buffer buffer) + (outline-end-of-subtree) + (forward-char 1) + (copy-marker (point))))) + (org-with-remote-undo buffer + (with-current-buffer buffer + (widen) + (goto-char pos) + (org-show-hidden-entry) + (save-excursion + (and (outline-next-heading) + (org-flag-heading nil))) ; show the next heading + (org-back-to-heading) + (setq marker (copy-marker (point))) + (goto-char (max (point-at-bol) (- (point-at-eol) anticol))) + (funcall command) + (message "_cmd: %S" _cmd) + (message "this-command: %S" this-command) + (unless (eq (marker-position marker) (marker-position endmarker)) + (setq newhead (org-get-heading)))) + + (beginning-of-line 1) + (save-excursion + (org-agenda-change-all-lines newhead hdmarker 'fixface)))) + t)))) + +(defun org-mouse-agenda-context-menu (&optional event) + (or (org-mouse-do-remotely 'org-mouse-context-menu) + (popup-menu + '("Agenda" + ("Agenda Files") + "--" + ["Undo" (progn (message "last command: %S" last-command) (setq this-command 'org-agenda-undo) (org-agenda-undo)) + :visible (if (eq last-command 'org-agenda-undo) + org-agenda-pending-undo-list + org-agenda-undo-list)] + ["Rebuild Buffer" org-agenda-redo t] + ["New Diary Entry" + org-agenda-diary-entry (org-agenda-check-type nil 'agenda 'timeline) t] + "--" + ["Goto Today" org-agenda-goto-today + (org-agenda-check-type nil 'agenda 'timeline) t] + ["Display Calendar" org-agenda-goto-calendar + (org-agenda-check-type nil 'agenda 'timeline) t] + ("Calendar Commands" + ["Phases of the Moon" org-agenda-phases-of-moon + (org-agenda-check-type nil 'agenda 'timeline)] + ["Sunrise/Sunset" org-agenda-sunrise-sunset + (org-agenda-check-type nil 'agenda 'timeline)] + ["Holidays" org-agenda-holidays + (org-agenda-check-type nil 'agenda 'timeline)] + ["Convert" org-agenda-convert-date + (org-agenda-check-type nil 'agenda 'timeline)] + "--" + ["Create iCalendar file" org-export-icalendar-combine-agenda-files t]) + "--" + ["Day View" org-agenda-day-view + :active (org-agenda-check-type nil 'agenda) + :style radio :selected (equal org-agenda-ndays 1)] + ["Week View" org-agenda-week-view + :active (org-agenda-check-type nil 'agenda) + :style radio :selected (equal org-agenda-ndays 7)] + "--" + ["Show Logbook entries" org-agenda-log-mode + :style toggle :selected org-agenda-show-log + :active (org-agenda-check-type nil 'agenda 'timeline)] + ["Include Diary" org-agenda-toggle-diary + :style toggle :selected org-agenda-include-diary + :active (org-agenda-check-type nil 'agenda)] + ["Use Time Grid" org-agenda-toggle-time-grid + :style toggle :selected org-agenda-use-time-grid + :active (org-agenda-check-type nil 'agenda)] + ["Follow Mode" org-agenda-follow-mode + :style toggle :selected org-agenda-follow-mode] + "--" + ["Quit" org-agenda-quit t] + ["Exit and Release Buffers" org-agenda-exit t] + )))) + +(defun org-mouse-get-gesture (event) + (let ((startxy (posn-x-y (event-start event))) + (endxy (posn-x-y (event-end event)))) + (if (< (car startxy) (car endxy)) :right :left))) + + +; (setq org-agenda-mode-hook nil) +(add-hook 'org-agenda-mode-hook + '(lambda () + (setq org-mouse-context-menu-function 'org-mouse-agenda-context-menu) + (define-key org-agenda-keymap + (if (featurep 'xemacs) [button3] [mouse-3]) + 'org-mouse-show-context-menu) + (define-key org-agenda-keymap [down-mouse-3] 'org-mouse-move-tree-start) + (define-key org-agenda-keymap [C-mouse-4] 'org-agenda-earlier) + (define-key org-agenda-keymap [C-mouse-5] 'org-agenda-later) + (define-key org-agenda-keymap [drag-mouse-3] + '(lambda (event) (interactive "e") + (case (org-mouse-get-gesture event) + (:left (org-agenda-earlier 1)) + (:right (org-agenda-later 1))))))) + +(provide 'org-mouse)