contrib/lisp/org-attach-embedded-images.el

   1 ;;; org-attach-embedded-images.el --- Transmute images to attachments
   2 ;;
   3 ;; Copyright 2018 Free Software Foundation, Inc.
   4 ;;
   5 ;; Author: Marco Wahl
   6 ;; Version: 0.0
   7 ;; Keywords: org, media
   8 ;;
   9 ;; This file is not part of GNU Emacs.
  10 ;;
  11 ;; This program 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, or (at your option)
  14 ;; any later version.
  15 ;;
  16 ;; This program 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 \f
  24 ;;; Commentary:
  25 ;;
  26 ;; There are occasions when images are displayed in a subtree which
  27 ;; are not (yet) org attachments.  For example if you copy and paste a
  28 ;; part of a web page (containing images) from eww to an org subtree.
  29
  30 ;; This module provides command `org-attach-embedded-images-in-subtree'
  31 ;; to save such images as attachments and insert org links to them.
  32
  33 ;; To use you might put the following in your .emacs:
  34
  35 ;; (require 'org-attach-embedded-images)
  36
  37 ;; Use
  38
  39 ;;     M-x org-attach-embedded-images-in-subtree
  40
  41 ;; in a subtree with embedded images.  The images get attached and can
  42 ;; later be reviewed.
  43
  44 ;; Note: Possibly
  45
  46 ;;     M-x org-toggle-inline-images is needed to see inline
  47
  48 ;; images in Org mode.
  49
  50 \f
  51 ;; Code:
  52
  53 (require 'org)
  54 (require 'org-attach)
  55
  56 \f
  57 ;; Auxiliary functions
  58
  59 (defun org-attach-embedded-images--next-property-display-data (position limit)
  60   "Return position of the next property-display location with image data.
  61 Return nil if there is no next display property.
  62 POSITION and LIMIT as in `next-single-property-change'."
  63   (let ((pos (next-single-property-change position 'display nil limit)))
  64     (while (and (< pos limit)
  65                 (let ((display-prop
  66                        (plist-get (text-properties-at pos) 'display)))
  67                   (or (not display-prop)
  68                       (not (plist-get (cdr display-prop) :data)))))
  69       (setq pos (next-single-property-change pos 'display nil limit)))
  70     pos))
  71
  72 (defun org-attach-embedded-images--attach-with-sha1-name (data)
  73   "Save the image given as DATA as org attachment with its sha1 as name.
  74 Return the filename."
  75   (let* ((extension (symbol-name (image-type-from-data data)))
  76          (basename (concat (sha1 data) "." extension))
  77          (org-attach-filename
  78           (concat (org-attach-dir t) "/" basename)))
  79     (unless (file-exists-p org-attach-filename)
  80       (with-temp-file org-attach-filename
  81         (setq buffer-file-coding-system 'binary)
  82         (set-buffer-multibyte nil)
  83         (insert data)))
  84     (org-attach-sync)
  85     org-attach-filename))
  86
  87 \f
  88 ;; Command
  89
  90 ;;;###autoload
  91 (defun org-attach-embedded-images-in-subtree ()
  92   "Save the displayed images as attachments and insert links to them."
  93   (interactive)
  94   (if (org-before-first-heading-p)
  95       (message "Before first heading.  Nothing has been attached.")
  96     (save-excursion
  97       (let ((beg (progn (org-back-to-heading) (point)))
  98             (end (progn (org-end-of-subtree) (point)))
  99             (names nil))
 100         ;; pass 1
 101         (goto-char beg)
 102         (while (< (goto-char (org-attach-embedded-images--next-property-display-data (point) end)) end)
 103           (let ((data (plist-get (cdr (plist-get (text-properties-at (point)) 'display)) :data)))
 104             (assert data)
 105             (push (org-attach-embedded-images--attach-with-sha1-name data)
 106                   names)))
 107         ;; pass 2
 108         (setq names (nreverse names))
 109         (goto-char beg)
 110         (while names
 111           (goto-char (org-attach-embedded-images--next-property-display-data (point) end))
 112           (while (get-text-property (point) 'display)
 113             (goto-char (next-property-change (point) nil end)))
 114           (skip-chars-forward "]")
 115           (insert (concat "\n[[" (pop names) "]]")))))))
 116
 117 \f
 118 (provide 'org-attach-embedded-images)
 119
 120 \f
 121 ;;; org-attach-embedded-images.el ends here