# RCS Status : $Id: FontInfo.pm,v 1.12 2003-10-23 14:12:27+02 jv Exp $
# Author : Johan Vromans
# Created On : December 1998
# Last Modified By: Johan Vromans
# Last Modified On: Thu Oct 23 14:12:25 2003
# Update Count : 57
# Status : Released
################ Module Preamble ################
package PostScript::FontInfo;
use strict;
BEGIN { require 5.005; }
use IO qw(File);
use vars qw($VERSION);
$VERSION = "1.05";
sub new {
my $class = shift;
my $font = shift;
my (%atts) = (error => 'die',
verbose => 0, trace => 0, debug => 0,
@_);
my $self = { file => $font };
bless $self, $class;
return $self unless defined $font;
$self->{debug} = $atts{debug};
$self->{trace} = $self->{debug} || $atts{trace};
$self->{verbose} = $self->{trace} || $atts{verbose};
my $error = lc($atts{error});
$self->{die} = sub {
die(@_) if $error eq "die";
warn(@_) if $error eq "warn";
};
eval {
$self->_loadinfo;
};
if ( $@ ) {
$self->_die($@);
return undef;
}
$self;
}
sub FileName { my $self = shift; $self->{file}; }
sub FontName { my $self = shift; $self->{name}; }
sub FullName { my $self = shift; $self->{fullname};}
sub InfoData { my $self = shift; $self->{data}; }
sub FontFamily { my $self = shift; $self->{family}; }
sub Version { my $self = shift; $self->{version}; }
sub PCFileNamePrefix { my $self = shift; $self->{pcprefix}; }
sub _loadinfo ($) {
my ($self) = shift;
my $data; # inf data
eval { # so we can use die
my $fn = $self->{file};
my $fh = new IO::File; # font file
my $sz = -s $fn; # file size
$fh->open ($fn) || $self->_die("$fn: $!\n");
print STDERR ("$fn: Loading INF file\n") if $self->{verbose};
# Read in the inf data.
my $len = 0;
while ( $fh->sysread ($data, 32768, $len) > 0 ) {
$len = length ($data);
}
$fh->close;
print STDERR ("Read $len bytes from $fn\n") if $self->{trace};
$self->_die("$fn: Expecting $sz bytes, got $len bytes\n") unless $sz == $len;
# Normalise line endings.
$data =~ s/\015\012?/\n/g;
if ( $data !~ /^FontName\s+\(\S+\)$/m ) {
$self->_die("$fn: Not a recognizable INF file\n");
}
};
$self->{name} = $1 if $data =~ /^FontName\s+\((\S+)\)$/mi;
$self->{fullname}= $1 if $data =~ /^FullName\s+\((.+?)\)$/mi;
$self->{family} = $1 if $data =~ /^FamilyName\s+\((.+)\)$/mi;
$self->{version} = $1 if $data =~ /^Version\s+\((.+)\)$/mi;
$self->{pcprefix}= lc($1)
if $data =~ /^PCFileNamePrefix\s+\((.+)\)$/mi;
$self->{data} = $data;
$self;
}
sub _die {
my ($self, @msg) = @_;
$self->{die}->(@msg);
}
1;
__END__
################ Documentation ################
=head1 NAME
PostScript::FontInfo - module to fetch data from PostScript font C<.inf> files
=head1 SYNOPSIS
my $info = new PostScript::FontInfo (filename, options);
print STDOUT ("Name = ", $info->name, "\n");
=head1 DESCRIPTION
This package allows font info files, so called C<.inf> files, to be
read and (partly) parsed.
=head1 CONSTRUCTOR
=over 4
=item new ( FILENAME [ , OPTIONS ] )
The constructor will read the file and parse its contents.
=back
=head1 OPTIONS
=over 4
=item error => [ 'die' | 'warn' | 'ignore' ]
B<DEPRECATED>. Please use 'eval { ... }' to intercept errors.
How errors must be handled. Default is to call die().
In any case, new() returns a undefined result.
Setting 'error' to 'ignore' may cause surprising results.
=item verbose => I<value>
Prints verbose info if I<value> is true.
=item trace => I<value>
Prints tracing info if I<value> is true.
=item debug => I<value>
Prints debugging info if I<value> is true.
Implies 'trace' and 'verbose'.
=back
=head1 INSTANCE METHODS
Each of these methods can return C<undef> if the corresponding
information could not be found in the file.
=over 4
=item FileName
The name of the file, e.g. 'tir_____.inf'.
=item FontName
The name of the font, e.g. 'Times-Roman'.
=item FullName
The full name of the font, e.g. 'Times Roman'.
=item FontFamily
The family name of the font, e.g. 'Times'.
=item Version
The version of the font, e.g. '001.007'.
=item PCFileNamePrefix
The prefix used to form MS-DOS compliant file names, e.g. 'tir__'.
=item InfoData
The complete contents of the file, normalised to Unix-style line endings.
=back
=head1 AUTHOR
Johan Vromans, Squirrel Consultancy <jvromans@squirrel.nl>
=head1 COPYRIGHT and DISCLAIMER
This program is Copyright 2003,1998 by Squirrel Consultancy. All
rights reserved.
This program is free software; you can redistribute it and/or modify
it under the terms of either: a) the GNU General Public License as
published by the Free Software Foundation; either version 1, or (at
your option) any later version, or b) the "Artistic License" which
comes with Perl.
This program 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 either the
GNU General Public License or the Artistic License for more details.
=cut