root/lang/gauche/oldtype/trunk/src/oldtype_to @ 22567

#!/usr/local/bin/gosh
;; -*- coding: utf-8 -*-
;;;
;;; oldtype_to - oldtype format to variouse document converter.
;;;
;;;  Copyright (c) 2007 Kiyoka Nishiyama, All rights reserved.
;;;
;;;  Permission is hereby granted, free of charge, to any person
;;;  obtaining a copy of this software and associated documentation
;;;  files (the "Software"), to deal in the Software without restriction,
;;;  including without limitation the rights to use, copy, modify,
;;;  merge, publish, distribute, sublicense, and/or sell copies of
;;;  the Software, and to permit persons to whom the Software is
;;;  furnished to do so, subject to the following conditions:
;;;
;;;  The above copyright notice and this permission notice shall be
;;;  included in all copies or substantial portions of the Software.
;;;
;;;  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;;  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
;;;  OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;;  NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;;;  BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN
;;;  AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF
;;;  OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
;;;  IN THE SOFTWARE.
;;;
;;; $Id: oldtype_to 198 2008-01-13 10:10:22Z kiyoka $
;;;
(use srfi-1)
(use sxml.tools)
(use sxml.serializer)
(use text.html-lite)
(use text.tree)
(use gauche.parseopt)
(use gauche.charconv)
(use oldtype.parse)
(use oldtype.format)
(use oldtype.util)
(use oldtype.page)
(use oldtype.timeline)


(define (oldtype:sxml->html sxml ot-path)
  (let (
        (html-body (srl:sxml->html sxml))
        (wikiname  (oldtype:otpath->wikiname ot-path)))
    (tree->string
     `(
       ,(html:html                                                      
         (html:head
          (html:meta :http-equiv "Content-Type"        :content "text/html; charset=utf-8")
          (html:meta :http-equiv "Content-Style-Type"  :content "text/css")
          (html:link :rel "stylesheet" :href "../design/oldtype.css" :type "text/css")
          (html:title wikiname)
          (html:body
           (html:h1 wikiname)
           html-body
           (html:div :class "footer"
                     "Generated by "
                     (html:a :href oldtype:site-url
                             "OldType")
                     " version "
                     oldtype:version)
           )))))))


;; Main -------------------------------------------------------
(define (main args)

  (define docstrings
    `(
      ,(string-append "oldtype_to version " oldtype:version)
      ""
      " Usage:"
      "     oldtype_to [type] wikiname.ot [wikiname.log] [wikiname.ann] > wikiname.(html/sxml)"
      ""
      " type:"
      "     internal, html, sxml, plain"
      "     `internal` is a internal format for Kahua oldtype application."
      " wikiname.ot:"
      "     input file in OldType wiki format document."
      " wikiname.log:"
      "     result of 'svn log wikiname.ot' command."
      " wikiname.ann:"
      "     result of 'svn ann wikiname.ot' command."
      ""
      " Options:"
      "     -h ... Display this help message."
      ))

  (define (cerr str)
    (display str (standard-error-port))
    (newline (standard-error-port)))

  (define (display-help)
    (for-each
     (lambda (docstring) (cerr docstring))
     docstrings)
    (exit 4))

  (define (parse-log-and-annotate rest-arg)
    (case (length rest-arg)
      ((0)
       #f)
      ((2)
       ;; process [wikiname.log] and [wikiname.ann] file
       (values
        (oldtype:parse-log      (car rest-arg))
        (oldtype:parse-annotate (cadr rest-arg))))
      (else
       (print "Error: You must specify both [wikiname.log] and [wikiname.ann] always.")
       (exit 1))))
  
  (let* (
         (wiki-mode #f)
         ;; Dropping the first argument.
         (_ (cdr args))
         
         ;; Checking switches.
         (_ (parse-options
             _
             (
              ("h" () (display-help)))))

         (input-file (if (> 1 (length _))
                         (display-help)
                         (cadr _)))
         (wikiname (regexp-replace #/.ot$/
                                   (sys-basename input-file)
                                   ""))
         (type (string->symbol (car _)))
         (rest (cddr _))

         (converted-str
          (port->string
           (open-input-conversion-port
            (open-input-file input-file)
            "*JP")))

         ;; Making string port from stdin/file
         ;;
         (input-port
          (open-input-string converted-str)))
    (case type
      ('internal
       (if (< 1 (length rest))
           (let1 oldtype-page   (parse (make <oldtype-page> :name wikiname) input-port (car rest) (cadr rest))
                 (pretty-print-sexp (serialize oldtype-page)))
           (let1 oldtype-page   (parse (make <oldtype-page> :name wikiname) input-port #f #f)
                 (pretty-print-sexp (serialize oldtype-page)))))
      ('sxml
       (let1 sxml (oldtype-parse input-port)
             (pretty-print-sexp sxml)))
      ('html
       (let* (
              (sxml           (oldtype-parse input-port))
              (expanded-sxml  (oldtype:expand-page sxml #f #f)))
         (display   (oldtype:sxml->html expanded-sxml input-file))))
      ('plain
       (let* (
              (sxml           (oldtype-parse input-port))
              (sexp           (oldtype:sxml->plain-text sxml #f)))
         (print
          (tree->string
           sexp))))
      ('rich
       (let* (
              (sxml           (oldtype-parse input-port))
              (sexp           (oldtype:sxml->plain-text sxml #t)))
         (print
          (tree->string
           sexp))))
      ('commands
       (let* (
              (sxml           (oldtype-parse input-port))
              (sexp           (oldtype:sxml->command-list sxml wikiname)))
         (pretty-print-sexp sexp)))
      (else
       (cerr (format "Unsupported type. [~a]" (symbol->string type)))
       (exit 1))))
  (exit 0))