Navi2ch でインラインに画像を表示する (Referer もつける)

最近の Emacs は画像をインラインに表示できるが、Navi2ch そのものは掲示板の画像をインラインで見ることができない。しかし、《2chログ：Navi2ch for Emacs （Part 11）》の 888 の記事にインライン表示をする elisp とそれ用のシェルスクリプトが書いてあった。

それを Meadow と Cygwin の bash を使って走らせることにする。Cygwin の ImageMagickも使えるようにしておかねばならない。

まず、シェルスクリプトは次のようなものを navi2ch.makethumb という名前で作り実行ビットを立てておく。

#!/bin/sh
#### 引数で与えられた画像をダウンロードし縮小したファイル名を返す ####
#### $2 には referer が入る。
tmp=${TMPDIR:-/tmp}/navi2ch-thumbnails
errimage=/cygdrive/c/WINDOWS/pchealth/helpctr/System/images/error.gif
thumbsize="300x150"

origfile="$tmp/${1#*tp://}"
thumbfile="$origfile.jpg"

# すでにテンポラリにあるイメージは再利用する。
if [ ! -f $origfile ]; then
    if [ -z "$2" ]; then
      /usr/bin/wget "$1" -q -N -x -P $tmp
    else
      /usr/bin/wget --referer="$2" "$1" -q -N -x -P $tmp
    fi
fi
if [ ! -f $origfile ]; then
    echo -n "$errimage"
    exit
fi

# アニメ Gif は scene 0 だけ取り出す。
scene=`identify -format "%n" "$origfile"`

if [ ! -s $thumbfile -o $thumbfile -ot $origfile ]; then
    if [ $scene -gt 1 ]; then
      convert -scene 0 -sample $thumbsize "$origfile" "$origfile-%d.jpg" > /dev/null 2>&1
      mv "$origfile-0.jpg" $thumbfile > /dev/null 2>&1
    else
      convert -sample $thumbsize "$origfile" "$origfile.jpg" > /dev/null 2>&1
    fi
fi
echo -n "$thumbfile"

次に .emacs や ~/.navi2ch/init.el とかに次を書き足す。

