outCMAP

   1 #!/usr/bin/perl
   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             %utf8mcs_map_from
  16             $inotp $perl56 $perl58
  17             @CDP @HZK @GT
  18             );
  19 use Getopt::Long;
  20 use utf8;
  21 use Fcntl ':flock';
  22 use Chise_utils ':all';
  23
  24 my $omegadb_path="/usr/local/lib/chise/omega";
  25
  26 ### Options ###
  27
  28 $opt_order='jtcgk';
  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 if($^V and $^V ge v5.8){
  58     $perl58=1;
  59 }elsif($^V and $^V ge v5.6){
  60     $perl56=1;
  61 }else{
  62     print STDERR "This versin is not supported.";
  63     exit 1;
  64 }
  65 if($perl58){
  66     eval "use Encode";
  67     binmode(STDIN, ':encoding(utf8)');
  68     binmode(STDOUT, ':encoding(utf8)');
  69 }
  70
  71 &GetOptions("in=s"=>\$opt_in_cs,
  72             "out=s"=>\$opt_out_cs,
  73             "help",\$opt_help);
  74
  75 $usage=<<EOF;
  76 Usage: $0 -i <input coding system> -o <cmap encoding>
  77     input coding system:
  78       Utf8mcs, Utf8cns, Utf8gb, Utf8jis, Utf8ks
  79     cmap encoding:
  80       UniCNS, UniGB, UniJIS, UniKS, UniMulti
  81 EOF
  82
  83 if($opt_in_cs or $opt_out_cs){
  84     $in_cs=$opt_in_cs;
  85     $out_cs=$opt_out_cs;
  86 }elsif(@ARGV==0){
  87     ($in_cs,$out_cs)=($0=~/(Utf8.+)To(\w+)/);
  88     $inotp=1;
  89 }
  90
  91 # $in_cs:
  92 #   Utf8mcs,Utf8cns,Utf8gb,Utf8jis,Utf8ks,
  93 # $out_cs:
  94 #   UniCNS,UniGB,UniJIS,UniKS,UniMulti
  95
  96 $in_cs=~s/Utf8/ucs\@/;
  97
  98 if($opt_help
  99    or not defined($in_cs)
 100    or not defined($out_cs)){
 101     print $usage;
 102     exit 1;
 103 }
 104
 105 $omegadb_path=~s!/$!!;
 106
 107 $idsdata_file="$omegadb_path/idsdata.pl";
 108 $ids_start=0x00;
 109 $font_start=0;
 110
 111 if(-e $idsdata_file){
 112     open(IDSDATA,"+<$idsdata_file") or die;
 113     flock(IDSDATA,LOCK_EX);
 114     seek(IDSDATA,0,0);
 115     while(<IDSDATA>){
 116         eval $_;
 117     }
 118     seek(IDSDATA,0,0);
 119 #         require $idsdata_file;
 120 }else{
 121     open(IDSDATA,">$idsdata_file") or die;
 122     flock(IDSDATA,LOCK_EX);
 123     seek(IDSDATA,0,0);
 124 }
 125
 126 $ids_argc=0;
 127 $ids="";
 128
 129 @GT=(#"=gt","=gt-k",
 130      "=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"
 131      #,"=gt-pj-k1","=gt-pj-k2"
 132      );
 133 @HZK=("=hanziku-1","=hanziku-10","=hanziku-11","=hanziku-12","=hanziku-2","=hanziku-3","=hanziku-4","=hanziku-5","=hanziku-6","=hanziku-7","=hanziku-8","=hanziku-9");
 134 @CDP=("=big5-cdp");
 135
 136 %order=('c'=>'UniCNS',
 137         'g'=>'UniGB',
 138         'j'=>'UniJIS',
 139         'k'=>'UniKS',
 140         't'=>'GT',
 141 #       not implemented yet.
 142 #       'h'=>'HZK',
 143 #       'd'=>'CDP',
 144         );
 145
 146 if(defined($opt_order)){
 147     if($opt_order=~/^[cgjkt]*$/){
 148         @order=split(//,$opt_order);
 149         @order=map {$order{$_}} @order;
 150     }else{
 151         print STDERR "Invalid order!\n";
 152         exit 1;
 153     }
 154 }
 155
 156 while(<>){
 157     if($perl56){
 158         # for perl 5.6
 159         if($inotp){
 160             s/(.)/pack("c",&get_char_id(unpack("U",$1),$in_cs))/ge;
 161         }else{
 162             s/(.)/pack("U",&get_char_id(unpack("U",$1),$in_cs))/ge;
 163         }
 164     }elsif($perl58){
 165         # for perl 5.8.
 166         $_=decode('utf8', $_);
 167         s/(.)/pack("U",&get_char_id(unpack("U",$1),$in_cs))/ge;
 168     }
 169     s/(amp.+?;)/&tex_de_er($1)/ge;
 170 #    s/(&.+?;)/&tex_de_er($1)/ge;
 171     @chars=split(//);
 172     for($i=0;$i<=$#chars;$i++){
 173         $char=$chars[$i];
 174         $char_id=unpack("U",$char);
 175
 176         if($char_id<=0x20){
 177             print $chars[$i];
 178             next;
 179         }elsif($char_id>0x20 and $char_id<=0xff){
 180             # Basic Latin
 181             # Latin-1 Supplement
 182             print &latin_parse();
 183             next;
 184         }elsif($char_id>=0x2ff0 and $char_id<=0x2fff){
 185             # Ideographic Description Characters
 186             print &ids_parse();
 187             next;
 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;
 203         }else{
 204             if(($out_char=&get_output_char($char_id,$out_cs))){
 205                 print $out_char,&add_break($i);
 206             }else{
 207                 print &get_macro_for_ids(&get_ids($char)),&add_break($i);
 208             }
 209         }
 210     }
 211 }
 212
 213 print IDSDATA 'use utf8;',"\n";
 214 foreach $ids (keys %ids){
 215     print IDSDATA '$ids{\'',$ids,'\'}=[',join ",",@{$ids{$ids}},"];\n" if($perl56);
 216     print IDSDATA '$ids{\'',encode('utf8',$ids),'\'}=[',join ",",@{$ids{$ids}},"];\n" if($perl58);
 217 }
 218 print IDSDATA '$font_start=',$font_start,";\n";
 219 print IDSDATA '$ids_start=',$ids_start,";\n";
 220 print IDSDATA "1;";
 221 flock(IDSDATA,LOCK_UN);
 222
 223 exit 0;
 224
 225 sub tex_de_er{
 226     my($er)=@_;
 227     my($out);
 228     $er=~s/^amp(.*);$/$1/;
 229 #    $er=~s/^&(.*);$/$1/;
 230     $out=&de_er($er);
 231     if($out and $out ne $er){
 232         return $out;
 233     }else{
 234         return "amp$er;";
 235     }
 236 }
 237
 238 sub add_break{
 239     my($i)=@_;
 240
 241     if($i<($#chars-1)){
 242         if(($chars[$i+1]=~m/[$strictly_forbidden_before]/o)
 243            and($chars[$i+2]=~m/[$strictly_forbidden_before]/o)){
 244             return "\\CJKunbreakablekernone ";
 245         }elsif($opt_protrude){
 246             if(($chars[$i+1]=~m/[$strictly_forbidden_before]/o)
 247                and($chars[$i+2]=~m/[^$strictly_forbidden_before]/o)){
 248                 return "\\CJKunbreakablekernone \\CJKprotrude ";
 249             }
 250         }
 251     }
 252     if(($i<$#chars)
 253        and($chars[$i+1]=~m/[$strictly_forbidden_before]/o)){
 254         return "\\CJKunbreakablekernone ";
 255     }
 256     if($chars[$i]=~m/[$strictly_forbidden_after]/o){
 257         return "\\CJKunbreakablekernone ";
 258     }
 259     if(($i<$#chars)
 260        and($chars[$i+1]=~m/[$forbidden_before]/o)){
 261         return "\\CJKunbreakablekerntwo ";
 262
 263     }
 264     if($chars[$i]=~m/[$forbidden_after]/o){
 265         return "\\CJKunbreakablekerntwo ";
 266     }
 267     if(($i<$#chars)
 268        and($chars[$i+1]=~m/[$slightly_forbidden_before]/o)){
 269         return "\\CJKunbreakablekernthree ";
 270     }
 271     if($chars[$i]=~m/[$slightly_forbidden_after]/o){
 272         return "\\CJKunbreakablekernthree ";
 273     }
 274     if($chars[$i]=~m/[$asian]/o){
 275         return "\\CJKbreakablekern ";
 276     }
 277     if(($i<$#chars)and($chars[$i+1]=~m/[$asian]/o)){
 278         return "\\CJKbreakablekern ";
 279     }
 280 }
 281
 282 sub latin_parse{
 283     # arguments: none
 284     # return: string for output with TeX macro.
 285     my($char_id);
 286     my $out_str=$chars[$i];
 287     $i++;
 288     while($i<=$#chars){
 289         $char_id=unpack("U",$chars[$i]);
 290         if($char_id<=0xff){
 291             $out_str.=pack("U",$char_id);
 292         }else{
 293             $i--;
 294             last;
 295         }
 296         $i++;
 297     }
 298     return '{\fontfamily{\rmdefault}\selectfont {'.$out_str.'}}';
 299 }
 300
 301 sub ids_parse{
 302     # arguments: none
 303     # return: character for output,
 304     #          TeX macro for ids,
 305     #          or GETA character if ids is invalid.
 306     my($ids,$ids_argc)=&ids_rest("",0,$chars[$i]);
 307
 308     while($ids_argc>0){
 309         # We are in IDS.
 310         $i++;
 311         if($i>$#chars){
 312             print STDERR "IDS parse error: $ids\n";
 313 #           return pack("U",0xfffd);
 314             return pack("U",0x3013);
 315         }
 316
 317         ($ids,$ids_argc)=&ids_rest($ids,$ids_argc,$chars[$i]);
 318         if($ids_argc==0){
 319             if(($char_id=&get_char_id_for_ids($ids))
 320                and($out_char=&get_output_char($char_id,$out_cs))){
 321                 return $out_char;
 322             }else{
 323                 return &get_macro_for_ids($ids) if($perl56);
 324                 return encode('utf8', &get_macro_for_ids($ids)) if($perl58);
 325             }
 326         }
 327     }
 328 }
 329
 330 sub ids_rest{
 331     # arguments: <ids>, <rest number of arguments for ids>, <character>
 332     # return: ids and rest number of arguments for ids.
 333     my($ids,$ids_argc,$char)=@_;
 334     my($argc);
 335     $argc=&ids_argc($char);
 336     if($argc){
 337         $ids_argc+= $ids_argc==0 ? $argc : $argc-1;
 338     }else{
 339         $ids_argc--;
 340     }
 341     $ids.=$char if($perl56);
 342     $ids.=encode('utf8',$char) if($perl58);
 343     return ($ids,$ids_argc);
 344 }
 345
 346 sub get_macro_for_ids{
 347     # argument: <ids>
 348     # return: TeX macro for ids
 349     #          or GETA character if ids is invalid for KAGE.
 350     my($ids)=@_;
 351     $ids=&normalize_ids($ids,"UniJIS");
 352 #    return pack("U",0xfffd) if(($ids!~/[$idc]/)
 353     return pack("U",0x3013) if(($ids!~/[$idc]/)
 354                                or($ids=~/[\x{10000}-]/));
 355                     #irregular for KAGE.
 356     if(not defined($ids{$ids}) and $ids{$ids}[1]>=0){
 357         $ids{$ids}[0]=$font_start;
 358         $ids{$ids}[1]=$ids_start;
 359         $ids_start++;
 360     }
 361     if($ids_start>255){
 362         $ids_start=0;
 363         $font_start++;
 364     }
 365     return "{\\fontencoding{OT1}\\fontfamily{"
 366         .sprintf("chise%03d",$ids{$ids}[0])
 367         ."}\\selectfont\\char$ids{$ids}[1]}";
 368 }
 369
 370 sub normalize_ids{
 371     # argument: <ids>, <output coding system>
 372     # return: ids or GETA character if ids is invalid for KAGE.
 373     my($ids,$out_cs)=@_;
 374     $ids = decode('utf8', $ids) if $perl58;
 375     $out_cs=~s/Uni(.+)/'ucs@'.lc($1)/e;
 376
 377     my $output_ids="";
 378     my($char,$char_id,$output_char_id);
 379     while($ids=~m/(.)/g){
 380         $char=$1;
 381         $char_id=unpack("U",$char);
 382         if($char=~/[$idc]/){
 383             $output_ids.=$char;
 384         }elsif($output_char_id=&get_char_attribute($char,"=$out_cs")){
 385             $output_ids.=pack("U",$output_char_id);
 386         }elsif($output_char_id=&get_char_attribute($char,"=ucs")){
 387             $output_ids.=pack("U",$output_char_id);
 388         }else{
 389 #           return pack("U",0xfffd);
 390             return pack("U",0x3013);
 391         }
 392     }
 393     return $output_ids;
 394 }
 395
 396 sub get_output_char{
 397     # argument: <char-id>
 398     # return: character in output coding system or TeX macro.
 399     my($char_id,$out_cs)=@_;
 400     my($char,$out_char_id,$suffix);
 401     my($gt,$hzk,$cdp);
 402
 403     $char=pack('U',$char_id);
 404
 405     if($out_cs eq 'UniJIS'
 406        and &get_char_attribute($char,"adobe-unijis-utf16-h")){
 407         if($out_char_id=&get_char_attribute($char,'=ucs@jis')
 408            or $out_char_id=&get_char_attribute($char,'=ucs')
 409            or $out_char_id=&get_char_attribute($char,'=>ucs@jis')
 410            or $out_char_id=&get_char_attribute($char,'=>ucs')
 411            ){
 412             return pack("U",$out_char_id);
 413         }
 414     }elsif($out_cs eq 'UniGB'
 415            and &get_char_attribute($char,"adobe-unigb-ucs2-h")){
 416         if($out_char_id=&get_char_attribute($char,'=ucs@gb')
 417            or $out_char_id=&get_char_attribute($char,'=ucs')
 418            or $out_char_id=&get_char_attribute($char,'=>ucs@gb')
 419            or $out_char_id=&get_char_attribute($char,'=>ucs')
 420            ){
 421             return pack("U",$out_char_id);
 422         }
 423     }elsif($out_cs eq 'UniCNS'
 424            and &get_char_attribute($char,"adobe-unicns-ucs2-h")){
 425         if($out_char_id=&get_char_attribute($char,'=ucs@cns')
 426            or $out_char_id=&get_char_attribute($char,'=ucs')
 427            or $out_char_id=&get_char_attribute($char,'=>ucs@cns')
 428            or $out_char_id=&get_char_attribute($char,'=>ucs')
 429            ){
 430             return pack("U",$out_char_id);
 431         }
 432     }elsif($out_cs eq 'UniKS'
 433            and &get_char_attribute($char,"adobe-uniks-ucs2-h")){
 434         if($out_char_id=&get_char_attribute($char,'=ucs@ks')
 435            or $out_char_id=&get_char_attribute($char,'=ucs')
 436            or $out_char_id=&get_char_attribute($char,'=>ucs@ks')
 437            or $out_char_id=&get_char_attribute($char,'=>ucs')
 438            ){
 439             return pack("U",$out_char_id);
 440         }
 441     }elsif($out_cs eq 'UniMulti'){
 442         foreach $out_cs (@order){
 443
 444             if($out_cs eq 'UniJIS'
 445                and &get_char_attribute($char,"adobe-unijis-utf16-h")){
 446                 if($out_char_id=&get_char_attribute($char,'=ucs@jis')
 447                    or $out_char_id=&get_char_attribute($char,'=ucs')
 448                    or $out_char_id=&get_char_attribute($char,'=>ucs@jis')
 449                    or $out_char_id=&get_char_attribute($char,'=>ucs')
 450                    ){
 451                     return '{\selectjisfont\char'.$out_char_id.'}';
 452                 }
 453             }elsif($out_cs eq 'UniGB'
 454                    and &get_char_attribute($char,"adobe-unigb-ucs2-h")){
 455                 if($out_char_id=&get_char_attribute($char,'=ucs@gb')
 456                    or $out_char_id=&get_char_attribute($char,'=ucs')
 457                    or $out_char_id=&get_char_attribute($char,'=>ucs@gb')
 458                    or $out_char_id=&get_char_attribute($char,'=>ucs')
 459                    ){
 460                     return '{\selectgbsfont\char'.$out_char_id.'}';
 461                 }
 462             }elsif($out_cs eq 'UniCNS'
 463                    and &get_char_attribute($char,"adobe-unicns-ucs2-h")){
 464                 if($out_char_id=&get_char_attribute($char,'=ucs@cns')
 465                    or $out_char_id=&get_char_attribute($char,'=ucs')
 466                    or $out_char_id=&get_char_attribute($char,'=>ucs@cns')
 467                    or $out_char_id=&get_char_attribute($char,'=>ucs')
 468                    ){
 469                     return '{\selectcnsfont\char'.$out_char_id.'}';
 470                 }
 471             }elsif($out_cs eq 'UniKS'
 472                    and &get_char_attribute($char,"adobe-uniks-ucs2-h")){
 473                 if($out_char_id=&get_char_attribute($char,'=ucs@ks')
 474                    or $out_char_id=&get_char_attribute($char,'=ucs')
 475                    or $out_char_id=&get_char_attribute($char,'=>ucs@ks')
 476                    or $out_char_id=&get_char_attribute($char,'=>ucs')
 477                    ){
 478                     return '{\selectksxfont\char'.$out_char_id.'}';
 479                 }
 480             }elsif($out_cs eq 'GT'){
 481                 return $gt if($gt=&get_macro_for_GT($char_id));
 482             }elsif($out_cs eq 'HZK'){
 483                 return $hzk if($hzk=&get_macro_for_HZK($char_id));
 484             }elsif($out_cs eq 'CDP'){
 485                 return $cdp if($cdp=&get_macro_for_CDP($char_id));
 486             }
 487         }
 488     }
 489     return undef;
 490 }
 491
 492 sub get_ids{
 493     # argument: <character>
 494     # return: ids
 495     my($char)=@_;
 496     my $ids="";
 497     $ids=&get_char_attribute($char,"ids-aggregated")
 498         or &get_char_attribute($char,"ids");
 499 #       or &get_char_attribute($char,"ideographic-structure");
 500     $ids=decode('utf8', $ids) if($perl58);
 501 #    $ids=~s/[? ()]//g;
 502     return $ids;
 503 }
 504
 505 sub get_char_id_for_ids{
 506     # argument: <ideographic description sequence>
 507     # return: char-id
 508     my($ids)=@_;
 509     my($output_char);
 510     $ids=decode('utf8', $ids) if($perl58);
 511
 512     if(($output_char)=&get_chars_matching("ids",$ids)){
 513         return unpack("U",$output_char);
 514     }else{
 515         return undef;
 516     }
 517 }
 518
 519 sub get_char_id{
 520     # argument: <char-id>, <input coding system>
 521     # return:   char-id.
 522     my($char_id,$in_cs)=@_;
 523     my($output_char);
 524
 525     return $char_id if($in_cs eq 'ucs@mcs');
 526
 527     if(($output_char)=&get_chars_matching("=$in_cs",$char_id)){
 528         return unpack("U",$output_char);
 529     }else{
 530         return $char_id;
 531     }
 532 }
 533
 534 sub get_macro_for_GT{
 535     # argument: <char-id>
 536     # return: TeX macro for GT fonts.
 537     my($char_id)=@_;
 538     my($char,$gt,$GT);
 539     $char=pack("U",$char_id);
 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     my($char_id)=@_;
 557     my($char,$hzk,$HZK);
 558     $char=pack("U",$char_id);
 559     foreach (@HZK){
 560         if($hzk=&get_char_attribute($char,$_)){
 561             m/hanziku\-(\d+)/ and $HZK=$1;
 562             last;
 563         }
 564     }
 565     if($hzk){
 566         return "{\\fontencoding{OT1}\\fontfamily{".sprintf("hzk%02d",$HZK)."}\\selectfont\\char".($hzk|0x8080)."}";
 567     }else{
 568         return undef;
 569     }
 570 }
 571
 572 sub get_macro_for_CDP{
 573     my($char_id)=@_;
 574     my($char,$cdp);
 575     $char=pack("U",$char_id);
 576     foreach (@CDP){
 577         if($cdp=&get_char_attribute($char,$_)){
 578             last;
 579         }
 580     }
 581     if($cdp){
 582         return "{\\fontencoding{OT1}\\fontfamily{cdp}\\selectfont\\char".($cdp|0x8080)."}";
 583     }else{
 584         return undef;
 585     }
 586 }