lisp/org-mouse.el

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