"Fossies" - the Fresh Open Source Software Archive 
Member "MagickStudio-1.9.6/fonts/type.sh" (14 Feb 2021, 11714 Bytes) of package /linux/www/MagickStudio-1.9.6.tar.gz:
As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Bash source code syntax highlighting (style:
standard) with prefixed line numbers and
code folding option.
Alternatively you can here
view or
download the uninterpreted source code file.
1 #!/usr/bin/perl -w
2 #
3 use strict;
4 (my $prog = $0) =~ s/^.*\///;
5 sub Usage {
6 die @_, &herefile( qq{
7 | Usage: $prog > ~/.magick/type.xml
8 |
9 | Generate an ImageMagick font list "type.xml" file for ALL fonts (both
10 | true type fonts (ttf) and Ghostscript fonts (afm)) currently on the
11 | local linux system. The fonts are found using the linux "locate"
12 | command, and the output informs IM of their location, font type, name
13 | and family.
14 |
15 | When the file has been generated you can then see a list of the
16 | fonts found with...
17 | convert -list type
18 | And use the fonts, by name, with commands like...
19 | convert -font Candice -pointsize 72 label:Anthony x:
20 | Instead of specifying the specific TTF font file
21 | convert -font ~/lib/font/truetype/favoriate/candice.ttf \
22 | -pointsize 72 label:Anthony x:
23 |
24 | NOTE before IM v6.1.2-3 the font list file was called "type.mgk" and
25 | not "type.xml".
26 |
27 | Note: IM version 5.5.7 installed as a system program (such as from a
28 | linux RPM) will NOT read this file from the home directory location
29 | above automatically. To fix this you may need to add a line to the
30 | systems "type.mgk" file such as...
31 | <include file="../../../../../../../home/anthony/.magick/type.mgk"/>
32 | Note that the path must be a relative path, thus the numerious ".."
33 | in the above line, you can specify more ".." than you really need.
34 |
35 | Anthony Thyssen May 2003
36 });
37 }
38 # Internal working notes...
39 #
40 # This script requires the linux "locate" command to find the fonts.
41 # originally it needed an extrenal tool to read TTF fonts, but now
42 # that is built-in.
43 #
44 # WARNING: Input arguments are NOT tested for correctness.
45 # This script represents a security risk if used ONLINE.
46 # I accept no responsiblity for misuse. Use at own risk.
47 #
48 # The original version of this hack script was found on
49 # http://studio.imagemagick.org/pipermail/magick-users/2003-March/001703.html
50 # by raptor <raptor@unacs.bg>, presumaibly around March 2002
51 #
52 # Re-Write by Anthony Thyssen <anthony@cit.gu.edu.au>, August 2002
53 # May 2003 Update with TTF family names
54 # Oct 2005 Update to use "getttinfo" is available
55 #
56 use strict;
57 use Fcntl qw( O_RDONLY SEEK_SET );
58 binmode(STDOUT, ":utf8");
59 binmode(STDERR, ":utf8");
60
61 my $VERBOSE = 1; # verbose output of fonts found
62 my $DEBUG = 0; # debug TTF file decoding
63
64 # ======================================================================
65 # Subroutines...
66 # ======================================================================
67 #
68 # True Type fonts Handling
69 #
70 my $ttf_template = herefile( q{
71 | <type
72 | format="ttf"
73 | name="%s"
74 | glyphs="%s"
75 | />
76 });
77 my $ttf_template_full = herefile( q{
78 | <type
79 | format="ttf"
80 | name="%s"
81 | fullname="%s"
82 | family="%s"
83 | glyphs="%s"
84 | />
85 });
86
87 sub ttf_file_parse {
88 #
89 # Method for Parsing TTF files curtesy of
90 # Peter N Lewis <peter@stairways.com.au>
91 #
92 my $file = $_[0];
93 my ( $font_family, $font_fullname, $font_psname ) = ( '','','','' );
94
95 my ( $fh, $len );
96 unless ( sysopen( $fh, $file, O_RDONLY ) ) {
97 warn "Cannot open $file: $!\n";
98 return;
99 }
100 my $header;
101 unless ( sysread( $fh, $header, 12 ) ) {
102 warn "Cant read header: $file";
103 close($fh);
104 return;
105 }
106 my ( $sfnt_version, $numTables, $searchRange, $entrySelector, $rangeShift
107 ) = unpack( 'Nnnnn', $header );
108
109 my $sfnt_version_code = unpack( 'A4', $header );
110 unless ( $sfnt_version == 0x00010000
111 || $sfnt_version_code eq 'true'
112 || $sfnt_version_code eq 'typ1' ) {
113 warn "TTF Version mismatch, not a basic TrueType font file: $file";
114 close($fh);
115 return;
116 }
117
118 #print STDERR "TTF Table count: $numTables\n" if $DEBUG;
119 foreach ( 1..$numTables ) {
120 my $table_entry;
121 unless ( sysread( $fh, $table_entry, 16 ) ) {
122 warn "Cant read master table $_ from $file";
123 last;
124 }
125
126 my ( $table_tag, $table_checkSum, $table_offset, $table_length
127 ) = unpack( 'A4NNN', $table_entry );
128 #print STDERR "Table: $table_tag\n" if $DEBUG;
129 $table_tag eq 'name' or next;
130
131 my $table_header;
132 sysseek( $fh, $table_offset, SEEK_SET ) or die "Can't seek: $file";
133 sysread( $fh, $table_header, 6 );
134 my ( $table_format, $table_count, $table_stringOffset
135 ) = unpack( 'nnn', $table_header );
136 print STDERR "Name Table Entries: $table_count\n" if $DEBUG;
137 my $table_base = $table_offset + 6;
138 my $storage_base = $table_base + $table_count * 12;
139
140 foreach my $index ( 1..$table_count ) {
141 my $entry;
142 sysseek( $fh, $table_base + ($index-1)*12, SEEK_SET )
143 or die "Cant seek: $file";
144 sysread( $fh, $entry, 12 );
145 my ( $name_platformID, $name_encodingID, $name_languageID,
146 $name_id, $name_length, $name_offset
147 ) = unpack( 'nnnnnn', $entry );
148 print STDERR "Index[$index]: ", join ( ", ",
149 $name_platformID, $name_encodingID, $name_languageID,
150 $name_id, $name_length, $name_offset ), "\n" if $DEBUG;
151 #
152 # ID meanings : figured out from getttinfo
153 #
154 # Platform: 0=Apple 1=macintosh 3=microsoft
155 # Encoding: 0=unicode(8) 1=unicode(16)
156 # Language: 0=english 1033=English-US 1041=Japanese 2052=Chinese
157 #
158 next unless $name_languageID == 0
159 || $name_languageID == 1033
160 ;
161
162 my $name;
163 sysseek( $fh, $storage_base + $name_offset, SEEK_SET )
164 or die "Cant seek: $file";
165 sysread( $fh, $name, $name_length );
166
167 # Decode UTF-16 to UTF-8 if nessary
168 $name = pack("U*",unpack("n*", $name)) if $name_encodingID == 1;
169 $name =~ s/\0//g; # clean fonts use UTF-16 when it should be UTF-8
170 print STDERR "$name\n" if $DEBUG;
171
172 $font_family = $name if $name_id == 1;
173 #font_subfamily = $name if $name_id == 2; # (EG: Regular)
174 #font_identifier = $name if $name_id == 3; # Unique Name
175 $font_fullname = $name if $name_id == 4;
176 #font_version = $name if $name_id == 5;
177 $font_psname = $name if $name_id == 6; # Postscipt Name
178 #font_trademark = $name if $name_id == 7;
179 #font_manufacturer = $name if $name_id == 8;
180 #font_designer = $name if $name_id == 9;
181 }
182 last; # found "name" table -- skip any other tables as irrelevent
183 }
184 close( $fh );
185 return ( $font_family, $font_fullname, $font_psname );
186 }
187
188 sub ttf_name {
189 my $file = shift;
190
191 my ( $family, $fullname, $psname ) = &ttf_file_parse( $file );
192 print STDERR "$file\n\t==> $family -- $fullname -- $psname\n" if $DEBUG;
193
194 $fullname =~ s/[^\s\w-]//g; # Check: Pepsi.ttf
195 $fullname =~ s/^\s+//;
196 $fullname =~ s/\s+$//;
197 $fullname =~ s/(^|\s)-/$1/g;
198 $fullname =~ s/-(\s|$)/$1/g;
199
200 $family =~ s/[^\s\w-]//g; # Check: Pepsi.ttf
201 $family =~ s/^\s*//;
202 $family =~ s/\s*$//;
203 $family =~ s/\s*(MS|ITC)$//; # font factory ititials
204 $family =~ s/^(MS|ITC)\s*//;
205 $family =~ s/\s*(FB|MT)\s*/ /; # Check: MaturaScriptCapitals
206 $family =~ s/^Monotype\s*//; # Check: Corsiva
207 $family =~ s/^AR PL\s*//; # Check: gkai00mp.ttf
208
209 # Determine simple font name
210 # Junk/abbr decriptive strings, foundaries, etc
211 # Test with the fonts given
212 my $name = ($fullname);
213 $name =~ s/-/ /g;
214 $name =~ s/\s*(MS|ITC)$//; # font factory ititials
215 $name =~ s/^(MS|ITC)\s*//;
216 $name =~ s/\s*(FB|MT)\s*/ /; # Check: MaturaScriptCapitals
217 $name =~ s/^Monotype\s*//; # Check: Corsiva
218 $name =~ s/^AR PL\s*//; # Check: gkai00mp.ttf
219
220 $name =~ s/Regular//g; # Check: Gecko
221 $name =~ s/\bReg\b//g; # Check: agencyr.ttf
222 $name =~ s/\bNormal\b//g;
223 #$name =~ s/\bSans\b//g;
224 $name =~ s/\bDemi\s*[Bb]old\b/Db/g;
225 $name =~ s/\bCondensed\b/C/g;
226 $name =~ s/\bBold\b/B/g;
227 $name =~ s/\bItalic\b/I/g;
228 $name =~ s/\bExtra[Bb]old\b/Xb/g;
229 $name =~ s/\bBlack\b/Bk/g;
230 $name =~ s/\bHeavy\b/H/g;
231 $name =~ s/\bMedium\b/M/g; # Check: gkai00mp.ttf
232 $name =~ s/\bLight\b/L/g;
233 $name =~ s/\bOblique\b/Ob/g;
234
235 $name =~ s/\s+//g;
236
237 $fullname =~ s/\s+/ /g;
238 $fullname =~ s/\s$//;
239 $fullname =~ s/^\s//;
240
241 # Failed to parse TTF file?
242 return( ( $file =~ m/^.*\/(.*?).ttf$/ )[0] ) unless $name;
243
244 return ($name, $fullname, $family); # return the name if found!
245 }
246
247 sub do_ttf_fonts {
248 for my $file ( locate('.ttf') ) {
249 chop $file;
250 my (@ttf) = ttf_name($file);
251
252 print STDERR join( ' - ', @ttf), "\n" if $VERBOSE;
253 printf $ttf_template, @ttf, $file if @ttf == 1;
254 printf $ttf_template_full, @ttf, $file if @ttf == 3;
255 }
256 }
257
258
259 #---------------------------
260 #
261 # Adobe Type fonts
262 #
263 # Get font name from the AFM file
264 my $afm_template_full = herefile( q{
265 | <type
266 | format="type1"
267 | name="%s"
268 | fullname="%s"
269 | family="%s"
270 | glyphs="%s"
271 | metrics="%s"
272 | />
273 });
274
275 sub afm_name {
276 my $file = shift;
277
278 my( $name, $fullname, $family ) = ('','','');
279 if ( open AFM, $file ) {
280 while( <AFM> ) {
281 chop; last if /^StartCharMetrics/;
282 #$name = $1 if /^FontName (.*)/;
283 $fullname = $1 if /^FullName (.*)/;
284 $family = $1 if /^FamilyName (.*)/;
285 }
286 close AFM;
287
288 $family =~ s/\s*L$//; # just the stupid 'L'
289 $fullname =~ s/\bL\b//;
290
291 $name = $fullname;
292
293 $name =~ s/\bRegular\b//; # Junk/abbr decriptive strings
294 $name =~ s/\bDemi\s*[Bb]old\b/Db/g;
295 $name =~ s/\bCondensed\b/C/g;
296 $name =~ s/\bBold\b/B/g;
297 $name =~ s/\bItalic\b/I/g;
298 $name =~ s/\bExtra[Bb]old\b/Xb/g;
299 $name =~ s/\bBlack\b/Bk/g;
300 $name =~ s/\bHeavy\b/H/g;
301 $name =~ s/\bLight\b/L/g;
302
303 $name =~ s/[-\s]+//g;
304 $fullname =~ s/\s+/ /g;
305 $fullname =~ s/\s$//g;
306 $fullname =~ s/^\s//g;
307 } else {
308 warn "Cannot open $file";
309 }
310
311 return ($name, $fullname, $family ) if $name && $fullname && $family;
312 }
313
314 sub do_afm_fonts {
315 my %atf;
316 # locate abode font files
317 map { chop; my ($k) = m/^(.*?).pfb*$/; $atf{$k}{pfb} = $_ } locate('.pfb');
318 map { chop; my ($k) = m/^(.*?).afm*$/; $atf{$k}{afm} = $_ } locate('.afm');
319
320 # for each Abode font where BOTH files were found.
321 for my $key (keys %atf) {
322 next unless $atf{$key}{pfb} && $atf{$key}{afm};
323 my (@afm) = afm_name($atf{$key}{afm});
324
325 print STDERR join( ' - ', @afm), "\n" if $VERBOSE;
326 printf $afm_template_full, @afm, $atf{$key}{pfb}, $atf{$key}{afm}
327 if @afm == 3;
328 }
329 }
330
331 # -----------------------------
332 #
333 # Miscellanous functions
334 #
335 sub locate {
336 #return `locate -r $_[0]\$`;
337 return `locate $_[0] | grep $_[0]\$`;
338 }
339
340 sub herefile { # Handle a multi-line quoted indented string
341 my $string = shift;
342 $string =~ s/^\s*//; # remove start spaces
343 $string =~ s/^\s*\| ?//gm; # remove line starts
344 $string =~ s/\s*$/\n/g; # remove end spaces
345 return $string;
346 }
347
348 # ======================================================================
349 # Main Function
350 # ======================================================================
351
352
353 # HACK -- extract font names for the given TTF font file.
354 if ( @ARGV ) {
355 $DEBUG=1,shift if $ARGV[0] =~ /^-d$/i;
356 Usage unless $ARGV[0] =~ /\.ttf$/i;
357 for my $file ( @ARGV ) {
358 print join( ' - ', ttf_name($file) ), "\n";
359 }
360 exit 0;
361 }
362
363 # Generate the "type.xml" file.
364
365 # Do the job...
366 print herefile( q{
367 | <?xml version="1.0"?>
368 | <typemap>
369 });
370
371 print STDERR "Doing TTF fonts\n" if $VERBOSE;
372 do_ttf_fonts();
373 print STDERR "Doing ATM fonts\n" if $VERBOSE;
374 do_afm_fonts();
375
376 print "</typemap>\n";
377
378