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