makefonts.pl

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