org-mode-mirror/org-mouse.el

;;; org-mouse.el --- Better mouse support for org-mode

;; Copyright (c) 2006 Piotr Zielinski
;;
;; Author: Piotr Zielinski <piotr dot zielinski at gmail dot com>
;; Version: 0.21
;; $Id: org-mouse.el 347 2006-11-12 23:57:50Z pz215 $
;; 
;; The latest version of this file is available from
;;
;; http://www.cl.cam.ac.uk/~pz215/files/org-mouse.el
;;
;; This file is *NOT* part of GNU Emacs.
;; This file is distributed under the same terms as GNU Emacs.

;; This program 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 2 of
;; the License, or (at your option) any later version.

;; This program 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 this program; if not, write to the Free
;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
;; MA 02111-1307 USA

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;;
;; Org-mouse provides better mouse support for org-mode.  Org-mode is
;; a mode for keeping notes, maintaining ToDo lists, and doing project
;; planning with a fast and effective plain-text system.  It is
;; available from
;;
;; http://staff.science.uva.nl/~dominik/Tools/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 
;; * date/time extraction from selected text (requires a python script)
;;   (eg. select text from your email and click "Add Appointment")
;;
;; The python script that automatically extracts date/time information
;; from a piece of English text is available from:
;;
;; http://www.cl.cam.ac.uk/~pz215/files/timeparser.py
;;
;; Use
;; ------------
;;
;; To use this package, put the following line in your .emacs:
;;
;;    (require 'org-mouse)
;;
;; Tested with Emacs 22.0.50, org-mode 4.33

;; 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 me with new feature suggestions / bugs

;; History:
;;
;; 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))

(defvar org-mouse-plain-list-regexp "\\([ \t]*\\)\\([-+*]\\|[0-9]+[.)]\\) ")
(defvar org-mouse-direct t)

(defgroup org-mouse nil
  "Org-mouse"
  :tag "Org Mouse."
  :group 'org)

(defcustom org-mouse-punctuation ":"
  ""
  :group 'org-mouse
  :type 'string)


(defun org-mouse-re-search-line (regexp)
  "Searches 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 ")))


(defun org-mouse-show-context-menu (event prefix)
  (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 :middle :end"
  (cond
   ((eolp) :end)
   ((org-mouse-bolp) :begin)
   (t :middle)))

(defun org-mouse-empty-line ()
  (save-excursion (beginning-of-line) (looking-at "[ \t]*$")))

(defun org-mouse-next-heading ()
  "Goes to the next heading and if there is none, it ensures 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 ()
  (interactive)
  (case (org-mouse-line-position)
    (:begin (beginning-of-line)
	    (org-insert-heading))
    (t (org-mouse-next-heading)
       (org-insert-heading))))

(defun org-mouse-timestamp-today (&optional shift units) 
  (interactive)
  (flet ((org-read-date (x &optional y) (current-time)))
     (org-time-stamp nil))
  (when shift
    (org-timestamp-change shift units)))

(defun org-mouse-keyword-menu (keywords function &optional selected itemformat)
  (message "kmenu: %S" selected)
  (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 ()
  (interactive)
  (replace-match "")
  (just-one-space))

(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)
  (setq group (or group 0))
  (let ((replace (org-mouse-match-closure 
		  '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))]))))
     
(defvar org-mouse-context-menu-function nil)
(make-variable-buffer-local 'org-mouse-context-menu-function)

(defun org-mouse-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 ()
  (interactive) 
  (let ((org-cycle-global-status nil))
    (org-cycle '(4))))

(defun org-mouse-set-priority (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)
  (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
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 ()
  (let ((ret) (current org-lowest-priority))
    (while (>= current ?A)
      (push (char-to-string current) ret)
      (decf current))
    ret))

(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)])))

			      
;     ["Jump" org-goto])))

(defun org-mouse-get-context (contextlist context)
  (let ((contextdata (find-if (lambda (x) (eq (car x) context)) contextlist)))
    (when contextdata
      (save-excursion 
	(goto-char (nth 1 contextdata))
;	(looking-at regexp)))))
	(re-search-forward ".*" (nth 2 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)
    (:begin			; 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-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") (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-todo-keywords))
    (popup-menu 
     `(nil
       ,@(org-mouse-keyword-replace-menu org-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"))))
   ((org-mouse-at-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))]
;       ["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)])))
   ((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-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]
	 "--"
	 ["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))))
	
    
      
(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)))))
	  (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)
	    (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")
	 "--"
	 ["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)