contrib/lisp/org-download.el

   1 ;;; org-download.el --- Image drag-and-drop for Emacs org-mode
   2
   3 ;; Copyright (C) 2014-2015 Free Software Foundation, Inc.
   4
   5 ;; Author: Oleh Krehel
   6 ;; Keywords: images, screenshots, download
   7 ;; Homepage: http://orgmode.org
   8
   9 ;; This file is not part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25 ;;
  26 ;; This extension facilitates moving images from point A to point B.
  27 ;;
  28 ;; Point A (the source) can be:
  29 ;; 1. An image inside your browser that you can drag to Emacs.
  30 ;; 2. An image on your file system that you can drag to Emacs.
  31 ;; 3. A local or remote image address in kill-ring.
  32 ;;    Use the `org-download-yank' command for this.
  33 ;;    Remember that you can use "0 w" in `dired' to get an address.
  34 ;; 4. An screenshot taken using `gnome-screenshot' or `scrot' or `gm'.
  35 ;;    Use the `org-download-screenshot' command for this.
  36 ;;    Customize the backend with  `org-download-screenshot-method'.
  37 ;;
  38 ;; Point B (the target) is an Emacs `org-mode' buffer where the inline
  39 ;; link will be inserted.  Several customization options will determine
  40 ;; where exactly on the file system the file will be stored.
  41 ;;
  42 ;; They are:
  43 ;; `org-download-method':
  44 ;; a. 'attach => use `org-mode' attachment machinery
  45 ;; b. 'directory => construct the directory in two stages:
  46 ;;    1. first part of the folder name is:
  47 ;;       * either "." (current folder)
  48 ;;       * or `org-download-image-dir' (if it's not nil).
  49 ;;         `org-download-image-dir' becomes buffer-local when set,
  50 ;;         so each file can customize this value, e.g with:
  51 ;;         # -*- mode: Org; org-download-image-dir: "~/Pictures/foo"; -*-
  52 ;;    2. second part is:
  53 ;;       * `org-download-heading-lvl' is nil => ""
  54 ;;       * `org-download-heading-lvl' is n => the name of current
  55 ;;         heading with level n. Level count starts with 0,
  56 ;;         i.e. * is 0, ** is 1, *** is 2 etc.
  57 ;;         `org-download-heading-lvl' becomes buffer-local when set,
  58 ;;         so each file can customize this value, e.g with:
  59 ;;         # -*- mode: Org; org-download-heading-lvl: nil; -*-
  60 ;;
  61 ;; `org-download-timestamp':
  62 ;; optionally add a timestamp to the file name.
  63 ;;
  64 ;; Customize `org-download-backend' to choose between `url-retrieve'
  65 ;; (the default) or `wget' or `curl'.
  66 ;;
  67 ;;; Code:
  68 \f
  69
  70 (eval-when-compile
  71   (require 'cl))
  72 (require 'url-parse)
  73 (require 'url-http)
  74
  75 (defgroup org-download nil
  76   "Image drag-and-drop for org-mode."
  77   :group 'org
  78   :prefix "org-download-")
  79
  80 (defcustom org-download-method 'directory
  81   "The way images should be stored."
  82   :type '(choice
  83           (const :tag "Directory" directory)
  84           (const :tag "Attachment" attach))
  85   :group 'org-download)
  86
  87 (defcustom org-download-image-dir nil
  88   "If set, images will be stored in this directory instead of \".\".
  89 See `org-download--dir-1' for more info."
  90   :type '(choice
  91           (const :tag "Default" nil)
  92           (string :tag "Directory"))
  93   :group 'org-download)
  94 (make-variable-buffer-local 'org-download-image-dir)
  95
  96 (defcustom org-download-heading-lvl 0
  97   "Heading level to be used in `org-download--dir-2'."
  98   :group 'org-download)
  99 (make-variable-buffer-local 'org-download-heading-lvl)
 100
 101 (defcustom org-download-backend t
 102   "Method to use for downloading."
 103   :type '(choice
 104           (const :tag "wget" "wget \"%s\" -O \"%s\"")
 105           (const :tag "curl" "curl \"%s\" -o \"%s\"")
 106           (const :tag "url-retrieve" t))
 107   :group 'org-download)
 108
 109 (defcustom org-download-timestamp "_%Y-%m-%d_%H:%M:%S"
 110   "This `format-time-string'-style string will be appended to the file name.
 111 Set this to \"\" if you don't want time stamps."
 112   :type 'string
 113   :group 'org-download)
 114
 115 (defcustom org-download-img-regex-list
 116   '("<img +src=\"" "<img +\\(class=\"[^\"]+\"\\)? *src=\"")
 117   "This regex is used to unalias links that look like images.
 118 The html to which the links points will be searched for these
 119 regexes, one by one, until one succeeds.  The found image address
 120 will be used."
 121   :group 'org-download)
 122
 123 (defcustom org-download-screenshot-method "gnome-screenshot -a -f %s"
 124   "The tool to capture screenshots."
 125   :type '(choice
 126           (const :tag "gnome-screenshot" "gnome-screenshot -a -f %s")
 127           (const :tag "scrot" "scrot -s %s")
 128           (const :tag "gm" "gm import %s"))
 129   :group 'org-download)
 130
 131 (defcustom org-download-image-width 0
 132   "When non-zero add #+attr_html: :width tag to the image."
 133   :type 'integer
 134   :group 'org-download)
 135
 136 (defun org-download-get-heading (lvl)
 137   "Return the heading of the current entry's LVL level parent."
 138   (save-excursion
 139     (let ((cur-lvl (org-current-level)))
 140       (if cur-lvl
 141           (progn
 142       (unless (= cur-lvl 1)
 143         (org-up-heading-all (- (1- (org-current-level)) lvl)))
 144       (substring-no-properties
 145              (org-get-heading)))
 146         ""))))
 147
 148 (defun org-download--dir-1 ()
 149   "Return the first part of the directory path for `org-download--dir'.
 150 It's `org-download-image-dir', unless it's nil.  Then it's \".\"."
 151   (or org-download-image-dir "."))
 152
 153 (defun org-download--dir-2 ()
 154   "Return the second part of the directory path for `org-download--dir'.
 155 Unless `org-download-heading-lvl' is nil, it's the name of the current
 156 `org-download-heading-lvl'-leveled heading.  Otherwise it's \"\"."
 157   (and org-download-heading-lvl
 158        (org-download-get-heading
 159         org-download-heading-lvl)))
 160
 161 (defun org-download--dir ()
 162   "Return the directory path for image storage.
 163
 164 The path is composed from `org-download--dir-1' and `org-download--dir-2'.
 165 The directory is created if it didn't exist before."
 166   (let* ((part1 (org-download--dir-1))
 167          (part2 (org-download--dir-2))
 168          (dir (if part2
 169                   (format "%s/%s" part1 part2)
 170                 part1)))
 171     (unless (file-exists-p dir)
 172       (make-directory dir t))
 173     dir))
 174
 175 (defun org-download--fullname (link)
 176   "Return the file name where LINK will be saved to.
 177
 178 It's affected by `org-download-timestamp' and `org-download--dir'."
 179   (let ((filename
 180          (file-name-nondirectory
 181           (car (url-path-and-query
 182                 (url-generic-parse-url link)))))
 183         (dir (org-download--dir)))
 184     (when (string-match ".*?\\.\\(?:png\\|jpg\\)\\(.*\\)$" filename)
 185       (setq filename (replace-match "" nil nil filename 1)))
 186     (abbreviate-file-name
 187      (expand-file-name
 188       (format "%s%s.%s"
 189             (file-name-sans-extension filename)
 190             (format-time-string org-download-timestamp)
 191               (file-name-extension filename))
 192       dir))))
 193
 194 (defun org-download--image (link filename)
 195   "Save LINK to FILENAME asynchronously and show inline images in current buffer."
 196   (when (string-match "^file://\\(.*\\)" link)
 197     (setq link (url-unhex-string (match-string 1 link))))
 198   (cond ((and (not (file-remote-p link))
 199               (file-exists-p link))
 200          (org-download--image/command "cp \"%s\" \"%s\"" link filename))
 201         ((eq org-download-backend t)
 202          (org-download--image/url-retrieve link filename))
 203         (t
 204          (org-download--image/command org-download-backend link filename))))
 205
 206 (defun org-download--image/command (command link filename)
 207   "Using COMMAND, save LINK to FILENAME.
 208 COMMAND is a format-style string with two slots for LINK and FILENAME."
 209   (require 'async)
 210   (async-start
 211    `(lambda() (shell-command
 212           ,(format command link
 213                    (expand-file-name filename))))
 214    (lexical-let ((cur-buf (current-buffer)))
 215      (lambda(x)
 216        (with-current-buffer cur-buf
 217          (org-display-inline-images))))))
 218
 219 (defun org-download--image/url-retrieve (link filename)
 220   "Save LINK to FILENAME using `url-retrieve'."
 221   (url-retrieve
 222    link
 223    (lambda (status filename buffer)
 224      ;; Write current buffer to FILENAME
 225      ;; and update inline images in BUFFER
 226      (let ((err (plist-get status :error)))
 227        (if err (error
 228                 "\"%s\" %s" link
 229                 (downcase (nth 2 (assq (nth 2 err) url-http-codes))))))
 230      (delete-region
 231       (point-min)
 232       (progn
 233         (re-search-forward "\n\n" nil 'move)
 234         (point)))
 235      (let ((coding-system-for-write 'no-conversion))
 236        (write-region nil nil filename nil nil nil 'confirm))
 237      (with-current-buffer buffer
 238        (org-display-inline-images)))
 239    (list
 240     (expand-file-name filename)
 241     (current-buffer))
 242    nil t))
 243
 244 (defun org-download-yank ()
 245   "Call `org-download-image' with current kill."
 246   (interactive)
 247   (org-download-image (current-kill 0)))
 248
 249 (defun org-download-screenshot ()
 250   "Capture screenshot and insert the resulting file.
 251 The screenshot tool is determined by `org-download-screenshot-method'."
 252   (interactive)
 253   (let ((link "/tmp/screenshot.png"))
 254     (shell-command (format org-download-screenshot-method link))
 255     (org-download-image link)))
 256
 257 (defun org-download-image (link)
 258   "Save image at address LINK to `org-download--dir'."
 259   (interactive "sUrl: ")
 260   (unless (image-type-from-file-name link)
 261     (with-current-buffer
 262         (url-retrieve-synchronously link t)
 263       (let ((regexes org-download-img-regex-list)
 264             lnk)
 265         (while (and (not lnk) regexes)
 266           (goto-char (point-min))
 267           (when (re-search-forward (pop regexes) nil t)
 268             (backward-char)
 269             (setq lnk (read (current-buffer)))))
 270         (if lnk
 271             (setq link lnk)
 272           (error "link %s does not point to an image; unaliasing failed" link)))))
 273   (let ((filename
 274          (if (eq org-download-method 'attach)
 275              (let ((org-download-image-dir (progn (require 'org-attach)
 276                                                   (org-attach-dir t)))
 277                    org-download-heading-lvl)
 278                (org-download--fullname link))
 279            (org-download--fullname link))))
 280     (when (image-type-from-file-name filename)
 281       (org-download--image link filename)
 282       (when (eq org-download-method 'attach)
 283         (org-attach-attach filename nil 'none))
 284       (if (looking-back "^[ \t]+")
 285           (delete-region (match-beginning 0) (match-end 0))
 286         (newline))
 287       (insert
 288        (format "#+DOWNLOADED: %s @ %s\n%s [[%s]]"
 289                       link
 290                       (format-time-string "%Y-%m-%d %H:%M:%S")
 291                       (if (= org-download-image-width 0)
 292                           ""
 293                  (format
 294                   "#+attr_html: :width %dpx\n" org-download-image-width))
 295                       filename))
 296       (org-display-inline-images))))
 297
 298 (defun org-download--at-comment-p ()
 299   "Check if current line begins with #+DOWLOADED:."
 300   (save-excursion
 301     (move-beginning-of-line nil)
 302     (looking-at "#\\+DOWNLOADED:")))
 303
 304 (defun org-download-delete ()
 305   "Delete inline image link on current line, and the file that it points to."
 306   (interactive)
 307   (cond ((org-download--at-comment-p)
 308          (delete-region (line-beginning-position)
 309                         (line-end-position))
 310          (org-download--delete (line-beginning-position)
 311                                nil
 312                                1))
 313         ((region-active-p)
 314          (org-download--delete (region-beginning)
 315                                (region-end))
 316          (delete-region (region-beginning)
 317                         (region-end)))
 318
 319         (t (org-download--delete (line-beginning-position)
 320                                  (line-end-position)))))
 321
 322 (defun org-download--delete (beg end &optional times)
 323   "Delete inline image links and the files they point to between BEG and END.
 324
 325 When TIMES isn't nil, delete only TIMES links."
 326   (unless times
 327     (setq times most-positive-fixnum))
 328   (save-excursion
 329     (goto-char beg)
 330     (while (and (>= (decf times) 0)
 331                 (re-search-forward "\\[\\[\\([^]]*\\)\\]\\]" end t))
 332       (let ((str (match-string-no-properties 1)))
 333         (delete-region beg
 334                        (match-end 0))
 335         (when (file-exists-p str)
 336           (delete-file str))))))
 337
 338 (defun org-download-dnd (uri action)
 339   "When in `org-mode' and URI points to image, download it.
 340 Otherwise, pass URI and ACTION back to dnd dispatch."
 341   (cond ((eq major-mode 'org-mode)
 342       ;; probably shouldn't redirect
 343       (unless (org-download-image uri)
 344            (message "not an image URL")))
 345         ((eq major-mode 'dired-mode)
 346          (org-download-dired uri))
 347     ;; redirect to someone else
 348         (t
 349     (let ((dnd-protocol-alist
 350            (rassq-delete-all
 351             'org-download-dnd
 352             (copy-alist dnd-protocol-alist))))
 353            (dnd-handle-one-url nil action uri)))))
 354
 355 (defun org-download-dired (uri)
 356   "Download URI to current directory."
 357   (raise-frame)
 358   (let ((filename (file-name-nondirectory
 359                    (car (url-path-and-query
 360                          (url-generic-parse-url uri))))))
 361     (message "Downloading %s to %s ..."
 362              filename
 363              (expand-file-name filename))
 364     (url-retrieve
 365      uri
 366      (lambda (status filename)
 367        (let ((err (plist-get status :error)))
 368          (if err (error
 369                   "\"%s\" %s" uri
 370                   (downcase (nth 2 (assq (nth 2 err) url-http-codes))))))
 371        (let ((coding-system-for-write 'no-conversion))
 372          (write-region nil nil filename nil nil nil 'confirm)))
 373      (list
 374       (expand-file-name filename))
 375      t t)))
 376
 377 (defun org-download-enable ()
 378   "Enable org-download."
 379   (unless (eq (cdr (assoc "^\\(https?\\|ftp\\|file\\|nfs\\)://" dnd-protocol-alist))
 380               'org-download-dnd)
 381     (setq dnd-protocol-alist
 382           `(("^\\(https?\\|ftp\\|file\\|nfs\\)://" . org-download-dnd) ,@dnd-protocol-alist))))
 383
 384 (defun org-download-disable ()
 385   "Disable org-download."
 386   (rassq-delete-all 'org-download-dnd dnd-protocol-alist))
 387
 388 (org-download-enable)
 389
 390 (provide 'org-download)
 391
 392 ;;; org-download.el ends here