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