makefonts.pl

   1 #!/usr/bin/perl -w -CSD
   2 # This script requires 't1asm' program, which is part of t1utils package,
   3 # and 'pfaedit'.
   4
   5 use strict;
   6 use utf8;
   7 use IO::Socket::INET;
   8 use BerkeleyDB;
   9 require 5.008001;
  10
  11 #my $kageaddr="home.fonts.jp:5100"; # Specify port number!
  12 #my $kageaddr="fonts.jp:80"; # Specify port number!
  13 #my $kagecgi="/~kamichi/test/kagecgi.cgi"; #
  14 #my $kagecgi="v0.4/engine/kage.cgi"; #
  15 my $kageaddr="localhost:80"; # Specify port number!
  16 my $kagecgi="cgi-bin/kage.cgi"; #
  17
  18 my $t1asm = "/usr/bin/env t1asm"; # point to 't1asm' executable.
  19 #die "Cannot execute $t1asm. Abort.\n" unless -x $t1asm;
  20 #my $pfaedit="/usr/bin/env pfaedit"; # point to 'pfaedit' executable.
  21 my $pfaedit="/usr/bin/env fontforge"; # point to 'fontforge' executable.
  22 #die "Cannot execute $pfaedit. Abort.\n" unless -x $pfaedit;
  23
  24 my $omegadb_path="";   # Check the path of omegadb, if needed.
  25 my $cleanup_script=""; # Check the path of pfaedit script, if needed.
  26
  27 unless($omegadb_path){
  28     if(-w '/usr/local/share/chise/omega'){
  29         $omegadb_path='/usr/local/share/chise/omega';
  30     }elsif(-w '/usr/share/chise/omega'){
  31         $omegadb_path='/usr/share/chise/omega';
  32     }elsif(-w '/sw/share/chise/omega'){
  33         $omegadb_path='/sw/share/chise/omega';
  34     }elsif(-w '/usr/local/lib/chise/omega'){
  35         $omegadb_path='/usr/local/lib/chise/omega';
  36     }else{
  37         $omegadb_path=".";
  38     }
  39 }
  40 $omegadb_path=~s!/$!!;
  41
  42 my $makefonts_dir;
  43 ($makefonts_dir=$0)=~s!^(.*)/.*$!$1!;
  44
  45 unless($cleanup_script){
  46     if(-e "$makefonts_dir/eps2t1.pfe"){
  47         $cleanup_script="$makefonts_dir/eps2t1.pfe";
  48     }elsif(-e "/usr/local/share/texmf/omega/ocp/chise_rqd/chise/eps2t1.pfe"){
  49         $cleanup_script="/usr/local/share/texmf/omega/ocp/chise_rqd/chise/eps2t1.pfe";
  50     }elsif(-e "/usr/local/share/texmf/omega/ocp/local/chise/eps2t1.pfe"){
  51         $cleanup_script="/usr/local/share/texmf/omega/ocp/local/chise/eps2t1.pfe";
  52     }elsif(-e "/usr/share/texmf/omega/ocp/chise_rqd/chise/eps2t1.pfe"){
  53         $cleanup_script="/usr/share/texmf/omega/ocp/local/chise/eps2t1.pfe";
  54     }elsif(-e "/sw/share/texmf/omega/ocp/local/chise/eps2t1.pfe"){
  55         $cleanup_script="/sw/share/texmf/omega/ocp/local/chise/eps2t1.pfe";
  56     }
  57 }
  58
  59 unless($cleanup_script and -e $cleanup_script){
  60     print STDERR "eps2t1.pfe not found!\n",
  61     "please check \$cleanup_script in $0.\n";
  62     exit 1;
  63 }
  64
  65 my $dbpath="$omegadb_path/glyph.db"; # check your DB path.
  66
  67 # Open Glyph Database
  68 my $db = new BerkeleyDB::Hash
  69     -Filename => $dbpath, -Flags => DB_CREATE
  70     || print STDERR "Cannot open $dbpath. Do not use glyph database.\n";
  71
  72 ####################
  73 #### subroutines ###
  74 ####################
  75
  76 sub printheader {
  77 my ($fontname, $fullname, $familyname,
  78     $weight, $version, $uniqueID,
  79     $numchars,  $encoding) = @_;
  80 return <<"HEADER";
  81 %!PS-Adobe-Font-1.0: $fontname
  82 11 dict begin
  83 /PaintType 0 def
  84 /FontType 1 def
  85 /FontMatrix [0.001 0 0 0.001 0 0] readonly def
  86 /UniqueID $uniqueID def
  87 /FontBBox [0 -100 1000 900 ]readonly def
  88 /FontInfo 8 dict dup begin
  89  /version ($version) readonly def
  90  /Notice (Copyright (C) Chise Project; Glyphs generated by KAGE server) readonly def
  91  /FullName ($fullname) readonly def
  92  /FamilyName ($familyname) readonly def
  93  /Weight ($weight) readonly def
  94  /ItalicAngle 0 def
  95  /isFixedPitch true def
  96  /UnderlinePosition -200 def
  97 end readonly def
  98 $encoding
  99 currentfile eexec
 100 dup
 101 /Private 9 dict dup begin
 102 /-|{string currentfile exch readstring pop}executeonly def
 103 /|-{noaccess def}executeonly def
 104 /|{noaccess put}executeonly def
 105 /BlueValues [] noaccess ND
 106 /UniqueID $uniqueID def
 107 /MinFeature{16 16} |-
 108 /ForceBold false def
 109 /password 5839 def
 110 /lenIV 4 def
 111 end readonly def
 112 2 index /CharStrings $numchars dict dup begin
 113 HEADER
 114 }
 115
 116 sub printfooter {
 117 return <<"FOOTER";
 118 /.notdef {
 119         0 1000 hsbw
 120         endchar
 121         } |-
 122 end
 123 end
 124 readonly put
 125 noaccess put
 126 dup/FontName get exch definefont pop
 127 mark currentfile closefile
 128 cleartomark
 129 FOOTER
 130 }
 131
 132 # Convert eps to Type1 charstring.
 133 # Return: Type1 charstring.
 134 sub eps2charstring {
 135     my ($eps) = @_;
 136     my @paths= split(/\n/, $eps);
 137     my ($x1, $y1, $x2, $y2);
 138     my $glyph= "\{\n0 1000 hsbw\n";
 139     for (@paths){
 140         if(m/error/i or m/bad/i){
 141             return undef;
 142         }
 143         next if(/^%/);
 144         if(m/([\-\d]+)\s+([\-\d]+)\s+moveto/){
 145             $x1=$1; $y1=$2; $y1=$y1+100;
 146             if(defined $x2){
 147                 $glyph.=sprintf("%d %d rmoveto\n",$x1-$x2,$y1-$y2);
 148             }else{
 149                 $glyph.="$x1 $y1 rmoveto\n";
 150             }
 151         }
 152         elsif(m/([\-\d]+)\s+([\-\d]+)\s+lineto/){
 153             $x2=$1; $y2=$2; $y2=$y2+100;
 154             $glyph.=sprintf("%d %d rlineto\n",$x2-$x1,$y2-$y1);
 155             $x1=$x2,$y1=$y2;
 156         }
 157         elsif(/closepath/){
 158             $glyph.="closepath\n";
 159         }
 160     }
 161     return $glyph.= "endchar\n\} |-\n";
 162 }
 163
 164 # Query KAGE server and generate Type1 charstrings.
 165 # Return: charstrings, encoding vector, and number of chars.
 166 sub makefont{
 167     my ($requests, $suffix) = @_; # Receive REF for @requests array.
 168     my $charstrings = "";
 169     my $charnum=0;
 170     my $encoding=""; # /Encoding vector
 171     my $blackbox=<<'BLACKBOX';
 172     {
 173         0 1000 hsbw
 174          100 800 rmoveto
 175          -800 vlineto
 176          800 hlineto
 177          800 vlineto
 178          closepath
 179          endchar} |-
 180 BLACKBOX
 181
 182      foreach my $req (@$requests){
 183          # Note:
 184          # Referene passing destroys the original array!
 185          my $request="$req.$suffix";
 186          my ($eps, $charstring);
 187          my $char = sprintf("ch%03d", $charnum);
 188          if(defined $db && $db->db_get($request, $eps)==0){
 189              # If glyph is already in DB, then use it.
 190              $charstring = eps2charstring($eps);
 191              print STDERR "Use cached glyph for $request.\n";
 192          }else{
 193              # If glyph is not yet in DB, query KAGE server.
 194              my $kageserver;
 195              my $location; # For redirection
 196              if($kageserver = IO::Socket::INET->new("$kageaddr")){
 197                  print $kageserver "GET /$kagecgi?$req&shotai=$suffix&type=eps\r\n";
 198 #                print $kageserver "HEAD /$kagecgi?$req&shotai=$suffix&type=svg HTTP/1.1\r\n";
 199 #                print $kageserver "Host: $kageaddr\r\n\r\n";
 200 #                #Get redirection info.
 201 #                local $/="\r\n";
 202 #                while(<$kageserver>){
 203 #                    chomp;
 204 #                    next unless m|^location:\s+http://([a-z0-9.:]+)/|i;
 205 #                    $location=$1;
 206 #                }
 207 #                close($kageserver);
 208 #                if($location
 209 #                   and $kageserver=IO::Socket::INET->new($location)){
 210 #                    print $kageserver "GET /$request.svg HTTP/1.1\r\n";
 211 #                    print $kageserver "Host: $location\r\n\r\n";
 212                      local $/; $eps=<$kageserver>;
 213                      close($kageserver);
 214                      $eps =~ s/\r//gm; # remove CR.
 215                      $eps =~ s/^.+\n\n//ms; # remove HTTP header.
 216 #                }else{
 217 #                    $eps="error";
 218 #                }
 219              }else{
 220                  print STDERR "Cannot connect to KAGE server at $kageaddr.\n";
 221                  $eps="error";
 222              }
 223              if($charstring = eps2charstring($eps)){
 224                  if(defined $db && $db->db_put($request, $eps)==0){
 225                      # If glyph request is successful, then store it to DB.
 226                      print STDERR "Glyph for $request cached.\n";
 227                  }
 228              }else{
 229                  # If glyph request failed, then print a black box.
 230                  # Do not store glyph to DB.
 231                  print STDERR "Glyph request for $request failed.\n";
 232                  $charstring = $blackbox;
 233              }
 234          }
 235          $charstrings.= "/$char $charstring";
 236          $encoding.= "dup $charnum/$char put\n";
 237          $charnum++;
 238      }
 239     return ($charstrings, $encoding, $charnum);
 240 }
 241
 242 ##############
 243 #### main ####
 244 ##############
 245
 246 # Read ids data generated by inCHISE
 247 my $idsdata="$omegadb_path/idsdata.txt";
 248 my ($font_start, $ids_start, %ids);
 249 if(-e $idsdata){
 250     # "require" doesn't work well.
 251     # I don't know why...
 252     open (my $data, "<:utf8","$idsdata");
 253     while(<$data>){
 254         utf8::decode($_);
 255         if(m/^START\t(\d+)\t(\d+)/){
 256             $font_start=$1,$ids_start=$2;
 257         }elsif(m/^(.*?)\t(\d+)\t(\d+)/){
 258             $ids{$1}=[$2,$3,];
 259         }
 260     }
 261     close($data);
 262 }else{
 263     die "Cannot read $idsdata\n";
 264 }
 265
 266 # Create (a nested) list of requests.
 267 # $Request[font-number][char-code]='uhhhh...'
 268 my @Requests;
 269 foreach my $key (keys %ids){
 270     my $code="";
 271     my @elements=();
 272     foreach my $elem (split(//,$key)){
 273         $elem=unpack('U', $elem);
 274         if($elem < 0x10000){ # BMP
 275             $code.=sprintf("u%04x", $elem);
 276         }elsif($elem < 0x110000){ # needs surrogate pair
 277             my $high_surrogate=($elem-0x10000) / 0x400 + 0xd800;
 278             my $low_surrogate=($elem-0x10000) % 0x400 + 0xdc00;
 279             $code.=sprintf("u%04xu%04x",
 280                            $high_surrogate, $low_surrogate);
 281         }else{ #out of range.
 282             $code="uffff"; # this generates KAGE server error.
 283             last;
 284         }
 285     }
 286     $code=~s/(.)u/$1.u/g;
 287     $Requests[$ids{$key}[0]]->[$ids{$key}[1]]=$code;
 288 }
 289
 290 print STDERR "Sending query to KAGE server at $kageaddr.\n";
 291
 292 # Create fonts.
 293 foreach my $fontnum (0 .. $#Requests){
 294     my @faces=(['Mincho', 'min', 'mincho'],
 295                ['Gothic', 'got', 'gothic']
 296                );
 297     foreach my $i (0 .. 1){
 298         my $fontname=sprintf("Chise%s%03d", $faces[$i][0], $fontnum);
 299         my $pfbname=sprintf("chisesub%03d%s.pfb", $fontnum, $faces[$i][1]);
 300         my $suffix=$faces[$i][2]; # .mincho or .gothic
 301         # Unique ID:
 302         # mincho= 430000...,  gothic 440000...
 303         my $unique_id=430000+$fontnum+$i*10000;
 304
 305         my($charstrings, $encoding, $charnum)=
 306             makefont($Requests[$fontnum], $suffix);
 307
 308         $encoding = sprintf("/Encoding %d array\n%sreadonly def",
 309                             $charnum, $encoding);
 310
 311         my $font =
 312             printheader($fontname, # FontName
 313                         $fontname, # FullName
 314                         'Chise',   # FamilyName
 315                         'Medium',  # Weight
 316                         '001.001', # version (whatever)
 317                         $unique_id, # UniqueID (should be >= 4000000)
 318                         $charnum+1, # Number of chars (.notdef included)
 319                         $encoding   # Encoding vector
 320                         ) . $charstrings . printfooter();
 321         # Convert font to PFB
 322         open(my $asm, '|-', "$t1asm -b -o $pfbname");
 323         print $asm $font;
 324         close($asm);
 325         # Clean up PFB
 326         system("$pfaedit -script $cleanup_script $pfbname");
 327     }
 328 }
 329
 330 # Close Database
 331 undef $db;