;;; exchange.el --- Exchange Report -*- coding: iso-2022-jp -*-

;; Copyright (C) 2004 MATSUURA Kyo <kyo@chimons.org>

;; Author: MATSUURA Kyo <kyo@chimons.org>

;; 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 2, 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 this program; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;; usage:
;;
;; (exchange-from-http)
;; (exchange-from-http "アメリカドル" "日本円")
;; (exchange-from-http "韓国ウォン" "日本円" 100)
;; (exchange-from-http "トルコリラ" "欧州ユーロ" 1000000 t)

;;; Code:

(require 'pces)
(require 'alist)
(require 'product)

(product-provide 'exchange-version
  (product-define "Exchange" nil '(0 4)))

(defvar exchange-from "アメリカドル"
  "* Default currency exchaged-from for `exchange-from-http'")
(defvar exchange-to "日本円"
  "* Default currency exchaged-to for `exchange-from-http'")

(defvar exchange-unit 1
  "* Default unit of currency exchanged-from for `exchange-from-http'")

(defvar exchange-short nil
  "* Toggle `exchange-message' and `exchange-short-message'")

(defvar exchange-message "%s%s\(%s\) = %f%s\(%s\)"
  "* Message format.
First `%s' is replaced with FROM's UNIT value,
second `%s' is replaced with FROM,
third `%s' is replaced with currency code of FROM,
fourth `%f' is replaced with RATE,
fifth `%s' is replaced with TO,
sixth `%s' is replaced with currency code of TO.")
(defvar exchange-short-message "%s%s = %f%s"
  "* Short Message format.
First `%s' is replaced with FROM's UNIT value,
second `%s' is replaced with currency code of FROM,
third `%f' is replaced with RATE,
fourth `%s' is replaced with currency code of TO.")

(defvar exchange-url-template "http://quote.yahoo.co.jp/q?s=%s%s=X&d=t")
(defvar exchange-get-func 'exchange-get)
(defvar exchange-coding-system
  (static-if (boundp 'MULE) '*euc-japan* 'euc-japan))


(defvar exchange-currency-alist
  '(
    ("アイルランドポンド" . "IEP")
    ("アメリカドル" . "USD")
    ("イギリスポンド" ."GBP")
    ("イタリアリラ" . "ITL")
    ("インドルピー" . "INR")
    ("インドネシアルピア" . "IDR")
    ("エクアドルスクレ" . "ECS")
    ("エジプトポンド" . "EGP")
    ("オーストリアシリング" . "ATS")
    ("オーストラリアドル" . "AUD")
    ("オランダギルダー" . "NLG")
    ("カナダドル" . "CAD")
    ("韓国ウォン" . "KRW")
    ("ギリシャドラクマ" . "GRD")
    ("クウェートディナール" . "KWD")
    ("コロンビアペソ" . "COP")
    ("サウジリアル" . "SAR")
    ("シンガポールドル" . "SGD")
    ("スイスフラン" . "CHF")
    ("スウェーデンクローナ" . "SEK")
    ("スペインペセタ" . "ESP")
    ("タイバーツ" . "THB")
    ("台湾ドル" . "TWD")
    ("中国元" . "CNY")
    ("チリペソ" . "CLP")
    ("デンマーククローネ" . "DKK")
    ("ドイツマルク" . "DEM")
    ("トルコリラ" . "TRL")
    ("日本円" . "JPY")
    ("ニュージーランドドル" . "NZD")
    ("ノルウェークローネ" . "NOK")
    ("パラグアイグァラニ" . "PYG")
    ("フィリピンペソ" . "PHP")
    ("フィンランドマルッカ" . "FIM")
    ("ブラジルリアル" . "BRL")
    ("フランスフラン" . "FRF")
    ("ベネズエラボリバー" . "VEB")
    ("ペルーソル" . "PEN")
    ("ベルギーフラン" . "BEF")
    ("ポルトガルエスクード" . "PTE")
    ("香港ドル" . "HKD")
    ("マレーシアリンギ" . "MYR")
    ("南アフリカランド" . "ZAR")
    ("メキシコペソ" . "MXN")
    ("UAEダーハム" . "AED")
    ("欧州ユーロ" . "EUR")
    ("ヨルダンディナール" . "JOD")
    ("ルーマニアルー" . "ROL")
    ("レバノンポンド" . "LBP")
    ("ロシアンルーブル" . "RUB")
    ))


(defun exchange-get (buf &optional args)
  (let (rate cut-from cut-to)
    (save-excursion
      (set-buffer buf)
      (goto-char (point-min))
      (when (search-forward "取引値<br>" nil t)
	(setq cut-from (point))
	(when (search-forward "買気配<br>" nil t)
	  (setq cut-to (point))))
      (if (and cut-from cut-to)
	  (narrow-to-region cut-from cut-to)
	(error "Exchange: レート情報を切り出せません．"))
      (goto-char (point-min))
      (if (re-search-forward "<b>\\([0-9]+\.[0-9]+\\)</b>" nil t)
	  (setq rate (match-string 1)))
      (if rate
	  (list rate)
	(error "Exchange: 通貨・レート情報を見付けられません．")))))


(defsubst exchange-compose (short unit from to from-code to-code rate)
  (if (null short)
      (format exchange-message
	      unit from from-code (* unit (string-to-number rate)) to to-code)
    (format exchange-short-message
	    unit from-code (* unit (string-to-number rate)) to-code)))

(defun exchange-from-http (&optional from to unit short)
  "Fetch exchange report from WEB.
If FROM is nil, the default value `exchange-from' is used instead.
If TO is nil, the default value `exchange-to' is used instead.
UNIT specifies FROM currency unit value. If nil, 1 is used instead."
  (interactive (if (or current-prefix-arg
		       (and
			(null exchange-from)
			(null exchange-to)
			(zerop exchange-unit)
			(null exchange-short)))
		   (list
		    (setq exchange-from
			  (completing-read "From: "
					   exchange-currency-alist nil t))
		    (setq exchange-to
			  (completing-read "To: "
					   exchange-currency-alist nil t))
		    (string-to-number
		     (read-from-minibuffer "Unit: "
					   (number-to-string exchange-unit)))
		    (if (y-or-n-p "Use long format? ")
			(setq exchange-short nil)
		      (setq exchange-short t)))))
  (setq from (or from exchange-from))
  (setq to (or to exchange-to))
  (setq unit (or unit exchange-unit))
  (setq short (or short exchange-short))
  (let (parsed-from parsed-to url ret ret-data)
    (setq parsed-from (assoc from exchange-currency-alist))
    (if (null parsed-from)
	(error "\"%s\": invalid currency. See Document. " from))
    (setq parsed-to (assoc to exchange-currency-alist))
    (if (null parsed-to)
	(error "\"%s\": invalid currency. See Document. " to))
    (setq url (format exchange-url-template (cdr parsed-from) (cdr parsed-to)))
    ;; fetch exchange report from web
    (setq ret-data (http-fetch-data-from-url-with-function
		    url exchange-get-func))
    (when ret-data
      (let ((from-code (cdr parsed-from))
	    (to-code (cdr parsed-to)))
	(setq ret (apply 'exchange-compose
			 short unit from to from-code to-code ret-data)))
      (if (interactive-p)
	  (message ret)
	ret))))


(defun exchange-narrow-to-header ()
  "Narrow to the message header."
  (let (case-fold-search)
    (narrow-to-region
     (goto-char (point-min))
     (goto-char (if (re-search-forward
		     (format "^$\\|^%s$"
			     (regexp-quote mail-header-separator))
		     nil t)
		    (match-beginning 0)
		  (point-max))))))

(defun exchange-insert-header (&optional from to unit short)
  "Insert X-Exchange: header.
If FROM is nil, the default value `exchange-from' is used instead.
If TO is nil, the default value `exchange-to' is used instead.
UNIT specifies FROM currency unit value. If nil, 1 is used instead."
  (interactive (if (or current-prefix-arg
		       (and
			(null exchange-from)
			(null exchange-to)
			(zerop exchange-unit)
			(null exchange-short)))
		   (list
		    (setq exchange-from
			  (completing-read "From: "
					   exchange-currency-alist nil t))
		    (setq exchange-to
			  (completing-read "To: "
					   exchange-currency-alist nil t))
		    (string-to-number
		     (read-from-minibuffer "Unit: "
					   (number-to-string exchange-unit)))
		    (if (y-or-n-p "Use long format? ")
			(setq exchange-short nil)
		      (setq exchange-short t)))))
  (let ((exchange (exchange-from-http from to unit short)))
    (if exchange
	(save-excursion
	  (save-restriction
	    (exchange-narrow-to-header)
	    (goto-char (point-max))
	    (insert "X-Exchange: " exchange "\n"))))))



;; functions for retrieving data from HTTP
(defvar http-fetch-timeout 20)
(defvar http-fetch-proxy-server nil)
(defvar http-fetch-proxy-port 8080)

(defun http-fetch-from-url (url)
  (let (connection server port buf)
    (if http-fetch-proxy-server
	(setq server http-fetch-proxy-server
	      port http-fetch-proxy-port)
      (string-match "^http://\\([^/:]+\\)\\(:\\([0-9]+\\)\\)?/" url)
      (setq server (match-string 1 url)
	    port (string-to-int (or (match-string 3 url) "80"))))
    (save-excursion
      (unwind-protect
	  (progn
	    (setq buf (generate-new-buffer "*HTTP Fetch*")))
	    (setq connection
		  (as-binary-process
		   (open-network-stream "*Fetch from HTTP*" 
					buf
					server
					port)))
	    (process-send-string
	     connection
	     (concat "GET " url " HTTP/1.0\r\n"))
	    (process-send-string connection "\r\n")
	    (set-buffer buf)
	    (setq buffer-read-only nil)
	    (goto-char (point-min))
	    (while (not (search-forward "</body>" nil t))
	      (unless (accept-process-output connection http-fetch-timeout)
		(kill-buffer buf)
		(error "http-fetch: Connection timeout!"))
	      (goto-char (point-min)))
	    (decode-coding-region (point-min)(point-max) exchange-coding-system)
	    (goto-char (point-min))
	    buf))))

(defun http-fetch-data-from-url-with-function (url func &rest args)
  "fetch data from URL and extract favorit data from retrieved HTML with FUNC."
  (let (buf ret)
    (setq buf (http-fetch-from-url url))
    (when buf
      (setq ret (apply func buf args))
      (kill-buffer buf)
      ret)))



(defun exchange-version ()
  "Print Exchange version."
  (interactive)
  (let ((product-info (product-string-1 "Exchange" t)))
    (if (interactive-p)
        (message "%s" product-info)
      product-info)))

(provide 'exchange)

;;; exchange.el ends here