inCHISE

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