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 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 $idsdata_file="idsdata.pl";
 102 $ids_start=0x00;
 103 $font_start=0;
 104
 105 if(-e $idsdata_file){
 106     require $idsdata_file;
 107 }
 108
 109 $ids_argc=0;
 110 $ids="";
 111
 112 @GT=(#"=gt","=gt-k",
 113      "=gt-pj-1","=gt-pj-2","=gt-pj-3","=gt-pj-4","=gt-pj-5",
 114      "=gt-pj-6","=gt-pj-7","=gt-pj-8","=gt-pj-9","=gt-pj-10",
 115      "=gt-pj-11"
 116      #,"=gt-pj-k1","=gt-pj-k2"
 117      );
 118 @HZK=("=hanziku-1","=hanziku-10","=hanziku-11","=hanziku-12",
 119       "=hanziku-2","=hanziku-3","=hanziku-4","=hanziku-5",
 120       "=hanziku-6","=hanziku-7","=hanziku-8","=hanziku-9");
 121 @CDP=("=big5-cdp");
 122
 123 while(<>){
 124     s/&(.*?);/&de_er($1)/ge;
 125     s/(.)/&get_char_in_ucsmcs($1,$in_cs)/ge if($in_cs ne 'ucs@mcs');
 126     @chars=split(//);
 127     for($i=0;$i<=$#chars;$i++){
 128         $char=$chars[$i];
 129         $char_id=unpack("U",$chars[$i]);
 130
 131         if($char_id<=0x7f){
 132             # Basic Latin
 133             print $char;
 134             next;
 135         }elsif($char_id>=0x2ff0 and $char_id<=0x2fff){
 136             # Ideographic Description Characters
 137             print &ids_parse();
 138             next;
 139         }elsif($char_id >= 0x20000 && $char_id <=0x2a6df){
 140             # CJK Unified Ideographs Extension B
 141             if(not defined($ids{$char}) and $ids{$char}[1]>=0){
 142                 $ids{$char}[0]=$font_start;
 143                 $ids{$char}[1]=$ids_start;
 144                 $ids_start++;
 145                 if($ids_start>255){
 146                     $ids_start=0;
 147                     $font_start++;
 148                 }
 149             }
 150             print "{\\fontencoding{OT1}\\fontfamily{" .
 151                 sprintf("chise%03d",$ids{$char}[0]) .
 152                 "}\\selectfont\\char$ids{$char}[1]}";
 153             next;
 154         }else{
 155             if(($out_char=&get_output_char($char_id))){
 156                 print $out_char;
 157             }else{
 158                 print &replace_ids(&get_ids($char));
 159             }
 160         }
 161     }
 162 }
 163
 164 open(IDSDATA,">$idsdata_file") or die;
 165 print IDSDATA 'use utf8;',"\n";
 166 foreach $ids (keys %ids){
 167     print IDSDATA '$ids{\'',$ids,'\'}='
 168         ,'[',join ",",@{$ids{$ids}},"];\n" if($perl56);
 169     print IDSDATA '$ids{\'',encode('utf8',$ids),'\'}='
 170         ,'[',join ",",@{$ids{$ids}},"];\n" if($perl58);
 171 }
 172 print IDSDATA '$font_start=',$font_start,";\n";
 173 print IDSDATA '$ids_start=',$ids_start,";\n";
 174 print IDSDATA "1;";
 175
 176 ### to use makefonts scripts, please uncomment the next lines.
 177 #if(-f $makefonts){
 178 #    system($perl,$makefonts) ==0
 179 #       or die "Could not make fonts: $?";
 180 #}else{
 181 #    print STDERR "cannot find $makefonts\n";
 182 #}
 183
 184 exit 0;
 185
 186 sub ids_parse{
 187     # arguments: none
 188     # return: return character for output,
 189     #          TeX macro for ids,
 190     #          or GETA character if ids is invalid.
 191     my($ids,$ids_argc)=&ids_rest("",0,$chars[$i]);
 192
 193     while($ids_argc>0){
 194         # We are in IDS.
 195         $i++;
 196         if($i>$#chars){
 197             print STDERR "IDS parse error: $ids\n";
 198             return $geta;
 199         }
 200
 201         ($ids,$ids_argc)=&ids_rest($ids,$ids_argc,$chars[$i]);
 202         if($ids_argc==0){
 203             if(($char_id=&get_char_id_for_ids($ids))
 204                and($out_char=&get_output_char($char_id))){
 205                 return $out_char;
 206             }else{
 207                 return &replace_ids($ids) if($perl56);
 208                 return encode('utf8', &replace_ids($ids)) if($perl58);
 209             }
 210         }
 211     }
 212 }
 213
 214 sub ids_rest{
 215     # arguments: <ids>, <rest number of arguments for ids>, <character>
 216     # return: ids and rest number of arguments for ids.
 217     my($ids,$ids_argc,$char)=@_;
 218     my($argc);
 219     $argc=&ids_argc($char);
 220     if($argc){
 221         $ids_argc+= $ids_argc==0 ? $argc : $argc-1;
 222     }else{
 223         $ids_argc--;
 224     }
 225     $ids.=$char if($perl56);
 226     $ids.=encode('utf8',$char) if($perl58);
 227     return ($ids,$ids_argc);
 228 }
 229
 230 sub replace_ids{
 231     # argument: <ids>
 232     # return: TeX macro for ids
 233     #          or GETA character if ids is invalid for KAGE.
 234     my($ids)=@_;
 235     $ids=&normalize_ids($ids,"UniJIS");
 236     return $geta if(($ids!~/[$idc]/)
 237                     or($ids=~/[\x{10000}-]/));
 238                     #irregular for KAGE.
 239     if(not defined($ids{$ids}) and $ids{$ids}[1]>=0){
 240         $ids{$ids}[0]=$font_start;
 241         $ids{$ids}[1]=$ids_start;
 242         $ids_start++;
 243     }
 244     if($ids_start>255){
 245         $ids_start=0;
 246         $font_start++;
 247     }
 248     return "{\\fontencoding{T1}\\fontfamily{"
 249         .sprintf("chisesub%03d",$ids{$ids}[0])
 250         ."}\\selectfont\\char$ids{$ids}[1]}";
 251 }
 252
 253 sub normalize_ids{
 254     # argument: <ids>, <output coding system>
 255     # return: ids or GETA character if ids is invalid for KAGE.
 256     my($ids,$out_cs)=@_;
 257     $ids = decode('utf8', $ids) if $perl58;
 258     $out_cs=~s/Uni(.+)/"ucs\@".lc($1)/e;
 259
 260     my $output_ids="";
 261     my($char,$char_id,$output_char_id);
 262     while($ids=~m/(.)/g){
 263         $char=$1;
 264         $char_id=unpack("U",$char);
 265         if($char=~/[$idc]/){
 266             $output_ids.=$char;
 267         }elsif($output_char_id=&get_char_attribute($char,"=$out_cs")){
 268             $output_ids.=pack("U",$output_char_id);
 269         }elsif($output_char_id=&get_char_attribute($char,"=ucs")){
 270             $output_ids.=pack("U",$output_char_id);
 271         }else{
 272             return $geta;
 273         }
 274     }
 275     return $output_ids;
 276 }
 277
 278 sub get_output_char{
 279     # argument: <char-id>
 280     # return: character in EUC-JP or TeX macro for pTeX.
 281     my($char_id)=@_;
 282     my($char,$out_char,$out_char_id,$gt);
 283
 284     $char=pack('U',$char_id);
 285
 286     if($out_char=&get_char_attribute($char,'=jis-x0208')){
 287         return pack("S",$out_char|0x8080);
 288     }else{
 289         foreach $out_cs (@order){
 290             if($out_cs eq 'UniJIS'
 291                and &get_char_attribute($char,"adobe-unijis-utf16-h")){
 292                 if($out_char_id=&get_char_attribute($char,'=ucs@jis')
 293                    or $out_char_id=&get_char_attribute($char,'=ucs')){
 294                     return "\\UTF{".sprintf("%X",$out_char_id)."}";
 295                 }
 296             }elsif($out_cs eq 'UniGB'
 297                    and &get_char_attribute($char,"adobe-unigb-ucs2-h")){
 298                 if($out_char_id=&get_char_attribute($char,'=ucs@gb')
 299                    or $out_char_id=&get_char_attribute($char,'=ucs')){
 300                     return "\\UTFC{".sprintf("%X",$out_char_id)."}";
 301                 }
 302             }elsif($out_cs eq 'UniCNS'
 303                    and &get_char_attribute($char,"adobe-unicns-ucs2-h")){
 304                 if($out_char_id=&get_char_attribute($char,'=ucs@cns')
 305                    or $out_char_id=&get_char_attribute($char,'=ucs')){
 306                     return "\\UTFT{".sprintf("%X",$out_char_id)."}";
 307                 }
 308             }elsif($out_cs eq 'UniKS'
 309                    and &get_char_attribute($char,"adobe-uniks-ucs2-h")){
 310                 if($out_char_id=&get_char_attribute($char,'=ucs@ks')
 311                    or $out_char_id=&get_char_attribute($char,'=ucs')){
 312                     return "\\UTFK{".sprintf("%X",$out_char_id)."}";
 313                 }
 314             }elsif($out_cs eq 'GT'){
 315                 return $gt if($gt=&get_macro_for_GT($char_id));
 316             }elsif($out_cs eq 'Multi'){
 317                 if($out_char_id=&get_char_attribute($char,'=ucs')){
 318                     return "\\UTFM{".sprintf("%X",$out_char_id)."}";
 319                 }
 320             }
 321         }
 322     }
 323     return undef;
 324 }
 325
 326 sub get_ids{
 327     # argument: <character>
 328     # return: ids
 329     my($char)=@_;
 330     my $ids="";
 331     $ids=&get_char_attribute($char,"ids-aggregated")
 332         or &get_char_attribute($char,"ids");
 333     $ids=decode('utf8', $ids) if($perl58);
 334     return $ids;
 335 }
 336
 337 sub get_char_id_for_ids{
 338     # argument: <character>
 339     # return: char-id
 340     my($ids)=@_;
 341     my($output_char);
 342     $ids=decode('utf8', $ids) if($perl58);
 343
 344     if(&get_reverse_db("ids")){
 345         if($output_char=$reverse_chardb{"ids"}->{$ids}){
 346             $output_char=decode('utf8',$output_char) if($perl58);
 347             $output_char=~s/^\?//;
 348             return unpack("U",$output_char);
 349         }
 350     }else{
 351         return undef;
 352     }
 353 }
 354
 355 sub get_char_in_ucsmcs{
 356     # argument: <character>, <input coding system>
 357     # return:   character in ucs@mcs.
 358     my($char,$in_cs)=@_;
 359     my($output_char);
 360
 361     if(&get_reverse_db("=$in_cs")){
 362         if($output_char=$reverse_chardb{"=$in_cs"}->{unpack("U",$char)}){
 363             $output_char=decode('utf8',$output_char) if($perl58);
 364             $output_char=~s/^\?//;
 365             return $output_char;
 366         }else{
 367             return $char;
 368         }
 369     }else{
 370         return $char;
 371     }
 372 }
 373
 374 sub get_macro_for_GT{
 375     # argument: <char-id>
 376     # return: TeX macro for GT fonts.
 377     my($char_id)=@_;
 378     my($char,$gt,$GT);
 379     $char=pack("U",$char_id);
 380     foreach (@GT){
 381         if($gt=&get_char_attribute($char,$_)){
 382             m/gt\-pj\-(\d+)/ and $GT=$1;
 383             last;
 384         }
 385     }
 386     if($gt){
 387         return "{\\fontfamily{"
 388             .sprintf("gto%02d",$GT)
 389             ."}\\selectfont\\char".($gt|0x8080)."}";
 390     }else{
 391         return undef;
 392     }
 393 }