org-mouse.el

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