org-mouse.el

   1 ;;; org-mouse.el --- Better mouse support for org-mode
   2
   3 ;; Copyright (c) 2006 Piotr Zielinski
   4 ;;
   5 ;; Author: Piotr Zielinski <piotr dot zielinski at gmail dot com>
   6 ;; Version: 0.24a
   7 ;; $Id: org-mouse.el 817 2007-02-01 00:28:02Z pz215 $
   8 ;;
   9 ;; The latest version of this file is available from
  10 ;;
  11 ;; http://www.cl.cam.ac.uk/~pz215/files/org-mouse.el
  12 ;;
  13 ;; This file is *NOT* part of GNU Emacs.
  14 ;; This file is distributed under the same terms as GNU Emacs.
  15
  16 ;; This program is free software; you can redistribute it and/or
  17 ;; modify it under the terms of the GNU General Public License as
  18 ;; published by the Free Software Foundation; either version 2 of
  19 ;; the License, or (at your option) any later version.
  20
  21 ;; This program is distributed in the hope that it will be
  22 ;; useful, but WITHOUT ANY WARRANTY; without even the implied
  23 ;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
  24 ;; PURPOSE.  See the GNU General Public License for more details.
  25
  26 ;; You should have received a copy of the GNU General Public
  27 ;; License along with this program; if not, write to the Free
  28 ;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
  29 ;; MA 02111-1307 USA
  30
  31 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  32 ;;
  33 ;;; Commentary:
  34 ;;
  35 ;; Org-mouse provides better mouse support for org-mode.  Org-mode is
  36 ;; a mode for keeping notes, maintaining ToDo lists, and doing project
  37 ;; planning with a fast and effective plain-text system.  It is
  38 ;; available from
  39 ;;
  40 ;; http://staff.science.uva.nl/~dominik/Tools/org/
  41 ;;
  42 ;; Org-mouse implements the following features:
  43 ;; * following links with the left mouse button (in Emacs 22)
  44 ;; * subtree expansion/collapse (org-cycle) with the left mouse button
  45 ;; * several context menus on the right mouse button:
  46 ;;    + general text
  47 ;;    + headlines
  48 ;;    + timestamps
  49 ;;    + priorities
  50 ;;    + links
  51 ;;    + tags
  52 ;; * promoting/demoting/moving subtrees with mouse-3
  53 ;;    + if the drag starts and ends in the same line then promote/demote
  54 ;;    + otherwise move the subtree
  55 ;; * date/time extraction from selected text (requires a python script)
  56 ;;   (eg. select text from your email and click "Add Appointment")
  57 ;;
  58 ;; The python script that automatically extracts date/time information
  59 ;; from a piece of English text is available from:
  60 ;;
  61 ;; http://www.cl.cam.ac.uk/~pz215/files/timeparser.py
  62 ;;
  63 ;; Use
  64 ;; ------------
  65 ;;
  66 ;; To use this package, put the following line in your .emacs:
  67 ;;
  68 ;;    (require 'org-mouse)
  69 ;;
  70 ;; Tested with Emacs 22.0.50, org-mode 4.58
  71
  72 ;; Fixme:
  73 ;; + deal with folding / unfolding issues
  74
  75 ;; TODO (This list is only theoretical, if you'd like to have some
  76 ;; feature implemented or a bug fix please send me an email, even if
  77 ;; something similar appears in the list below.  This will help me get
  78 ;; the priorities right.):
  79 ;;
  80 ;; + org-store-link, insert link
  81 ;; + org tables
  82 ;; + occur with the current word/tag (same menu item)
  83 ;; + ctrl-c ctrl-c, for example, renumber the current list
  84 ;; + internal links
  85
  86 ;; Please email me with new feature suggestions / bugs
  87
  88 ;; History:
  89 ;;
  90 ;; Version 0.24
  91 ;; + minor changes to the table menu
  92 ;;
  93 ;; Version 0.23
  94 ;; + preliminary support for tables and calculation marks
  95 ;; + context menu support for org-agenda-undo & org-sort-entries
  96 ;;
  97 ;; Version 0.22
  98 ;; + handles undo support for the agenda buffer (requires org-mode >=4.58)
  99 ;;
 100 ;; Version 0.21
 101 ;; + selected text activates its context menu
 102 ;; + shift-middleclick or right-drag inserts the text from the clipboard in the form of a link
 103 ;;
 104 ;; Version 0.20
 105 ;; + the new "TODO Status" submenu replaces the "Cycle TODO" menu item
 106 ;; + the TODO menu can now list occurrences of a specific TODO keyword
 107 ;; + #+STARTUP line is now recognized
 108 ;;
 109 ;; Version 0.19
 110 ;; + added support for dragging URLs to the org-buffer
 111 ;;
 112 ;; Version 0.18
 113 ;; + added support for agenda blocks
 114 ;;
 115 ;; Version 0.17
 116 ;; + toggle checkboxes with a single click
 117 ;;
 118 ;; Version 0.16
 119 ;; + added support for checkboxes
 120 ;;
 121 ;; Version 0.15
 122 ;; + org-mode now works with the Agenda buffer as well
 123 ;;
 124 ;; Version 0.14
 125 ;; + added a menu option that converts plain list items to outline items
 126 ;;
 127 ;; Version 0.13
 128 ;; + "Insert Heading" now inserts a sibling heading if the point is
 129 ;;   on "***" and a child heading otherwise
 130 ;;
 131 ;; Version 0.12
 132 ;; + compatible with Emacs 21
 133 ;; + custom agenda commands added to the main menu
 134 ;; + moving trees should now work between windows in the same frame
 135 ;;
 136 ;; Version 0.11
 137 ;; + fixed org-mouse-at-link (thanks to Carsten)
 138 ;; + removed [follow-link] bindings
 139 ;;
 140 ;; Version 0.10
 141 ;; + added a menu option to remove highlights
 142 ;; + compatible with org-mode 4.21 now
 143 ;;
 144 ;; Version 0.08:
 145 ;; + trees can be moved/promoted/demoted by dragging with the right
 146 ;;   mouse button (mouse-3)
 147 ;; + small changes in the above function
 148 ;;
 149 ;; Versions 0.01 -- 0.07: (I don't remember)
 150
 151 (require 'cl)
 152
 153 (defvar org-mouse-plain-list-regexp "\\([ \t]*\\)\\([-+*]\\|[0-9]+[.)]\\) ")
 154 (defvar org-mouse-direct t)
 155
 156 (defgroup org-mouse nil
 157   "Org-mouse"
 158   :tag "Org Mouse."
 159   :group 'org)
 160
 161 (defcustom org-mouse-punctuation ":"
 162   ""
 163   :group 'org-mouse
 164   :type 'string)
 165
 166
 167 (defun org-mouse-re-search-line (regexp)
 168   "Searches the current line for a given regular expression."
 169   (beginning-of-line)
 170   (re-search-forward regexp (point-at-eol) t))
 171
 172 (defun org-mouse-end-headline ()
 173   "Go to the end of current headline (ignoring tags)."
 174   (interactive)
 175   (end-of-line)
 176   (skip-chars-backward "\t ")
 177   (when (looking-back ":[A-Za-z]+:")
 178     (skip-chars-backward ":A-Za-z")
 179     (skip-chars-backward "\t ")))
 180
 181
 182 (defun org-mouse-show-context-menu (event prefix)
 183   (interactive "@e \nP")
 184   (if (and (= (event-click-count event) 1)
 185            (or (not mark-active)
 186                (sit-for (/ double-click-time 1000.0))))
 187       (progn
 188         (select-window (posn-window (event-start event)))
 189         (when (not (org-mouse-mark-active))
 190           (goto-char (posn-point (event-start event)))
 191           (when (not (eolp)) (save-excursion (run-hooks 'post-command-hook)))
 192           (let ((redisplay-dont-pause t))
 193             (sit-for 0)))
 194         (if (functionp org-mouse-context-menu-function)
 195             (funcall org-mouse-context-menu-function event)
 196           (mouse-major-mode-menu event prefix))
 197         )
 198     (setq this-command 'mouse-save-then-kill)
 199     (mouse-save-then-kill event)))
 200
 201
 202 (defun org-mouse-line-position ()
 203   "Returns :beginning :middle :end"
 204   (cond
 205    ((eolp) :end)
 206    ((org-mouse-bolp) :begin)
 207    (t :middle)))
 208
 209 (defun org-mouse-empty-line ()
 210   (save-excursion (beginning-of-line) (looking-at "[ \t]*$")))
 211
 212 (defun org-mouse-next-heading ()
 213   "Goes to the next heading and if there is none, it ensures that the point is at the beginning of an empty line."
 214   (unless (outline-next-heading)
 215     (beginning-of-line)
 216     (unless (org-mouse-empty-line)
 217       (end-of-line)
 218       (newline))))
 219
 220 (defun org-mouse-insert-heading ()
 221   (interactive)
 222   (case (org-mouse-line-position)
 223     (:begin (beginning-of-line)
 224             (org-insert-heading))
 225     (t (org-mouse-next-heading)
 226        (org-insert-heading))))
 227
 228 (defun org-mouse-timestamp-today (&optional shift units)
 229   (interactive)
 230   (flet ((org-read-date (&rest rest) (current-time)))
 231      (org-time-stamp nil))
 232   (when shift
 233     (org-timestamp-change shift units)))
 234
 235 (defun org-mouse-keyword-menu (keywords function &optional selected itemformat)
 236   (mapcar
 237    `(lambda (keyword)
 238      (vector (cond
 239               ((functionp ,itemformat) (funcall ,itemformat keyword))
 240               ((stringp ,itemformat) (format ,itemformat keyword))
 241               (t keyword))
 242              (list 'funcall ,function keyword)
 243              :style (cond
 244                      ((null ,selected) t)
 245                      ((functionp ,selected) 'toggle)
 246                      (t 'radio))
 247              :selected (if (functionp ,selected)
 248                            (and (funcall ,selected keyword) t)
 249                          (equal ,selected keyword))))
 250     keywords))
 251
 252 (defun org-mouse-remove-match-and-spaces ()
 253   (interactive)
 254   (replace-match "")
 255   (just-one-space))
 256
 257 (defun org-mouse-replace-match-and-surround (newtext &optional fixedcase
 258                                                      literal string subexp)
 259   "The same as replace-match, but surrounds the replacement with spaces."
 260   (apply 'replace-match rest)
 261   (save-excursion
 262     (goto-char (match-beginning (or subexp 0)))
 263     (just-one-space)
 264     (goto-char (match-end (or subexp 0)))
 265     (just-one-space)))
 266
 267
 268 (defun org-mouse-keyword-replace-menu (keywords &optional group itemformat
 269                                                 nosurround)
 270   (setq group (or group 0))
 271   (let ((replace (org-mouse-match-closure
 272                   (if nosurround 'replace-match
 273                     'org-mouse-replace-match-and-surround))))
 274     (append
 275      (org-mouse-keyword-menu
 276       keywords
 277       `(lambda (keyword) (funcall ,replace keyword t t nil ,group))
 278       (match-string group)
 279       itemformat)
 280      `(["None" org-mouse-remove-match-and-spaces
 281         :style radio
 282         :selected ,(not (member (match-string group) keywords))]))))
 283
 284 (defvar org-mouse-context-menu-function nil)
 285 (make-variable-buffer-local 'org-mouse-context-menu-function)
 286
 287 (defun org-mouse-show-headlines ()
 288   (interactive)
 289   (let ((this-command 'org-cycle)
 290         (last-command 'org-cycle)
 291         (org-cycle-global-status nil))
 292     (org-cycle '(4))
 293     (org-cycle '(4))))
 294
 295 (defun org-mouse-show-overview ()
 296   (interactive)
 297   (let ((org-cycle-global-status nil))
 298     (org-cycle '(4))))
 299
 300 (defun org-mouse-set-priority (priority)
 301   (flet ((read-char-exclusive () priority))
 302     (org-priority)))
 303
 304 (defvar org-mouse-priority-regexp "\\[#\\([A-Z]\\)\\]"
 305   "Regular expression matching the priority indicator.  Differs from `org-priority-regexp' in that it doesn't contain the leading '.*?'.")
 306
 307
 308 (defun org-mouse-get-priority (&optional default)
 309   (save-excursion
 310     (if (org-mouse-re-search-line org-mouse-priority-regexp)
 311         (match-string 1)
 312       (when default (char-to-string org-default-priority)))))
 313
 314 (defun org-mouse-at-link ()
 315   (and (eq (get-text-property (point) 'face) 'org-link)
 316        (save-excursion
 317          (goto-char (previous-single-property-change (point) 'face))
 318          (or (looking-at org-bracket-link-regexp)
 319              (looking-at org-angle-link-re)
 320              (looking-at org-plain-link-re)))))
 321
 322
 323 (defun org-mouse-delete-timestamp ()
 324   "Deletes the current timestamp as well as the preceding
 325 SCHEDULED: or DEADLINE: or ANYTHINGLIKETHIS:"
 326   (when (or (org-at-date-range-p) (org-at-timestamp-p))
 327     (replace-match "")                  ; delete the timestamp
 328     (skip-chars-backward " :A-Z")
 329     (when (looking-at " *[A-Z][A-Z]+:")
 330       (replace-match ""))))
 331
 332 (defun org-mouse-looking-at (regexp skipchars &optional movechars)
 333   (save-excursion
 334     (let ((point (point)))
 335       (if (looking-at regexp) t
 336         (skip-chars-backward skipchars)
 337         (forward-char (or movechars 0))
 338         (when (looking-at regexp)
 339           (> (match-end 0) point))))))
 340
 341
 342 (defun org-mouse-priority-list ()
 343    (loop for priority from ?A to org-lowest-priority
 344          collect (char-to-string priority)))
 345
 346 (defun org-mouse-tag-menu ()            ;todo
 347   (append
 348    (let ((tags (org-split-string (org-get-tags) ":")))
 349      (org-mouse-keyword-menu
 350       (sort (mapcar 'car (org-get-buffer-tags)) 'string-lessp)
 351       `(lambda (tag)
 352          (org-mouse-set-tags
 353           (sort (if (member tag (quote ,tags))
 354                     (delete tag (quote ,tags))
 355                   (cons tag (quote ,tags)))
 356                 'string-lessp)))
 357       `(lambda (tag) (member tag (quote ,tags)))
 358       ))
 359    '("--"
 360      ["Align Tags Here" (org-set-tags nil t) t]
 361      ["Align Tags in Buffer" (org-set-tags t t) t]
 362      ["Set Tags ..." (org-set-tags) t])))
 363
 364
 365
 366 (defun org-mouse-set-tags (tags)
 367   (save-excursion
 368     ;; remove existing tags first
 369     (beginning-of-line)
 370     (when (org-mouse-re-search-line ":\\(\\([A-Za-z_]+:\\)+\\)")
 371       (replace-match ""))
 372
 373     ;; set new tags if any
 374     (when tags
 375       (end-of-line)
 376       (insert " :" (mapconcat 'identity tags ":") ":")
 377       (org-set-tags nil t))))
 378
 379 (defun org-mouse-insert-checkbox ()
 380   (interactive)
 381   (and (org-at-item-p)
 382        (goto-char (match-end 0))
 383        (unless (org-at-item-checkbox-p)
 384          (delete-horizontal-space)
 385          (insert " [ ] "))))
 386
 387 (defun org-mouse-agenda-type (type)
 388   (case type
 389    ('tags "Tags: ")
 390    ('todo "TODO: ")
 391    ('tags-tree "Tags tree: ")
 392    ('todo-tree "TODO tree: ")
 393    ('occur-tree "Occur tree: ")
 394    (t "Agenda command ???")))
 395
 396
 397 (defun org-mouse-list-options-menu (alloptions &optional function)
 398   (let ((options (save-match-data
 399                    (split-string (match-string-no-properties 1)))))
 400     (print options)
 401     (loop for name in alloptions
 402           collect
 403           (vector name
 404                   `(progn
 405                      (replace-match
 406                       (mapconcat 'identity
 407                                  (sort (if (member ',name ',options)
 408                                            (delete ',name ',options)
 409                                          (cons ',name ',options))
 410                                        'string-lessp)
 411                                  " ")
 412                       nil nil nil 1)
 413                      (when (functionp ',function) (funcall ',function)))
 414                     :style 'toggle
 415                     :selected (and (member name options) t)))))
 416
 417
 418
 419
 420 (defun org-mouse-clip-text (text maxlength)
 421   (if (> (length text) maxlength)
 422       (concat (substring text 0 (- maxlength 3)) "...")
 423     text))
 424
 425 (defun org-mouse-popup-global-menu ()
 426   (popup-menu
 427    `("Main Menu"
 428      ["Show Overview" org-mouse-show-overview t]
 429      ["Show Headlines" org-mouse-show-headlines t]
 430      ["Show All" show-all t]
 431      ["Remove Highlights" org-remove-occur-highlights
 432       :visible org-occur-highlights]
 433      "--"
 434      ["Check Deadlines"
 435       (if (functionp 'org-check-deadlines-and-todos)
 436           (org-check-deadlines-and-todos org-deadline-warning-days)
 437         (org-check-deadlines org-deadline-warning-days)) t]
 438      ["Check TODOs" org-show-todo-tree t]
 439      ("Check Tags"
 440       ,@(org-mouse-keyword-menu
 441          (sort (mapcar 'car (org-get-buffer-tags)) 'string-lessp)
 442          '(lambda (tag) (org-tags-sparse-tree nil tag)))
 443       "--"
 444       ["Custom Tag ..." org-tags-sparse-tree t])
 445      ["Check Phrase ..." org-occur]
 446      "--"
 447      ["Display Agenda" org-agenda-list t]
 448      ["Display Timeline" org-timeline t]
 449      ["Display TODO List" org-todo-list t]
 450      ("Display Tags"
 451       ,@(org-mouse-keyword-menu
 452          (sort (mapcar 'car (org-get-buffer-tags)) 'string-lessp)
 453          '(lambda (tag) (org-tags-view nil tag)))
 454       "--"
 455       ["Custom Tag ..." org-tags-view t])
 456      ["Display Calendar" org-goto-calendar t]
 457      "--"
 458      ,@(org-mouse-keyword-menu
 459         (mapcar 'car org-agenda-custom-commands)
 460         '(lambda (key)
 461            (eval `(flet ((read-char-exclusive () (string-to-char ,key)))
 462                       (org-agenda nil))))
 463         nil
 464         '(lambda (key)
 465            (let ((entry (assoc key org-agenda-custom-commands)))
 466              (org-mouse-clip-text
 467               (cond
 468                ((stringp (nth 1 entry)) (nth 1 entry))
 469                ((stringp (nth 2 entry))
 470                 (concat (org-mouse-agenda-type (nth 1 entry))
 471                         (nth 2 entry)))
 472                (t "Agenda Command '%s'"))
 473               30))))
 474 ;; )
 475      "--"
 476      ["Delete Blank Lines" delete-blank-lines
 477       :visible (org-mouse-empty-line)]
 478      ["Insert Checkbox" org-mouse-insert-checkbox
 479       :visible (and (org-at-item-p) (not (org-at-item-checkbox-p)))]
 480      ["Insert Checkboxes"
 481       (org-mouse-for-each-item 'org-mouse-insert-checkbox)
 482       :visible (and (org-at-item-p) (not (org-at-item-checkbox-p)))]
 483      ["Plain List to Outline" org-mouse-transform-to-outline
 484       :visible (org-at-item-p)])))
 485
 486
 487 (defun org-mouse-get-context (contextlist context)
 488   (let ((contextdata (assq context contextlist)))
 489     (when contextdata
 490       (save-excursion
 491         (goto-char (second contextdata))
 492         (re-search-forward ".*" (third contextdata))))))
 493
 494 (defun org-mouse-for-each-item (function)
 495   (save-excursion
 496     (ignore-errors
 497       (while t (org-previous-item)))
 498     (ignore-errors
 499       (while t
 500         (funcall function)
 501         (org-next-item)))))
 502
 503 (defun org-mouse-bolp ()
 504   "Returns true if there only spaces, tabs, and '*',  between the beginning of line and the point"
 505   (save-excursion
 506     (skip-chars-backward " \t*") (bolp)))
 507
 508 (defun org-mouse-insert-item (text)
 509   (case (org-mouse-line-position)
 510     (:begin                     ; insert before
 511      (beginning-of-line)
 512      (looking-at "[ \t]*")
 513      (open-line 1)
 514      (indent-to (- (match-end 0) (match-beginning 0)))
 515      (insert "+ "))
 516
 517     (:middle                    ; insert after
 518      (end-of-line)
 519      (newline t)
 520      (indent-relative)
 521      (insert "+ "))
 522
 523     (:end                               ; insert text here
 524      (skip-chars-backward " \t")
 525      (kill-region (point) (point-at-eol))
 526      (unless (looking-back org-mouse-punctuation)
 527        (insert (concat org-mouse-punctuation " ")))))
 528
 529   (insert text)
 530   (beginning-of-line))
 531
 532
 533
 534 (defadvice dnd-insert-text (around org-mouse-dnd-insert-text activate)
 535   (if (eq major-mode 'org-mode)
 536       (org-mouse-insert-item text)
 537     ad-do-it))
 538
 539 (defadvice dnd-open-file (around org-mouse-dnd-open-file activate)
 540   (if (eq major-mode 'org-mode)
 541       (org-mouse-insert-item uri)
 542     ad-do-it))
 543
 544 (defun org-mouse-match-closure (function)
 545   (let ((match (match-data t)))
 546     `(lambda (&rest rest)
 547       (save-match-data
 548         (set-match-data ',match)
 549         (apply ',function rest)))))
 550
 551 (defun org-mouse-todo-keywords ()
 552   (if (boundp 'org-todo-keywords-1) org-todo-keywords-1 org-todo-keywords))
 553
 554 (defun org-mouse-match-todo-keyword ()
 555   (save-excursion
 556     (org-back-to-heading)
 557     (if (looking-at outline-regexp) (goto-char (match-end 0)))
 558     (or (looking-at (concat " +" org-todo-regexp " *"))
 559         (looking-at " \\( *\\)"))))
 560
 561 (defun org-mouse-yank-link (click)
 562   (interactive "e")
 563   ;; Give temporary modes such as isearch a chance to turn off.
 564   (run-hooks 'mouse-leave-buffer-hook)
 565   (mouse-set-point click)
 566   (setq mouse-selection-click-count 0)
 567   (delete-horizontal-space)
 568   (insert-for-yank (concat " [[" (current-kill 0) "]] ")))
 569
 570
 571 (defun org-mouse-context-menu (&optional event)
 572   (let ((stamp-prefixes (list org-deadline-string org-scheduled-string))
 573         (contextlist (org-context)))
 574     (flet ((get-context (context) (org-mouse-get-context contextlist context)))
 575   (cond
 576    ((org-mouse-mark-active)
 577     (let ((region-string (buffer-substring (region-beginning) (region-end))))
 578       (popup-menu
 579        `(nil
 580          ["Sparse Tree" (org-occur ',region-string)]
 581          ["Find in Buffer" (occur ',region-string)]
 582          ["Grep in Current Dir"
 583           (grep (format "grep -rnH -e '%s' *" ',region-string))]
 584          ["Grep in Parent Dir"
 585           (grep (format "grep -rnH -e '%s' ../*" ',region-string))]
 586          "--"
 587          ["Convert to Link"
 588           (progn (save-excursion (goto-char (region-beginning)) (insert "[["))
 589                  (save-excursion (goto-char (region-end)) (insert "]]")))]
 590          ["Insert Link Here" (org-mouse-yank-link ',event)]))))
 591
 592    ((save-excursion (beginning-of-line) (looking-at "#\\+STARTUP: \\(.*\\)"))
 593     (popup-menu
 594      `(nil
 595        ,@(org-mouse-list-options-menu (mapcar 'car org-startup-options)
 596                                       'org-mode-restart))))
 597    ((or (eolp)
 598         (and (looking-at "\\(  \\|\t\\)\\(+:[0-9a-zA-Z_:]+\\)?\\(  \\|\t\\)+$")
 599              (looking-back "  \\|\t")))
 600     (org-mouse-popup-global-menu))
 601    ((get-context :checkbox)
 602     (popup-menu
 603      '(nil
 604        ["Toggle" org-toggle-checkbox t]
 605        ["Remove" org-mouse-remove-match-and-spaces t]
 606        ""
 607        ["All Clear" (org-mouse-for-each-item
 608                      (lambda ()
 609                        (when (save-excursion (org-at-item-checkbox-p))
 610                          (replace-match "[ ]"))))]
 611        ["All Set" (org-mouse-for-each-item
 612                      (lambda ()
 613                        (when (save-excursion (org-at-item-checkbox-p))
 614                          (replace-match "[X]"))))]
 615        ["All Toggle" (org-mouse-for-each-item 'org-toggle-checkbox) t]
 616        ["All Remove" (org-mouse-for-each-item
 617                      (lambda ()
 618                        (when (save-excursion (org-at-item-checkbox-p))
 619                          (org-mouse-remove-match-and-spaces))))]
 620        )))
 621    ((and (org-mouse-looking-at "\\b\\w+" "a-zA-Z0-9_")
 622          (member (match-string 0) (org-mouse-todo-keywords)))
 623     (popup-menu
 624      `(nil
 625        ,@(org-mouse-keyword-replace-menu (org-mouse-todo-keywords))
 626        "--"
 627        ["Check TODOs" org-show-todo-tree t]
 628        ["List all TODO keywords" org-todo-list t]
 629        [,(format "List only %s" (match-string 0))
 630         (org-todo-list (match-string 0)) t]
 631        )))
 632    ((and (org-mouse-looking-at "\\b[A-Z]+:" "A-Z")
 633          (member (match-string 0) stamp-prefixes))
 634     (popup-menu
 635      `(nil
 636        ,@(org-mouse-keyword-replace-menu stamp-prefixes)
 637        "--"
 638        ["Check Deadlines" org-check-deadlines t]
 639        )))
 640    ((org-mouse-looking-at org-mouse-priority-regexp "[]A-Z#") ; priority
 641     (popup-menu `(nil ,@(org-mouse-keyword-replace-menu
 642                          (org-mouse-priority-list) 1 "Priority %s" t))))
 643    ((org-mouse-at-link)
 644     (popup-menu
 645      '(nil
 646        ["Open" org-open-at-point t]
 647        ["Open in Emacs" (org-open-at-point t) t]
 648        "--"
 649        ["Copy link" (kill-new (match-string 0))]
 650        ["Cut link"
 651         (progn
 652           (kill-region (match-beginning 0) (match-end 0))
 653           (just-one-space))]
 654        "--"
 655        ["Grep for TODOs"
 656         (grep (format "grep -nH -i 'todo\\|fixme' %s*" (match-string 2)))]
 657 ;       ["Paste file link" ((insert "file:") (yank))]
 658        )))
 659    ((org-mouse-looking-at ":\\([A-Za-z0-9_]+\\):" "A-Za-z0-9_" -1) ;tags
 660     (popup-menu
 661      `(nil
 662        [,(format "Display '%s'" (match-string 1))
 663         (org-tags-view nil ,(match-string 1))]
 664        [,(format "Sparse Tree '%s'" (match-string 1))
 665         (org-tags-sparse-tree nil ,(match-string 1))]
 666        "--"
 667        ,@(org-mouse-tag-menu))))
 668    ((org-at-timestamp-p)
 669     (popup-menu
 670      '(nil
 671        ["Show Day" org-open-at-point t]
 672        ["Change Timestamp" org-time-stamp t]
 673        ["Delete Timestamp" (org-mouse-delete-timestamp) t]
 674        ["Compute Time Range" org-evaluate-time-range (org-at-date-range-p)]
 675        "--"
 676        ["Set for Today" org-mouse-timestamp-today]
 677        ["Set for Tomorrow" (org-mouse-timestamp-today 1 'day)]
 678        ["Set in 1 Week" (org-mouse-timestamp-today 7 'day)]
 679        ["Set in 2 Weeks" (org-mouse-timestamp-today 14 'day)]
 680        ["Set in a Month" (org-mouse-timestamp-today 1 'month)]
 681        "--"
 682        ["+ 1 Day" (org-timestamp-change 1 'day)]
 683        ["+ 1 Week" (org-timestamp-change 7 'day)]
 684        ["+ 1 Month" (org-timestamp-change 1 'month)]
 685        "--"
 686        ["- 1 Day" (org-timestamp-change -1 'day)]
 687        ["- 1 Week" (org-timestamp-change -7 'day)]
 688        ["- 1 Month" (org-timestamp-change -1 'month)])))
 689    ((get-context :table-special)
 690     (let ((mdata (match-data)))
 691       (incf (car mdata) 2)
 692       (store-match-data mdata))
 693     (message "match: %S" (match-string 0))
 694     (popup-menu `(nil ,@(org-mouse-keyword-replace-menu
 695                          '(" " "!" "^" "_" "$" "#" "*" "'") 0
 696                          (lambda (mark)
 697                            (case (string-to-char mark)
 698                              (?  "( ) Nothing Special")
 699                              (?! "(!) Column Names")
 700                              (?^ "(^) Field Names Above")
 701                              (?_ "(^) Field Names Below")
 702                              (?$ "($) Formula Parameters")
 703                              (?# "(#) Recalculation: Auto")
 704                              (?* "(*) Recalculation: Manual")
 705                              (?' "(') Recalculation: None"))) t))))
 706    ((assq :table contextlist)
 707     (popup-menu
 708      '(nil
 709        ["Align Table" org-ctrl-c-ctrl-c]
 710        ["Blank Field" org-table-blank-field]
 711        ["Edit Field" org-table-edit-field]
 712         "--"
 713         ("Column"
 714          ["Move Column Left" org-metaleft]
 715          ["Move Column Right" org-metaright]
 716          ["Delete Column" org-shiftmetaleft]
 717          ["Insert Column" org-shiftmetaright]
 718          "--"
 719          ["Enable Narrowing" (setq org-table-limit-column-width (not org-table-limit-column-width)) :selected org-table-limit-column-width :style toggle])
 720         ("Row"
 721          ["Move Row Up" org-metaup]
 722          ["Move Row Down" org-metadown]
 723          ["Delete Row" org-shiftmetaup]
 724          ["Insert Row" org-shiftmetadown]
 725          ["Sort lines in region" org-table-sort-lines (org-at-table-p)]
 726          "--"
 727          ["Insert Hline" org-table-insert-hline])
 728         ("Rectangle"
 729          ["Copy Rectangle" org-copy-special]
 730          ["Cut Rectangle" org-cut-special]
 731          ["Paste Rectangle" org-paste-special]
 732          ["Fill Rectangle" org-table-wrap-region])
 733         "--"
 734         ["Set Column Formula" org-table-eval-formula]
 735         ["Set Field Formula" (org-table-eval-formula '(4))]
 736         ["Edit Formulas" org-table-edit-formulas]
 737         "--"
 738         ["Recalculate Line" org-table-recalculate]
 739         ["Recalculate All" (org-table-recalculate '(4))]
 740         ["Iterate All" (org-table-recalculate '(16))]
 741         "--"
 742         ["Toggle Recalculate Mark" org-table-rotate-recalc-marks]
 743         ["Sum Column/Rectangle" org-table-sum
 744          :active (or (org-at-table-p) (org-region-active-p))]
 745         ["Field Info" org-table-field-info]
 746         ["Debug Formulas"
 747          (setq org-table-formula-debug (not org-table-formula-debug))
 748          :style toggle :selected org-table-formula-debug]
 749         )))
 750    ((and (assq :headline contextlist) (not (eolp)))
 751     (let ((priority (org-mouse-get-priority t)))
 752       (popup-menu
 753        `("Headline Menu"
 754          ("Tags and Priorities"
 755           ,@(org-mouse-keyword-menu
 756              (org-mouse-priority-list)
 757              '(lambda (keyword)
 758                 (org-mouse-set-priority (string-to-char keyword)))
 759              priority "Priority %s")
 760           "--"
 761           ,@(org-mouse-tag-menu))
 762          ("TODO Status"
 763           ,@(progn (org-mouse-match-todo-keyword)
 764                    (org-mouse-keyword-replace-menu (org-mouse-todo-keywords)
 765                                                    1)))
 766          ["Show Tags"
 767           (with-current-buffer org-mouse-main-buffer (org-agenda-show-tags))
 768           :visible (not org-mouse-direct)]
 769          ["Show Priority"
 770           (with-current-buffer org-mouse-main-buffer (org-agenda-show-priority))
 771           :visible (not org-mouse-direct)]
 772          ,@(if org-mouse-direct '("--") nil)
 773          ["New Heading" org-mouse-insert-heading :visible org-mouse-direct]
 774          ["Set Deadline"
 775           (progn (org-mouse-end-headline) (insert " ") (org-deadline))
 776           :active (not (save-excursion
 777                          (org-mouse-re-search-line org-deadline-regexp)))]
 778          ["Schedule Task"
 779           (progn (org-mouse-end-headline) (insert " ") (org-schedule))
 780           :active (not (save-excursion
 781                          (org-mouse-re-search-line org-scheduled-regexp)))]
 782          ["Insert Timestamp"
 783           (progn (org-mouse-end-headline) (insert " ") (org-time-stamp nil)) t]
 784 ;        ["Timestamp (inactive)" org-time-stamp-inactive t]
 785          "--"
 786          ["Archive Subtree" org-archive-subtree]
 787          ["Cut Subtree"  org-cut-special]
 788          ["Copy Subtree"  org-copy-special]
 789          ["Paste Subtree"  org-paste-special :visible org-mouse-direct]
 790          ("Sort Children"
 791           ["Alphabetically" (org-sort-entries nil ?a)]
 792           ["Numerically" (org-sort-entries nil ?n)]
 793           ["By Time/Date" (org-sort-entries nil ?t)]
 794           "--"
 795           ["Reverse Alphabetically" (org-sort-entries nil ?A)]
 796           ["Reverse Numerically" (org-sort-entries nil ?N)]
 797           ["Reverse By Time/Date" (org-sort-entries nil ?T)])
 798          "--"
 799          ["Move Trees" org-mouse-move-tree :active nil]
 800          ))))
 801    (t
 802     (org-mouse-popup-global-menu))))))
 803
 804
 805
 806 ;; (defun org-mouse-at-regexp (regexp)
 807 ;;   (save-excursion
 808 ;;     (let ((point (point))
 809 ;;        (bol (progn (beginning-of-line) (point)))
 810 ;;        (eol (progn (end-of-line) (point))))
 811 ;;       (goto-char point)
 812 ;;       (re-search-backward regexp bol 1)
 813 ;;       (and (not (eolp))
 814 ;;         (progn (forward-char)
 815 ;;                (re-search-forward regexp eol t))
 816 ;;         (<= (match-beginning 0) point)))))
 817
 818 (defun org-mouse-mark-active ()
 819   (and mark-active transient-mark-mode))
 820
 821 (defun org-mouse-in-region-p (pos)
 822   (and (org-mouse-mark-active)
 823        (>= pos (region-beginning))
 824        (<  pos (region-end))))
 825
 826 (defun org-mouse-down-mouse (event)
 827   (interactive "e")
 828   (setq this-command last-command)
 829   (unless (and (= 1 (event-click-count event))
 830                (org-mouse-in-region-p (posn-point (event-start event))))
 831     (mouse-drag-region event)))
 832
 833 (add-hook 'org-mode-hook
 834   '(lambda ()
 835      (setq org-mouse-context-menu-function 'org-mouse-context-menu)
 836
 837 ;     (define-key org-mouse-map [follow-link] 'mouse-face)
 838      (define-key org-mouse-map (if (featurep 'xemacs) [button3] [mouse-3]) nil)
 839      (define-key org-mode-map [mouse-3] 'org-mouse-show-context-menu)
 840      (define-key org-mode-map [down-mouse-1] 'org-mouse-down-mouse)
 841      (define-key org-mouse-map [C-drag-mouse-1] 'org-mouse-move-tree)
 842      (define-key org-mouse-map [C-down-mouse-1] 'org-mouse-move-tree-start)
 843      (define-key org-mode-map [S-mouse-2] 'org-mouse-yank-link)
 844      (define-key org-mode-map [drag-mouse-3] 'org-mouse-yank-link)
 845      (define-key org-mouse-map [drag-mouse-3] 'org-mouse-move-tree)
 846      (define-key org-mouse-map [down-mouse-3] 'org-mouse-move-tree-start)
 847
 848      (font-lock-add-keywords nil
 849         `((,outline-regexp
 850            0 `(face org-link mouse-face highlight keymap ,org-mouse-map)
 851            'prepend)
 852           ("^[ \t]*\\([-+*]\\|[0-9]+[.)]\\) +"
 853            (1 `(face org-link keymap ,org-mouse-map mouse-face highlight) 'prepend))
 854           ("^[ \t]*\\([-+*]\\|[0-9]+[.)]\\) +\\(\\[[ X]\\]\\)"
 855            (2 `(face bold keymap ,org-mouse-map mouse-face highlight) t)))
 856         t)
 857
 858      (defadvice org-open-at-point (around org-mouse-open-at-point activate)
 859        (let ((context (org-context)))
 860          (cond
 861           ((assq :headline-stars context) (org-cycle))
 862           ((assq :checkbox context) (org-toggle-checkbox))
 863           ((assq :item-bullet context)
 864            (let ((org-cycle-include-plain-lists t)) (org-cycle)))
 865           (t ad-do-it))))))
 866
 867 (defun org-mouse-move-tree-start (event)
 868   (interactive "e")
 869   (message "Same line: promote/demote, (***):move before, (text): make a child"))
 870
 871
 872 (defun org-mouse-make-marker (position)
 873   (with-current-buffer (window-buffer (posn-window position))
 874     (copy-marker (posn-point position))))
 875
 876 (defun org-mouse-move-tree (event)
 877   ;; todo: handle movements between different buffers
 878   (interactive "e")
 879   (save-excursion
 880     (let* ((start (org-mouse-make-marker (event-start event)))
 881            (end (org-mouse-make-marker (event-end event)))
 882            (sbuf (marker-buffer start))
 883            (ebuf (marker-buffer end)))
 884
 885      (when (and sbuf ebuf)
 886       (set-buffer sbuf)
 887       (goto-char start)
 888       (org-back-to-heading)
 889       (if (and (eq sbuf ebuf)
 890                (equal
 891                 (point)
 892                 (save-excursion (goto-char end) (org-back-to-heading) (point))))
 893         ;; if the same line then promote/demote
 894         (if (>= end start) (org-demote-subtree) (org-promote-subtree))
 895       ;; if different lines then move
 896       (org-cut-subtree)
 897
 898       (set-buffer ebuf)
 899       (goto-char end)
 900       (org-back-to-heading)
 901       (when  (and (eq sbuf ebuf)
 902                   (equal
 903                    (point)
 904                    (save-excursion (goto-char start)
 905                                    (org-back-to-heading) (point))))
 906         (outline-end-of-subtree)
 907         (end-of-line)
 908         (if (eobp) (newline) (forward-char)))
 909
 910       (when (looking-at outline-regexp)
 911         (let ((level (- (match-end 0) (match-beginning 0))))
 912           (when (> end (match-end 0))
 913             (outline-end-of-subtree)
 914             (end-of-line)
 915             (if (eobp) (newline) (forward-char))
 916             (setq level (1+ level)))
 917           (org-paste-subtree level)
 918           (save-excursion
 919             (outline-end-of-subtree)
 920             (when (bolp) (delete-char -1))))))))))
 921
 922
 923 (defun org-mouse-transform-to-outline ()
 924   (interactive)
 925   (org-back-to-heading)
 926   (let ((minlevel 1000)
 927         (replace-text (concat (match-string 0) "* ")))
 928     (beginning-of-line 2)
 929     (save-excursion
 930       (while (not (or (eobp) (looking-at outline-regexp)))
 931         (when (looking-at org-mouse-plain-list-regexp)
 932           (setq minlevel (min minlevel (- (match-end 1) (match-beginning 1)))))
 933         (forward-line)))
 934     (while (not (or (eobp) (looking-at outline-regexp)))
 935       (when (and (looking-at org-mouse-plain-list-regexp)
 936                  (eq minlevel (- (match-end 1) (match-beginning 1))))
 937         (replace-match replace-text))
 938       (forward-line))))
 939
 940
 941
 942 (defun org-mouse-do-remotely (command)
 943 ;  (org-agenda-check-no-diary)
 944   (when (get-text-property (point) 'org-marker)
 945     (let* ((anticol (- (point-at-eol) (point)))
 946            (marker (get-text-property (point) 'org-marker))
 947            (buffer (marker-buffer marker))
 948            (pos (marker-position marker))
 949            (hdmarker (get-text-property (point) 'org-hd-marker))
 950            (buffer-read-only nil)
 951            (newhead "--- removed ---")
 952            (org-mouse-direct nil)
 953            (org-mouse-main-buffer (current-buffer)))
 954       (when (eq (with-current-buffer buffer major-mode) 'org-mode)
 955         (let ((endmarker (save-excursion
 956                           (set-buffer buffer)
 957                           (outline-end-of-subtree)
 958                           (forward-char 1)
 959                           (copy-marker (point)))))
 960           (org-with-remote-undo buffer
 961             (with-current-buffer buffer
 962               (widen)
 963               (goto-char pos)
 964               (org-show-hidden-entry)
 965               (save-excursion
 966                 (and (outline-next-heading)
 967                      (org-flag-heading nil)))   ; show the next heading
 968               (org-back-to-heading)
 969               (setq marker (copy-marker (point)))
 970               (goto-char (max (point-at-bol) (- (point-at-eol) anticol)))
 971               (funcall command)
 972               (message "_cmd: %S" _cmd)
 973               (message "this-command: %S" this-command)
 974               (unless (eq (marker-position marker) (marker-position endmarker))
 975                 (setq newhead (org-get-heading))))
 976
 977             (beginning-of-line 1)
 978             (save-excursion
 979               (org-agenda-change-all-lines newhead hdmarker 'fixface))))
 980         t))))
 981
 982 (defun org-mouse-agenda-context-menu (&optional event)
 983   (or (org-mouse-do-remotely 'org-mouse-context-menu)
 984       (popup-menu
 985        '("Agenda"
 986          ("Agenda Files")
 987          "--"
 988          ["Undo" (progn (message "last command: %S" last-command) (setq this-command 'org-agenda-undo) (org-agenda-undo))
 989           :visible (if (eq last-command 'org-agenda-undo)
 990                        org-agenda-pending-undo-list
 991                      org-agenda-undo-list)]
 992          ["Rebuild Buffer" org-agenda-redo t]
 993          ["New Diary Entry"
 994           org-agenda-diary-entry (org-agenda-check-type nil 'agenda 'timeline) t]
 995          "--"
 996          ["Goto Today" org-agenda-goto-today
 997           (org-agenda-check-type nil 'agenda 'timeline) t]
 998          ["Display Calendar" org-agenda-goto-calendar
 999           (org-agenda-check-type nil 'agenda 'timeline) t]
1000          ("Calendar Commands"
1001           ["Phases of the Moon" org-agenda-phases-of-moon
1002            (org-agenda-check-type nil 'agenda 'timeline)]
1003           ["Sunrise/Sunset" org-agenda-sunrise-sunset
1004            (org-agenda-check-type nil 'agenda 'timeline)]
1005           ["Holidays" org-agenda-holidays
1006            (org-agenda-check-type nil 'agenda 'timeline)]
1007           ["Convert" org-agenda-convert-date
1008            (org-agenda-check-type nil 'agenda 'timeline)]
1009           "--"
1010           ["Create iCalendar file" org-export-icalendar-combine-agenda-files t])
1011          "--"
1012          ["Day View" org-agenda-day-view
1013           :active (org-agenda-check-type nil 'agenda)
1014           :style radio :selected (equal org-agenda-ndays 1)]
1015          ["Week View" org-agenda-week-view
1016           :active (org-agenda-check-type nil 'agenda)
1017           :style radio :selected (equal org-agenda-ndays 7)]
1018          "--"
1019          ["Show Logbook entries" org-agenda-log-mode
1020           :style toggle :selected org-agenda-show-log
1021           :active (org-agenda-check-type nil 'agenda 'timeline)]
1022          ["Include Diary" org-agenda-toggle-diary
1023           :style toggle :selected org-agenda-include-diary
1024           :active (org-agenda-check-type nil 'agenda)]
1025          ["Use Time Grid" org-agenda-toggle-time-grid
1026           :style toggle :selected org-agenda-use-time-grid
1027           :active (org-agenda-check-type nil 'agenda)]
1028          ["Follow Mode" org-agenda-follow-mode
1029           :style toggle :selected org-agenda-follow-mode]
1030          "--"
1031          ["Quit" org-agenda-quit t]
1032          ["Exit and Release Buffers" org-agenda-exit t]
1033          ))))
1034
1035 (defun org-mouse-get-gesture (event)
1036   (let ((startxy (posn-x-y (event-start event)))
1037         (endxy (posn-x-y (event-end event))))
1038     (if (< (car startxy) (car endxy)) :right :left)))
1039
1040
1041 ; (setq org-agenda-mode-hook nil)
1042 (add-hook 'org-agenda-mode-hook
1043    '(lambda ()
1044      (setq org-mouse-context-menu-function 'org-mouse-agenda-context-menu)
1045      (define-key org-agenda-keymap
1046        (if (featurep 'xemacs) [button3] [mouse-3])
1047        'org-mouse-show-context-menu)
1048      (define-key org-agenda-keymap [down-mouse-3] 'org-mouse-move-tree-start)
1049      (define-key org-agenda-keymap [C-mouse-4] 'org-agenda-earlier)
1050      (define-key org-agenda-keymap [C-mouse-5] 'org-agenda-later)
1051      (define-key org-agenda-keymap [drag-mouse-3]
1052        '(lambda (event) (interactive "e")
1053           (case (org-mouse-get-gesture event)
1054             (:left (org-agenda-earlier 1))
1055             (:right (org-agenda-later 1)))))))
1056
1057 (provide 'org-mouse)
1058