2 # This script requires 't1asm' program, which is part of t1utils package,
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.
17 my $dbpath="/Users/izumi/.chise/glyph.db"; # Set to your DB path.
19 my $db = new BerkeleyDB::Hash
20 -Filename => $dbpath, -Flags => DB_CREATE
21 || print STDERR "Cannot open $dbpath. Do not use glyph database.\n";
28 my ($fontname, $fullname, $familyname,
29 $weight, $version, $uniqueID,
30 $numchars, $encoding) = @_;
32 %!PS-Adobe-Font-1.0: $fontname
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
46 /isFixedPitch true def
47 /UnderlinePosition -200 def
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
63 2 index /CharStrings $numchars dict dup begin
77 dup/FontName get exch definefont pop
78 mark currentfile closefile
83 # Convert svg to Type1 charstring.
84 # Return: Type1 charstring.
87 my @paths= split(/\n/, $svg);
88 my ($x1, $y1, $x2, $y2);
89 my $glyph= "\{\n0 1000 hsbw\n";
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));
100 $glyph.=sprintf("%d %d rmoveto\n", $x1-$x2, $y1-$y2);
102 $glyph.= "$x1 $y1 rmoveto\n";
104 foreach my $pair (@point_pair) {
105 ($x2, $y2) = split(/,/, $pair);
107 $glyph.=sprintf("%d %d rlineto\n", $x2-$x1, $y2-$y1);
110 $glyph.= "closepath\n";
112 return $glyph.= "endchar\n\} |-\n";
115 # Query KAGE server and generate Type1 charstrings.
116 # Return: charstrings, encoding vector, and number of chars.
118 my ($requests, $suffix) = @_; # Receive REF for @requests array.
119 my $charstrings = "";
121 my $encoding=""; # /Encoding vector
122 my $blackbox=<<'BLACKBOX';
133 foreach my $req (@$requests){
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";
144 # If glyph is not yet in DB, query KAGE server.
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.
152 while(<$kageserver>){
154 next unless m|^location:\s+http://([a-z0-9.:]+)/|i;
158 print STDERR "Connecting $location...\n";
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>;
165 $svg =~ s/\r//gm; # remove CR.
166 $svg =~ s/^.+\n\n//ms; # remove HTTP header.
171 print STDERR "Cannot connect to KAGE server at $kageaddr.\n";
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";
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;
186 $charstrings.= "/$char $charstring";
187 $encoding.= "dup $charnum/$char put\n";
190 return ($charstrings, $encoding, $charnum);
197 # Read ids data generated by outCMAP
198 my $idsdata="idsdata.pl";
199 my ($font_start, $ids_start, %ids);
201 # "require" doesn't work well.
202 # I don't know why...
203 open (my $data, "<$idsdata");
209 die "Cannot read $idsdata\n";
212 # Create (a nested) list of requests.
213 # $Request[font-number][char-code]='uhhhh...'
215 foreach my $key (keys %ids){
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.
232 $Requests[$ids{$key}[0]]->[$ids{$key}[1]]=$code;
236 foreach my $fontnum (0 .. $#Requests){
237 my @faces=(['Mincho', 'min', 'mincho'],
238 ['Gothic', 'got', 'gothic']
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
245 # mincho= 430000..., gothic 440000...
246 my $unique_id=430000+$fontnum+$i*10000;
248 my($charstrings, $encoding, $charnum)=
249 makefont($Requests[$fontnum], $suffix);
251 $encoding = sprintf("/Encoding %d array\n%sreadonly def",
252 $charnum, $encoding);
255 printheader($fontname, # FontName
256 $fontname, # FullName
257 'Chise', # FamilyName
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");
269 system("$pfaedit -script $cleanup_script $pfbname");