diff --git a/contrib/lisp/org-attach-embedded-images.el b/contrib/lisp/org-attach-embedded-images.el new file mode 100644 index 000000000..83d6757a0 --- /dev/null +++ b/contrib/lisp/org-attach-embedded-images.el @@ -0,0 +1,121 @@ +;;; org-attach-embedded-images.el --- Transmute images to attachments +;; +;; Copyright 2018 Free Software Foundation, Inc. +;; +;; Author: Marco Wahl +;; Version: 0.0 +;; Keywords: org, media +;; +;; This file is not part of GNU Emacs. +;; +;; 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, 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 GNU Emacs. If not, see . + +;;; Commentary: +;; +;; There are occasions when images are displayed in a subtree which +;; are not (yet) org attachments. For example if you copy and paste a +;; part of a web page (containing images) from eww to an org subtree. + +;; This module provides command `org-attach-embedded-images-in-subtree' +;; to save such images as attachments and insert org links to them. + +;; To use you might put the following in your .emacs: + +;; (require 'org-attach-embedded-images) + +;; Use + +;; M-x org-attach-embedded-images-in-subtree + +;; in a subtree with embedded images. The images get attached and can +;; later be reviewed. + +;; Note: Possibly + +;; M-x org-toggle-inline-images is needed to see inline + +;; images in Org mode. + + +;; Code: + +(require 'org) +(require 'org-attach) + + +;; Auxiliary functions + +(defun org-attach-embedded-images--next-property-display-data (position limit) + "Return position of the next property-display location with image data. +Return nil if there is no next display property. +POSITION and LIMIT as in `next-single-property-change'." + (let ((pos (next-single-property-change position 'display nil limit))) + (while (and (< pos limit) + (let ((display-prop + (plist-get (text-properties-at pos) 'display))) + (or (not display-prop) + (not (plist-get (cdr display-prop) :data))))) + (setq pos (next-single-property-change pos 'display nil limit))) + pos)) + +(defun org-attach-embedded-images--attach-with-sha1-name (data) + "Save the image given as DATA as org attachment with its sha1 as name. +Return the filename." + (let* ((extension (symbol-name (image-type-from-data data))) + (basename (concat (sha1 data) "." extension)) + (org-attach-filename + (concat (org-attach-dir t) "/" basename))) + (unless (file-exists-p org-attach-filename) + (with-temp-file org-attach-filename + (setq buffer-file-coding-system 'binary) + (set-buffer-multibyte nil) + (insert data))) + (org-attach-sync) + org-attach-filename)) + + +;; Command + +;;;###autoload +(defun org-attach-embedded-images-in-subtree () + "Save the displayed images as attachments and insert links to them." + (interactive) + (if (org-before-first-heading-p) + (message "Before first heading. Nothing has been attached.") + (save-excursion + (let ((beg (progn (org-back-to-heading) (point))) + (end (progn (org-end-of-subtree) (point))) + (names nil)) + ;; pass 1 + (goto-char beg) + (while (< (goto-char (org-attach-embedded-images--next-property-display-data (point) end)) end) + (let ((data (plist-get (cdr (plist-get (text-properties-at (point)) 'display)) :data))) + (assert data) + (push (org-attach-embedded-images--attach-with-sha1-name data) + names))) + ;; pass 2 + (setq names (nreverse names)) + (goto-char beg) + (while names + (goto-char (org-attach-embedded-images--next-property-display-data (point) end)) + (while (get-text-property (point) 'display) + (goto-char (next-property-change (point) nil end))) + (skip-chars-forward "]") + (insert (concat "\n[[" (pop names) "]]"))))))) + + +(provide 'org-attach-embedded-images) + + +;;; org-attach-embedded-images.el ends here