From 251a3ca7c3a84b65547f4d125d961fd5845add41 Mon Sep 17 00:00:00 2001 From: Carsten Dominik Date: Fri, 16 Jul 2010 14:15:41 +0200 Subject: [PATCH] Add org-wikinodes.el as a contributed package * contrib/lisp/org-wikinodes.el: New file. * lisp/org-exp.el (org-export-preprocess-after-radio-targets-hook): (org-export-define-heading-targets-headline-hook): New hooks. * lisp/org.el (org-modules): Add entry for org-wikinodes.el. (org-font-lock-set-keywords-hook): New hook. (org-open-at-point-functions): New hook. (org-find-exact-headling-in-buffer): (org-find-exact-heading-in-directory): New functions. (org-mode-flyspell-verify): Better cursor position for checking if flyspell should ignore a word. --- contrib/README | 2 +- contrib/lisp/org-wikinodes.el | 339 ++++++++++++++++++++++++++++++++++ lisp/org-exp.el | 12 +- lisp/org.el | 56 +++++- 4 files changed, 405 insertions(+), 4 deletions(-) create mode 100644 contrib/lisp/org-wikinodes.el diff --git a/contrib/README b/contrib/README index 3cb076d0e..4a1879092 100644 --- a/contrib/README +++ b/contrib/README @@ -44,7 +44,7 @@ orgtbl-sqlinsert.el --- Convert Org-mode tables to SQL insertions org-toc.el --- Table of contents for Org-mode buffer org-track.el --- Keep up with Org development org-velocity.el --- something like Notational Velocity for Org - +org-wikinodes --- CamelCase wiki-like links for Org PACKAGES diff --git a/contrib/lisp/org-wikinodes.el b/contrib/lisp/org-wikinodes.el new file mode 100644 index 000000000..0a000521e --- /dev/null +++ b/contrib/lisp/org-wikinodes.el @@ -0,0 +1,339 @@ +;;; org-wikinodes.el --- Wiki-like CamelCase links to outline nodes + +;; Copyright (C) 2010 Free Software Foundation, Inc. + +;; Author: Carsten Dominik +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.01trans +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(require 'org) +(eval-when-compile + (require 'cl)) + +(defgroup org-wikinodes nil + "Wiki-like CamelCase links words to outline nodes in Org mode." + :tag "Org WikiNodes" + :group 'org) + +(defconst org-wikinodes-camel-regexp "\\<[A-Z]+[a-z]+[A-Z]+[a-z]+[a-zA-Z]*\\>" + "Regular expression matching CamelCase words.") + +(defcustom org-wikinodes-active t + "Should CamelCase links be active in the current file?" + :group 'org-wikinodes + :type 'boolean) +(put 'org-wikinodes-active 'safe-local-variable 'booleanp) + +(defcustom org-wikinodes-scope 'file + "The scope of searches for wiki targets. +Allowed values are: + +file Search for targets in the current file only +directory Search for targets in all org files in the current directory" + :group 'org-wikinodes + :type '(choice + (const :tag "Find targets in current file" file) + (const :tag "Find targets in current directory" directory))) + +(defcustom org-wikinodes-create-targets 'query + "Non-nil means create Wiki target when following a wiki link fails. +Allowed values are: + +nil never create node, just throw an error if the target does not exist +query ask the user what to do +t create the node in the current buffer +\"file.org\" create the node in the file \"file.org\", in the same directory + +If you are using wiki links across files, you need to set `org-wikinodes-scope' +to `directory'." + :group 'org-wikinodes + :type '(choice + (const :tag "Never automatically create node" nil) + (const :tag "In current file" t) + (file :tag "In one special file\n") + (const :tag "Query the user" query))) + +;;; Link activation + +(defun org-wikinodes-activate-links (limit) + "Activate CamelCase words as links to Wiki targets." + (when org-wikinodes-active + (let (case-fold-search) + (if (re-search-forward org-wikinodes-camel-regexp limit t) + (if (equal (char-after (point-at-bol)) ?*) + (progn + ;; in heading - deactivate flyspell + (org-remove-flyspell-overlays-in (match-beginning 0) + (match-end 0)) + (add-text-properties (match-beginning 0) (match-end 0) + '(org-no-flyspell t)) + t) + ;; this is a wiki link + (org-remove-flyspell-overlays-in (match-beginning 0) + (match-end 0)) + (add-text-properties (match-beginning 0) (match-end 0) + (list 'mouse-face 'highlight + 'face 'org-link + 'keymap org-mouse-map + 'help-echo "Wiki Link")) + t))))) + +;;; Following links and creating non-existing target nodes + +(defun org-wikinodes-open-at-point () + "Check if the cursor is on a Wiki link and follow the link. + +This function goes into `org-open-at-point-functions'." + (and org-wikinodes-active + (not (org-on-heading-p)) + (let (case-fold-search) (org-in-regexp org-wikinodes-camel-regexp)) + (progn (org-wikinodes-follow-link (match-string 0)) t))) + +(defun org-wikinodes-follow-link (target) + "Follow a wiki link to TARGET. + +This need to be found as an exact headline match, either in the current +buffer, or in any .org file in the current directory, depending on the +variable `org-wikinodes-scope'. + +If a target headline is not found, it may be created according to the +setting of `org-wikinodes-create-targets'." + (if current-prefix-arg (org-wikinodes-clear-direcory-targets-cache)) + (let ((create org-wikinodes-create-targets) + visiting buffer m pos file rpl) + (setq pos + (or (org-find-exact-headling-in-buffer target (current-buffer)) + (and (eq org-wikinodes-scope 'directory) + (setq file (org-wikinodes-which-file target)) + (org-find-exact-headling-in-buffer + target (or (get-file-buffer file) + (find-file-noselect file)))))) + (if pos + (progn + (org-mark-ring-push (point)) + (org-goto-marker-or-bmk pos) + (move-marker pos nil)) + (when (eq create 'query) + (if (eq org-wikinodes-scope 'directory) + (progn + (message "Node \"%s\" does not exist. Should it be created? +\[RET] in this buffer [TAB] in another file [q]uit" target) + (setq rpl (read-char-exclusive)) + (cond + ((member rpl '(?\C-g ?q)) (error "Abort")) + ((equal rpl ?\C-m) (setq create t)) + ((equal rpl ?\C-i) + (setq create (file-name-nondirectory + (read-file-name "Create in file: ")))) + (t (error "Invalid selection")))) + (if (y-or-n-p (format "Create new node \"%s\" in current buffer? " + target)) + (setq create t) + (error "Abort")))) + + (cond + ((not create) + ;; We are not allowed to create the new node + (error "No match for link to \"%s\"" target)) + ((stringp create) + ;; Make new node in another file + (org-mark-ring-push (point)) + (switch-to-buffer (find-file-noselect create)) + (goto-char (point-max)) + (or (bolp) (newline)) + (insert "\n* " target "\n") + (backward-char 1) + (org-wikinodes-add-target-to-cache target) + (message "New Wiki target `%s' created in file \"%s\"" + target create)) + (t + ;; Make new node in current buffer + (org-mark-ring-push (point)) + (goto-char (point-max)) + (or (bolp) (newline)) + (insert "* " target "\n") + (backward-char 1) + (org-wikinodes-add-target-to-cache target) + (message "New Wiki target `%s' created in current buffer" + target)))))) + +;;; The target cache + +(defvar org-wikinodes-directory-targets-cache nil) + +(defun org-wikinodes-clear-cache-when-on-target () + "When on a headline that is a Wiki target, clear the cache." + (when (and (org-on-heading-p) + (org-in-regexp (format org-complex-heading-regexp-format + org-wikinodes-camel-regexp)) + (org-in-regexp org-wikinodes-camel-regexp)) + (org-wikinodes-clear-direcory-targets-cache) + t)) + +(defun org-wikinodes-clear-direcory-targets-cache () + "Clear the cache where to find wiki targets." + (interactive) + (setq org-wikinodes-directory-targets-cache nil) + (message "Wiki target cache cleared, so that it will update when used again")) + +(defun org-wikinodes-get-targets () + "Return a list of all wiki targets in the current buffer." + (let ((re (format org-complex-heading-regexp-format + org-wikinodes-camel-regexp)) + (case-fold-search nil) + targets) + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (while (re-search-forward re nil t) + (push (org-match-string-no-properties 4) targets)))) + (nreverse targets))) + +(defun org-wikinodes-get-links-for-directory (dir) + "Return an alist that connects wiki links to files in directory DIR." + (let ((files (directory-files dir nil "\\`[^.#].*\\.org\\'")) + (org-inhibit-startup t) + target-file-alist file visiting m buffer) + (while (setq file (pop files)) + (setq visiting (org-find-base-buffer-visiting file)) + (setq buffer (or visiting (find-file-noselect file))) + (with-current-buffer buffer + (mapc + (lambda (target) + (setq target-file-alist (cons (cons target file) target-file-alist))) + (org-wikinodes-get-targets))) + (or visiting (kill-buffer buffer))) + target-file-alist)) + +(defun org-wikinodes-add-target-to-cache (target &optional file) + (setq file (or file buffer-file-name (error "No file for new wiki target"))) + (set-text-properties 0 (length target) nil target) + (let ((dir (file-name-directory (expand-file-name file))) + a) + (setq a (assoc dir org-wikinodes-directory-targets-cache)) + (if a + ;; Push the new target onto the existing list + (push (cons target (expand-file-name file)) (cdr a)) + ;; Call org-wikinodes-which-file so that the cache will be filled + (org-wikinodes-which-file target dir)))) + +(defun org-wikinodes-which-file (target &optional directory) + "Return the file for wiki headline TARGET DIRECTORY. +If there is no such wiki target, return nil." + (setq directory (expand-file-name (or directory default-directory))) + (unless (assoc directory org-wikinodes-directory-targets-cache) + (push (cons directory (org-wikinodes-get-links-for-directory directory)) + org-wikinodes-directory-targets-cache)) + (cdr (assoc target (cdr (assoc directory + org-wikinodes-directory-targets-cache))))) + +;;; Exporting Wiki links + +(defvar target) +(defvar target-alist) +(defvar last-section-target) +(defvar org-export-target-aliases) +(defun org-wikinodes-set-wiki-targets-during-export () + (let ((line (buffer-substring (point-at-bol) (point-at-eol))) + (case-fold-search nil) + wtarget a) + (when (string-match (format org-complex-heading-regexp-format + org-wikinodes-camel-regexp) + line) + (setq wtarget (match-string 4 line)) + (push (cons wtarget target) target-alist) + (setq a (or (assoc last-section-target org-export-target-aliases) + (progn + (push (list last-section-target) + org-export-target-aliases) + (car org-export-target-aliases)))) + (push (caar target-alist) (cdr a))))) + +(defvar org-current-export-file) +(defun org-wikinodes-process-links-for-export () + "Process Wiki links in the export preprocess buffer. + +Try to find target matches in the wiki scope and replace CamelCase words +with working links." + (let ((re org-wikinodes-camel-regexp) + (case-fold-search nil) + link file) + (goto-char (point-min)) + (while (re-search-forward re nil t) + (org-if-unprotected-at (match-beginning 0) + (unless (save-match-data + (or (org-on-heading-p) + (org-in-regexp org-bracket-link-regexp) + (org-in-regexp org-plain-link-re) + (org-in-regexp "<<[^<>]+>>"))) + (setq link (match-string 0)) + (delete-region (match-beginning 0) (match-end 0)) + (save-match-data + (cond + ((org-find-exact-headling-in-buffer link (current-buffer)) + ;; Found in current buffer + (insert (format "[[#%s][%s]]" link link))) + ((eq org-wikinodes-scope 'file) + ;; No match in file, and other files are not allowed + (insert (format "%s" link))) + ((setq file + (and (org-string-nw-p org-current-export-file) + (org-wikinodes-which-file + link (file-name-directory org-current-export-file)))) + ;; Match in another file in the current directory + (insert (format "[[file:%s::%s][%s]]" file link link))) + (t ;; No match for this link + (insert (format "%s" link)))))))))) + +;;; Hook the WikiNode mechanism into Org + +;; `C-c C-o' should follow wiki links +(add-hook 'org-open-at-point-functions 'org-wikinodes-open-at-point) + +;; `C-c C-c' should clear the cache +(add-hook 'org-ctrl-c-ctrl-c-hook 'org-wikinodes-clear-cache-when-on-target) + +;; Make Wiki haeding create additional link names for headlines +(add-hook 'org-export-define-heading-targets-headline-hook + 'org-wikinodes-set-wiki-targets-during-export) + +;; Turn Wiki links into links the exporter will treat correctly +(add-hook 'org-export-preprocess-after-radio-targets-hook + 'org-wikinodes-process-links-for-export) + +;; Activate CamelCase words as part of Org mode font lock + +(defun org-wikinodes-add-to-font-lock-keywords () + "Add wikinode CamelCase highlighting to `org-font-lock-extra-keywords'." + (let ((m (member '(org-activate-plain-links) org-font-lock-extra-keywords))) + (if m + (setcdr m (cons '(org-wikinodes-activate-links) (cdr m))) + (message + "Failed to add wikinodes to `org-font-lock-extra-keywords'.")))) + +(add-hook 'org-font-lock-set-keywords-hook + 'org-wikinodes-add-to-font-lock-keywords) + +(provide 'org-wikinodes) + +;; arch-tag: e3b56e38-a2be-478c-b56c-68a913ec54ec + +;;; org-wikinodes.el ends here diff --git a/lisp/org-exp.el b/lisp/org-exp.el index 36f820254..cd0a1050a 100644 --- a/lisp/org-exp.el +++ b/lisp/org-exp.el @@ -417,6 +417,10 @@ This is run just before backend-specific blocks get selected.") This is run after blockquote/quote/verse/center have been marked with cookies.") +(defvar org-export-preprocess-after-radio-targets-hook nil + "Hook for preprocessing an export buffer. +This is run after radio target processing.") + (defvar org-export-preprocess-before-normalizing-links-hook nil "Hook for preprocessing an export buffer. This hook is run before links are normalized.") @@ -1120,6 +1124,7 @@ on this string to produce the exported version." ;; Find matches for radio targets and turn them into internal links (org-export-mark-radio-links) + (run-hooks 'org-export-preprocess-after-radio-targets-hook) ;; Find all links that contain a newline and put them into a single line (org-export-concatenate-multiline-links) @@ -1185,6 +1190,10 @@ on this string to produce the exported version." p (or (next-single-property-change p :org-license-to-kill) (point-max)))))) +(defvar org-export-define-heading-targets-headline-hook nil + "Hook that is run when a headline was matched during target search. +This is part of the preprocessing for export.") + (defun org-export-define-heading-targets (target-alist) "Find all headings and define the targets for them. The new targets are added to TARGET-ALIST, which is also returned. @@ -1228,7 +1237,8 @@ Also find all ID and CUSTOM_ID properties and store them." (push (cons target target) target-alist) (add-text-properties (point-at-bol) (point-at-eol) - (list 'target target)))))) + (list 'target target)) + (run-hooks 'org-export-define-heading-targets-headline-hook))))) target-alist) (defun org-export-handle-invisible-targets (target-alist) diff --git a/lisp/org.el b/lisp/org.el index 1eb802376..2ac2aef1d 100644 --- a/lisp/org.el +++ b/lisp/org.el @@ -331,6 +331,7 @@ to add the symbol `xyz', and the package must have a call to (const :tag "C toc: Table of contents for Org-mode buffer" org-toc) (const :tag "C track: Keep up with Org-mode development" org-track) (const :tag "C velocity Something like Notational Velocity for Org" org-velocity) + (const :tag "C wikinodes: CamelCase wiki-like links" org-wikinodes) (repeat :tag "External packages" :inline t (symbol :tag "Package")))) (defcustom org-support-shift-select nil @@ -5379,6 +5380,12 @@ For plain list items, if they are matched by `outline-regexp', this returns (defvar org-font-lock-hook nil "Functions to be called for special font lock stuff.") +(defvar org-font-lock-set-keywords-hook nil + "Functions that can manipulate `org-font-lock-extra-keywords'. +This is calles after `org-font-lock-extra-keywords' is defined, but before +it is installed to be used by font lock. This can be useful if something +needs to be inserted at a specific position in the font-lock sequence.") + (defun org-font-lock-hook (limit) (run-hook-with-args 'org-font-lock-hook limit)) @@ -5473,6 +5480,7 @@ For plain list items, if they are matched by `outline-regexp', this returns '(org-fontify-meta-lines-and-blocks) ))) (setq org-font-lock-extra-keywords (delq nil org-font-lock-extra-keywords)) + (run-hooks 'org-font-lock-set-keywords-hook) ;; Now set the full font-lock-keywords (org-set-local 'org-font-lock-keywords org-font-lock-extra-keywords) (org-set-local 'font-lock-defaults @@ -8988,6 +8996,13 @@ Org-mode syntax." org-link-abbrev-alist-local))) (org-open-at-point arg reference-buffer))))) +(defvar org-open-at-point-functions nil + "Hook that is run when following a link at point. + +Functions in this hook must return t if they identify and follow +a link at point. If they don't find anything interesting at point, +they must return nil.") + (defun org-open-at-point (&optional in-emacs reference-buffer) "Open link at or after point. If there is no link at point, this function will search forward up to @@ -9013,6 +9028,7 @@ application the system uses for this file type." (not (get-text-property (point) 'org-linked-text))) (or (org-offer-links-in-entry in-emacs) (progn (require 'org-attach) (org-attach-reveal 'if-exists)))) + ((run-hook-with-args-until-success 'org-open-at-point-functions)) ((org-at-timestamp-p t) (org-follow-timestamp-link)) ((or (org-footnote-at-reference-p) (org-footnote-at-definition-p)) (org-footnote-action)) @@ -13988,6 +14004,42 @@ only headings." (when (org-on-heading-p) (move-marker (make-marker) (point)))))))) +(defun org-find-exact-headling-in-buffer (heading &optional buffer pos-only) + "Find node HEADING in BUFFER. +Return a marker to the heading if it was found, or nil if not. +If POS-ONLY is set, return just the position instead of a marker. + +The heading text must match exact, but it may have a TODO keyword, +a priority cookie and tags in the standard locations." + (with-current-buffer (or buffer (current-buffer)) + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (let (case-fold-search) + (if (setq p (re-search-forward + (format org-complex-heading-regexp-format + (regexp-quote heading)) nil t)) + (if pos-only + (match-beginning 0) + (move-marker (make-marker) (match-beginning 0))))))))) + +(defun org-find-exact-heading-in-directory (heading &optional dir) + "Find Org node headline HEADING in all .org files in directory DIR. +When the target headline is found, return a marker to this location." + (let ((files (directory-files (or dir default-directory) + nil "\\`[^.#].*\\.org\\'")) + file visiting m buffer) + (catch 'found + (while (setq file (pop files)) + (message "trying %s" file) + (setq visiting (org-find-base-buffer-visiting file)) + (setq buffer (or visiting (find-file-noselect file))) + (setq m (org-find-exact-headling-in-buffer + target buffer)) + (when (and (not m) (not visiting)) (kill-buffer buffer)) + (and m (throw 'found m)))))) + (defun org-find-entry-with-id (ident) "Locate the entry that contains the ID property with exact value IDENT. IDENT can be a string, a symbol or a number, this function will search for @@ -19401,8 +19453,8 @@ To get rid of the restriction, use \\[org-agenda-remove-restriction-lock]." ;; Make flyspell not check words in links, to not mess up our keymap (defun org-mode-flyspell-verify () "Don't let flyspell put overlays at active buttons." - (and (not (get-text-property (point) 'keymap)) - (not (get-text-property (point) 'org-no-flyspell)))) + (and (not (get-text-property (max (1- (point)) (point-min)) 'keymap)) + (not (get-text-property (max (1- (point)) (point-min)) 'org-no-flyspell)))) (defun org-remove-flyspell-overlays-in (beg end) "Remove flyspell overlays in region."