← Back to branch summary

~ubuntu-branches/ubuntu/lucid/gauche-c-wrapper/lucid

« back to all changes in this revision

Viewing changes to doc/extract

  • Committer: Bazaar Package Importer
  • Author(s): NIIBE Yutaka
  • Date: 2008-04-07 09:15:03 UTC
  • Revision ID: james.westby@ubuntu.com-20080407091503-wu0h414koe95kj4i
Tags: upstream-0.5.2
Import upstream version 0.5.2

Show diffs side-by-side

added added

removed removed

Lines of Context:
doc/extract
 
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.16 2006/04/07 11:29:48 shirok Exp $
 
16
;;;
 
17
 
 
18
(use gauche.regexp)
 
19
(use gauche.parseopt)
 
20
(use gauche.charconv)
 
21
(use srfi-13)
 
22
 
 
23
(define *outfile* #f)
 
24
(define *lang* 'en)
 
25
(define *version*
 
26
  (string-trim-both (call-with-input-file "../VERSION" port->string)))
 
27
(define *node-table* '())
 
28
(define *header-table* '())
 
29
 
 
30
(define (scan-nodes)
 
31
  (let ((current-node #f)
 
32
        (current-header #f))
 
33
    (port-for-each
 
34
     (lambda (line)
 
35
       (rxmatch-case line
 
36
         (#/^@node\s+([^,]+)/ (#f node)
 
37
          (set! current-node (string-trim-right node)))
 
38
         (#/^@(chapter|(sub)*section|appendix\w*)\s+(.*)/ (#f #f #f header)
 
39
          (set! current-header (string-trim-right header)))
 
40
         (#/^@c NODE\s+([^,]*)(,(.*))?/ (#f jnode #f jheader)
 
41
          (let* ((jn (string-trim-right jnode))
 
42
                 (jh (if jheader (string-trim-both jheader) jn)))
 
43
            (push! *node-table* (cons current-node jn))
 
44
            (push! *header-table* (cons current-header jh))))
 
45
         (#/^@include\s+(\S+)/ (#f file)
 
46
           (with-input-from-file file (cut scan-nodes) :encoding 'euc-jp))
 
47
         ))
 
48
     read-line)))
 
49
 
 
50
(define (filter pattern-in pattern-out)
 
51
  (define (in line)
 
52
    (rxmatch-case line
 
53
      (test eof-object?)
 
54
      (pattern-in () (in (read-line)))
 
55
      (pattern-out () (out (read-line)))
 
56
      (#/^@include\s+(\S+)/ (#f file)
 
57
        (with-input-from-file file (cut filter pattern-in pattern-out)
 
58
                              :encoding 'euc-jp)
 
59
        (in (read-line)))
 
60
      (#/^@c COMMON$/ () (in (read-line)))
 
61
      (test (lambda _ (eq? *lang* 'en))
 
62
            (display (regexp-replace-all #/@VERSION@/ line *version*))
 
63
            (newline) (in (read-line)))
 
64
      (#/^@node\s+(.*)$/ (#f nodedesc)
 
65
        (process-node nodedesc) (in (read-line)))
 
66
      (#/^@(chapter|(sub)*section|appendix\w*)\s+(.*)/ (#f cmd #f header)
 
67
        (process-header cmd header) (in (read-line)))
 
68
      (#/^\* ([^:]+)::(.*)?/ (#f node desc)
 
69
        (process-menu node #f desc) (in (read-line)))
 
70
      (#/^\* ([^:]+):\s+([^)]+\))\.(.*)?/ (#f tag node desc)
 
71
        (process-menu node tag desc) (in (read-line)))
 
72
      (else (display
 
73
             (regexp-replace-all #/@VERSION@/
 
74
              (regexp-replace-all #/(@x?ref)\{([^\}]+)\}/ line process-ref)
 
75
              *version*))
 
76
            (newline)
 
77
            (in (read-line)))))
 
78
 
 
79
  (define (out line)
 
80
    (rxmatch-case line
 
81
      (test eof-object?)
 
82
      (pattern-in ()  (in (read-line)))
 
83
      (#/^@c COMMON$/ () (in (read-line)))
 
84
      (else (out (read-line)))))
 
85
 
 
86
  (in (read-line)))
 
87
 
 
88
(define (process-node nodedesc)
 
89
  (display "@node ")
 
90
  (display
 
91
   (string-join
 
92
    (map (lambda (name)
 
93
           (cond ((assoc (string-trim-both name) *node-table*) => cdr)
 
94
                 (else name)))
 
95
         (string-split nodedesc #\,))
 
96
    ", "))
 
97
  (newline))
 
98
 
 
99
(define (process-header cmd header)
 
100
  (format #t "@~a ~a\n"
 
101
          cmd
 
102
          (cond ((assoc (string-trim-both header) *header-table*) => cdr)
 
103
                (else header))))
 
104
 
 
105
(define (process-menu node tag desc)
 
106
  (if tag
 
107
    (format #t "* ~a: ~a.  ~a\n"
 
108
            tag
 
109
            (cond ((assoc (string-trim-both node) *node-table*) => cdr)
 
110
                  (else node))
 
111
            (string-trim-both (or desc "")))
 
112
    (format #t "* ~a::  ~a\n"
 
113
            (cond ((assoc (string-trim-both node) *node-table*) => cdr)
 
114
                  (else node))
 
115
            (string-trim-both (or desc "")))))
 
116
 
 
117
(define (process-ref match)
 
118
  (let ((cmd  (rxmatch-substring match 1))
 
119
        (node (rxmatch-substring match 2)))
 
120
    (format #f "~a{~a}"
 
121
            cmd
 
122
            (cond ((assoc (string-trim-both node) *node-table*) => cdr)
 
123
                  (else node)))))
 
124
 
 
125
(define (usage)
 
126
  (display "Usage: extract [-en|-jp][-o outfile] infile\n")
 
127
  (exit 1))
 
128
 
 
129
(define (main args)
 
130
  (let ((a (parse-options (cdr args)
 
131
             (("o=s" (outfile) (set! *outfile* outfile))
 
132
              ("en"  () (set! *lang* 'en))
 
133
              ("jp"  () (set! *lang* 'jp))
 
134
              (else _ (usage))))))
 
135
 
 
136
    (define (do-it)
 
137
      (case *lang*
 
138
        ((en) (filter #/^@c EN$/ #/^@c JP$/))
 
139
        ((jp) (filter #/^@c JP$/ #/^@c EN$/))))
 
140
 
 
141
    (define outenc (if (eq? *lang* 'jp) 'euc-jp 'utf8))
 
142
    
 
143
    (unless (= (length a) 1) (usage))
 
144
 
 
145
    (when (eq? *lang* 'jp)
 
146
      (with-input-from-file (car a) scan-nodes :encoding 'euc-jp))
 
147
    
 
148
    (with-input-from-file (car a)
 
149
      (lambda ()
 
150
        (if *outfile*
 
151
          (with-output-to-file *outfile* do-it :encoding outenc)
 
152
          (let1 out (open-output-conversion-port
 
153
                     (current-output-port) outenc)
 
154
            (with-output-to-port out do-it)
 
155
            (close-output-port out))))
 
156
      :encoding 'euc-jp)
 
157
    0))
 
158
 
 
159
;; Local variables:
 
160
;; mode: Scheme
 
161
;; end: