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             print &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 #if(-f $makefonts){
 177 #    system($perl,$makefonts) ==0
 178 #       or die "Could not make fonts: $?";
 179 #}else{
 180 #    print STDERR "cannot find $makefonts\n";
 181 #}
 182
 183 exit 0;
 184
 185 sub ids_parse{
 186     # arguments: none
 187     # return: return character for output,
 188     #          TeX macro for ids,
 189     #          or GETA character if ids is invalid.
 190     my($ids,$ids_argc)=&ids_rest("",0,$chars[$i]);
 191
 192     while($ids_argc>0){
 193         # We are in IDS.
 194         $i++;
 195         if($i>$#chars){
 196             print STDERR "IDS parse error: $ids\n";
 197             return $geta;
 198         }
 199
 200         ($ids,$ids_argc)=&ids_rest($ids,$ids_argc,$chars[$i]);
 201         if($ids_argc==0){
 202             if(($char_id=&get_char_id_for_ids($ids))
 203                and($out_char=&get_output_char($char_id))){
 204                 return $out_char;
 205             }else{
 206                 return &replace_ids($ids) if($perl56);
 207                 return encode('utf8', &replace_ids($ids)) if($perl58);
 208             }
 209         }
 210     }
 211 }
 212
 213 sub ids_rest{
 214     # arguments: <ids>, <rest number of arguments for ids>, <character>
 215     # return: ids and rest number of arguments for ids.
 216     my($ids,$ids_argc,$char)=@_;
 217     my($argc);
 218     $argc=&ids_argc($char);
 219     if($argc){
 220         $ids_argc+= $ids_argc==0 ? $argc : $argc-1;
 221     }else{
 222         $ids_argc--;
 223     }
 224     $ids.=$char if($perl56);
 225     $ids.=encode('utf8',$char) if($perl58);
 226     return ($ids,$ids_argc);
 227 }
 228
 229 sub replace_ids{
 230     # argument: <ids>
 231     # return: TeX macro for ids
 232     #          or GETA character if ids is invalid for KAGE.
 233     my($ids)=@_;
 234     $ids=&normalize_ids($ids,"UniJIS");
 235     return $geta if(($ids!~/[$idc]/)
 236                     or($ids=~/[\x{10000}-]/));
 237                     #irregular for KAGE.
 238     if(not defined($ids{$ids}) and $ids{$ids}[1]>=0){
 239         $ids{$ids}[0]=$font_start;
 240         $ids{$ids}[1]=$ids_start;
 241         $ids_start++;
 242     }
 243     if($ids_start>255){
 244         $ids_start=0;
 245         $font_start++;
 246     }
 247     return "{\\fontencoding{T1}\\fontfamily{"
 248         .sprintf("chisesub%03d",$ids{$ids}[0])
 249         ."}\\selectfont\\char$ids{$ids}[1]}";
 250 }
 251
 252 sub normalize_ids{
 253     # argument: <ids>, <output coding system>
 254     # return: ids or GETA character if ids is invalid for KAGE.
 255     my($ids,$out_cs)=@_;
 256     $ids = decode('utf8', $ids) if $perl58;
 257     $out_cs=~s/Uni(.+)/"ucs\@".lc($1)/e;
 258
 259     my $output_ids="";
 260     my($char,$char_id,$output_char_id);
 261     while($ids=~m/(.)/g){
 262         $char=$1;
 263         $char_id=unpack("U",$char);
 264         if($char=~/[$idc]/){
 265             $output_ids.=$char;
 266         }elsif($output_char_id=&get_char_attribute($char,"=$out_cs")){
 267             $output_ids.=pack("U",$output_char_id);
 268         }elsif($output_char_id=&get_char_attribute($char,"=ucs")){
 269             $output_ids.=pack("U",$output_char_id);
 270         }else{
 271             return $geta;
 272         }
 273     }
 274     return $output_ids;
 275 }
 276
 277 sub get_output_char{
 278     # argument: <char-id>
 279     # return: character in EUC-JP or TeX macro for pTeX.
 280     my($char_id)=@_;
 281     my($char,$out_char,$out_char_id,$gt);
 282
 283     $char=pack('U',$char_id);
 284
 285     if($out_char=&get_char_attribute($char,'=jis-x0208')){
 286         return pack("S",$out_char|0x8080);
 287     }else{
 288         foreach $out_cs (@order){
 289             if($out_cs eq 'UniJIS'
 290                and &get_char_attribute($char,"adobe-unijis-utf16-h")){
 291                 if($out_char_id=&get_char_attribute($char,'=ucs@jis')
 292                    or $out_char_id=&get_char_attribute($char,'=ucs')){
 293                     return "\\UTF{".sprintf("%X",$out_char_id)."}";
 294                 }
 295             }elsif($out_cs eq 'UniGB'
 296                    and &get_char_attribute($char,"adobe-unigb-ucs2-h")){
 297                 if($out_char_id=&get_char_attribute($char,'=ucs@gb')
 298                    or $out_char_id=&get_char_attribute($char,'=ucs')){
 299                     return "\\UTFC{".sprintf("%X",$out_char_id)."}";
 300                 }
 301             }elsif($out_cs eq 'UniCNS'
 302                    and &get_char_attribute($char,"adobe-unicns-ucs2-h")){
 303                 if($out_char_id=&get_char_attribute($char,'=ucs@cns')
 304                    or $out_char_id=&get_char_attribute($char,'=ucs')){
 305                     return "\\UTFT{".sprintf("%X",$out_char_id)."}";
 306                 }
 307             }elsif($out_cs eq 'UniKS'
 308                    and &get_char_attribute($char,"adobe-uniks-ucs2-h")){
 309                 if($out_char_id=&get_char_attribute($char,'=ucs@ks')
 310                    or $out_char_id=&get_char_attribute($char,'=ucs')){
 311                     return "\\UTFK{".sprintf("%X",$out_char_id)."}";
 312                 }
 313             }elsif($out_cs eq 'GT'){
 314                 return $gt if($gt=&get_macro_for_GT($char_id));
 315             }elsif($out_cs eq 'Multi'){
 316                 if($out_char_id=&get_char_attribute($char,'=ucs')){
 317                     return "\\UTFM{".sprintf("%X",$out_char_id)."}";
 318                 }
 319             }
 320         }
 321     }
 322     return undef;
 323 }
 324
 325 sub get_ids{
 326     # argument: <character>
 327     # return: ids
 328     my($char)=@_;
 329     my $ids="";
 330     $ids=&get_char_attribute($char,"ids-aggregated")
 331         or &get_char_attribute($char,"ids");
 332     $ids=decode('utf8', $ids) if($perl58);
 333     return $ids;
 334 }
 335
 336 sub get_char_id_for_ids{
 337     # argument: <character>
 338     # return: char-id
 339     my($ids)=@_;
 340     my($output_char);
 341     $ids=decode('utf8', $ids) if($perl58);
 342
 343     if(&get_reverse_db("ids")){
 344         if($output_char=$reverse_chardb{"ids"}->{$ids}){
 345             $output_char=decode('utf8',$output_char) if($perl58);
 346             $output_char=~s/^\?//;
 347             return unpack("U",$output_char);
 348         }
 349     }else{
 350         return undef;
 351     }
 352 }
 353
 354 sub get_char_in_ucsmcs{
 355     # argument: <character>, <input coding system>
 356     # return:   character in ucs@mcs.
 357     my($char,$in_cs)=@_;
 358     my($output_char);
 359
 360     if(&get_reverse_db("=$in_cs")){
 361         if($output_char=$reverse_chardb{"=$in_cs"}->{$char}){
 362             $output_char=decode('utf8',$output_char) if($perl58);
 363             return $output_char=~s/^\?//;
 364         }
 365     }else{
 366         return $char;
 367     }
 368 }
 369
 370 sub get_macro_for_GT{
 371     # argument: <char-id>
 372     # return: TeX macro for GT fonts.
 373     my($char_id)=@_;
 374     my($char,$gt,$GT);
 375     $char=pack("U",$char_id);
 376     foreach (@GT){
 377         if($gt=&get_char_attribute($char,$_)){
 378             m/gt\-pj\-(\d+)/ and $GT=$1;
 379             last;
 380         }
 381     }
 382     if($gt){
 383         return "{\\fontfamily{"
 384             .sprintf("gto%02d",$GT)
 385             ."}\\selectfont\\char".($gt|0x8080)."}";
 386     }else{
 387         return undef;
 388     }
 389 }