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