1: ;;;
    2: ;;; extract - filter bilingual texinfo document
    3: ;;;
    4: ;;;  Copyright(C) 2001-2003 by Shiro Kawai (shiro@acm.org)
    5: ;;;
    6: ;;;  Permission to use, copy, modify, distribute this software and
    7: ;;;  accompanying documentation for any purpose is hereby granted,
    8: ;;;  provided that existing copyright notices are retained in all
    9: ;;;  copies and that this notice is included verbatim in all
   10: ;;;  distributions.
   11: ;;;  This software is provided as is, without express or implied
   12: ;;;  warranty.  In no circumstances the author(s) shall be liable
   13: ;;;  for any damages arising out of the use of this software.
   14: ;;;
   15: ;;;  $Id: extract,v 1.17 2006/11/09 23:47:32 shirok Exp $
   16: ;;;
   17: 
   18: (use gauche.parseopt)
   19: (use gauche.charconv)
   20: (use srfi-1)
   21: (use srfi-13)
   22: (use file.util)
   23: 
   24: (define *outfile* #f)
   25: (define *lang* 'en)
   26: (define *version*
   27:   (string-trim-both (file->string (or (find (cut sys-access <> R_OK)
   28:                                             '("../VERSION"
   29:                                               "./VERSION"))
   30:                                       (error "No VERSION file?")))))
   31: (define *node-table* '())
   32: (define *header-table* '())
   33: 
   34: (define (scan-nodes)
   35:   (let ((current-node #f)
   36:         (current-header #f))
   37:     (port-for-each
   38:      (lambda (line)
   39:        (rxmatch-case line
   40:          (#/^@node\s+([^,]+)/ (#f node)
   41:           (set! current-node (string-trim-right node)))
   42:          (#/^@(chapter|(sub)*section|appendix\w*)\s+(.*)/ (#f #f #f header)
   43:           (set! current-header (string-trim-right header)))
   44:          (#/^@c NODE\s+([^,]*)(,(.*))?/ (#f jnode #f jheader)
   45:           (let* ((jn (string-trim-right jnode))
   46:                  (jh (if jheader (string-trim-both jheader) jn)))
   47:             (push! *node-table* (cons current-node jn))
   48:             (push! *header-table* (cons current-header jh))))
   49:          (#/^@include\s+(\S+)/ (#f file)
   50:            (with-input-from-file file (cut scan-nodes) :encoding 'euc-jp))
   51:          ))
   52:      read-line)))
   53: 
   54: (define (filter pattern-in pattern-out)
   55:   (define (in line)
   56:     (rxmatch-case line
   57:       (test eof-object?)
   58:       (pattern-in () (in (read-line)))
   59:       (pattern-out () (out (read-line)))
   60:       (#/^@include\s+(\S+)/ (#f file)
   61:         (with-input-from-file file (cut filter pattern-in pattern-out)
   62:                               :encoding 'euc-jp)
   63:         (in (read-line)))
   64:       (#/^@c COMMON$/ () (in (read-line)))
   65:       (test (lambda _ (eq? *lang* 'en))
   66:             (display (regexp-replace-all #/@VERSION@/ line *version*))
   67:             (newline) (in (read-line)))
   68:       (#/^@node\s+(.*)$/ (#f nodedesc)
   69:         (process-node nodedesc) (in (read-line)))
   70:       (#/^@(chapter|(sub)*section|appendix\w*)\s+(.*)/ (#f cmd #f header)
   71:         (process-header cmd header) (in (read-line)))
   72:       (#/^\* ([^:]+)::(.*)?/ (#f node desc)
   73:         (process-menu node #f desc) (in (read-line)))
   74:       (#/^\* ([^:]+):\s+([^)]+\))\.(.*)?/ (#f tag node desc)
   75:         (process-menu node tag desc) (in (read-line)))
   76:       (else (display
   77:              (regexp-replace-all #/@VERSION@/
   78:               (regexp-replace-all #/(@x?ref)\{([^\}]+)\}/ line process-ref)
   79:               *version*))
   80:             (newline)
   81:             (in (read-line)))))
   82: 
   83:   (define (out line)
   84:     (rxmatch-case line
   85:       (test eof-object?)
   86:       (pattern-in ()  (in (read-line)))
   87:       (#/^@c COMMON$/ () (in (read-line)))
   88:       (else (out (read-line)))))
   89: 
   90:   (in (read-line)))
   91: 
   92: (define (process-node nodedesc)
   93:   (display "@node ")
   94:   (display
   95:    (string-join
   96:     (map (lambda (name)
   97:            (cond ((assoc (string-trim-both name) *node-table*) => cdr)
   98:                  (else name)))
   99:          (string-split nodedesc #\,))
  100:     ", "))
  101:   (newline))
  102: 
  103: (define (process-header cmd header)
  104:   (format #t "@~a ~a\n"
  105:           cmd
  106:           (cond ((assoc (string-trim-both header) *header-table*) => cdr)
  107:                 (else header))))
  108: 
  109: (define (process-menu node tag desc)
  110:   (if tag
  111:     (format #t "* ~a: ~a.  ~a\n"
  112:             tag
  113:             (cond ((assoc (string-trim-both node) *node-table*) => cdr)
  114:                   (else node))
  115:             (string-trim-both (or desc "")))
  116:     (format #t "* ~a::  ~a\n"
  117:             (cond ((assoc (string-trim-both node) *node-table*) => cdr)
  118:                   (else node))
  119:             (string-trim-both (or desc "")))))
  120: 
  121: (define (process-ref match)
  122:   (let ((cmd  (rxmatch-substring match 1))
  123:         (node (rxmatch-substring match 2)))
  124:     (format #f "~a{~a}"
  125:             cmd
  126:             (cond ((assoc (string-trim-both node) *node-table*) => cdr)
  127:                   (else node)))))
  128: 
  129: (define (usage)
  130:   (display "Usage: extract [-en|-jp][-o outfile] infile\n")
  131:   (exit 1))
  132: 
  133: (define (main args)
  134:   (let ((a (parse-options (cdr args)
  135:              (("o=s" (outfile) (set! *outfile* outfile))
  136:               ("en"  () (set! *lang* 'en))
  137:               ("jp"  () (set! *lang* 'jp))
  138:               (else _ (usage))))))
  139: 
  140:     (define (do-it)
  141:       (case *lang*
  142:         ((en) (filter #/^@c EN$/ #/^@c JP$/))
  143:         ((jp) (filter #/^@c JP$/ #/^@c EN$/))))
  144: 
  145:     (define outenc (if (eq? *lang* 'jp) 'euc-jp 'utf8))
  146:     
  147:     (unless (= (length a) 1) (usage))
  148: 
  149:     (when (eq? *lang* 'jp)
  150:       (with-input-from-file (car a) scan-nodes :encoding 'euc-jp))
  151:     
  152:     (with-input-from-file (car a)
  153:       (lambda ()
  154:         (if *outfile*
  155:           (with-output-to-file *outfile* do-it :encoding outenc)
  156:           (let1 out (open-output-conversion-port
  157:                      (current-output-port) outenc)
  158:             (with-output-to-port out do-it)
  159:             (close-output-port out))))
  160:       :encoding 'euc-jp)
  161:     0))
  162: 
  163: ;; Local variables:
  164: ;; mode: Scheme
  165: ;; end: