画像のリサイズの実験

(require 'cl-lib)
(require 'org)
(require 'org-element)
(require 'subr-x)
(require 'url-util)

(defcustom snowfox/org2blog-image-max-dimension 500
  "縮小後の画像の最大幅・高さ。"
  :type 'integer)

(defcustom snowfox/org2blog-image-jpeg-quality 85
  "JPEG/WebPの縮小コピーに使う品質。"
  :type 'integer)

(defun snowfox/org2blog--imagemagick ()
  "ImageMagickの変換・識別コマンドを返す。"
  (cond
   ((executable-find "magick")
    (list :convert (executable-find "magick")
          :identify (executable-find "magick")
          :identify-prefix '("identify")))
   ((and (executable-find "convert") (executable-find "identify"))
    (list :convert (executable-find "convert")
          :identify (executable-find "identify")
          :identify-prefix nil))
   (t
    (user-error
     "ImageMagickが見つかりません（magick または convert/identify が必要です）"))))

(defun snowfox/org2blog--run (program args)
  "PROGRAMにARGSを渡して実行し、失敗したらエラーにする。"
  (with-temp-buffer
    (let ((status (apply #'call-process program nil t nil args)))
      (unless (and (integerp status) (= status 0))
        (error "%s" (string-trim (buffer-string))))
      (buffer-string))))

(defun snowfox/org2blog--dimensions (file imagemagick)
  "FILEの画像サイズを(width . height)で返す。"
  (let* ((prefix (plist-get imagemagick :identify-prefix))
         (program (plist-get imagemagick :identify))
         (output
          (snowfox/org2blog--run
           program
           (append prefix (list "-ping" "-format" "%w %h" file)))))
    (unless (string-match
             "\\`[[:space:]]*\\([0-9]+\\)[[:space:]]+\\([0-9]+\\)"
             output)
      (error "画像の縦横サイズを読み取れません: %s" file))
    (cons (string-to-number (match-string 1 output))
          (string-to-number (match-string 2 output)))))

(defun snowfox/org2blog--resize-copy (source imagemagick)
  "SOURCEの縮小コピーを作り、そのファイル名を返す。"
  (let* ((extension (file-name-extension source t))
         (ext (downcase (or (file-name-extension source) "")))
         (target
          (concat (file-name-sans-extension source)
                  "-web-"
                  (number-to-string snowfox/org2blog-image-max-dimension)
                  extension))
         (temp
          (make-temp-file
           (expand-file-name ".org2blog-resize-"
                             (file-name-directory target))
           nil extension))
         (args
          (append
           (list source
                 "-auto-orient"
                 "-resize"
                 (format "%dx%d>"
                         snowfox/org2blog-image-max-dimension
                         snowfox/org2blog-image-max-dimension))
           (when (member ext '("jpg" "jpeg" "webp"))
             (list "-quality"
                   (number-to-string snowfox/org2blog-image-jpeg-quality)))
           (list temp))))
    (unwind-protect
        (progn
          (when (and (file-exists-p target)
                     (not (yes-or-no-p
                           (format "既存の縮小コピーを上書きしますか？ %s "
                                   target))))
            (user-error "上書きを取り消しました: %s" target))
          (snowfox/org2blog--run
           (plist-get imagemagick :convert)
           args)
          (rename-file temp target t)
          target)
      (when (file-exists-p temp)
        (delete-file temp)))))

(defun snowfox/org2blog--rewritten-link (record target base)
  "RECORDのOrgリンクをTARGETへのリンクにした文字列を返す。"
  (let* ((begin (plist-get record :begin))
         (end (plist-get record :end))
         (whole (buffer-substring-no-properties begin end))
         (raw (plist-get record :raw))
         (prefix (if (string-prefix-p "file:" raw) "file:" ""))
         (old-path (substring raw (length prefix)))
         (absolute (file-name-absolute-p old-path))
         (new-path
          (if absolute
              target
            (file-relative-name target base)))
         (new-path
          (if (and (string-empty-p prefix)
                   (not absolute)
                   (not (string-prefix-p "./" new-path))
                   (not (string-prefix-p "../" new-path)))
              (concat "./" new-path)
            new-path))
         (new-raw (concat prefix (org-link-escape new-path)))
         (position (string-match (regexp-quote raw) whole)))
    (unless position
      (error "Orgリンク内でリンク先を特定できません: %s" raw))
    (concat (substring whole 0 position)
            new-raw
            (substring whole (+ position (length raw))))))

(defun snowfox/org2blog-resize-images ()
  "Orgバッファ内の大きなローカル画像を縮小し、リンクを差し替える。"
  (interactive)
  (unless (derived-mode-p 'org-mode)
    (user-error "Orgバッファで実行してください"))
  (let* ((base
          (file-name-as-directory
           (expand-file-name
            (if buffer-file-name
                (file-name-directory buffer-file-name)
              default-directory))))
         (imagemagick (snowfox/org2blog--imagemagick))
         (tree (org-element-parse-buffer))
         (records
          (delq nil
                (org-element-map
                    tree 'link
                  (lambda (link)
                    (when (and (equal (org-element-property :type link) "file")
                               (not (org-element-property :search-option link)))
                      (let* ((path
                              (org-link-unescape
                               (org-element-property :path link)))
                             (file (expand-file-name path base)))
                        ;; URLエンコードされた空白なども試す。
                        (unless (file-exists-p file)
                          (setq file
                                (expand-file-name
                                 (url-unhex-string path)
                                 base)))
                        (list :begin (org-element-property :begin link)
                              :end (org-element-property :end link)
                              :raw (org-element-property :raw-link link)
                              :file file)))))))
         (sources
          (delete-dups
           (mapcar (lambda (record) (plist-get record :file))
                   records)))
         candidates
         errors
         (resized (make-hash-table :test 'equal))
         edits)

    ;; リンク先の画像を調べ、縮小が必要なものだけ候補にする。
    (dolist (file sources)
      (let ((ext (downcase (or (file-name-extension file) ""))))
        (when (and (file-regular-p file)
                   (not (file-remote-p file))
                   (member ext '("jpg" "jpeg" "png" "webp"))
                   ;; すでに生成した縮小コピーは再処理しない。
                   (not (string-match-p
                         "-web-[0-9]+\\'"
                         (file-name-sans-extension file))))
          (condition-case err
              (let* ((size
                      (snowfox/org2blog--dimensions file imagemagick))
                     (long-side (max (car size) (cdr size))))
                (when (> long-side snowfox/org2blog-image-max-dimension)
                  (push (list file size) candidates)))
            (error
             (push (format "%s: %s"
                           file
                           (error-message-string err))
                   errors))))))

    (setq candidates (nreverse candidates))

    (when candidates
      (unless
          (yes-or-no-p
           (format
            "%d枚の画像を縮小コピーにして、このバッファのリンクを差し替えますか？ "
            (length candidates)))
        (user-error "処理を取り消しました"))

      ;; 元画像は残したまま、縮小コピーを作る。
      (dolist (candidate candidates)
        (let ((file (car candidate)))
          (condition-case err
              (puthash file
                       (snowfox/org2blog--resize-copy file imagemagick)
                       resized)
            (error
             (push (format "%s: %s"
                           file
                           (error-message-string err))
                   errors)))))

      ;; リンクの位置がずれないよう、後ろから順に差し替える。
      (dolist (record records)
        (let ((target (gethash (plist-get record :file) resized)))
          (when target
            (condition-case err
                (push (list (plist-get record :begin)
                            (plist-get record :end)
                            (snowfox/org2blog--rewritten-link
                             record target base))
                      edits)
              (error
               (push (error-message-string err)
                     errors))))))

      (dolist (edit (sort edits (lambda (a b) (> (car a) (car b)))))
        (goto-char (nth 0 edit))
        (delete-region (nth 0 edit) (nth 1 edit))
        (insert (nth 2 edit))))

    (dolist (error-message (nreverse errors))
      (message "画像処理: %s" error-message))

    (message "画像処理完了: 縮小コピー %d枚、リンク差し替え %dか所"
             (hash-table-count resized)
             (length edits))))