;;; sb-mailman.el --- shimbun backend class for mailman archiver -*- coding: iso-2022-7bit; -*-

;; Copyright (C) 2002, 2003 NAKAJIMA Mikio <minakaji@namazu.org>
;; Copyright (C) 2002       Katsumi Yamaoka <yamaoka@jpl.org>
;; Copyright (C) 2005       Tsuyoshi CHO <cho@namazu.org>

;; Authors: NAKAJIMA Mikio  <minakaji@namazu.org>,
;;          Katsumi Yamaoka <yamaoka@jpl.org>,
;;          Tsuyoshi CHO    <cho@namazu.org>
;; Keywords: news

;; This file is a part of shimbun.

;; 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; if not, you can either send email to this
;; program's maintainer or write to: The Free Software Foundation,
;; Inc.; 59 Temple Place, Suite 330; Boston, MA 02111-1307, USA.

;;; Commentary:

;; Mailman is the GNU Mailing List Manager.
;; See http://www.gnu.org/software/mailman/index.html for its detail.

;;; Code:

(eval-when-compile
  (require 'cl))

(require 'shimbun)

(eval-and-compile
  (luna-define-class shimbun-mailman (shimbun) ()))

(defun shimbun-mailman-make-contents (shimbun header)
  (subst-char-in-region (point-min) (point-max) ?\t ?\  t)
  (shimbun-decode-entities)
  (goto-char (point-min))
  (let ((end (search-forward "<!--beginarticle-->")))
    (goto-char (point-min))
    (search-forward "</HEAD>")
    (when (re-search-forward "<H1>\\([^\n]+\\)\\(\n +\\)?</H1>" end t nil)
      (shimbun-header-set-subject
       header
       (shimbun-mime-encode-string (match-string 1))))
    (when (re-search-forward "<B>\\([^\n]+\\)\\(\n +\\)?</B> *\n +\
<A HREF=\"[^\n]+\n +TITLE=\"[^\n]+\">\\([^\n]+\\)"
			     end t nil)
      (shimbun-header-set-from
       header
       (shimbun-mime-encode-string (concat (match-string 1)
					   " <" (match-string 3) ">")))
      (when (re-search-forward "<I>\\([^\n]+\\)</I>" end t nil)
	(shimbun-header-set-date header (match-string 1)))
      (delete-region (point-min) end)
      (delete-region (search-forward "<!--endarticle-->") (point-max))
      (shimbun-header-insert-and-buffer-string shimbun header nil t))))

(luna-define-method shimbun-make-contents ((shimbun shimbun-mailman) header)
  (shimbun-mailman-make-contents shimbun header))

(defun shimbun-mailman-headers (shimbun range)
  (with-temp-buffer
    (let* ((index-url (shimbun-index-url shimbun))
	   (group (shimbun-current-group-internal shimbun))
	   (suffix (if (string-match "^http://\\([^/]+\\)/" index-url)
		       (match-string 1 index-url)
		     index-url))
	   auxs aux id url subject from headers)
      (shimbun-retrieve-url (shimbun-expand-url "index.html" index-url)
			    'reload)
      (setq case-fold-search t)
      (let ((pages (shimbun-header-index-pages range))
	    (count 0))
	(while (and (if pages (<= (incf count) pages) t)
		    (re-search-forward "<a href=\"\\(20[0-9][0-9]q[1-4]\
\\|20[0-9][0-9]-\\(January\\|February\\|March\\|April\\|May\\|June\
\\|July\\|August\\|September\\|October\\|November\\|December\\)\
\\)/date.html\">"
				       nil t))
	  (push (match-string 1) auxs)))
      (setq auxs (nreverse auxs))
      (catch 'stop
	(while auxs
	  (erase-buffer)
	  (shimbun-retrieve-url (shimbun-expand-url
				 (concat (setq aux (car auxs)) "/date.html")
				 index-url)
				'reload)
	  (subst-char-in-region (point-min) (point-max) ?\t ?\  t)
	  (goto-char (point-max))
	  (while (re-search-backward "<LI><A HREF=\"\\(\\([0-9]+\\)\\.html\\)\
\">\\([^\n]+\\)\n</A><A NAME=\"[0-9]+\">&nbsp;</A>\n *<I>\\([^\n]+\\)\n</I>"
				     nil t)
	    (setq id (format "<%06d.%s@%s>"
			     (string-to-number (match-string 2))
			     group
			     suffix))
	    (when (shimbun-search-id shimbun id)
	      (throw 'stop nil))
	    (setq url (shimbun-expand-url (concat aux "/" (match-string 1))
					  index-url)
		  subject (match-string 3)
		  from (match-string 4))
	    (setq subject (with-temp-buffer
			    (insert subject)
			    (shimbun-decode-entities)
			    (shimbun-remove-markup)
			    (buffer-string)))
	    (push (shimbun-make-header
		   0 (shimbun-mime-encode-string subject)
		   (shimbun-mime-encode-string from)
		   "" id "" 0 0 url)
		  headers))
	  (setq auxs (cdr auxs))))
      headers)))

(luna-define-method shimbun-headers ((shimbun shimbun-mailman) &optional range)
  (shimbun-mailman-headers shimbun range))

;;; Derived class for mailing list archives written in any language(m18n)
;;; mailman-m18n
(eval-and-compile
  (luna-define-class shimbun-mailman-m18n (shimbun-mailman)
		     (language-spec-alist atmark-regexp))
  (luna-define-internal-accessors 'shimbun-mailman-m18n))

(defvar shimbun-mailman-m18n-atmark-regexp
  ;;   (concat " \\("
  ;; 	(mapconcat
  ;; 	 'cdr
  ;; 	 '((ja . "＠")
  ;; 	   (en . "at")
  ;; 	   (fr .  "w")
  ;; 	   (nil . "a")
  ;; 	   (nil . "en"))
  ;; 	 "\\|")
  ;; 	"\\) ")
  " \\(＠\\|at\\|w\\|a\\|en\\) "
  "Regexp for atmark(@) alt char/string")

(defvar shimbun-mailman-m18n-language-spec-alist
  '( ;; lang method aux
    (ar "latin" nil)
    (en "latin" nil) ;; method latin and aux nil use default(english).
    (da "latin" nil)
    (de "latin" '("Jan" "Feb" "Mar" "Apr" "Mai" "Jun" "Jul" "Aug" "Sep" "Okt" "Nov" "Dez"))
    (eo "latin" nii)
    (es "latin" '("Jan" "Feb" "Mar" "Apr" "Maj" "Jun" "Jul" "Aug" "Sep" "Okt" "Nov" "Dec"))
    (fr "latin" '("Jan" "Fev" "Mar" "Avr" "Mai" "Jui" "Juli" "Aou" "Sep" "Oct" "Nov" "D,Aic"))
    (hi "latin" nil)
    (ia "latin" nil)
    (is "latin" '("Jan" "Feb" "Mar" "Apr" "Ma,Am" "J,Azn" "J,Azl" ",AAg,Az" "Sep" "Okt" "N,Asv" "Des"))
    (it "latin" '("Gen" "Feb" "Mar" "Apr" "Mag" "Giu" "Lug" "Ago" "Set" "Ott" "Nov" "Dic"))
    (ja "ja"    nil)
    (no "latin" '("Jan" "Feb" "Mar" "Apr" "Mai" "Jun" "Jul" "Aug" "Sep" "Okt" "Nov" "Des"))
    (pl "latin" '("Sty" "Lut" "Mar" "Kwi" "Maj" "Cze" "Lip" "Sie" "Wrz" "Pa,B<" "Lis" "Gru")))
  "Alist for lauguage-specification(date and etc).")

(luna-define-method initialize-instance :after ((shimbun shimbun-mailman-m18n)
						&rest init-args)
  (shimbun-mailman-m18n-set-language-spec-alist-internal
   shimbun
   (symbol-value
    (intern-soft (concat "shimbun-" (shimbun-server-internal shimbun)
			 "-language-spec-alist"))))
  (shimbun-mailman-m18n-set-atmark-regexp-internal
   shimbun
   (symbol-value
    (intern-soft (concat "shimbun-" (shimbun-server-internal shimbun)
			 "-atmark-regexp"))))
  shimbun)

(luna-define-generic shimbun-mailman-m18n-language (shimbun-mailman-m18n)
  "Get current group language symbol.")

(luna-define-generic shimbun-mailman-m18n-charset (shimbun-mailman-m18n)
  "Get current group/article charset string")

(defvar shimbun-mailman-m18n-latin-regexp-and-rule-alist
  '( ;; Regex pattern(year month day time zone)
    ("\\([^ ,0-9]+\\) +\\([^ ,0-9]+\\) +\\([0-9]+\\) +\\([:0-9]+\\) +\\([A-Z]+\\) +\\([0-9]+\\)" .
     (6 2 3 4 5))
    ("\\([^ ,0-9]+\\),? +\\([0-9]+\\)\\.? +\\([^ ,0-9]+\\) +\\([0-9]+\\),? +\\([:0-9]+\\) +\\([A-Z]+\\)" .
     (4 3 2 5 6))
    ("\\([^ ,0-9]+\\) +\\([0-9]+\\) +\\([^ ,0-9]+\\) +\\([:0-9]+\\) +\\([A-Z]+\\) +\\([0-9]+\\)" .
     (6 3 2 4 5))
    ))

(defun shimbun-mailman-m18n-latin-date-decode (date-string &optional aux)
  "Decode date function for latin,require month-string-list 1-12.
Default is english."
  (let ((alist shimbun-mailman-m18n-latin-regexp-and-rule-alist)
	(date "")
	(match-flag nil)
	(month-list (or aux
			;;; Default English rule
			'("Jan" "Feb" "Mar" "Apr" "May"
			  "Jun" "Jul" "Aug" "Sep" "Oct"
			  "Nov" "Dec")))
	regex rule year month day time zone)
    (while (progn
	     (setq regex (car (car alist)))
	     (setq rule  (cdr (car alist)))
	     (setq match-flag (string-match regex date-string))
	     ;; if match-flag is non-nil,match regex for date-string
	     (when match-flag
	       (setq year  (match-string (nth 0 rule) date-string))
	       (setq month (match-string (nth 1 rule) date-string))
	       (setq day   (match-string (nth 2 rule) date-string))
	       (setq time  (match-string (nth 3 rule) date-string))
	       (setq zone  (match-string (nth 4 rule) date-string)))
	     (setq alist (cdr alist))
	     ;; repeat if alist is remain,and match-flag are nil
	     (and alist (not match-flag))))
    (when match-flag ;; matched
      (setq date (shimbun-make-date-string
		  (string-to-number year)
		  (length (member month (reverse month-list)))
		  (string-to-number day)
		  time
		  zone))
      (print date))
    date))

(defun shimbun-mailman-m18n-ja-date-decode (date-string &optional aux)
  "Decode date function for Japnese localized"
  (if (string-match " *\\([0-9][0-9][0-9][0-9]\\)年 *\\([0-9][0-9]*\\)\
月 *\\([0-9][0-9]*\\)日 *(\\(月\\|火\\|水\\|木\\|金\\|土\\|日\\)) *\
\\([:0-9]+\\) *\\([A-Z]+\\) *" date-string)
      ;; <I>2003年 4月 11日 (金) 02:43:25 CEST</I> ;; squeak-ja
      (shimbun-make-date-string
       (string-to-number (match-string 1 date-string))
       (string-to-number (match-string 2 date-string))
       (string-to-number (match-string 3 date-string))
       (match-string 5 date-string)
       (match-string 6 date-string))
    ;; In the early days, the RFC822 style date format has been used.
    date-string))

(luna-define-generic shimbun-mailman-m18n-make-date-string (shimbun-mailman-m18n
							    date-string)
  "Create Date: feild value from mailman's date string.")
(luna-define-method shimbun-mailman-m18n-make-date-string ((shimbun shimbun-mailman-m18n)
							   date-string)
  (let* ((spec (assoc (shimbun-mailman-m18n-language shimbun)
		      (or (shimbun-mailman-m18n-language-spec-alist-internal shimbun)
			  shimbun-mailman-m18n-language-spec-alist)))
	 (method (nth 1 spec))
	 (aux    (nth 2 spec))
	 (date-function (or (and method
				 (stringp method)
				 (intern-soft (concat "shimbun-mailman-m18n-" method "-date-decode")))
			    'shimbun-mailman-m18n-latin-date-decode)))
    (funcall date-function date-string aux)))

(luna-define-method shimbun-make-contents ((shimbun shimbun-mailman-m18n) header)
  (subst-char-in-region (point-min) (point-max) ?\t ?\  t)
  (shimbun-decode-entities)
  (goto-char (point-min))
  (let* ((case-fold-search t)
	 (end (search-forward "<!--beginarticle-->"))
	 name address date)
    (goto-char (point-min))
    (search-forward "</HEAD>")
    (when (re-search-forward "<H1>\\([^\n]+\\)\\(\n +\\)?</H1>" end t nil)
      (shimbun-header-set-subject
       header
       (shimbun-mime-encode-string (match-string 1))))
    (when (re-search-forward "<B>\\([^\n]+\\)\\(\n +\\)?</B> *\n +\
<A HREF=\"[^\n]+\n +TITLE=\"[^\n]+\">\\([^\n]+\\)"
			     end t nil)
      (setq name (match-string 1)
	    address (match-string 3))
      ;; foobar at example.com -> foobar@example.com
      (when (string-match (or (shimbun-mailman-m18n-atmark-regexp-internal shimbun)
			      shimbun-mailman-m18n-atmark-regexp)
			  name)
	(setq name (concat (substring name 0 (match-beginning 0))
			   "@"
			   (substring name (match-end 0)))))
      (when (string-match (or (shimbun-mailman-m18n-atmark-regexp-internal shimbun)
			      shimbun-mailman-m18n-atmark-regexp)
			  address)
	(setq address (concat (substring address 0 (match-beginning 0))
			      "@"
			      (substring address (match-end 0)))))
      (shimbun-header-set-from
       header
       (shimbun-mime-encode-string (concat name " <" address ">"))))
    (when (re-search-forward "<I>\\([^<]*\\)</I>" end t nil)
      (let (date)
	(setq date (shimbun-mailman-m18n-make-date-string shimbun
							  (match-string-no-properties 1)))
	(unless (eq "" date)
	  (shimbun-header-set-date header date))))
    (delete-region (point-min) end)
    (delete-region (search-forward "<!--endarticle-->") (point-max))
    (shimbun-header-insert-and-buffer-string shimbun header
					     (shimbun-mailman-m18n-charset shimbun)
					     t)))

;;; Derived class for mailing list archives written in Japanese

(luna-define-class shimbun-mailman-ja (shimbun-mailman-m18n) ())

(luna-define-method shimbun-mailman-m18n-language ((shimbun shimbun-mailman-ja))
  'ja)

(luna-define-method shimbun-mailman-m18n-charset ((shimbun shimbun-mailman-ja))
  "ISO-2022-JP")

(provide 'sb-mailman)

;;; sb-mailman.el ends here