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         }elsif($output_char_id=&get_char_attribute($char,"ucs")){
 260             $output_ids.=pack("U",$output_char_id);
 261         }else{
 262             return $geta;
 263         }
 264     }
 265     return $output_ids;
 266 }
 267
 268 sub get_output_char{
 269     my($char_id)=@_;
 270     my($char,$out_char,$suffix);
 271     my($jis,$euc,$gt);
 272
 273     $char=pack('U',$char_id);
 274
 275     if($jis=&get_char_attribute($char,'=jis-x0208')){
 276         return pack("S",$jis|0x8080);
 277     }else{
 278         foreach $out_cs (@order){
 279             if($out_cs eq 'UniJIS'){
 280                 if($out_char=&get_char_attribute($char,'=ucs@jis')
 281                    or ($out_char=&get_char_attribute($char,'=ucs')and
 282                        &get_char_attribute($char,"adobe-unijis-ucs2-h"))
 283                    ){
 284                     return "\\UTF{".sprintf("%X",$out_char)."}";
 285                 }
 286             }elsif($out_cs eq 'UniGB'){
 287                 if($out_char=&get_char_attribute($char,'=ucs@gb')
 288                    or ($out_char=&get_char_attribute($char,'=ucs')and
 289                        &get_char_attribute($char,"adobe-unigb-ucs2-h"))
 290                    ){
 291                     return "\\UTFC{".sprintf("%X",$out_char)."}";
 292                 }
 293             }elsif($out_cs eq 'UniCNS'){
 294                 if($out_char=&get_char_attribute($char,'=ucs@cns')
 295                    or ($out_char=&get_char_attribute($char,'=ucs')and
 296                        &get_char_attribute($char,"adobe-unicns-ucs2-h"))
 297                    ){
 298                     return "\\UTFT{".sprintf("%X",$out_char)."}";
 299                 }
 300             }elsif($out_cs eq 'UniKS'){
 301                 if($out_char=&get_char_attribute($char,'=ucs@ks')
 302                    or ($out_char=&get_char_attribute($char,'=ucs')and
 303                        &get_char_attribute($char,"adobe-uniks-ucs2-h"))
 304                    ){
 305                     return "\\UTFK{".sprintf("%X",$out_char)."}";
 306                 }
 307             }elsif($out_cs eq 'GT'){
 308                 return $gt if($gt=&get_macro_for_GT($char_id));
 309             }elsif($out_cs eq 'Multi'){
 310                 if($out_char=&get_char_attribute($char,'=ucs')){
 311                     return "\\UTFM{".sprintf("%X",$out_char)."}";
 312                 }
 313             }
 314         }
 315     }
 316     return undef;
 317 }
 318
 319 sub get_ids{
 320     my($char)=@_;
 321     my $ids="";
 322     $ids=&get_char_attribute($char,"ids-aggregated")
 323         or &get_char_attribute($char,"ids");
 324     $ids=decode('utf8', $ids) if($perl58);
 325     return $ids;
 326 }
 327
 328 sub get_char_id_for_ids{
 329     my($ids)=@_;
 330     my($output_char);
 331     $ids=decode('utf8', $ids) if($perl58);
 332
 333     if(&get_reverse_db("ids")){
 334         if($output_char=$reverse_chardb{"ids"}->{$ids}){
 335             $output_char=~s/^\?//;
 336             return unpack("U",$output_char);
 337         }
 338     }else{
 339         return undef;
 340     }
 341 }
 342
 343 sub get_char_in_ucsmcs{
 344     # argument: <character>, <input coding system>
 345     # return:   character in ucs@mcs.
 346     my($char,$in_cs)=@_;
 347     my($output_char);
 348
 349     if(&get_reverse_db("=$in_cs")){
 350         if($output_char=$reverse_chardb{"=$in_cs"}->{$char}){
 351             return $output_char=~s/^\?//;
 352         }
 353     }else{
 354         return $char;
 355     }
 356 }
 357
 358 sub get_macro_for_GT{
 359     my($char_id)=@_;
 360     my($char,$gt,$GT);
 361     $char=pack("U",$char_id);
 362     foreach (@GT){
 363         if($gt=&get_char_attribute($char,$_)){
 364             m/gt\-pj\-(\d+)/ and $GT=$1;
 365             last;
 366         }
 367     }
 368     if($gt){
 369         return "{\\fontfamily{"
 370             .sprintf("gto%02d",$GT)
 371             ."}\\selectfont\\char".($gt|0x8080)."}";
 372     }else{
 373         return undef;
 374     }
 375 }