[Emacs-diffs] Changes to org-mouse.el [EMACS_22_BASE]

[Carsten Dominik]

CVSROOT:        /sources/emacs
Module name:    emacs
Branch:         EMACS_22_BASE
Changes by:     Carsten Dominik <cdominik>      08/04/08 07:44:52

Index: org-mouse.el
===================================================================
RCS file: org-mouse.el
diff -N org-mouse.el
--- /dev/null   1 Jan 1970 00:00:00 -0000
+++ org-mouse.el        8 Apr 2008 07:44:50 -0000       1.5.2.2
@@ -0,0 +1,1110 @@
+;;; org-mouse.el --- Better mouse support for org-mode
+
+;; Copyright (C) 2006, 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.23
+;;
+;; 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)
+
+;; arch-tag: ff1ae557-3529-41a3-95c6-baaebdcc280f