;;; pollen.el --- Pollen Report -*- coding: iso-2022-jp -*- ;; Copyright (C) 1999-2002 Junichiro KITA ;; Author: Junichiro KITA ;; 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: ;; ;; (pollen-from-http "群馬県南部") ;;; Code: (require 'pces) (require 'alist) (require 'product) (product-provide 'pollen-version (product-define "Pollen" nil '(0 4))) (defvar pollen-where "群馬県南部" "* Default place for `pollen-from-http'") (defvar pollen-message "%sの%sの杉花粉は%sです" "* Message format. First `%s' is replaced with DATE, second `%s' with WHERE, third `%s' with QUANTITY.") (defvar pollen-message-off-season "もう%sには杉花粉は飛んでいません" "* Message format for off season. First %s is replaced with WHERE") (defvar pollen-season-start 2) (defvar pollen-season-end 4) (defvar pollen-url-template "http://weather.asahi.com/kafun/%s.html") (defvar pollen-get-func 'pollen-get) (defvar pollen-coding-system (static-if (boundp 'MULE) '*euc-japan* 'euc-japan)) (defvar pollen-fetch-interval (* 60 60 3) "* Default life time for cached data.") (defvar pollen-cache nil "'((where time quantity) ...)") (defvar pollen-region-alist '( ;; 東北 ("青森県津軽" . "tohoku/3110") ("青森県下北" . "tohoku/3120") ("青森県三八上北" . "tohoku/3130") ("秋田県沿岸" . "tohoku/3210") ("秋田県内陸" . "tohoku/3220") ("山形県村山" . "tohoku/3510") ("山形県置賜" . "tohoku/3520") ("山形県庄内" . "tohoku/3530") ("山形県最上" . "tohoku/3540") ("岩手県内陸" . "tohoku/3310") ("岩手県沿岸北部" . "tohoku/3320") ("岩手県沿岸南部" . "tohoku/3330") ("宮城県平野" . "tohoku/3410") ("宮城県山沿い" . "tohoku/3420") ("福島県中通り" . "tohoku/3610") ("福島県浜通り" . "tohoku/3620") ("福島県会津" . "tohoku/3630") ;; 関東 ("茨城県北部" . "kanto/4010") ("茨城県南部" . "kanto/4020") ("栃木県南部" . "kanto/4110") ("栃木県北部" . "kanto/4120") ("群馬県南部" . "kanto/4210") ("群馬県北部" . "kanto/4220") ("埼玉県南部" . "kanto/4310") ("埼玉県北部" . "kanto/4320") ("埼玉県秩父" . "kanto/4330") ("千葉県北西部" . "kanto/4510") ("千葉県北東部" . "kanto/4520") ("千葉県南部" . "kanto/4530") ("東京都23区" . "kanto/4401") ("東京都多摩" . "kanto/4402") ("神奈川県東部" . "kanto/4610") ("神奈川県西部" . "kanto/4620") ;; 中部 ("新潟県下越" . "chubu/5410") ("新潟県中越" . "chubu/5420") ("新潟県上越" . "chubu/5430") ("新潟県佐賀" . "chubu/5440") ("富山県東部" . "chubu/5510") ("富山県西部" . "chubu/5520") ("石川県加賀" . "chubu/5610") ("石川県能登" . "chubu/5620") ("福井県嶺北" . "chubu/5710") ("福井県嶺南" . "chubu/5720") ("山梨県中西部" . "chubu/4910") ("山梨県東部富士五湖" . "chubu/4920") ("長野県北部" . "chubu/4810") ("長野県中部" . "chubu/4820") ("長野県南部" . "chubu/4830") ("静岡県中部" . "chubu/5010") ("静岡県伊豆" . "chubu/5020") ("静岡県東部" . "chubu/5030") ("静岡県西部" . "chubu/5040") ("愛知県西部" . "chubu/5110") ("愛知県東部" . "chubu/5120") ("岐阜県美濃" . "chubu/5210") ("岐阜県飛騨" . "chubu/5220") ;; 近畿 ("滋賀県南部" . "kinki/6010") ("滋賀県北部" . "kinki/6020") ("京都府北部" . "kinki/400") ("京都府南部" . "kinki/6100") ("奈良県北部" . "kinki/6410") ("奈良県南部" . "kinki/6420") ("三重県北中部" . "kinki/5310") ("三重県南部" . "kinki/5320") ("和歌山県北部" . "kinki/6510") ("和歌山県南部" . "kinki/6520") ("大阪府全域" . "kinki/6200") ("大阪府" . "kinki/6200") ("大阪府全県" . "kinki/6200") ("兵庫県南部" . "kinki/6310") ("兵庫県北部" . "kinki/6320") ;; 中国・四国 ("鳥取県東部" . "chushikoku/6910") ("鳥取県西部" . "chushikoku/6920") ("島根県隠岐" . "chushikoku/600") ("島根県東部" . "chushikoku/6810") ("島根県西部" . "chushikoku/6820") ("岡山県南部" . "chushikoku/6610") ("岡山県北部" . "chushikoku/6620") ("広島県南部" . "chushikoku/6710") ("広島県北部" . "chushikoku/6720") ("山口県西部" . "chushikoku/8110") ("山口県中部" . "chushikoku/8120") ("山口県東部" . "chushikoku/8130") ("山口県北部" . "chushikoku/8140") ("愛媛県中予" . "chushikoku/7310") ("愛媛県東予" . "chushikoku/7320") ("愛媛県南予" . "chushikoku/7330") ("香川県全域" . "chushikoku/7200") ("香川県" . "chushikoku/7200") ("香川県全県" . "chushikoku/7200") ("徳島県北部" . "chushikoku/7110") ("徳島県南部" . "chushikoku/7120") ("高知県中部" . "chushikoku/7410") ("高知県東部" . "chushikoku/7420") ("高知県西部" . "chushikoku/7430") ;; 九州 ("福岡県福岡" . "kyushu/8210") ("福岡県北九州" . "kyushu/8220") ("福岡県筑豊" . "kyushu/8230") ("福岡県筑後" . "kyushu/8240") ("佐賀県南部" . "kyushu/8510") ("佐賀県北部" . "kyushu/8520") ("長崎県南部" . "kyushu/8410") ("長崎県北部" . "kyushu/8420") ("長崎県壱岐対馬" . "kyushu/700") ("長崎県五島" . "kyushu/800") ("大分県中部" . "kyushu/8310") ("大分県北部" . "kyushu/8320") ("大分県西部" . "kyushu/8330") ("大分県南部" . "kyushu/8340") ("熊本県熊本" . "kyushu/8610") ("熊本県阿蘇" . "kyushu/8620") ("熊本県天草芦北" . "kyushu/8630") ("熊本県球麿" . "kyushu/8640") ("宮崎県南部平野部" . "kyushu/8710") ("宮崎県北部平野部" . "kyushu/8720") ("宮崎県南部山沿い" . "kyushu/8730") ("宮崎県北部山沿い" . "kyushu/8740") ("鹿児島県薩摩" . "kyushu/8810") ("鹿児島県大隈" . "kyushu/8820") ("鹿児島県種子島・屋久島" . "kyushu/900") ("鹿児島県奄美" . "kyushu/1000") )) (defun pollen-get (buf &optional args) (let (date quantity from to) (save-excursion (set-buffer buf) ;; 予報情報だけを切り出し (シーズン毎に書き換える) (goto-char (point-min)) (when (search-forward "日付" nil t) (forward-line 1) (setq from (point)) (when (search-forward "" nil t) (forward-line -1) (setq to (point)))) (if to (narrow-to-region from to) (error "Pollen: 予報情報を切り出せません．")) ;; 日付・花粉情報の取得 (シーズン毎に書き換える) (goto-char (point-min)) (while (re-search-forward "\\([1-6]+/[1-3]?[0-9]\\)" nil t) (setq date (match-string 1))) (if (re-search-forward "alt=\"\\(.*\\)\"" nil t) (setq quantity (match-string 1))) (if (and date quantity) (list date quantity) (error "Pollen: 日付・花粉情報を見付けられません．"))))) (defsubst pollen-current-second () (string-to-int (format-time-string "%s" (current-time)))) (defun pollen-set-cache (where date quantity) (setq pollen-cache (put-alist where (list (pollen-current-second) date quantity) pollen-cache))) (defun pollen-get-cache (where) (let (current cache ret) (setq cache (assoc where pollen-cache)) (when cache (setq current (pollen-current-second)) (if (< current (+ (cadr cache) pollen-fetch-interval)) (setq ret (cddr cache)))) ret)) (if (fboundp 'pollen-compose) nil (defun pollen-compose (where date quantity) (format pollen-message date where quantity))) (defsubst pollen-off-season-p () (let ((month (string-to-int (format-time-string "%m" (current-time))))) (if (and (>= month pollen-season-start) (<= month pollen-season-end)) nil t))) (defsubst pollen-compose-off-season (where) (format pollen-message-off-season where)) (defun pollen-from-http (&optional where offline) "Fetch pollen report from WEB. If WHERE is nil, the default value `pollen-where' is used instead. If OFFLINE is nil, don't fetch pollen report from WEB, only use cache." (interactive (if (or current-prefix-arg (null pollen-where)) (list (setq pollen-where (completing-read "Where: " pollen-region-alist nil t))))) (setq where (or where pollen-where)) (let (parsed-where url ret ret-data) (setq parsed-where (assoc where pollen-region-alist)) (if (null parsed-where) (error "\"%s\": invalid region. See Document. " where)) (setq url (format pollen-url-template (cdr parsed-where))) ;; if WHERE is not cached and offline is nil(or, online), ;; fetch pollen report from web (if (pollen-off-season-p) (pollen-compose-off-season where) (when (and (null (setq ret-data (pollen-get-cache where))) (null offline)) (setq ret-data (http-fetch-data-from-url-with-function url pollen-get-func))) (when ret-data (apply 'pollen-set-cache where ret-data) (setq ret (apply 'pollen-compose where ret-data)) (if (interactive-p) (message ret) ret))))) (defun pollen-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 pollen-insert-header (&optional where offline) "Insert X-Pollen: header. If WHERE is nil, the default value `pollen-where' is used instead. If OFFLINE is nil, don't fetch pollen report from WEB, only use cache." (interactive (if (or current-prefix-arg (null pollen-where)) (list (setq pollen-where (completing-read "Where: " pollen-region-alist nil t))))) (setq where (or where pollen-where)) (let (current-prefix-arg) (let ((pollen (pollen-from-http where offline))) (if pollen (save-excursion (save-restriction (pollen-narrow-to-header) (goto-char (point-max)) (insert "X-Pollen: " pollen "\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 "" 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) pollen-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 pollen-version () "Print Pollen version." (interactive) (let ((product-info (product-string-1 "Pollen" t))) (if (interactive-p) (message "%s" product-info) product-info))) (provide 'pollen) ;;; pollen.el ends here