summaryrefslogtreecommitdiff
path: root/contrib/lisp/org-download.el
diff options
context:
space:
mode:
Diffstat (limited to 'contrib/lisp/org-download.el')
-rw-r--r--contrib/lisp/org-download.el392
1 files changed, 392 insertions, 0 deletions
diff --git a/contrib/lisp/org-download.el b/contrib/lisp/org-download.el
new file mode 100644
index 0000000..6bff649
--- /dev/null
+++ b/contrib/lisp/org-download.el
@@ -0,0 +1,392 @@
+;;; org-download.el --- Image drag-and-drop for Emacs org-mode
+
+;; Copyright (C) 2014-2015 Free Software Foundation, Inc.
+
+;; Author: Oleh Krehel
+;; Keywords: images, screenshots, download
+;; Homepage: http://orgmode.org
+
+;; This file is not 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 <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; This extension facilitates moving images from point A to point B.
+;;
+;; Point A (the source) can be:
+;; 1. An image inside your browser that you can drag to Emacs.
+;; 2. An image on your file system that you can drag to Emacs.
+;; 3. A local or remote image address in kill-ring.
+;; Use the `org-download-yank' command for this.
+;; Remember that you can use "0 w" in `dired' to get an address.
+;; 4. An screenshot taken using `gnome-screenshot' or `scrot' or `gm'.
+;; Use the `org-download-screenshot' command for this.
+;; Customize the backend with `org-download-screenshot-method'.
+;;
+;; Point B (the target) is an Emacs `org-mode' buffer where the inline
+;; link will be inserted. Several customization options will determine
+;; where exactly on the file system the file will be stored.
+;;
+;; They are:
+;; `org-download-method':
+;; a. 'attach => use `org-mode' attachment machinery
+;; b. 'directory => construct the directory in two stages:
+;; 1. first part of the folder name is:
+;; * either "." (current folder)
+;; * or `org-download-image-dir' (if it's not nil).
+;; `org-download-image-dir' becomes buffer-local when set,
+;; so each file can customize this value, e.g with:
+;; # -*- mode: Org; org-download-image-dir: "~/Pictures/foo"; -*-
+;; 2. second part is:
+;; * `org-download-heading-lvl' is nil => ""
+;; * `org-download-heading-lvl' is n => the name of current
+;; heading with level n. Level count starts with 0,
+;; i.e. * is 0, ** is 1, *** is 2 etc.
+;; `org-download-heading-lvl' becomes buffer-local when set,
+;; so each file can customize this value, e.g with:
+;; # -*- mode: Org; org-download-heading-lvl: nil; -*-
+;;
+;; `org-download-timestamp':
+;; optionally add a timestamp to the file name.
+;;
+;; Customize `org-download-backend' to choose between `url-retrieve'
+;; (the default) or `wget' or `curl'.
+;;
+;;; Code:
+
+
+(eval-when-compile
+ (require 'cl))
+(require 'url-parse)
+(require 'url-http)
+
+(defgroup org-download nil
+ "Image drag-and-drop for org-mode."
+ :group 'org
+ :prefix "org-download-")
+
+(defcustom org-download-method 'directory
+ "The way images should be stored."
+ :type '(choice
+ (const :tag "Directory" directory)
+ (const :tag "Attachment" attach))
+ :group 'org-download)
+
+(defcustom org-download-image-dir nil
+ "If set, images will be stored in this directory instead of \".\".
+See `org-download--dir-1' for more info."
+ :type '(choice
+ (const :tag "Default" nil)
+ (string :tag "Directory"))
+ :group 'org-download)
+(make-variable-buffer-local 'org-download-image-dir)
+
+(defcustom org-download-heading-lvl 0
+ "Heading level to be used in `org-download--dir-2'."
+ :group 'org-download)
+(make-variable-buffer-local 'org-download-heading-lvl)
+
+(defcustom org-download-backend t
+ "Method to use for downloading."
+ :type '(choice
+ (const :tag "wget" "wget \"%s\" -O \"%s\"")
+ (const :tag "curl" "curl \"%s\" -o \"%s\"")
+ (const :tag "url-retrieve" t))
+ :group 'org-download)
+
+(defcustom org-download-timestamp "_%Y-%m-%d_%H:%M:%S"
+ "This `format-time-string'-style string will be appended to the file name.
+Set this to \"\" if you don't want time stamps."
+ :type 'string
+ :group 'org-download)
+
+(defcustom org-download-img-regex-list
+ '("<img +src=\"" "<img +\\(class=\"[^\"]+\"\\)? *src=\"")
+ "This regex is used to unalias links that look like images.
+The html to which the links points will be searched for these
+regexes, one by one, until one succeeds. The found image address
+will be used."
+ :group 'org-download)
+
+(defcustom org-download-screenshot-method "gnome-screenshot -a -f %s"
+ "The tool to capture screenshots."
+ :type '(choice
+ (const :tag "gnome-screenshot" "gnome-screenshot -a -f %s")
+ (const :tag "scrot" "scrot -s %s")
+ (const :tag "gm" "gm import %s"))
+ :group 'org-download)
+
+(defcustom org-download-image-width 0
+ "When non-zero add #+attr_html: :width tag to the image."
+ :type 'integer
+ :group 'org-download)
+
+(defun org-download-get-heading (lvl)
+ "Return the heading of the current entry's LVL level parent."
+ (save-excursion
+ (let ((cur-lvl (org-current-level)))
+ (if cur-lvl
+ (progn
+ (unless (= cur-lvl 1)
+ (org-up-heading-all (- (1- (org-current-level)) lvl)))
+ (substring-no-properties
+ (org-get-heading)))
+ ""))))
+
+(defun org-download--dir-1 ()
+ "Return the first part of the directory path for `org-download--dir'.
+It's `org-download-image-dir', unless it's nil. Then it's \".\"."
+ (or org-download-image-dir "."))
+
+(defun org-download--dir-2 ()
+ "Return the second part of the directory path for `org-download--dir'.
+Unless `org-download-heading-lvl' is nil, it's the name of the current
+`org-download-heading-lvl'-leveled heading. Otherwise it's \"\"."
+ (and org-download-heading-lvl
+ (org-download-get-heading
+ org-download-heading-lvl)))
+
+(defun org-download--dir ()
+ "Return the directory path for image storage.
+
+The path is composed from `org-download--dir-1' and `org-download--dir-2'.
+The directory is created if it didn't exist before."
+ (let* ((part1 (org-download--dir-1))
+ (part2 (org-download--dir-2))
+ (dir (if part2
+ (format "%s/%s" part1 part2)
+ part1)))
+ (unless (file-exists-p dir)
+ (make-directory dir t))
+ dir))
+
+(defun org-download--fullname (link)
+ "Return the file name where LINK will be saved to.
+
+It's affected by `org-download-timestamp' and `org-download--dir'."
+ (let ((filename
+ (file-name-nondirectory
+ (car (url-path-and-query
+ (url-generic-parse-url link)))))
+ (dir (org-download--dir)))
+ (when (string-match ".*?\\.\\(?:png\\|jpg\\)\\(.*\\)$" filename)
+ (setq filename (replace-match "" nil nil filename 1)))
+ (abbreviate-file-name
+ (expand-file-name
+ (format "%s%s.%s"
+ (file-name-sans-extension filename)
+ (format-time-string org-download-timestamp)
+ (file-name-extension filename))
+ dir))))
+
+(defun org-download--image (link filename)
+ "Save LINK to FILENAME asynchronously and show inline images in current buffer."
+ (when (string-match "^file://\\(.*\\)" link)
+ (setq link (url-unhex-string (match-string 1 link))))
+ (cond ((and (not (file-remote-p link))
+ (file-exists-p link))
+ (org-download--image/command "cp \"%s\" \"%s\"" link filename))
+ ((eq org-download-backend t)
+ (org-download--image/url-retrieve link filename))
+ (t
+ (org-download--image/command org-download-backend link filename))))
+
+(defun org-download--image/command (command link filename)
+ "Using COMMAND, save LINK to FILENAME.
+COMMAND is a format-style string with two slots for LINK and FILENAME."
+ (require 'async)
+ (async-start
+ `(lambda() (shell-command
+ ,(format command link
+ (expand-file-name filename))))
+ (lexical-let ((cur-buf (current-buffer)))
+ (lambda(x)
+ (with-current-buffer cur-buf
+ (org-display-inline-images))))))
+
+(defun org-download--image/url-retrieve (link filename)
+ "Save LINK to FILENAME using `url-retrieve'."
+ (url-retrieve
+ link
+ (lambda (status filename buffer)
+ ;; Write current buffer to FILENAME
+ ;; and update inline images in BUFFER
+ (let ((err (plist-get status :error)))
+ (if err (error
+ "\"%s\" %s" link
+ (downcase (nth 2 (assq (nth 2 err) url-http-codes))))))
+ (delete-region
+ (point-min)
+ (progn
+ (re-search-forward "\n\n" nil 'move)
+ (point)))
+ (let ((coding-system-for-write 'no-conversion))
+ (write-region nil nil filename nil nil nil 'confirm))
+ (with-current-buffer buffer
+ (org-display-inline-images)))
+ (list
+ (expand-file-name filename)
+ (current-buffer))
+ nil t))
+
+(defun org-download-yank ()
+ "Call `org-download-image' with current kill."
+ (interactive)
+ (org-download-image (current-kill 0)))
+
+(defun org-download-screenshot ()
+ "Capture screenshot and insert the resulting file.
+The screenshot tool is determined by `org-download-screenshot-method'."
+ (interactive)
+ (let ((link "/tmp/screenshot.png"))
+ (shell-command (format org-download-screenshot-method link))
+ (org-download-image link)))
+
+(defun org-download-image (link)
+ "Save image at address LINK to `org-download--dir'."
+ (interactive "sUrl: ")
+ (unless (image-type-from-file-name link)
+ (with-current-buffer
+ (url-retrieve-synchronously link t)
+ (let ((regexes org-download-img-regex-list)
+ lnk)
+ (while (and (not lnk) regexes)
+ (goto-char (point-min))
+ (when (re-search-forward (pop regexes) nil t)
+ (backward-char)
+ (setq lnk (read (current-buffer)))))
+ (if lnk
+ (setq link lnk)
+ (error "link %s does not point to an image; unaliasing failed" link)))))
+ (let ((filename
+ (if (eq org-download-method 'attach)
+ (let ((org-download-image-dir (progn (require 'org-attach)
+ (org-attach-dir t)))
+ org-download-heading-lvl)
+ (org-download--fullname link))
+ (org-download--fullname link))))
+ (when (image-type-from-file-name filename)
+ (org-download--image link filename)
+ (when (eq org-download-method 'attach)
+ (org-attach-attach filename nil 'none))
+ (if (looking-back "^[ \t]+")
+ (delete-region (match-beginning 0) (match-end 0))
+ (newline))
+ (insert
+ (format "#+DOWNLOADED: %s @ %s\n%s [[%s]]"
+ link
+ (format-time-string "%Y-%m-%d %H:%M:%S")
+ (if (= org-download-image-width 0)
+ ""
+ (format
+ "#+attr_html: :width %dpx\n" org-download-image-width))
+ filename))
+ (org-display-inline-images))))
+
+(defun org-download--at-comment-p ()
+ "Check if current line begins with #+DOWLOADED:."
+ (save-excursion
+ (move-beginning-of-line nil)
+ (looking-at "#\\+DOWNLOADED:")))
+
+(defun org-download-delete ()
+ "Delete inline image link on current line, and the file that it points to."
+ (interactive)
+ (cond ((org-download--at-comment-p)
+ (delete-region (line-beginning-position)
+ (line-end-position))
+ (org-download--delete (line-beginning-position)
+ nil
+ 1))
+ ((region-active-p)
+ (org-download--delete (region-beginning)
+ (region-end))
+ (delete-region (region-beginning)
+ (region-end)))
+
+ (t (org-download--delete (line-beginning-position)
+ (line-end-position)))))
+
+(defun org-download--delete (beg end &optional times)
+ "Delete inline image links and the files they point to between BEG and END.
+
+When TIMES isn't nil, delete only TIMES links."
+ (unless times
+ (setq times most-positive-fixnum))
+ (save-excursion
+ (goto-char beg)
+ (while (and (>= (decf times) 0)
+ (re-search-forward "\\[\\[\\([^]]*\\)\\]\\]" end t))
+ (let ((str (match-string-no-properties 1)))
+ (delete-region beg
+ (match-end 0))
+ (when (file-exists-p str)
+ (delete-file str))))))
+
+(defun org-download-dnd (uri action)
+ "When in `org-mode' and URI points to image, download it.
+Otherwise, pass URI and ACTION back to dnd dispatch."
+ (cond ((eq major-mode 'org-mode)
+ ;; probably shouldn't redirect
+ (unless (org-download-image uri)
+ (message "not an image URL")))
+ ((eq major-mode 'dired-mode)
+ (org-download-dired uri))
+ ;; redirect to someone else
+ (t
+ (let ((dnd-protocol-alist
+ (rassq-delete-all
+ 'org-download-dnd
+ (copy-alist dnd-protocol-alist))))
+ (dnd-handle-one-url nil action uri)))))
+
+(defun org-download-dired (uri)
+ "Download URI to current directory."
+ (raise-frame)
+ (let ((filename (file-name-nondirectory
+ (car (url-path-and-query
+ (url-generic-parse-url uri))))))
+ (message "Downloading %s to %s ..."
+ filename
+ (expand-file-name filename))
+ (url-retrieve
+ uri
+ (lambda (status filename)
+ (let ((err (plist-get status :error)))
+ (if err (error
+ "\"%s\" %s" uri
+ (downcase (nth 2 (assq (nth 2 err) url-http-codes))))))
+ (let ((coding-system-for-write 'no-conversion))
+ (write-region nil nil filename nil nil nil 'confirm)))
+ (list
+ (expand-file-name filename))
+ t t)))
+
+(defun org-download-enable ()
+ "Enable org-download."
+ (unless (eq (cdr (assoc "^\\(https?\\|ftp\\|file\\|nfs\\)://" dnd-protocol-alist))
+ 'org-download-dnd)
+ (setq dnd-protocol-alist
+ `(("^\\(https?\\|ftp\\|file\\|nfs\\)://" . org-download-dnd) ,@dnd-protocol-alist))))
+
+(defun org-download-disable ()
+ "Disable org-download."
+ (rassq-delete-all 'org-download-dnd dnd-protocol-alist))
+
+(org-download-enable)
+
+(provide 'org-download)
+
+;;; org-download.el ends here
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-21 10:23:27 +0000