contrib/lisp/org-download.el

   1 ;;; org-download.el --- Image drag-and-drop for Emacs org-mode
   2
   3 ;; Copyright (C) 2014 Free Software Foundation, Inc.
   4
   5 ;; Author: Oleh Krehel
   6 ;; Keywords: images, screenshots, download
   7 ;; Homepage: http://orgmode.org
   8
   9 ;; This file is 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-screenshot-method "gnome-screenshot -a -f %s"
 116   "The tool to capture screenshots."
 117   :type '(choice
 118           (const :tag "gnome-screenshot" "gnome-screenshot -a -f %s")
 119           (const :tag "scrot" "scrot -s %s")
 120           (const :tag "gm" "gm import %s"))
 121   :group 'org-download)
 122
 123 (defcustom org-download-image-width 0
 124   "When non-zero add #+attr_html: :width tag to the image."
 125   :type 'integer
 126   :group 'org-download)
 127
 128 (defun org-download-get-heading (lvl)
 129   "Return the heading of the current entry's LVL level parent."
 130   (save-excursion
 131     (let ((cur-lvl (org-current-level)))
 132       (unless (= cur-lvl 1)
 133         (org-up-heading-all (- (1- (org-current-level)) lvl)))
 134       (substring-no-properties
 135        (org-get-heading)))))
 136
 137 (defun org-download--dir-1 ()
 138   "Return the first part of the directory path for `org-download--dir'.
 139 It's `org-download-image-dir', unless it's nil.  Then it's \".\"."
 140   (or org-download-image-dir "."))
 141
 142 (defun org-download--dir-2 ()
 143   "Return the second part of the directory path for `org-download--dir'.
 144 Unless `org-download-heading-lvl' is nil, it's the name of the current
 145 `org-download-heading-lvl'-leveled heading.  Otherwise it's \"\"."
 146   (and org-download-heading-lvl
 147        (org-download-get-heading
 148         org-download-heading-lvl)))
 149
 150 (defun org-download--dir ()
 151   "Return the directory path for image storage.
 152
 153 The path is composed from `org-download--dir-1' and `org-download--dir-2'.
 154 The directory is created if it didn't exist before."
 155   (let* ((part1 (org-download--dir-1))
 156          (part2 (org-download--dir-2))
 157          (dir (if part2
 158                   (format "%s/%s" part1 part2)
 159                 part1)))
 160     (unless (file-exists-p dir)
 161       (make-directory dir t))
 162     dir))
 163
 164 (defun org-download--fullname (link)
 165   "Return the file name where LINK will be saved to.
 166
 167 It's affected by `org-download-timestamp' and `org-download--dir'."
 168   (let ((filename
 169          (file-name-nondirectory
 170           (car (url-path-and-query
 171                 (url-generic-parse-url link)))))
 172         (dir (org-download--dir)))
 173     (format "%s/%s%s.%s"
 174             dir
 175             (file-name-sans-extension filename)
 176             (format-time-string org-download-timestamp)
 177             (file-name-extension filename))))
 178
 179 (defun org-download--image (link filename)
 180   "Save LINK to FILENAME asynchronously and show inline images in current buffer."
 181   (when (string-match "^file://\\(.*\\)" link)
 182     (setq link (url-unhex-string (match-string 1 link))))
 183   (cond ((file-exists-p link)
 184          (org-download--image/command "cp \"%s\" \"%s\"" link filename))
 185         ((eq org-download-backend t)
 186          (org-download--image/url-retrieve link filename))
 187         (t
 188          (org-download--image/command org-download-backend link filename))))
 189
 190 (defun org-download--image/command (command link filename)
 191   "Using COMMAND, save LINK to FILENAME.
 192 COMMAND is a format-style string with two slots for LINK and FILENAME."
 193   (require 'async)
 194   (async-start
 195    `(lambda() (shell-command
 196           ,(format command link
 197                    (expand-file-name filename))))
 198    (lexical-let ((cur-buf (current-buffer)))
 199      (lambda(x)
 200        (with-current-buffer cur-buf
 201          (org-display-inline-images))))))
 202
 203 (defun org-download--image/url-retrieve (link filename)
 204   "Save LINK to FILENAME using `url-retrieve'."
 205   (url-retrieve
 206    link
 207    (lambda (status filename buffer)
 208      ;; Write current buffer to FILENAME
 209      ;; and update inline images in BUFFER
 210      (let ((err (plist-get status :error)))
 211        (if err (error
 212                 "\"%s\" %s" link
 213                 (downcase (nth 2 (assq (nth 2 err) url-http-codes))))))
 214      (delete-region
 215       (point-min)
 216       (progn
 217         (re-search-forward "\n\n" nil 'move)
 218         (point)))
 219      (let ((coding-system-for-write 'no-conversion))
 220        (write-region nil nil filename nil nil nil 'confirm))
 221      (with-current-buffer buffer
 222        (org-display-inline-images)))
 223    (list
 224     (expand-file-name filename)
 225     (current-buffer))
 226    nil t))
 227
 228 (defun org-download-yank ()
 229   "Call `org-download-image' with current kill."
 230   (interactive)
 231   (org-download-image (current-kill 0)))
 232
 233 (defun org-download-screenshot ()
 234   "Capture screenshot and insert the resulting file.
 235 The screenshot tool is determined by `org-download-screenshot-method'."
 236   (interactive)
 237   (let ((link "/tmp/screenshot.png"))
 238     (shell-command (format org-download-screenshot-method link))
 239     (org-download-image link)))
 240
 241 (defun org-download-image (link)
 242   "Save image at address LINK to `org-download--dir'."
 243   (interactive "sUrl: ")
 244   (let ((filename
 245          (if (eq org-download-method 'attach)
 246              (let ((org-download-image-dir (progn (require 'org-attach)
 247                                                   (org-attach-dir t)))
 248                    org-download-heading-lvl)
 249                (org-download--fullname link))
 250            (org-download--fullname link))))
 251     (when (image-type-from-file-name filename)
 252       (org-download--image link filename)
 253       (when (eq org-download-method 'attach)
 254         (org-attach-attach filename nil 'none))
 255       (if (looking-back "^[ \t]+")
 256           (delete-region (match-beginning 0) (match-end 0))
 257         (newline))
 258       (insert (format "#+DOWNLOADED: %s @ %s\n%s [[%s]]"
 259                       link
 260                       (format-time-string "%Y-%m-%d %H:%M:%S")
 261                       (if (= org-download-image-width 0)
 262                           ""
 263                         (format "#+attr_html: :width %dpx\n" org-download-image-width))
 264                       filename))
 265       (org-display-inline-images))))
 266
 267 (defun org-download--at-comment-p ()
 268   "Check if current line begins with #+DOWLOADED:."
 269   (save-excursion
 270     (move-beginning-of-line nil)
 271     (looking-at "#\\+DOWNLOADED:")))
 272
 273 (defun org-download-delete ()
 274   "Delete inline image link on current line, and the file that it points to."
 275   (interactive)
 276   (cond ((org-download--at-comment-p)
 277          (delete-region (line-beginning-position)
 278                         (line-end-position))
 279          (org-download--delete (line-beginning-position)
 280                                nil
 281                                1))
 282         ((region-active-p)
 283          (org-download--delete (region-beginning)
 284                                (region-end))
 285          (delete-region (region-beginning)
 286                         (region-end)))
 287
 288         (t (org-download--delete (line-beginning-position)
 289                                  (line-end-position)))))
 290
 291 (defun org-download--delete (beg end &optional times)
 292   "Delete inline image links and the files they point to between BEG and END.
 293
 294 When TIMES isn't nil, delete only TIMES links."
 295   (unless times
 296     (setq times most-positive-fixnum))
 297   (save-excursion
 298     (goto-char beg)
 299     (while (and (>= (decf times) 0)
 300                 (re-search-forward "\\[\\[\\([^]]*\\)\\]\\]" end t))
 301       (let ((str (match-string-no-properties 1)))
 302         (delete-region (match-beginning 0)
 303                        (match-end 0))
 304         (when (file-exists-p str)
 305           (delete-file str))))))
 306
 307 (defun org-download-dnd (uri action)
 308   "When in `org-mode' and URI points to image, download it.
 309 Otherwise, pass URI and ACTION back to dnd dispatch."
 310   (if (eq major-mode 'org-mode)
 311       ;; probably shouldn't redirect
 312       (unless (org-download-image uri)
 313         (message "not an image URL"))
 314     ;; redirect to someone else
 315     (let ((dnd-protocol-alist
 316            (rassq-delete-all
 317             'org-download-dnd
 318             (copy-alist dnd-protocol-alist))))
 319       (dnd-handle-one-url nil action uri))))
 320
 321 (defun org-download-enable ()
 322   "Enable org-download."
 323   (unless (eq (cdr (assoc "^\\(https?\\|ftp\\|file\\|nfs\\)://" dnd-protocol-alist))
 324               'org-download-dnd)
 325     (setq dnd-protocol-alist
 326           `(("^\\(https?\\|ftp\\|file\\|nfs\\)://" . org-download-dnd) ,@dnd-protocol-alist))))
 327
 328 (defun org-download-disable ()
 329   "Disable org-download."
 330   (rassq-delete-all 'org-download-dnd dnd-protocol-alist))
 331
 332 (org-download-enable)
 333
 334 (provide 'org-download)
 335
 336 ;;; org-download.el ends here