From a97f2c1830910d7a239dcbb98e200a6e4038acaa Mon Sep 17 00:00:00 2001 From: Kyle Meyer Date: Thu, 13 Aug 2015 01:53:58 -0400 Subject: [PATCH] Add org-link-edit.el to contrib * contrib/lisp/org-link-edit.el: New file. * contrib/README: Add org-link-edit.el entry. Copy org-link-edit.el from upstream's b3aa4dd. --- contrib/README | 1 + contrib/lisp/org-link-edit.el | 327 ++++++++++++++++++++++++++++++++++ 2 files changed, 328 insertions(+) create mode 100644 contrib/lisp/org-link-edit.el diff --git a/contrib/README b/contrib/README index 6a8918fef..fdbcef0a0 100644 --- a/contrib/README +++ b/contrib/README @@ -39,6 +39,7 @@ org-interactive-query.el --- Interactive modification of tags query org-invoice.el --- Help manage client invoices in OrgMode org-learn.el --- SuperMemo's incremental learning algorithm org-license.el --- Insert free licenses to your org documents +org-link-edit.el --- Slurp and barf with Org links org-mac-iCal.el --- Imports events from iCal.app to the Emacs diary org-mac-link.el --- Grab links and URLs from various Mac applications org-mairix.el --- Hook mairix search into Org for different MUAs diff --git a/contrib/lisp/org-link-edit.el b/contrib/lisp/org-link-edit.el new file mode 100644 index 000000000..ffdfa26cb --- /dev/null +++ b/contrib/lisp/org-link-edit.el @@ -0,0 +1,327 @@ +;;; org-link-edit.el --- Slurp and barf with Org links + +;; Copyright (C) 2015 Kyle Meyer + +;; Author: Kyle Meyer +;; URL: https://github.com/kyleam/org-link-edit +;; Keywords: convenience +;; Version: 1.0.0 +;; Package-Requires: ((cl-lib "0.5") (org "8.2")) + +;; This program 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. + +;; This program 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 this program. If not, see . + +;;; Commentary: + +;; Org Link Edit provides Paredit-inspired slurping and barfing +;; commands for Org link descriptions. +;; +;; There are four commands, all which operate when point is on an Org +;; link. +;; +;; - org-link-edit-forward-slurp +;; - org-link-edit-backward-slurp +;; - org-link-edit-forward-barf +;; - org-link-edit-backward-barf +;; +;; Org Link Edit doesn't bind these commands to any keys. Finding +;; good keys for these commands is difficult because, while it's +;; convenient to be able to quickly repeat these commands, they won't +;; be used frequently enough to be worthy of a short, repeat-friendly +;; binding. Using Hydra [1] provides a nice solution to this. After +;; an initial key sequence, any of the commands will be repeatable +;; with a single key. (Plus, you get a nice interface that displays +;; the key for each command.) Below is one example of how you could +;; configure this. +;; +;; (define-key org-mode-map YOUR-KEY +;; (defhydra hydra-org-link-edit () +;; "Org Link Edit" +;; ("j" org-link-edit-forward-slurp "forward slurp") +;; ("k" org-link-edit-forward-barf "forward barf") +;; ("u" org-link-edit-backward-slurp "backward slurp") +;; ("i" org-link-edit-backward-barf "backward barf") +;; ("q" nil "cancel"))) +;; +;; [1] https://github.com/abo-abo/hydra + +;;; Code: + +(require 'org) +(require 'org-element) +(require 'cl-lib) + +(defun org-link-edit--get-link-data () + "Return list with information about the link at point. +The list includes +- the position at the start of the link +- the position at the end of the link +- the link text +- the link description (nil when on a plain link)" + (let ((el (org-element-context))) + ;; Don't use `org-element-lineage' because it isn't available + ;; until Org version 8.3. + (while (and el (not (memq (car el) '(link)))) + (setq el (org-element-property :parent el))) + (unless (eq (car el) 'link) + (user-error "Point is not on a link")) + (save-excursion + (goto-char (org-element-property :begin el)) + (cond + ;; Use match-{beginning,end} because match-end is consistently + ;; positioned after ]], while the :end property is positioned + ;; at the next word on the line, if one is present. + ((looking-at org-bracket-link-regexp) + (list (match-beginning 0) + (match-end 0) + (match-string-no-properties 1) + (or (and (match-end 3) + (match-string-no-properties 3)) + ""))) + ((looking-at org-plain-link-re) + (list (match-beginning 0) + (match-end 0) + (match-string-no-properties 0) + nil)) + (t + (error "What am I looking at?")))))) + +(defun org-link-edit--forward-blob (n &optional no-punctuation) + "Move forward N blobs (backward if N is negative). + +A block of non-whitespace characters is a blob. If +NO-PUNCTUATION is non-nil, trailing punctuation characters are +not considered part of the blob when going in the forward +direction. + +If the edge of the buffer is reached before completing the +movement, return nil. Otherwise, return t." + (let* ((forward-p (> n 0)) + (nblobs (abs n)) + (skip-func (if forward-p 'skip-syntax-forward 'skip-syntax-backward)) + skip-func-retval) + (while (/= nblobs 0) + (funcall skip-func " ") + (setq skip-func-retval (funcall skip-func "^ ")) + (setq nblobs (1- nblobs))) + (when (and forward-p no-punctuation) + (let ((punc-tail-offset (save-excursion (skip-syntax-backward ".")))) + ;; Don't consider trailing punctuation as part of the blob + ;; unless the whole blob consists of punctuation. + (unless (= skip-func-retval (- punc-tail-offset)) + (goto-char (+ (point) punc-tail-offset))))) + (/= skip-func-retval 0))) + +;;;###autoload +(defun org-link-edit-forward-slurp (&optional n) + "Slurp N trailing blobs into link's description. + + The \[\[http://orgmode.org/\]\[Org mode\]\] site + + | + v + + The \[\[http://orgmode.org/\]\[Org mode site\]\] + +A blob is a block of non-whitespace characters. When slurping +forward, trailing punctuation characters are not considered part +of a blob. + +After slurping, return the slurped text and move point to the +beginning of the link. + +If N is negative, slurp leading blobs instead of trailing blobs." + (interactive "p") + (setq n (or n 1)) + (cond + ((= n 0)) + ((< n 0) + (org-link-edit-backward-slurp (- n))) + (t + (cl-multiple-value-bind (beg end link desc) (org-link-edit--get-link-data) + (goto-char (save-excursion + (goto-char end) + (or (org-link-edit--forward-blob n 'no-punctuation) + (user-error "Not enough blobs after the link")) + (point))) + (let ((slurped (buffer-substring-no-properties end (point)))) + (setq slurped (replace-regexp-in-string "\n+" " " slurped)) + (when (and (= (length desc) 0) + (string-match "^\\s-+\\(.*\\)" slurped)) + (setq slurped (match-string 1 slurped))) + (setq desc (concat desc slurped) + end (+ end (length slurped))) + (delete-region beg (point)) + (insert (org-make-link-string link desc)) + (goto-char beg) + slurped))))) + +;;;###autoload +(defun org-link-edit-backward-slurp (&optional n) + "Slurp N leading blobs into link's description. + + The \[\[http://orgmode.org/\]\[Org mode\]\] site + + | + v + + \[\[http://orgmode.org/\]\[The Org mode\]\] site + +A blob is a block of non-whitespace characters. + +After slurping, return the slurped text and move point to the +beginning of the link. + +If N is negative, slurp trailing blobs instead of leading blobs." + (interactive "p") + (setq n (or n 1)) + (cond + ((= n 0)) + ((< n 0) + (org-link-edit-forward-slurp (- n))) + (t + (cl-multiple-value-bind (beg end link desc) (org-link-edit--get-link-data) + (goto-char (save-excursion + (goto-char beg) + (or (org-link-edit--forward-blob (- n)) + (user-error "Not enough blobs before the link")) + (point))) + (let ((slurped (buffer-substring-no-properties (point) beg))) + (when (and (= (length desc) 0) + (string-match "\\(.*\\)\\s-+$" slurped)) + (setq slurped (match-string 1 slurped))) + (setq slurped (replace-regexp-in-string "\n+" " " slurped)) + (setq desc (concat slurped desc) + beg (- beg (length slurped))) + (delete-region (point) end) + (insert (org-make-link-string link desc)) + (goto-char beg) + slurped))))) + +(defun org-link-edit--split-first-blobs (string n) + "Split STRING into (N first blobs . other) cons cell. +'N first blobs' contains all text from the start of STRING up to +the start of the N+1 blob. 'other' includes the remaining text +of STRING. If the number of blobs in STRING is fewer than N, +'other' is nil." + (when (< n 0) (user-error "N cannot be negative")) + (with-temp-buffer + (insert string) + (goto-char (point-min)) + (with-syntax-table org-mode-syntax-table + (let ((within-bound (org-link-edit--forward-blob n))) + (skip-syntax-forward " ") + (cons (buffer-substring 1 (point)) + (and within-bound + (buffer-substring (point) (point-max)))))))) + +(defun org-link-edit--split-last-blobs (string n) + "Split STRING into (other . N last blobs) cons cell. +'N last blobs' contains all text from the end of STRING back to +the end of the N+1 last blob. 'other' includes the remaining +text of STRING. If the number of blobs in STRING is fewer than +N, 'other' is nil." + (when (< n 0) (user-error "N cannot be negative")) + (with-temp-buffer + (insert string) + (goto-char (point-max)) + (with-syntax-table org-mode-syntax-table + (let ((within-bound (org-link-edit--forward-blob (- n)))) + (skip-syntax-backward " ") + (cons (and within-bound + (buffer-substring 1 (point))) + (buffer-substring (point) (point-max))))))) + +;;;###autoload +(defun org-link-edit-forward-barf (&optional n) + "Barf N trailing blobs from link's description. + + The \[\[http://orgmode.org/\]\[Org mode\]\] site + + | + v + + The \[\[http://orgmode.org/\]\[Org\]\] mode site + +A blob is a block of non-whitespace characters. + +After barfing, return the barfed text and move point to the +beginning of the link. + +If N is negative, barf leading blobs instead of trailing blobs." + (interactive "p") + (setq n (or n 1)) + (cond + ((= n 0)) + ((< n 0) + (org-link-edit-backward-barf (- n))) + (t + (cl-multiple-value-bind (beg end link desc) (org-link-edit--get-link-data) + (when (= (length desc) 0) + (user-error "Link has no description")) + (pcase-let ((`(,new-desc . ,barfed) (org-link-edit--split-last-blobs + desc n))) + (unless new-desc (user-error "Not enough blobs in description")) + (delete-region beg end) + (insert (org-make-link-string link new-desc)) + (if (string= new-desc "") + ;; Two brackets are dropped when an empty description is + ;; passed to `org-make-link-string'. + (progn (goto-char (- end (+ 2 (length desc)))) + (setq barfed (concat " " barfed))) + (goto-char (- end (- (length desc) (length new-desc))))) + (insert barfed) + (goto-char beg) + barfed))))) + +;;;###autoload +(defun org-link-edit-backward-barf (&optional n) + "Barf N leading blobs from link's description. + + The \[\[http://orgmode.org/\]\[Org mode\]\] site + + | + v + + The Org \[\[http://orgmode.org/\]\[mode\]\] site + +A blob is a block of non-whitespace characters. + +After barfing, return the barfed text and move point to the +beginning of the link. + +If N is negative, barf trailing blobs instead of leading blobs." + (interactive "p") + (setq n (or n 1)) + (cond + ((= n 0)) + ((< n 0) + (org-link-edit-forward-barf (- n))) + (t + (cl-multiple-value-bind (beg end link desc) (org-link-edit--get-link-data) + (when (= (length desc) 0) + (user-error "Link has no description")) + (pcase-let ((`(,barfed . ,new-desc) (org-link-edit--split-first-blobs + desc n))) + (unless new-desc (user-error "Not enough blobs in description")) + (delete-region beg end) + (insert (org-make-link-string link new-desc)) + (when (string= new-desc "") + (setq barfed (concat barfed " "))) + (goto-char beg) + (insert barfed) + (goto-char (+ beg (length barfed))) + barfed))))) + +(provide 'org-link-edit) +;;; org-link-edit.el ends here