eb100c689b09ea4da6d77cef0216fbdc2af2e81b
[chise/omega.git] / chise2otf / chise2otf
1 #!/usr/bin/perl
2
3 use strict;
4 use vars qw($opt_in_cs $opt_order $opt_help $usage
5             $in_cs $out_cs $i @chars
6             @order $order %order
7             $char $char_id $out_char
8             $ids $ids_argc %ids $idsdb
9             $idsdata_file $ids_start $font_start
10             $perl56 $perl58
11             @CDP @HZK @GT
12             );
13 use Getopt::Long;
14 use utf8;
15 use Chise_utils ':all';
16
17 my $perl="/usr/bin/perl";
18 my $makefonts="/Users/izumi/.chise/makefonts.pl";
19 my $geta=pack("S",8750|0x8080);
20
21 if($^V and $^V ge v5.8){
22     $perl58=1;
23 }elsif($^V and $^V ge v5.6){
24     $perl56=1;
25 }else{
26     print STDERR "This versin is not supported.";
27 }
28 if($perl58){
29     eval "use Encode";
30     binmode(STDIN, ':encoding(utf8)');
31     binmode(STDOUT, ':encoding(utf8)');
32 }
33
34 &GetOptions("in=s"=>\$opt_in_cs,
35             "i=s"=>\$opt_in_cs,
36             "o=s"=>\$opt_order,
37             "order=s"=>\$opt_order,
38             "help",\$opt_help,
39             "h",\$opt_help);
40
41 $usage=<<EOF;
42 Usage: $0 -i <input coding system> -o <order of kanji> <filename>
43     input coding system: (default: ucs\@mcs)
44       ucs\@mcs, ucs\@cns, ucs\@gb, ucs\@jis, ucs\@ks
45     order of kanji: (default: j)
46        c: CNS
47        g: GB
48        j: JIS
49        k: KS
50        t: GT
51        m: Multi, use \\UTFM of otf.sty
52       You can also combine them, ex. jtcgkm
53 EOF
54
55 %order=('c'=>'UniCNS',
56         'g'=>'UniGB',
57         'j'=>'UniJIS',
58         'k'=>'UniKS',
59         't'=>'GT',
60         'm'=>'Multi',
61         );
62
63 if($opt_help){
64     print STDERR $usage;
65     exit 1;
66 }
67
68 if(not defined($opt_in_cs)){
69     print STDERR "Assuming input coding system is ucs\@mcs.\n";
70     $in_cs='ucs@mcs';
71 }else{
72     if(($opt_in_cs ne 'ucs@mcs')or
73        ($opt_in_cs ne 'ucs@cns')or
74        ($opt_in_cs ne 'ucs@gb')or
75        ($opt_in_cs ne 'ucs@jis')or
76        ($opt_in_cs ne 'ucs@ks')){
77         $in_cs=$opt_in_cs;
78     }else{
79         print STDERR $usage;
80         exit 1;
81     }
82 }
83
84 if(not defined($opt_order)){
85     print STDERR "Using only UniJIS.\n";
86     $opt_order='j';
87 }
88
89 if(defined($opt_order)){
90     if($opt_order=~/^[cgjktm]+$/){
91         @order=split(//,$opt_order);
92         @order=map {$order{$_}} @order;
93     }else{
94         print STDERR "Invalid option!\n";
95         print $usage;
96         exit 1;
97     }
98 }
99
100 $idsdata_file="idsdata.pl";
101 $ids_start=0x00; 
102 $font_start=0;
103
104 if(-e $idsdata_file){
105     require $idsdata_file;
106 }
107
108 $ids_argc=0;
109 $ids="";
110
111 @GT=(#"=gt","=gt-k",
112      "=gt-pj-1","=gt-pj-2","=gt-pj-3","=gt-pj-4","=gt-pj-5",
113      "=gt-pj-6","=gt-pj-7","=gt-pj-8","=gt-pj-9","=gt-pj-10",
114      "=gt-pj-11"
115      #,"=gt-pj-k1","=gt-pj-k2"
116      );
117 @HZK=("=hanziku-1","=hanziku-10","=hanziku-11","=hanziku-12",
118       "=hanziku-2","=hanziku-3","=hanziku-4","=hanziku-5",
119       "=hanziku-6","=hanziku-7","=hanziku-8","=hanziku-9");
120 @CDP=("=big5-cdp");
121
122 while(<>){
123     s/&(.*?);/&de_er($1)/ge;
124     s/(.)/&get_char_in_ucsmcs($1,$in_cs)/ge if($in_cs ne 'ucs@mcs');
125     @chars=split(//);
126     for($i=0;$i<=$#chars;$i++){
127         $char=$chars[$i];
128         $char_id=unpack("U",$chars[$i]);
129
130         if($char_id<=0x7f){
131             # Basic Latin
132             print $char;
133             next;
134         }elsif($char_id>=0x2ff0 and $char_id<=0x2fff){
135             # Ideographic Description Characters
136             &ids_parse();
137             next;
138         }elsif($char_id >= 0x20000 && $char_id <=0x2a6df){
139             # CJK Unified Ideographs Extension B
140             if(not defined($ids{$char}) and $ids{$char}[1]>=0){
141                 $ids{$char}[0]=$font_start;
142                 $ids{$char}[1]=$ids_start;
143                 $ids_start++;
144                 if($ids_start>255){
145                     $ids_start=0;
146                     $font_start++;
147                 }
148             }
149             print "{\\fontencoding{OT1}\\fontfamily{" .
150                 sprintf("chise%03d",$ids{$char}[0]) .
151                 "}\\selectfont\\char$ids{$char}[1]}";
152             next;
153         }else{
154             if(($out_char=&get_output_char($char_id))){
155                 print $out_char;
156             }else{
157                 print &replace_ids(&get_ids($char));
158             }
159         }
160     }
161 }
162
163 open(IDSDATA,">$idsdata_file") or die;
164 print IDSDATA 'use utf8;',"\n";
165 foreach $ids (keys %ids){
166     print IDSDATA '$ids{\'',$ids,'\'}='
167         ,'[',join ",",@{$ids{$ids}},"];\n" if($perl56);
168     print IDSDATA '$ids{\'',encode('utf8',$ids),'\'}='
169         ,'[',join ",",@{$ids{$ids}},"];\n" if($perl58);
170 }
171 print IDSDATA '$font_start=',$font_start,";\n";
172 print IDSDATA '$ids_start=',$ids_start,";\n";
173 print IDSDATA "1;";
174
175 ### to use makefonts scripts, please uncomment the next lines.
176 # system($perl,$makefonts) ==0
177 #    or die "Could not make fonts: $?";
178
179 exit 0;
180
181 sub ids_parse{
182     my($ids,$ids_argc)=&ids_rest("",0,$chars[$i]);
183
184     while($ids_argc>0){
185         # We are in IDS.
186         $i++;
187         if($i>$#chars){
188             print STDERR "IDS parse error: $ids\n";
189             print $geta;
190             $ids="";
191             $ids_argc=0;
192             return;
193         }
194
195         ($ids,$ids_argc)=&ids_rest($ids,$ids_argc,$chars[$i]);
196         if($ids_argc==0){
197             if(($char_id=&get_char_id_for_ids($ids))
198                and($out_char=&get_output_char($char_id))){
199                 print $out_char;
200             }else{
201                 print &replace_ids($ids) if($perl56);
202                 print encode('utf8', &replace_ids($ids)) if($perl58);
203             }
204             $ids="";
205             return;
206         }
207     }
208 }
209
210 sub ids_rest{
211     my($ids,$ids_argc,$char)=@_;
212     my($argc);
213     $argc=&ids_argc($char);
214     if($argc){
215         $ids_argc+= $ids_argc==0 ? $argc : $argc-1;
216     }else{
217         $ids_argc--;
218     }
219     $ids.=$char if($perl56);
220     $ids.=encode('utf8',$char) if($perl58);
221     return ($ids,$ids_argc);
222 }
223
224 sub replace_ids{
225     my($ids)=@_;
226     $ids=&normalize_ids($ids,"UniJIS");
227     return $geta if(($ids!~/[$idc]/)
228                     or($ids=~/[\x{10000}-]/));
229                     #irregular for KAGE.
230     if(not defined($ids{$ids}) and $ids{$ids}[1]>=0){
231         $ids{$ids}[0]=$font_start;
232         $ids{$ids}[1]=$ids_start;
233         $ids_start++;
234     }
235     if($ids_start>255){
236         $ids_start=0;
237         $font_start++;
238     }
239     return "{\\fontencoding{T1}\\fontfamily{"
240         .sprintf("chisesub%03d",$ids{$ids}[0])
241         ."}\\selectfont\\char$ids{$ids}[1]}";
242 }
243
244 sub normalize_ids{
245     my($ids,$out_cs)=@_;
246     $ids = decode('utf8', $ids) if $perl58;
247     $out_cs=~s/Uni(.+)/"ucs\@".lc($1)/e;
248     my $output_ids="";
249     my($char,$char_id,$output_char_id);
250     while($ids=~m/(.)/g){
251         $char=$1;
252         $char_id=unpack("U",$char);
253         if($char=~/[$idc]/){
254             $output_ids.=$char;
255         }elsif($output_char_id=&get_char_attribute($char,"=$out_cs")){
256             $output_ids.=pack("U",$output_char_id);
257         }elsif($output_char_id=&get_char_attribute($char,"=ucs")){
258             $output_ids.=pack("U",$output_char_id);
259         }else{
260             return $geta;
261         }
262     }
263     return $output_ids;
264 }
265
266 sub get_output_char{
267     my($char_id)=@_;
268     my($char,$out_char,$suffix);
269     my($jis,$euc,$gt);
270     
271     $char=pack('U',$char_id);
272
273     if($jis=&get_char_attribute($char,'=jis-x0208')){
274         return pack("S",$jis|0x8080);
275     }else{
276         foreach $out_cs (@order){
277             if($out_cs eq 'UniJIS'
278                and &get_char_attribute($char,"adobe-unijis-utf16-h")){
279                 if($out_char=&get_char_attribute($char,'=ucs@jis')
280                    or $out_char=&get_char_attribute($char,'=ucs')){
281                     return "\\UTF{".sprintf("%X",$out_char)."}";
282                 }
283             }elsif($out_cs eq 'UniGB'
284                    and &get_char_attribute($char,"adobe-unigb-ucs2-h")){
285                 if($out_char=&get_char_attribute($char,'=ucs@gb')
286                    or $out_char=&get_char_attribute($char,'=ucs')){
287                     return "\\UTFC{".sprintf("%X",$out_char)."}";
288                 }
289             }elsif($out_cs eq 'UniCNS'
290                    and &get_char_attribute($char,"adobe-unicns-ucs2-h")){
291                 if($out_char=&get_char_attribute($char,'=ucs@cns')
292                    or $out_char=&get_char_attribute($char,'=ucs')){
293                     return "\\UTFT{".sprintf("%X",$out_char)."}";
294                 }
295             }elsif($out_cs eq 'UniKS'
296                    and &get_char_attribute($char,"adobe-uniks-ucs2-h")){
297                 if($out_char=&get_char_attribute($char,'=ucs@ks')
298                    or $out_char=&get_char_attribute($char,'=ucs')){
299                     return "\\UTFK{".sprintf("%X",$out_char)."}";
300                 }
301             }elsif($out_cs eq 'GT'){
302                 return $gt if($gt=&get_macro_for_GT($char_id));
303             }elsif($out_cs eq 'Multi'){
304                 if($out_char=&get_char_attribute($char,'=ucs')){
305                     return "\\UTFM{".sprintf("%X",$out_char)."}";
306                 }
307             }
308         }
309     }
310     return undef;
311 }
312
313 sub get_ids{
314     my($char)=@_;
315     my $ids="";
316     $ids=&get_char_attribute($char,"ids-aggregated")
317         or &get_char_attribute($char,"ids");
318     $ids=decode('utf8', $ids) if($perl58);
319     return $ids;
320 }
321
322 sub get_char_id_for_ids{
323     my($ids)=@_;
324     my($output_char);
325     $ids=decode('utf8', $ids) if($perl58);
326
327     if(&get_reverse_db("ids")){
328         if($output_char=$reverse_chardb{"ids"}->{$ids}){
329             $output_char=~s/^\?//;
330             return unpack("U",$output_char);
331         }
332     }else{
333         return undef;
334     }
335 }
336
337 sub get_char_in_ucsmcs{
338     # argument: <character>, <input coding system>
339     # return:   character in ucs@mcs.
340     my($char,$in_cs)=@_;
341     my($output_char);
342
343     if(&get_reverse_db("=$in_cs")){
344         if($output_char=$reverse_chardb{"=$in_cs"}->{$char}){
345             return $output_char=~s/^\?//;
346         }
347     }else{
348         return $char;
349     }
350 }
351
352 sub get_macro_for_GT{
353     my($char_id)=@_;
354     my($char,$gt,$GT);
355     $char=pack("U",$char_id);
356     foreach (@GT){
357         if($gt=&get_char_attribute($char,$_)){
358             m/gt\-pj\-(\d+)/ and $GT=$1;
359             last;
360         }
361     }
362     if($gt){
363         return "{\\fontfamily{"
364             .sprintf("gto%02d",$GT)
365             ."}\\selectfont\\char".($gt|0x8080)."}";
366     }else{
367         return undef;
368     }
369 }