org-mouse.el

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