タイムアウトつき url-retrieve-synchronously

SKK の ML に書いた内容をブログにもメモしときます。

url-retrieve-synchronously は同期的に HTTP で指定した URL にアクセスすることができますが、相手サイトが重いと反応が中々返ってこず、Emacs が固まってしまいます。

その問題を解決するために、タイムアウトつきの url-retrieve-synchronously を作ってみました。
単純に run-with-timer で url-retrieve のプロセスを監視するタイマを作り、タイマが励起されると url-retrieve のプロセスが殺される仕組みです。
タイマウトは、デフォルトで2秒で発生します。

(require 'url-http)

(defun my-url-retrieve-with-timeout (url coding-system &optional timeout-interval)
  (let ((url-max-redirections 0)	; URL リダイレクトを抑制する
	;; `url-retrieve' のためのコールバック関数
	(url-callback #'(lambda (status coding)
			  (let (p)
			    (setq done t)
			    (when (setq p (url-http-symbol-value-in-buffer
					   'url-http-end-of-headers
					   (current-buffer)))
			      (setq jsonp
				    (decode-coding-string
				     (buffer-substring (1+ p) (point-max))
				     coding))))))
	;; タイムアウト発生時に呼ばれるコールバック関数
	(timeout-callback #'(lambda ()
			      ;; `url-retrieve' のプロセスを止める
			      (when (processp proc)
				(delete-process proc))
			      ;; `url-retrieve' は終わったものと見做す
			      (unless done
				(setq done t))))
	;; タイムアウト時間
	(timeout-interval (if timeout-interval timeout-interval 2))
	(done nil)
	buf proc jsonp timeout)
    (unwind-protect
	;; condition-case を用いて全てのエラーを捕捉する。ここで、捕捉した
	;; エラーは無視する。開発、デバッグ時には condition-case のブロック
	;; を外す。
	(condition-case e
	    (when (setq buf
			(url-retrieve url url-callback (list coding-system)))
	      (setq proc (get-buffer-process buf)
		    ;; タイムアウト監視用の timer を設定する
		    timeout (run-with-timer timeout-interval timeout-interval
					    timeout-callback))
	      ;; `url-retrieve' は非同期なので、同期的に結果を得られるよ
	      ;; うに待ち合わせる。ここでは、
	      ;; `url-retrieve-synchronously' が行っていることとほぼ同等
	      ;; のことをしている。本関数では、URL リダイクレトはしない
	      ;; (はず)なので、URL リダイレクトに対する対策の部分のみ削除
	      ;; してある。
	      (while (null done)
		(when (and proc (memq (process-status proc)
				      '(closed exit signal failed))
			   (eq proc (or (get-buffer-process buf) proc)))
		  (delete-process proc)
		  (setq done t))
		(unless (or (with-local-quit
			      (accept-process-output proc))
			    (null proc))
		  (when quit-flag
		    (delete-process proc))
		  (setq proc (and (not quit-flag)
				  (get-buffer-process buf))))))
	  (error
	   ;; 全てのエラーは無視する
	   nil))
      (when (bufferp buf)
	(kill-buffer buf))
      ;; タイムアウト用の timer を削除する
      (when timeout
	(cancel-timer timeout)
	;; 一応、初期化をしておく
	(setq timeout nil)))
    jsonp))

利用例としては、social ime 相手に使うと以下のような感じです。
もし、2秒以内に social ime から応答が無ければ、my-url-retrieve-with-timeout は nil を返します。

(let ((url (concat "http://www.social-ime.com/api/"
		   "?string=" (url-hexify-string
			       (encode-coding-string "あ" 'utf-8))))
      res)
  (when (setq res (my-url-retrieve-with-timeout url 'euc-jp))
    (split-string (substring res 0 (1- (length res))) "\t" t)))
;; => ("亜" "唖" "娃" "阿" "蛙" "吾" "亞" "呀" "堊" "婀" "椏" "痾" "錏" "鐚" "閼" "鴉" "あ" "ア")

timeout の間隔を短くする場合、my-url-retrieve-with-timeout の第3引数に数値を指定します。
少数でもオッケーです。

(my-url-retrieve-with-timeout url 'euc-jp 0.5)

もっと上手いやり方があるだろうなーとか思いながら、そんなこんなで。

更新時刻

• 2011/11/12 23:20