inCHISE

   1 #!/usr/bin/perl -w -CSD
   2
   3 # ver.0.2
   4
   5 use strict;
   6 use vars qw($omegadb_path
   7             $opt_protrude $opt_allow_unify
   8             %opt_order %order %order_map
   9             $opt_in_cs $opt_out_cs
  10             $opt_help $usage
  11             $in_cs $out_cs $i @chars
  12             $char $char_id $out_char
  13             $char_unified @chars_unified
  14             $ids $ids_argc %ids $idsdb $geta
  15             $idsdata_file $ids_start $font_start
  16             @CDP @HZK @GT
  17             );
  18 use Getopt::Long;
  19 use utf8;
  20 use Fcntl ':flock';
  21 use Chise_utils ':all';
  22 require 5.008;
  23
  24 my $omegadb_path="/usr/local/lib/chise/omega";
  25
  26 ### Options ###
  27
  28 #$opt_order{'UniMulti'}='jcgk';
  29 $opt_order{'UniMulti'}='jGcgkHC';
  30 $opt_order{'UniCNS'}='c';
  31 $opt_order{'UniGB'}='g';
  32 $opt_order{'UniJIS'}='j';
  33 $opt_order{'UniKS'}='k';
  34
  35 $opt_allow_unify=1; # 1=true, 0=false.
  36 $opt_protrude=0;# 1=true, 0=false.
  37
  38 ### End ###
  39
  40 my $strictly_forbidden_after = '「【『［（〈“‘‘（〔｛《{\[\(\x{3016}｛｢';
  41 #       \x{3016} | # white 【
  42
  43 my $forbidden_after = "\x{0000}";
  44
  45 # ￥¥＄$〒♯＃#￠¢￡£＠@§
  46 my $slightly_forbidden_after = '￥¥＄$〒♯＃#￠¢￡£＠@§';
  47
  48 # $strictly_forbidden_before
  49 # All these characters are allowed to protrude
  50 # in the right margin
  51 my $strictly_forbidden_before=
  52     '!,.:;?、。！，．：；？。\)#}’”〉》」』】〕\x{3017}）］｝｝」\]';
  53 ###       \x{3017} | # white 】
  54
  55 my $forbidden_before
  56     = 'ー々ぁぃぅぇぉゃゅょっゎァィゥェォャュョッヮヵヶ';
  57
  58 my $slightly_forbidden_before
  59     = '\x{000a}\#\-‐−‰′″℃゛゜ゝゞヽヾ＂％－ﾞﾟ';
  60
  61 my $asian = '\x{1100}-\x{11FF}\x{2E80}-\x{D7AF}\x{F900}-\x{FAFF}\x{FE30}-\x{FE4F}\x{FF00}-\x{FFFFFF}';
  62
  63 my $space = '\x{0020}\x{0009}\x{000A}\x{000C}\x{000D}';
  64
  65 &GetOptions("in=s"=>\$opt_in_cs,
  66             "out=s"=>\$opt_out_cs,
  67             "help",\$opt_help);
  68
  69 $usage=<<EOF;
  70 Usage: $0 -i <input coding system> -o <cmap encoding>
  71     input coding system:
  72       Utf8mcs, Utf8cns, Utf8gb, Utf8jis, Utf8ks
  73     cmap encoding:
  74       UniCNS, UniGB, UniJIS, UniKS, UniMulti
  75 EOF
  76
  77 if($opt_in_cs or $opt_out_cs){
  78     $in_cs=$opt_in_cs;
  79     $out_cs=$opt_out_cs;
  80 }elsif(@ARGV==0){
  81     ($in_cs,$out_cs)=($0=~/(Utf8.+)To(\w+)/);
  82 }
  83
  84 # $in_cs:
  85 #   Utf8mcs,Utf8cns,Utf8gb,Utf8jis,Utf8ks,
  86 # $out_cs:
  87 #   UniCNS,UniGB,UniJIS,UniKS,UniMulti
  88
  89 $in_cs=~s/Utf8/ucs\@/;
  90
  91 if($opt_help
  92    or not defined($in_cs)
  93    or not defined($out_cs)){
  94     print $usage;
  95     exit 1;
  96 }
  97
  98 $omegadb_path=~s!/$!!;
  99
 100 $idsdata_file="$omegadb_path/idsdata.pl";
 101 $ids_start=0x00;
 102 $font_start=0;
 103
 104 if(-e $idsdata_file){
 105     open(IDSDATA,"+<:utf8",$idsdata_file) or die;
 106     flock(IDSDATA,LOCK_EX);
 107     seek(IDSDATA,0,0);
 108     while(<IDSDATA>){
 109         eval $_;
 110     }
 111     seek(IDSDATA,0,0);
 112 #         require $idsdata_file;
 113 }else{
 114     open(IDSDATA,">:utf8",$idsdata_file) or die;
 115     flock(IDSDATA,LOCK_EX);
 116     seek(IDSDATA,0,0);
 117 }
 118
 119 $ids_argc=0;
 120 $ids="";
 121
 122 $geta=pack("U",0x3013);
 123 #$geta=pack("U",0xfffd);
 124
 125 @GT=(#"=gt","=gt-k",
 126      "=gt-pj-1","=gt-pj-2","=gt-pj-3","=gt-pj-4","=gt-pj-5",
 127      "=gt-pj-6","=gt-pj-7","=gt-pj-8","=gt-pj-9","=gt-pj-10",
 128      "=gt-pj-11"
 129      #,"=gt-pj-k1","=gt-pj-k2"
 130      );
 131 @HZK=("=hanziku-1","=hanziku-2","=hanziku-3","=hanziku-4",
 132       "=hanziku-5","=hanziku-6","=hanziku-7","=hanziku-8",
 133       "=hanziku-9","=hanziku-10","=hanziku-11","=hanziku-12");
 134 @CDP=("=big5-cdp");
 135
 136 %order_map=('c'=>'UniCNS',
 137             'g'=>'UniGB',
 138             'j'=>'UniJIS',
 139             'k'=>'UniKS',
 140             'G'=>'GT',
 141             'H'=>'HZK',
 142             'C'=>'CDP',
 143             );
 144
 145 foreach $out_cs ('UniCNS','UniGB','UniJIS','UniKS','UniMulti'){
 146     if(defined($opt_order{$out_cs})){
 147         if($opt_order{$out_cs}=~/^[cgjkGHC]+$/){
 148             @{$order{$out_cs}}=map {$order_map{$_}}
 149             (split(//,$opt_order{$out_cs}));
 150         }else{
 151             print STDERR "Invalid order for $out_cs!\n";
 152             exit 1;
 153         }
 154     }
 155 }
 156
 157 while(<>){
 158     utf8::decode($_);
 159     if($in_cs ne 'ucs@mcs'){
 160         s/(.)/&get_char_in_mcs($1,$in_cs)/ge;
 161     }
 162     s/(amp.+?;)/&de_tex_er($1)/ge;
 163 #    s/(&.+?;)/&de_tex_er($1)/ge;
 164     @chars=split(//);
 165   CHAR:
 166     for($i=0;$i<=$#chars;$i++){
 167         $char=$chars[$i];
 168         $char_id=unpack("U",$char);
 169
 170         if($char_id<=0x20){
 171             print $chars[$i];
 172             next CHAR;
 173         }elsif($char_id>0x20 and $char_id<=0x02af){
 174             # Basic Latin
 175             # Latin-1 Supplement
 176             # Latin Extended-A
 177             # Latin Extended-B
 178             # IPA Extensions
 179             print &latin_parse();
 180             next CHAR;
 181         }elsif($char_id>=0x2ff0 and $char_id<=0x2fff){
 182             # Ideographic Description Characters
 183             print &ids_parse();
 184             next CHAR;
 185         }else{
 186             if(($out_char=&get_output_char($char,$out_cs))){
 187                 print $out_char,&add_break($i);
 188             }elsif($char_id >= 0x20000 && $char_id <=0x2a6df){
 189                 # CJK Unified Ideographs Extension B
 190                 if(not defined($ids{$char}) and $ids{$char}[1]>=0){
 191                     $ids{$char}[0]=$font_start;
 192                     $ids{$char}[1]=$ids_start;
 193                     $ids_start++;
 194                     if($ids_start>255){
 195                         $ids_start=0;
 196                         $font_start++;
 197                     }
 198                 }
 199                 print "{\\fontencoding{OT1}\\fontfamily{" .
 200                     sprintf("chise%03d",$ids{$char}[0]) .
 201                     "}\\selectfont\\char$ids{$char}[1]}",&add_break($i);
 202                 next CHAR;
 203             }else{
 204                 if($opt_allow_unify){
 205                     @chars_unified=&get_chars_unified($char);
 206                     if(@chars_unified>0){
 207                         foreach $char_unified (@chars_unified){
 208                             if(($out_char
 209                                 =&get_output_char($char_unified,$out_cs))){
 210                                 print $out_char,&add_break($i);
 211                                 next CHAR;
 212                             }
 213                         }
 214                     }
 215                 }
 216                 if($ids=&get_ids($char)){
 217                     print &get_macro_for_ids($ids),&add_break($i);
 218                 }else{
 219                     print '\rule{1ex}{1ex}',&add_break($i);
 220                 }
 221             }
 222         }
 223     }
 224 }
 225
 226 print IDSDATA 'use utf8;',"\n";
 227 foreach $ids (keys %ids){
 228     print IDSDATA '$ids{\'',$ids,'\'}='
 229     ,'[',join ",",@{$ids{$ids}},"];\n";
 230 }
 231 print IDSDATA '$font_start=',$font_start,";\n";
 232 print IDSDATA '$ids_start=',$ids_start,";\n";
 233 print IDSDATA "1;";
 234 flock(IDSDATA,LOCK_UN);
 235
 236 exit 0;
 237
 238 sub de_tex_er{
 239     my($er)=@_;
 240     my($prefix,$suffix);
 241     my($output_char,$atr,$value);
 242     $er=~/^(amp)(.*)(;)$/
 243         and $prefix=$1,$er=$2,$suffix=$3;
 244     $prefix or $prefix="",$suffix or $suffix="";
 245     if($er=~/^U[\+|\-]([a-fA-F\d]+)/){
 246         $output_char=pack("U",hex($1));
 247     }elsif($er=~/^(?:I\-)?($er_prefix_re)\-?([0-9a-fA-F]+)$/){
 248         ($atr,$value)=($1,$2);
 249         unless($er_alias{$atr}=~/daikanwa|gt/){
 250             $value=hex($value);
 251         }
 252         ($output_char)=&get_chars_matching($er_alias{$atr},$value);
 253     }
 254     if($output_char){
 255         return $output_char;
 256     }else{
 257         return $prefix.$er.$suffix;
 258     }
 259 }
 260
 261 sub add_break{
 262     my($i)=@_;
 263
 264     if($i<($#chars-1)){
 265         if(($chars[$i+1]=~m/[$strictly_forbidden_before]/o)
 266            and($chars[$i+2]=~m/[$strictly_forbidden_before]/o)){
 267             return "\\CJKunbreakablekernone ";
 268         }elsif($opt_protrude){
 269             if(($chars[$i+1]=~m/[$strictly_forbidden_before]/o)
 270                and($chars[$i+2]=~m/[^$strictly_forbidden_before]/o)){
 271                 return "\\CJKunbreakablekernone \\CJKprotrude ";
 272             }
 273         }
 274     }
 275     if(($i<$#chars)
 276        and($chars[$i+1]=~m/[$strictly_forbidden_before]/o)){
 277         return "\\CJKunbreakablekernone ";
 278     }
 279     if($chars[$i]=~m/[$strictly_forbidden_after]/o){
 280         return "\\CJKunbreakablekernone ";
 281     }
 282     if(($i<$#chars)
 283        and($chars[$i+1]=~m/[$forbidden_before]/o)){
 284         return "\\CJKunbreakablekerntwo ";
 285
 286     }
 287     if($chars[$i]=~m/[$forbidden_after]/o){
 288         return "\\CJKunbreakablekerntwo ";
 289     }
 290     if(($i<$#chars)
 291        and($chars[$i+1]=~m/[$slightly_forbidden_before]/o)){
 292         return "\\CJKunbreakablekernthree ";
 293     }
 294     if($chars[$i]=~m/[$slightly_forbidden_after]/o){
 295         return "\\CJKunbreakablekernthree ";
 296     }
 297     if($chars[$i]=~m/[$asian]/o){
 298         return "\\CJKbreakablekern ";
 299     }
 300     if(($i<$#chars)and($chars[$i+1]=~m/[$asian]/o)){
 301         return "\\CJKbreakablekern ";
 302     }
 303 }
 304
 305 sub latin_parse{
 306     # arguments: none
 307     # return: string for output with TeX macro.
 308     my($char_id);
 309     my $out_str=$chars[$i];
 310     $i++;
 311     while($i<=$#chars){
 312         $char_id=unpack("U",$chars[$i]);
 313         if($char_id>0x20 and $char_id<=0x02af){
 314             $out_str.=$chars[$i];
 315         }else{
 316             $i--;
 317             last;
 318         }
 319         $i++;
 320     }
 321     return '{\normalfont {'.$out_str.'}}';
 322 }
 323
 324 sub ids_parse{
 325     # arguments: none
 326     # return: character for output,
 327     #          TeX macro for ids,
 328     #          or GETA character if ids is invalid.
 329     my($ids,$ids_argc)=&ids_rest("",0,$chars[$i]);
 330
 331     while($ids_argc>0){
 332         # We are in IDS.
 333         $i++;
 334         if($i>$#chars){
 335             print STDERR "IDS parse error: $ids\n";
 336             return $geta;
 337         }
 338
 339         ($ids,$ids_argc)=&ids_rest($ids,$ids_argc,$chars[$i]);
 340         if($ids_argc==0){
 341             if(($char=&get_char_for_ids($ids))
 342                and($out_char=&get_output_char($char,$out_cs))){
 343                 return $out_char;
 344             }else{
 345                 return &get_macro_for_ids($ids);
 346             }
 347         }
 348     }
 349 }
 350
 351 sub ids_rest{
 352     # arguments: <ids>, <rest number of arguments for ids>, <character>
 353     # return: ids and rest number of arguments for ids.
 354     my($ids,$ids_argc,$char)=@_;
 355     my($argc);
 356     $argc=&ids_argc($char);
 357     if($argc){
 358         $ids_argc+=$ids_argc==0?$argc:$argc-1;
 359     }else{
 360         $ids_argc--;
 361     }
 362     $ids.=$char;
 363     return ($ids,$ids_argc);
 364 }
 365
 366 sub get_macro_for_ids{
 367     # argument: <ids>
 368     # return: TeX macro for ids
 369     #          or GETA character if ids is invalid for KAGE.
 370     my($ids)=@_;
 371     $ids=&normalize_ids($ids,"UniJIS");
 372     return $geta if(($ids!~/[$idc]/)
 373                     or($ids=~/[\x{10000}-]/));
 374                     #irregular for KAGE.
 375     if(not defined($ids{$ids}) and $ids{$ids}[1]>=0){
 376         $ids{$ids}[0]=$font_start;
 377         $ids{$ids}[1]=$ids_start;
 378         $ids_start++;
 379     }
 380     if($ids_start>255){
 381         $ids_start=0;
 382         $font_start++;
 383     }
 384     return "{\\fontencoding{OT1}\\fontfamily{"
 385         .sprintf("chise%03d",$ids{$ids}[0])
 386         ."}\\selectfont\\char$ids{$ids}[1]}";
 387 }
 388
 389 sub normalize_ids{
 390     # argument: <ids>, <output coding system>
 391     # return: ids or GETA character if ids is invalid for KAGE.
 392     my($ids,$out_cs)=@_;
 393     $out_cs=~s/Uni(.+)/'ucs@'.lc($1)/e;
 394
 395     my $output_ids="";
 396     my($char,$output_char_id);
 397     while($ids=~m/(.)/g){
 398         $char=$1;
 399         if($char=~/[$idc]/){
 400             $output_ids.=$char;
 401         }elsif($output_char_id=&get_char_attribute($char,"=$out_cs")
 402            or $output_char_id=&get_char_attribute($char,"=ucs")
 403            or $output_char_id=&get_char_attribute($char,"=>$out_cs")
 404            or $output_char_id=&get_char_attribute($char,"=>ucs")
 405            or $output_char_id=&get_char_attribute($char,"=>ucs*")
 406               ){
 407             $output_ids.=pack("U",$output_char_id);
 408         }else{
 409             return $geta;
 410         }
 411     }
 412     return $output_ids;
 413 }
 414
 415 sub get_output_char{
 416     # argument: <char>
 417     # return: character in output coding system or TeX macro or undef.
 418     my($char,$out_cs)=@_;
 419     my($out_char_id,$suffix);
 420     my($gt,$hzk,$cdp);
 421
 422     foreach $out_cs (@{$order{$out_cs}}){
 423         if($out_cs eq 'UniJIS'
 424            and &get_char_attribute($char,"vnd-adobe-cid-unijis-utf16-h")){
 425             if($out_char_id=&get_char_attribute($char,'=ucs@jis')
 426                or $out_char_id=&get_char_attribute($char,'=ucs')
 427                or $out_char_id=&get_char_attribute($char,'=>ucs@jis')
 428                or $out_char_id=&get_char_attribute($char,'=>ucs')
 429                or $out_char_id=&get_char_attribute($char,'=>ucs*')
 430                ){
 431                 return '{\selectjisfont\char'.$out_char_id.'}';
 432             }
 433         }elsif($out_cs eq 'UniGB'
 434                and &get_char_attribute($char,"vnd-adobe-cid-unigb-ucs2-h")){
 435             if($out_char_id=&get_char_attribute($char,'=ucs@gb')
 436                or $out_char_id=&get_char_attribute($char,'=ucs')
 437                or $out_char_id=&get_char_attribute($char,'=>ucs@gb')
 438                or $out_char_id=&get_char_attribute($char,'=>ucs')
 439                or $out_char_id=&get_char_attribute($char,'=>ucs*')
 440                ){
 441                 return '{\selectgbsfont\char'.$out_char_id.'}';
 442             }
 443         }elsif($out_cs eq 'UniCNS'
 444                and &get_char_attribute($char,"vnd-adobe-cid-unicns-ucs2-h")){
 445             if($out_char_id=&get_char_attribute($char,'=ucs@cns')
 446                or $out_char_id=&get_char_attribute($char,'=ucs')
 447                or $out_char_id=&get_char_attribute($char,'=>ucs@cns')
 448                or $out_char_id=&get_char_attribute($char,'=>ucs')
 449                or $out_char_id=&get_char_attribute($char,'=>ucs*')
 450                ){
 451                 return '{\selectcnsfont\char'.$out_char_id.'}';
 452             }
 453         }elsif($out_cs eq 'UniKS'
 454                and &get_char_attribute($char,"vnd-adobe-cid-uniks-ucs2-h")){
 455             if($out_char_id=&get_char_attribute($char,'=ucs@ks')
 456                or $out_char_id=&get_char_attribute($char,'=ucs')
 457                or $out_char_id=&get_char_attribute($char,'=>ucs@ks')
 458                or $out_char_id=&get_char_attribute($char,'=>ucs')
 459                or $out_char_id=&get_char_attribute($char,'=>ucs*')
 460                ){
 461                 return '{\selectksxfont\char'.$out_char_id.'}';
 462             }
 463         }elsif($out_cs eq 'GT'){
 464             return $gt if($gt=&get_macro_for_GT($char));
 465         }elsif($out_cs eq 'HZK'){
 466             return $hzk if($hzk=&get_macro_for_HZK($char));
 467         }elsif($out_cs eq 'CDP'){
 468             return $cdp if($cdp=&get_macro_for_CDP($char));
 469         }
 470     }
 471     return undef;
 472 }
 473
 474 sub get_ids{
 475     # argument: <character>
 476     # return: ids
 477     my($char)=@_;
 478     my $ids="";
 479     $ids=&get_char_attribute($char,"ids-aggregated")
 480         or $ids=&get_char_attribute($char,"ids");
 481 #         or $ids=&get_char_attribute($char,"ideographic-structure");
 482 #    $ids=~s/[? ()]//g;
 483     return $ids;
 484 }
 485
 486 sub get_char_for_ids{
 487     # argument: <ideographic description sequence>
 488     # return: char or undef.
 489     my($ids)=@_;
 490     my($output_char);
 491
 492     if(($output_char)=&get_chars_matching("ids",$ids)){
 493         return $output_char;
 494     }else{
 495         return undef;
 496     }
 497 }
 498
 499 sub get_char_in_mcs{
 500     # argument: <char>, <input coding system>
 501     # return:   char in ucs@mcs.
 502     my($char,$in_cs)=@_;
 503     my($output_char);
 504
 505     return $char if($in_cs eq 'ucs@mcs');
 506
 507     if(($output_char)=&get_chars_matching("=$in_cs",unpack("U",$char))){
 508         return $output_char;
 509     }else{
 510         return $char;
 511     }
 512 }
 513
 514 sub get_chars_unified{
 515     my($char)=@_;
 516     my($chars,$ucs,$char_ucs);
 517     my(@chars);
 518
 519     if($chars=&get_char_attribute($char,'->ucs-unified')){
 520         $chars=~s/^\((.*)\)$/$1/;
 521         return (split(/\s*\?/,$chars));
 522     }elsif($ucs=&get_char_attribute($char,'=>ucs*')
 523           or $ucs=&get_char_attribute($char,'=>ucs')){
 524         $char_ucs=pack("U",$ucs);
 525         if($chars=&get_char_attribute($char_ucs,'->ucs-unified')){
 526             $chars=~s/^\((.*)\)$/$1/;
 527             @chars=grep {not /^$char$/}
 528                 (split(/\s*\?/,$chars));
 529             push(@chars,$char_ucs);
 530             return @chars;
 531         }
 532     }
 533 }
 534
 535 sub get_macro_for_GT{
 536     # argument: <char>
 537     # return: TeX macro for GT fonts or undef.
 538     my($char)=@_;
 539     my($gt,$GT);
 540     foreach (@GT){
 541         if($gt=&get_char_attribute($char,$_)){
 542             m/gt\-pj\-(\d+)/ and $GT=$1;
 543             last;
 544         }
 545     }
 546     if($gt){
 547         return "{\\fontencoding{OT1}\\fontfamily{"
 548             .sprintf("gt%02d",$GT)
 549             ."}\\selectfont\\char".($gt|0x8080)."}";
 550     }else{
 551         return undef;
 552     }
 553 }
 554
 555 sub get_macro_for_HZK{
 556     # argument: <char>
 557     # return: TeX macro for Hanziku fonts or undef.
 558     my($char)=@_;
 559     my($hzk,$HZK);
 560     foreach (@HZK){
 561         if($hzk=&get_char_attribute($char,$_)){
 562             m/hanziku\-(\d+)/ and $HZK=$1;
 563             last;
 564         }
 565     }
 566     if($hzk){
 567         return "{\\fontencoding{OT1}\\fontfamily{".sprintf("hzk%02d",$HZK)."}\\selectfont\\char".$hzk."}";
 568     }else{
 569         return undef;
 570     }
 571 }
 572
 573 sub get_macro_for_CDP{
 574     # argument: <char>
 575     # return: TeX macro for CDP fonts or undef.
 576     my($char)=@_;
 577     my($cdp,$ucs);
 578     foreach (@CDP){
 579         if($cdp=&get_char_attribute($char,$_)){
 580             last;
 581         }
 582     }
 583     if($cdp){
 584         $ucs=&get_char_attribute(&get_chars_matching("=big5-pua",$cdp),"=ucs");
 585         if($ucs){
 586             return "{\\fontencoding{OT1}\\fontfamily{cdp}\\selectfont\\char"
 587                 .$ucs.
 588                     "}";
 589         }else{
 590             print STDERR "This should not happen.\n";
 591             print STDERR "ucs code point of CDP: $cdp not found.\n";
 592         }
 593     }else{
 594         return undef;
 595     }
 596 }