;;; sb-multi.el --- Virtual shimbun class to retrieve multiple pages.

;; Copyright (C) 2006-2009, 2011 TSUCHIYA Masatoshi <tsuchiya@namazu.org>

;; Author: TSUCHIYA Masatoshi <tsuchiya@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; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;;; Code:

(eval-when-compile
  (require 'cl)
  ;; `multiple-value-bind' requires the 2nd argument to be multiple-value,
  ;; not a list, in particular for XEmacs 21.5.  `values-list' does it,
  ;; but is a run-time cl function in XEmacs 21.4 and Emacs 21.
  (when (eq 'identity (symbol-function 'values-list))
    (define-compiler-macro values-list (arg)
      arg)))

(require 'shimbun)

(autoload 'shimbun-shallow-rendering "sb-text")

(luna-define-class shimbun-multi () ())

(luna-define-generic shimbun-multi-next-url (shimbun header url)
  "Return a URL of the next page if it exists in this current buffer.")

(luna-define-generic shimbun-multi-clear-contents (shimbun
						   header
						   has-previous-page
						   has-next-page)
  "Clear a content in this current buffer for an article of SHIMBUN.
Return nil, unless a content is cleared successfully.")

(luna-define-method shimbun-multi-clear-contents ((shimbun shimbun-multi)
						  header
						  has-previous-page
						  has-next-page)
  (shimbun-clear-contents shimbun header))

(defun shimbun-multi-retrieve-next-pages (shimbun header base-cid url
						  &optional images cont)
  (let ((prefer-text-plain (shimbun-prefer-text-plain-internal shimbun))
	(case-fold-search t) base-url next-url)
    (setq base-url (or (shimbun-current-base-url)
		       (file-name-directory url))
	  next-url (shimbun-multi-next-url shimbun header base-url))
    (when (shimbun-multi-clear-contents shimbun header cont next-url)
      (goto-char (point-min))
      (insert "<html>\n<head>\n<base href=\""
	      base-url
	      "\">\n</head>\n<body>\n")
      (goto-char (point-max))
      (if next-url
	  (insert "\n</body>\n</html>\n")
	(if prefer-text-plain
	    (shimbun-insert-footer shimbun header)
	  (shimbun-insert-footer shimbun header t "</body>\n</html>\n"))))
    (if prefer-text-plain
	(shimbun-shallow-rendering)
      (when shimbun-encapsulate-images
	(setq images (shimbun-mime-replace-image-tags shimbun
						      base-cid
						      base-url
						      images))))
    (let ((body (shimbun-make-text-entity (if prefer-text-plain
					      "text/plain"
					    "text/html")
					  (buffer-string)))
	  (result
	   (when next-url
	     (with-temp-buffer
	       (shimbun-fetch-url shimbun next-url nil nil url)
	       (shimbun-multi-retrieve-next-pages shimbun
						  header
						  base-cid
						  next-url
						  images t)))))
      (list (cons body (car result))
	    (or (nth 1 result) images)))))

(defun shimbun-multi-make-contents (shimbun header)
  (let ((base-cid (shimbun-header-id header))
	(body))
    (if (string-match "\\`<\\([^>]+\\)>\\'" base-cid)
	(setq base-cid (match-string 1 base-cid))
      (error "Cannot extract base CID from %s for %s"
	     base-cid (shimbun-article-url shimbun header)))
    (multiple-value-bind (texts images)
	(values-list
	 (shimbun-multi-retrieve-next-pages shimbun header base-cid
					    (shimbun-article-url shimbun
								 header)))
      (if (= (length texts) 1)
	  (setq body (car texts))
	(setq body (shimbun-make-multipart-entity))
	(let ((i 0))
	  (dolist (text texts)
	    (setf (shimbun-entity-cid text)
		  (format "shimbun.%d.%s" (incf i) base-cid))))
	(apply 'shimbun-entity-add-child body texts))
      (when images
	(setf (shimbun-entity-cid body) (concat "shimbun.0." base-cid))
	(let ((new (shimbun-make-multipart-entity)))
	  (shimbun-entity-add-child new body)
	  (apply 'shimbun-entity-add-child new (mapcar 'cdr (nreverse images)))
	  (setq body new))))
    (erase-buffer)
    (shimbun-header-insert shimbun header)
    (insert "MIME-Version: 1.0\n")
    (shimbun-entity-insert body))
  (buffer-string))

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

(provide 'sb-multi)

;;; sb-multi.el ends here