(eval-after-load "navi2ch"
    '(progn
        (defvar my-navi2ch-show-image-queue nil)
        (defvar my-navi2ch-check-host t
          "t なら同じホストの場合のみ連続読み込み時にイメージも読み込む。")
        (make-variable-buffer-local 'my-navi2ch-show-image-queue)
        
        (defun my-navi2ch-article-insert-image (proc file)
          "FILE で渡された画像をスレに挿入する．PROC が終了すると呼ばれる．"
          (let ((buf (buffer-name (process-buffer proc))))
            (set-process-buffer proc nil)
            (unless (file-exists-p file)
              (setq my-navi2ch-show-image-queue nil)
              (message "画像の取得または作成に失敗しました。"))
            (when (and buf
                      (file-exists-p file))
              (with-current-buffer buf
                (save-excursion
                  (let ((buffer-read-only nil)
                        (orig (file-name-sans-extension file)))
                    (goto-char (process-mark proc))
                    (forward-line)
                    (insert-image (create-image file))
                    (add-text-properties (1- (point)) (point)
                                        (if (string< navi2ch-version "1.8.0")
                                            (list 'link t 'link-head t
                                                  'url orig 'help-echo orig)
                                          (list 'navi2ch-link-type 'url
                                                'navi2ch-link orig
                                                'help-echo orig)))
                    (insert "\n")
                    (when my-navi2ch-show-image-queue
                      (let ((fun (car my-navi2ch-show-image-queue)))
                        (setq my-navi2ch-show-image-queue
                              (cdr my-navi2ch-show-image-queue))
                        (apply (car fun) (cdr fun))))))))))
                        
        (defun my-navi2ch-article-show-image ()
          "非同期で画像を縮小しインラインに表示する．"
          (interactive)
          (let* ((point (point))
                (board (cdr (assq 'uri navi2ch-article-current-board)))
                (url (if (string< navi2ch-version  "1.8.0")
                          (get-text-property point 'url)
                        (get-text-property point 'navi2ch-link)))
                (ext (when url
                        (file-name-extension url)))
                (proc (get-buffer-process (current-buffer)))
                (stat (and proc (process-status proc))))
            (when (and stat (eq stat 'run))
              (message "以前のプロセスがまだ動いています。"))
            (when (and ext
                      (not (and stat (eq stat 'run)))
                      (member (downcase ext) navi2ch-browse-url-image-extentions))
              ;; Cygwin を使う場合はあったほうがいいのでは？
              (setenv "BASH_ENV" "~/.bash_profile")
              (setq proc
                    (start-process "navi2ch.thumb" (current-buffer)
                                  "c:\\cygwin\\bin\\bash.exe"
                                  "-c"
                                  (concat "navi2ch.makethumb " url " " board)))
              (set-process-filter proc 'my-navi2ch-article-insert-image)
              (set-marker (process-mark proc) point))))
              
        (defun my-navi2ch-article-add-property-and-next-image (beg end force)
          (add-text-properties beg end '(my-navi2ch "shown"))
          (my-navi2ch-article-show-next-images force))
          
        (defun my-navi2ch-article-show-next-images (&optional force)
          "カーソル以下のイメージを連続的に読み込む。"
          (interactive "P")
          (save-excursion
            (let* ((num (navi2ch-article-get-current-number))
                  (board (cdr (assq 'uri navi2ch-article-current-board))))
              (if (re-search-forward
                  (concat "h?ttp://\\([^ \t\n\r]+\\.\\("
                          (mapconcat (lambda (s) s)
                                      navi2ch-browse-url-image-extentions "\\|")
                          "\\)\\)") nil t)
                  (let ((url (concat "http://&quot; (match-string 1)))
                        (beg (match-beginning 0))
                        (end (match-end 0))
                        (func 'my-navi2ch-article-add-property-and-next-image)
                        (prop (get-text-property (match-beginning 1)
                                                'my-navi2ch)))
                    (when (and (or force
                                  (not my-navi2ch-check-host)
                                  (string= (navi2ch-url-to-host url)
                                            (navi2ch-url-to-host board)))
                              (not (string= prop "shown")))
                      (goto-char beg)
                      (my-navi2ch-article-show-image)
                      (setq my-navi2ch-show-image-queue
                            (append my-navi2ch-show-image-queue
                                    (list (list func beg end force))))))))))
                                    
        ;; スレを読みにいったときに自動的にイメージを挿入するようにして
        ;; おく。my-navi2ch-check-host を t にしておけば安心。
        (add-hook 'navi2ch-article-mode-hook
                  'my-navi2ch-article-show-next-images)
                  
        ;; "T" でその URL だけ強制的に表示。
        (define-key navi2ch-article-mode-map "T" 'my-navi2ch-article-show-image)
        ;; 通常はそのホストのイメージは読み込んでるはずだから、"I" で連
        ;; 続読みをするときは強制的に全部読む。
        (define-key navi2ch-article-mode-map "I"
          (lambda () (interactive)
            (my-navi2ch-article-show-next-images t)))
      ))
      
ちなみに、どの掲示板見てるかバレそうだけど、次のようにするとダーティだけど HTTP ヘッダに付けるリファラが設定できたりする。

(eval-after-load "navi2ch"
    '(progn
        ;; 一部リファラがないとアクセスできない掲示板に対応。
        (defadvice navi2ch-net-make-request-header
          (around navi2ch-net-make-request-header-with-referer
                (header-alist) activate)
          (let ((header ad-do-it)
                (board (or navi2ch-article-current-board
                          navi2ch-board-current-board)))
            (unless (assoc "Referer" header-alist)
              (if board
                  (setq header 
                        (concat header "Referer: " (cdr (assq 'uri board))
                                "\r\n"))))
            (setq ad-return-value header)))
            
        ;; document.write だけしかしない javascript なら対応できる。
        (setq navi2ch-article-filter-list
              (cons 
              (lambda ()
                (goto-char (point-min))
                (while (re-search-forward "document\\.write('\\([^']*\\)');" nil t)
                  (replace-match "\\1")))
              navi2ch-article-filter-list))
              
        ;; <br /> に対応。
        (setq navi2ch-replace-html-tag-alist
              (append navi2ch-replace-html-tag-alist
                      '(("<br />" . "\n"))))
        (navi2ch-update-html-tag-regexp)
      ))
      
おっと、ただし、これらは cygwin-mount.el （説明ページ） が必須です。.emacs に次の行があるのをご確認を。動作の軽い cygwin-mount-mw32.el （説明ページ） というものもあります。

(require 'cygwin-mount)
(cygwin-mount-activate)

■追記 (2010-07-01)
  
どうも navi2ch のバージョンアップにより、get-text-property で得る値が変わっているらしい。行儀が悪いが、とりあえずの<ruby><rb>弥縫策</rb><rt>びほうさく</rt></ruby>を反映した。また私が行っているサイトでは <br /> が使われているので、それに対応した。

更新：06/03/04,2010-07-01
初公開：2006年03月04日 06:44:27
最新版：2010年07月01日 20:21:58


Comments:

よろしくです。
投稿: ゆか | 2010-02-04 18:28:57 (JST)

[E:heart01] 更新：navi2ch-1.8.3 では少なくとも使えなくなっていたので、詳しいところはチェックしてないが、とりあえず動くよう修正した。他の人のところでは動いていたのだろうか？
投稿: JRF | 2010-07-01 10:12:41 (JST)

Links:

Navi2ch: http://navi2ch.sourceforge.net/ (hbm)
2chログ：Navi2ch for Emacs （Part 11）: http://pc.2ch.net/test/read.cgi/unix/1065246418/ (hbm)
ImageMagick: http://www.imagemagick.org/
navi2ch.makethumb: http://jrf.cocolog-nifty.com/archive/navi2ch.makethumb
次: http://jrf.cocolog-nifty.com/archive/my-navi2ch.el
cygwin-mount.el （説明ページ）: http://www.bookshelf.jp/soft/meadow_23.html#SEC241 (hbm)
cygwin-mount-mw32.el （説明ページ）: http://www4.kcn.ne.jp/~boochang/emacs/elisp.html (hbm)
ゆか: http://sweetkiss.in