org.el: Fontify links to current buffer when inserting a link.

* org.el (org-link-to-org-use-id): use `org-capture' instead
of `org-remember' in the docstring.
(org-link-fontify-links-to-this-file): New function to fontify
links to the current buffer in `org-stored-links'.
(org-store-link): Small code simplification.
(org-link-prettify): Enclose literal links into <...> instead
of [[...]].
(org-insert-link): Use `org-link-fontify-links-to-this-file'.
Also allow completion over links' descriptions, as well as
links destinations.  When the user uses the description for
completion, don't prompt again for a description.

Thanks to Yagnesh Raghava Yakkala who suggested this.
This commit is contained in:
Bastien Guerry 2012-08-03 14:08:20 +02:00
parent 7fdd49dd33
commit 1e34c5d34f
1 changed files with 52 additions and 24 deletions

View File

@ -1454,10 +1454,10 @@ create-if-interactive
job for remember, only use the ID if it already exists. The job for remember, only use the ID if it already exists. The
purpose of this setting is to avoid proliferation of unwanted purpose of this setting is to avoid proliferation of unwanted
IDs, just because you happen to be in an Org file when you IDs, just because you happen to be in an Org file when you
call `org-remember' that automatically and preemptively call `org-capture' that automatically and preemptively creates a
creates a link. If you do want to get an ID link in a remember link. If you do want to get an ID link in a remember template to
template to an entry not having an ID, create it first by an entry not having an ID, create it first by explicitly creating
explicitly creating a link to it, using `C-c C-l' first. a link to it, using `C-c C-l' first.
create-if-interactive-and-no-custom-id create-if-interactive-and-no-custom-id
Like create-if-interactive, but do not create an ID if there is Like create-if-interactive, but do not create an ID if there is
@ -8876,19 +8876,16 @@ For file links, arg negates `org-context-in-file-links'."
link (org-make-link cpltxt))) link (org-make-link cpltxt)))
((and (featurep 'org-id) ((and (featurep 'org-id)
(or (eq org-link-to-org-use-id t) (or (eq org-link-to-org-use-id t)
(and (eq org-link-to-org-use-id 'create-if-interactive) (and (org-called-interactively-p 'any)
(org-called-interactively-p 'any)) (or (eq org-link-to-org-use-id 'create-if-interactive)
(and (eq org-link-to-org-use-id (and (eq org-link-to-org-use-id
'create-if-interactive-and-no-custom-id) 'create-if-interactive-and-no-custom-id)
(org-called-interactively-p 'any) (not custom-id))))
(not custom-id)) (and org-link-to-org-use-id (org-entry-get nil "ID"))))
(and org-link-to-org-use-id
(org-entry-get nil "ID"))))
;; We can make a link using the ID. ;; We can make a link using the ID.
(setq link (condition-case nil (setq link (condition-case nil
(prog1 (org-id-store-link) (prog1 (org-id-store-link)
(setq desc (plist-get org-store-link-plist (setq desc (plist-get org-store-link-plist :description)))
:description)))
(error (error
;; probably before first headline, link to file only ;; probably before first headline, link to file only
(concat "file:" (concat "file:"
@ -9190,7 +9187,7 @@ The car of LINK must be a raw link the cdr of LINK must be either
a link description or nil." a link description or nil."
(let ((desc (or (cadr link) "<no description>"))) (let ((desc (or (cadr link) "<no description>")))
(concat (format "%-45s" (substring desc 0 (min (length desc) 40))) (concat (format "%-45s" (substring desc 0 (min (length desc) 40)))
"[[" (car link) "]]"))) "<" (car link) ">")))
;;;###autoload ;;;###autoload
(defun org-insert-link-global () (defun org-insert-link-global ()
@ -9209,6 +9206,29 @@ This command can be called in any mode to insert a link in Org-mode syntax."
(org-insert-link nil (car l) (cadr l)) (org-insert-link nil (car l) (cadr l))
(insert "\n")))) (insert "\n"))))
(defun org-link-fontify-links-to-this-file ()
"Fontify links to the current file in `org-stored-links'."
(let ((f (buffer-file-name)) a b)
(setq a (mapcar (lambda(l)
(let ((ll (car l)))
(when (and (string-match "^file:\\(.+\\)::" ll)
(equal f (expand-file-name (match-string 1 ll))))
ll)))
org-stored-links))
(when (featurep 'org-id)
(setq b (mapcar (lambda(l)
(let ((ll (car l)))
(when (and (string-match "^id:\\(.+\\)$" ll)
(equal f (expand-file-name
(or (org-id-find-id-file
(match-string 1 ll)) ""))))
ll)))
org-stored-links)))
(mapcar (lambda(l)
(put-text-property 0 (length l) 'face 'font-lock-comment-face l))
(delq nil (append a b)))))
(defvar org-link-links-in-this-file nil)
(defun org-insert-link (&optional complete-file link-location default-description) (defun org-insert-link (&optional complete-file link-location default-description)
"Insert a link. At the prompt, enter the link. "Insert a link. At the prompt, enter the link.
@ -9257,7 +9277,7 @@ be used as the default description."
(desc region) (desc region)
tmphist ; byte-compile incorrectly complains about this tmphist ; byte-compile incorrectly complains about this
(link link-location) (link link-location)
entry file all-prefixes) entry file all-prefixes auto-desc)
(cond (cond
(link-location) ; specified by arg, just use it. (link-location) ; specified by arg, just use it.
((org-in-regexp org-bracket-link-regexp 1) ((org-in-regexp org-bracket-link-regexp 1)
@ -9278,13 +9298,16 @@ be used as the default description."
(setq link (org-file-complete-link complete-file))) (setq link (org-file-complete-link complete-file)))
(t (t
;; Read link, with completion for stored links. ;; Read link, with completion for stored links.
(with-output-to-temp-buffer "*Org Links*" (org-link-fontify-links-to-this-file)
(princ "Insert a link. (org-switch-to-buffer-other-window "*Org Links*")
(with-current-buffer "*Org Links*"
(erase-buffer)
(insert "Insert a link.
Use TAB to complete link prefixes, then RET for type-specific completion support\n") Use TAB to complete link prefixes, then RET for type-specific completion support\n")
(when org-stored-links (when org-stored-links
(princ "\nStored links are available with <up>/<down> or M-p/n (most recent with RET):\n\n") (insert "\nStored links are available with <up>/<down> or M-p/n (most recent with RET):\n\n")
(princ (mapconcat 'org-link-prettify (insert (mapconcat 'org-link-prettify
(reverse org-stored-links) "\n")))) (reverse org-stored-links) "\n"))))
(let ((cw (selected-window))) (let ((cw (selected-window)))
(select-window (get-buffer-window "*Org Links*" 'visible)) (select-window (get-buffer-window "*Org Links*" 'visible))
(with-current-buffer "*Org Links*" (setq truncate-lines t)) (with-current-buffer "*Org Links*" (setq truncate-lines t))
@ -9307,12 +9330,16 @@ Use TAB to complete link prefixes, then RET for type-specific completion support
(append (append
(mapcar (lambda (x) (list (concat x ":"))) (mapcar (lambda (x) (list (concat x ":")))
all-prefixes) all-prefixes)
(mapcar 'car org-stored-links)) (mapcar 'car org-stored-links)
(mapcar 'cadr org-stored-links))
nil nil nil nil nil nil
'tmphist 'tmphist
(car (car org-stored-links))))) (caar org-stored-links))))
(if (not (string-match "\\S-" link)) (if (not (string-match "\\S-" link))
(error "No link selected")) (error "No link selected"))
(mapc (lambda(l)
(when (equal link (cadr l)) (setq link (car l) auto-desc t)))
org-stored-links)
(if (or (member link all-prefixes) (if (or (member link all-prefixes)
(and (equal ":" (substring link -1)) (and (equal ":" (substring link -1))
(member (substring link 0 -1) all-prefixes) (member (substring link 0 -1) all-prefixes)
@ -9377,7 +9404,8 @@ Use TAB to complete link prefixes, then RET for type-specific completion support
(if org-make-link-description-function (if org-make-link-description-function
(setq desc (funcall org-make-link-description-function link desc)) (setq desc (funcall org-make-link-description-function link desc))
(if default-description (setq desc default-description) (if default-description (setq desc default-description)
(setq desc (read-string "Description: " desc)))) (setq desc (or (and auto-desc desc)
(read-string "Description: " desc)))))
(unless (string-match "\\S-" desc) (setq desc nil)) (unless (string-match "\\S-" desc) (setq desc nil))
(if remove (apply 'delete-region remove)) (if remove (apply 'delete-region remove))