#!Perl
#--------------------------------------------------------------------------
# mac_font_sheet.pl -- version 2 (1998-03-05)
# Author: Sean M. Burke (sburke@netadventure.net)
#
# Run me under MacPerl and I'll make a fontsheet, in RTF and in HTML, of
# all the fonts installed on this box; I'll put the fontsheet on the desktop.
#
#--------------------------------------------------------------------------
# Availability & Copying:
#
# mac_font_sheet.pl is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by the
# Free Software Foundation, version 2.
#
# mac_font_sheet.pl is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
# To see a copy of the GNU General Public License, see
# http://www.ling.nwu.edu/~sburke/gnu_release.html, or write to the
# Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
#--------------------------------------------------------------------------
# Rev notes:
# 1998-02-23: Version 1 -- released. Whee.
# 1998-03-05: Version 2 -- now spits out the font sheet in HTML, too
use Mac::Fonts;
$greek = "Lorem ipsum dolor sit amet, consectetaur adipisicing elit.";
$greek_point_size = 22; # used for RTF
$title_point_size = 12; # used for RTF
$display_font = "Times"; # used for RTF
$header = '{\header \pard\qr\plain\f0\chpgn\par}'; # used for RTF
# set to '' for no page numbering
#End of configurables.
# Don't mess with the code below here unless you know what you're doing.
#--------------------------------------------------------------------------
$charset = '\fcharset77'; # I've no idea what this is, but MSWord likes it
$now = epoch2rtf($^T);
$greek_point_size *= 2; # to get twips
$title_point_size *= 2; # to get twips
$machine = $root = MacPerl::MakePath(scalar( MacPerl::Volumes ));
$machine =~ s/\W+/_/g; # just cuz
$outname = "${root}desktop folder:font_sheet.rtf";
$outname_html = "${root}desktop folder:font_sheet.html";
print "Getting all installed fonts. This make take 3 or 4 minutes...\n";
# Make a list of all available fonts.
# CRUDE HACK! CRUDE HACK! CRUDE HACK! CRUDE HACK! CRUDE HACK!
for ($i = 1; $i < 65536; $i++) {
$fonts{$name} = $i if ($name = GetFontName($i)) ne ''
and $name =~ /^\w/s;
}
@fonts = sort {lc($a) cmp lc($b)} (keys %fonts);
die "No fonts found! Spork error 51863!!!!" unless @fonts;
die "Display font $display_font not found!!!" unless
grep($_ eq $display_font, @fonts);
unshift(@fonts, $display_font); # so f0 will be the display font
die "Can't open output file $outname"
unless open(OUTFILE, ">$outname");
die "Can't open output file $outname_html"
unless open(OUTFILE_HTML, ">$outname_html");
print "Outputting to $outname and $outname_html\n";
# Start the file and emit the font table
print OUTFILE "{\\rtf1\\mac \\deff0 {\\fonttbl\n";
print OUTFILE_HTML
"Font Sheet
\n$#fonts installed fonts:\n\n";
foreach (0 .. $#fonts) {
$name = $fonts[$_];
$name =~ s/ / /g;
print OUTFILE "{\\f$_\\fnil $charset $fonts[$_];}\n";
print OUTFILE_HTML "- ",
$greek,
" ($name)\n";
}
print OUTFILE_HTML "
\n\n";
close(OUTFILE_HTML);
print OUTFILE "}\n{\\colortbl\\red0\\green0\\blue0;}
{\\stylesheet{\\fs20 \\snext0 Normal;}}\n{\\info
{\\creatim$now}{\\revtim$now}
{\\title fontsheet for \"$machine\" at ", scalar(localtime),
"}}$header\n
{\\f0\\fs18 $#fonts installed fonts:\}\n";
# Now actually emit the sample text
foreach (1 .. $#fonts) {
$name = $fonts[$_];
$name =~ s/ /\\~/g;
print OUTFILE
"\\par\\pard {\\f0$title_point_size\\bullet\\~}",
"{\\f$_\\fs$greek_point_size $greek}",
"{\\f0\\fs$title_point_size\\~($name)}\n"
}
print OUTFILE "}\n";
close(OUTFILE);
MacPerl::SetFileInfo('MSWD', 'TEXT', $outname);
MacPerl::SetFileInfo('MOSS', 'TEXT', $outname_html);
print "Done. Runtime: ", time - $^T, "s\n\n";
exit;
#--------------------------------------------------------------------------
sub epoch2rtf {
local(@bits) = (localtime($_[0]))[5,4,3,2,1,0];
# Note that this is local time. I guess that's right
++$bits[1]; # PERL counts January=0 but RTF counts January=1
$bits[0] += 1900;
return sprintf('\yr%d\mo%d\dy%d\hr%d\min%d\sec%d', @bits);
}
__END__