outCMAP

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