chise2otf/chise2otf

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use vars qw($opt_in_cs $opt_order $opt_kage $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 $exec_makefonts=0;
  20 my $geta=pack("S",8750|0x8080);
  21
  22 if($^V and $^V ge v5.8){
  23     $perl58=1;
  24 }elsif($^V and $^V ge v5.6){
  25     $perl56=1;
  26 }else{
  27     print STDERR "This versin is not supported.";
  28 }
  29 if($perl58){
  30     eval "use Encode";
  31     binmode(STDIN, ':encoding(utf8)');
  32     binmode(STDOUT, ':encoding(utf8)');
  33 }
  34
  35 &GetOptions("in=s"=>\$opt_in_cs,
  36             "order=s"=>\$opt_order,
  37             "kage",\$opt_kage,
  38             "help",\$opt_help);
  39
  40 $usage=<<EOF;
  41 Usage: $0 [-i <input coding system>] [-o <order of kanji>] [-k] <filename>
  42     input coding system: (default: ucs\@mcs)
  43       ucs\@mcs, ucs\@cns, ucs\@gb, ucs\@jis, ucs\@ks
  44     order of kanji: (default: j)
  45        c: CNS
  46        g: GB
  47        j: JIS
  48        k: KS
  49        t: GT
  50        m: Multi, use \\UTFM of otf.sty
  51       You can also combine them, ex. jtcgkm
  52     k: use Kage server.
  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 eq 'ucs@mcs')or
  73        ($opt_in_cs eq 'ucs@cns')or
  74        ($opt_in_cs eq 'ucs@gb')or
  75        ($opt_in_cs eq 'ucs@jis')or
  76        ($opt_in_cs eq 'ucs@ks')){
  77         $in_cs=$opt_in_cs;
  78     }else{
  79         print STDERR "Invalid arguments.\n";
  80         print STDERR $usage;
  81         exit 1;
  82     }
  83 }
  84
  85 if(not defined($opt_order)){
  86     print STDERR "Using only UniJIS.\n";
  87     $opt_order='j';
  88 }
  89
  90 if(defined($opt_order)){
  91     if($opt_order=~/^[cgjktm]+$/){
  92         @order=split(//,$opt_order);
  93         @order=map {$order{$_}} @order;
  94     }else{
  95         print STDERR "Invalid option!\n";
  96         print $usage;
  97         exit 1;
  98     }
  99 }
 100
 101 if($opt_kage){
 102     $exec_makefonts=1;
 103 }
 104
 105 $idsdata_file="idsdata.pl";
 106 $ids_start=0x00;
 107 $font_start=0;
 108
 109 if(-e $idsdata_file){
 110     require $idsdata_file;
 111 }
 112
 113 $ids_argc=0;
 114 $ids="";
 115
 116 @GT=(#"=gt","=gt-k",
 117      "=gt-pj-1","=gt-pj-2","=gt-pj-3","=gt-pj-4","=gt-pj-5",
 118      "=gt-pj-6","=gt-pj-7","=gt-pj-8","=gt-pj-9","=gt-pj-10",
 119      "=gt-pj-11"
 120      #,"=gt-pj-k1","=gt-pj-k2"
 121      );
 122 @HZK=("=hanziku-1","=hanziku-10","=hanziku-11","=hanziku-12",
 123       "=hanziku-2","=hanziku-3","=hanziku-4","=hanziku-5",
 124       "=hanziku-6","=hanziku-7","=hanziku-8","=hanziku-9");
 125 @CDP=("=big5-cdp");
 126
 127 while(<>){
 128     s/&(.*?);/&de_er($1)/ge;
 129     if($in_cs ne 'ucs@mcs'){
 130         s/(.)/pack("U",&get_char_id(unpack("U",$1),$in_cs))/ge;
 131     }
 132     @chars=split(//);
 133     for($i=0;$i<=$#chars;$i++){
 134         $char=$chars[$i];
 135         $char_id=unpack("U",$chars[$i]);
 136
 137         if($char_id<=0x7f){
 138             # Basic Latin
 139             print $char;
 140             next;
 141         }elsif($char_id>=0x2ff0 and $char_id<=0x2fff){
 142             # Ideographic Description Characters
 143             print &ids_parse();
 144             next;
 145         }elsif($char_id >= 0x20000 && $char_id <=0x2a6df){
 146             # CJK Unified Ideographs Extension B
 147             if(not defined($ids{$char}) and $ids{$char}[1]>=0){
 148                 $ids{$char}[0]=$font_start;
 149                 $ids{$char}[1]=$ids_start;
 150                 $ids_start++;
 151                 if($ids_start>255){
 152                     $ids_start=0;
 153                     $font_start++;
 154                 }
 155             }
 156             print "{\\fontencoding{OT1}\\fontfamily{" .
 157                 sprintf("chise%03d",$ids{$char}[0]) .
 158                 "}\\selectfont\\char$ids{$char}[1]}";
 159             next;
 160         }else{
 161             if(($out_char=&get_output_char($char_id))){
 162                 print $out_char;
 163             }else{
 164                 print &get_macro_for_ids(&get_ids($char));
 165             }
 166         }
 167     }
 168 }
 169
 170 open(IDSDATA,">$idsdata_file") or die;
 171 print IDSDATA 'use utf8;',"\n";
 172 foreach $ids (keys %ids){
 173     print IDSDATA '$ids{\'',$ids,'\'}='
 174         ,'[',join ",",@{$ids{$ids}},"];\n" if($perl56);
 175     print IDSDATA '$ids{\'',encode('utf8',$ids),'\'}='
 176         ,'[',join ",",@{$ids{$ids}},"];\n" if($perl58);
 177 }
 178 print IDSDATA '$font_start=',$font_start,";\n";
 179 print IDSDATA '$ids_start=',$ids_start,";\n";
 180 print IDSDATA "1;";
 181
 182 if($exec_makefonts){
 183     if(-f $makefonts){
 184         system($perl,$makefonts) ==0
 185             or die "Could not make fonts: $?";
 186     }else{
 187         print STDERR "cannot find $makefonts\n";
 188     }
 189 }
 190
 191 exit 0;
 192
 193 sub ids_parse{
 194     # arguments: none
 195     # return: return character for output,
 196     #          TeX macro for ids,
 197     #          or GETA character if ids is invalid.
 198     my($ids,$ids_argc)=&ids_rest("",0,$chars[$i]);
 199
 200     while($ids_argc>0){
 201         # We are in IDS.
 202         $i++;
 203         if($i>$#chars){
 204             print STDERR "IDS parse error: $ids\n";
 205             return $geta;
 206         }
 207
 208         ($ids,$ids_argc)=&ids_rest($ids,$ids_argc,$chars[$i]);
 209         if($ids_argc==0){
 210             if(($char_id=&get_char_id_for_ids($ids))
 211                and($out_char=&get_output_char($char_id))){
 212                 return $out_char;
 213             }else{
 214                 return &get_macro_for_ids($ids) if($perl56);
 215                 return encode('utf8', &get_macro_for_ids($ids)) if($perl58);
 216             }
 217         }
 218     }
 219 }
 220
 221 sub ids_rest{
 222     # arguments: <ids>, <rest number of arguments for ids>, <character>
 223     # return: ids and rest number of arguments for ids.
 224     my($ids,$ids_argc,$char)=@_;
 225     my($argc);
 226     $argc=&ids_argc($char);
 227     if($argc){
 228         $ids_argc+= $ids_argc==0 ? $argc : $argc-1;
 229     }else{
 230         $ids_argc--;
 231     }
 232     $ids.=$char if($perl56);
 233     $ids.=encode('utf8',$char) if($perl58);
 234     return ($ids,$ids_argc);
 235 }
 236
 237 sub get_macro_for_ids{
 238     # argument: <ids>
 239     # return: TeX macro for ids
 240     #          or GETA character if ids is invalid for KAGE.
 241     my($ids)=@_;
 242 #    return $geta if(not $exec_makefonts);
 243     $ids=&normalize_ids($ids,"UniJIS");
 244     return $geta if(($ids!~/[$idc]/)
 245                     or($ids=~/[\x{10000}-]/));
 246                     #irregular for KAGE.
 247     if(not defined($ids{$ids}) and $ids{$ids}[1]>=0){
 248         $ids{$ids}[0]=$font_start;
 249         $ids{$ids}[1]=$ids_start;
 250         $ids_start++;
 251     }
 252     if($ids_start>255){
 253         $ids_start=0;
 254         $font_start++;
 255     }
 256     return "{\\fontencoding{T1}\\fontfamily{"
 257         .sprintf("chisesub%03d",$ids{$ids}[0])
 258         ."}\\selectfont\\char$ids{$ids}[1]}";
 259 }
 260
 261 sub normalize_ids{
 262     # argument: <ids>, <output coding system>
 263     # return: ids or GETA character if ids is invalid for KAGE.
 264     my($ids,$out_cs)=@_;
 265     $ids = decode('utf8', $ids) if $perl58;
 266     $out_cs=~s/Uni(.+)/"ucs\@".lc($1)/e;
 267
 268     my $output_ids="";
 269     my($char,$char_id,$output_char_id);
 270     while($ids=~m/(.)/g){
 271         $char=$1;
 272         $char_id=unpack("U",$char);
 273         if($char=~/[$idc]/){
 274             $output_ids.=$char;
 275         }elsif($output_char_id=&get_char_attribute($char,"=$out_cs")){
 276             $output_ids.=pack("U",$output_char_id);
 277         }elsif($output_char_id=&get_char_attribute($char,"=ucs")){
 278             $output_ids.=pack("U",$output_char_id);
 279         }else{
 280             return $geta;
 281         }
 282     }
 283     return $output_ids;
 284 }
 285
 286 sub get_output_char{
 287     # argument: <char-id>
 288     # return: character in EUC-JP or TeX macro for pTeX.
 289     my($char_id)=@_;
 290     my($char,$out_char,$out_char_id,$gt);
 291
 292     $char=pack('U',$char_id);
 293
 294     if($out_char=&get_char_attribute($char,'=jis-x0208')){
 295         return pack("S",$out_char|0x8080);
 296     }else{
 297         foreach $out_cs (@order){
 298             if($out_cs eq 'UniJIS'
 299                and &get_char_attribute($char,"adobe-unijis-utf16-h")){
 300                 if($out_char_id=&get_char_attribute($char,'=ucs@jis')
 301                    or $out_char_id=&get_char_attribute($char,'=ucs')){
 302                     return "\\UTF{".sprintf("%X",$out_char_id)."}";
 303                 }
 304             }elsif($out_cs eq 'UniGB'
 305                    and &get_char_attribute($char,"adobe-unigb-ucs2-h")){
 306                 if($out_char_id=&get_char_attribute($char,'=ucs@gb')
 307                    or $out_char_id=&get_char_attribute($char,'=ucs')){
 308                     return "\\UTFC{".sprintf("%X",$out_char_id)."}";
 309                 }
 310             }elsif($out_cs eq 'UniCNS'
 311                    and &get_char_attribute($char,"adobe-unicns-ucs2-h")){
 312                 if($out_char_id=&get_char_attribute($char,'=ucs@cns')
 313                    or $out_char_id=&get_char_attribute($char,'=ucs')){
 314                     return "\\UTFT{".sprintf("%X",$out_char_id)."}";
 315                 }
 316             }elsif($out_cs eq 'UniKS'
 317                    and &get_char_attribute($char,"adobe-uniks-ucs2-h")){
 318                 if($out_char_id=&get_char_attribute($char,'=ucs@ks')
 319                    or $out_char_id=&get_char_attribute($char,'=ucs')){
 320                     return "\\UTFK{".sprintf("%X",$out_char_id)."}";
 321                 }
 322             }elsif($out_cs eq 'GT'){
 323                 return $gt if($gt=&get_macro_for_GT($char_id));
 324             }elsif($out_cs eq 'Multi'){
 325                 if($out_char_id=&get_char_attribute($char,'=ucs')){
 326                     return "\\UTFM{".sprintf("%X",$out_char_id)."}";
 327                 }
 328             }
 329         }
 330     }
 331     return undef;
 332 }
 333
 334 sub get_ids{
 335     # argument: <character>
 336     # return: ids
 337     my($char)=@_;
 338     my $ids="";
 339     $ids=&get_char_attribute($char,"ids-aggregated")
 340         or &get_char_attribute($char,"ids");
 341     $ids=decode('utf8', $ids) if($perl58);
 342     return $ids;
 343 }
 344
 345 sub get_char_id_for_ids{
 346     # argument: <character>
 347     # return: char-id
 348     my($ids)=@_;
 349     my($output_char);
 350     $ids=decode('utf8', $ids) if($perl58);
 351
 352     if(($output_char)=&get_chars_matching("ids",$ids)){
 353         return unpack("U",$output_char);
 354     }else{
 355         return undef;
 356     }
 357 }
 358
 359 sub get_char_id{
 360     # argument: <char-id>, <input coding system>
 361     # return:   char-id.
 362     my($char_id,$in_cs)=@_;
 363     my($output_char);
 364
 365     if(($output_char)=&get_chars_matching("=$in_cs",$char_id)){
 366         return unpack("U",$output_char);
 367     }else{
 368         return $char_id;
 369     }
 370 }
 371
 372 sub get_macro_for_GT{
 373     # argument: <char-id>
 374     # return: TeX macro for GT fonts.
 375     my($char_id)=@_;
 376     my($char,$gt,$GT);
 377     $char=pack("U",$char_id);
 378     foreach (@GT){
 379         if($gt=&get_char_attribute($char,$_)){
 380             m/gt\-pj\-(\d+)/ and $GT=$1;
 381             last;
 382         }
 383     }
 384     if($gt){
 385         return "{\\fontfamily{"
 386             .sprintf("gto%02d",$GT)
 387             ."}\\selectfont\\char".($gt|0x8080)."}";
 388     }else{
 389         return undef;
 390     }
 391 }