MeadowでExcite翻訳

といっても単にhttpリクエスト投げてるだけだけど。ほとんどopen-network-streamのデモみたいなもの。

http://www.bookshelf.jp/cgi-bin/goto.cgi?file=meadow&node=reference%20functionとかhttp://www.bookshelf.jp/cgi-bin/goto.cgi?file=elisp&node=Coding%20Systemsがとても参考になった。

;;; Emacs lisp for web translation
;;;
;;; This is ad-hoc script to translate English and Japanese each other.
;;; It works only with http://www.excite.co.jp/world/.
;;;

(defvar trans-user-mail-address "nozom@knzm.dip.jp") ;;; must be changed!

(defvar trans-version "1.0.0")
(defvar trans-user-agent (concat "webtrans.el/" trans-version))

(defvar trans-process-name "elisp-retrieval-process")
(defvar trans-process-buffer-name "*elisp-buffer*")
(defvar trans-popup-buffer-name "*trans*")

(defun encode-url (raw-text)
  (mapconcat (lambda (c)
               (cond
                ((or (and (<= ?a c) (<= c ?z))
                     (and (<= ?A c) (<= c ?Z))
                     (and (<= ?0 c) (<= c ?9))
                     (position c "*-.@_"))
                 (char-to-string c))
                ((string= " " (char-to-string c))
                 "+")
                (t
                 (format "%%%02x" c))))
             raw-text ""))

(defun retrieve-http (method host path &optional header-alist post-alist filter coding-system)
  (with-temp-buffer
    (let* *1
           (pbuf (process-buffer http))
           request post-data)

      (setq post-data
            (mapconcat (lambda (lst)
                         (mapconcat (lambda (elt)
                                      (let *2
                       post-alist "&"))

      (add-to-list 'header-alist (list "From:" trans-user-mail-address))
      (add-to-list 'header-alist (list "UserAgent:" trans-user-agent))
      (add-to-list 'header-alist (list "Host:" host))
      (add-to-list 'header-alist (list "Connection:" "Close"))
      (when (string= (upcase method) "POST")
        (add-to-list 'header-alist (list "Content-Type:"
                                         "application/x-www-form-urlencoded"))
        (add-to-list 'header-alist (list "Content-Length:"
                                         (int-to-string (length post-data)))))

      (setq request (concat method " " path " HTTP/1.1\r\n"
                            (mapconcat
                             (lambda (x) (concat (car x) " " (cadr x) "\r\n"))
                             header-alist "")
                            "\r\n"
                            post-data))

      (save-excursion
        (set-buffer pbuf)
        (widen)
        (erase-buffer))
      (process-send-string http request)
      (while (eq (process-status http) 'open)
        (accept-process-output))
      (save-excursion
        (set-buffer pbuf)
        (or coding-system
            (setq coding-system (car (detect-coding-region (point-min) (point-max)))))
        (and coding-system
             (not (eq coding-system 'raw-text))
             (decode-coding-region (point-min) (point-max) coding-system)))
      (insert-buffer-substring pbuf)
      (kill-buffer pbuf)
      (if (null filter)
          (buffer-string)
        (goto-char (point-min))
        (funcall filter)))))

(defun trans-english-to-japanese-string (string)
  (retrieve-http
   "POST"
   "www.excite.co.jp"
   "/world/english/"
   nil
   `(("wb_lp" "ENJA") ("start" "翻訳") ("before" ,string))
   (lambda nil
     (when (re-search-forward "<textarea [^>]*name=\"after\"[^>]*>\\([^<]*\\)</textarea>" nil t)
       (match-string 1)))
   'japanese-shift-jis))

(defun trans-japanese-to-english-string (string)
  (retrieve-http
   "POST"
   "www.excite.co.jp"
   "/world/english/"
   nil
   `(("wb_lp" "JAEN") ("start" "翻訳") ("before" ,string))
   (lambda nil
     (when (re-search-forward "<textarea [^>]*name=\"after\"[^>]*>\\([^<]*\\)</textarea>" nil t)
       (match-string 1)))
   'japanese-shift-jis))

(defun trans-pop-up-result (string)
  (let )*3

(defun trans-japanese-to-english-region (start end)
  (interactive "r")
  (message "translating into English...")
  (trans-pop-up-result (trans-japanese-to-english-string
                        (buffer-substring start end)))
  (message "translating into English...done."))

(defun trans (start end)
  (interactive "r")
  (let *4 str)
         'trans-japanese-to-english-region
       'trans-english-to-japanese-region))))

Excite翻訳をこういう使い方していいのか良く分からないので、使うときはあまり迷惑にならないように気をつけて使うこと。

*1:coding-system-for-read 'binary) (coding-system-for-write 'binary) (http (open-network-stream trans-process-name trans-process-buffer-name host 80

*2:coding-system (or coding-system (car (detect-coding-string elt))))) (encode-url (if coding-system (encode-coding-string elt coding-system) elt)))) lst "="

*3:buf (get-buffer-create trans-popup-buffer-name)))( (set-buffer buf) (erase-buffer) (insert string) (pop-to-buffer buf))) (defun trans-english-to-japanese-region (start end) (interactive "r") (message "translating into Japanese...") (trans-pop-up-result (trans-english-to-japanese-string (buffer-substring start end))) (message "translating into Japanese...done."

*4:str (buffer-substring start end))) (call-interactively (if (position-if (lambda (x) (> x 256