File Coverage

lib/PostScript/Resources.pm

Criterion	Covered	Total	%
statement	125	171	73.1
branch	41	104	39.4
condition	8	19	42.1
subroutine	16	17	94.1
pod	3	4	75.0
total	193	315	61.2

# RCS Status      : $Id: Resources.pm,v 1.12 2004/12/18 16:40:52 jv Exp $# Author          : Johan Vromans
# Created On      : Januari 1999
# Last Modified By: Johan Vromans
# Last Modified On: Thu Oct 23 14:11:52 2003
# Update Count    : 187
# Status          : Released

################ Module Preamble ################

package PostScript::Resources;

use strict;

BEGIN { require 5.005; }

use IO qw(File);
use File::Basename;
use File::Spec;

use vars qw($VERSION);
$VERSION = "1.03";

my $ResourcePath = ".";		# default standard resource path
my $defupr = "PSref.upr";	# principal resource file
my $fn;				# file currently being loaded
my $fh;				# handle of file currently being loaded
my $section;			# section currently being loaded
my $exclusive;			# last loaded file was exclusive
my $rscidx;			# current resource index

my $trace;
my $debug;
my $verbose;
my $error;

sub new {
    my $class = shift;
    my (%atts) = (path    => $ENV{"PSRESOURCEPATH"} || "::",
		  stdpath => $ResourcePath,
		  error   => 'die',	# 'die', 'warn' or 'ignore'
		  verbose => 0,
		  trace   => 0,
		  debug   => 0,
		  @_);

    $debug   =           lc($atts{debug});
    $trace   = $debug || lc($atts{trace});
    $verbose = $trace || lc($atts{verbose});
    $error   = lc($atts{error});

    my $self = {};
    bless $self, $class;

    # Get the resource paths.
    my $path = $atts{path};
    $path =~ s|::|:$atts{stdpath}:|g;
    $path =~ s|^:||;

    # According to the specs, the file names are either literal,
    # absolute or relative. In the latter case, the current prefix
    # (which defaults to the directory of the .upr file) must be
    # appended.
    # To avoid lots of unnecessary file name parsing, each prefix
    # will be stored in a prefix array, and the index in this array
    # will be prepended to each file name entry.
    # The costly filename manipulation will only be done when a
    # filename needs to be returned (sub _buildfilename).

    # Create the prefix array and reset the index.
    $self->{prefix} = [];
    $rscidx = 0;

    # Process the entries in the list.
    foreach my $rsc ( split (":", $path) ) {

	print STDERR ("rsc#$rscidx: $rsc \n") if $debug;

	if ( -d $rsc ) {
	    print STDERR ("rsc#$rscidx: $rsc \n") if $debug;

	    # Directory.
	    $exclusive = 0;

	    # First check for a PSres.upr, and load it if possible.
	    $fn = File::Spec->catfile ($rsc, "PSres.upr");
	    if ( -f $fn ) {
		print STDERR ("rsc#$rscidx: load $fn\n") if $debug;
		$rscidx++;
		eval { _loadFile ($self) };
		if ( $@ ) {
		    die ($@)  if $error eq "die";
		    warn ($@) if $error eq "warn";
		    next;
		}
	    }

	    # Unless PSres.upr was an exclusive resource, load all
	    # files with .upr extension.
	    unless ( $exclusive ) {
		my $dh = do { local *DH };
		opendir ($dh, $rsc);
		my @files = grep (/\.upr$/, readdir ($dh));
		closedir ($dh);
		foreach my $file ( @files ) {
		    # Skip the PSres.upr. It is already loaded.
		    next if $file eq "PSres.upr";

		    $fn = File::Spec->catfile ($rsc, $file);
		    print STDERR ("rsc#$rscidx: load $fn\n") if $debug;
		    $rscidx++;
		    eval { _loadFile ($self) };
		    if ( $@ ) {
			die ($@)  if $error eq "die";
			warn ($@) if $error eq "warn";
			next;
		    }
		}
	    }
	}
	else {

	    # File. This is _not_ defined in the specs.

	    $fn = $rsc;
	    print STDERR ("rsc#$rscidx: load $fn\n") if $debug;
	    $rscidx++;
	    eval { _loadFile ($self) };
	    if ( $@ ) {
		die ($@)  if $error eq "die";
		warn ($@) if $error eq "warn";
		next;
	    }
	}
    }

    $self;
}

sub FontAFM ($$) {
    my ($self, $font) = @_;
    return _buildfilename ($self, $font)
      if defined ($font = $self->{FontAFM}->{$font});
    undef;
}

sub FontOutline ($$) {
    my ($self, $font) = @_;
    return _buildfilename ($self, $font)
      if defined ($font = $self->{FontOutline}->{$font});
    undef;
}

sub _buildfilename ($$) {
    my ($self, $name) = @_;
    my $i;
    ($i, $name) = unpack ("IA*", $name);
    return $1 if $name =~ /^=(.*)$/;
    return $name if File::Spec->file_name_is_absolute ($name);
    File::Spec->canonpath (File::Spec->catfile ($self->{prefix}->[$i], $name));
}

sub _loadFile ($) {

    my ($self) = @_;

    my $data;			# data

    eval {			# so we can use die

	$fh = new IO::File;	# font file
	my $sz = -s $fn;	# file size

	$fh->open ($fn) || die ("$fn: $!\n");
	print STDERR ($fn, ": Loading Resources\n") if $verbose;

	# Read in the data.
	my $line = <$fh>;
	die ($fn."[$.]: Unrecognized file format\n")
	  unless $line =~ /^PS-Resources-(Exclusive-)?([\d.]+)/;
	$exclusive = defined $1;
	my $version = $2;

	# The resources file is organised in sections, each starting
	# with the section name and terminated by a line with just
	# a period.
	# Following the first PS-Resources line, the sections are
	# enumerated, e.g.:
	#
	#  PS-Resources-1.0
	#  FontAFM
	#  FontOutlines
	#  FontFamily
	#  FontPrebuilt
	#  FontBDF
	#  FontBDFSizes
	#  .
	#
	# Optionally, the name of the resource directory follows. It
	# is preceded with a slash, e.g.:
	#
	#  //usr/share/psresources
	#
	# This is then followed by each of the sections, e.g.:
	#
	#  FontAFM
	#  ... afm info ...
	#  .
	#  FontOutlines
	#  ... outlines info ...
	#  .
	#  FontFamily
	#  ... family info ...
	#  .
	#
	# Backslash escapes are NOT handled, except for continuation.
	#
	# We have a _loadXXX subroutine for each section, where XXX is
	# the section name. Flexible and extensible.
	#
	# The current approach is to ignore the first section.

	$self->_skipSection ($fh);

	# Then, load the sections from the file, skipping unknown ones.

	my $checkdir = 1;
	while ( defined ($section = _readLine ($self, $fh)) ) {
	    chomp ($section);
	    if ( $checkdir && $section =~ /^\/(.*)/ ) {
		$self->{prefix}->[$rscidx] = $1;
		$checkdir = 0;
		next;
	    }
	    $checkdir = 0;
	    my $loader = defined &{"_load$section"} ? "_load$section" :
	      "_skipSection";
	    no strict 'refs';
	    die ($fn."[$.]: Premature end of $section section\n")
	      if $fh->eof || !$loader->($self);
	}

    };

    # Set the dfeault value for the directory prefix, if necessary.
    $self->{prefix}->[$rscidx] ||= dirname ($fn);

    $fh->close;
    die ($@) if $@;
    $self;
}

sub _readLine () {
    # Read a line, handling continuation lines.
    my $line;
    while ( 1 ) {
	return undef if $fh->eof;
	$line .= <$fh>;
	if ( $line =~ /^(.*)\\$/ ) {
	    $line = $1;
	    redo;
	}
	$line = $1 if $line =~ /^(.*)%/; # remove comments
	$line =~ s/\s+$//;		# remove trailing blanks
	next unless $line =~ /\S/;	# skip empty lines
	return $line;
    }
    continue { $line = "" }
    undef;
}

sub _loadFontAFM ($) {
    my ($self) = @_;
    print STDERR ($fn, "[$.]: Loading section $section\n") if $trace;

    my $afm;
    $afm = $self->{FontAFM} = {}
      unless defined ($afm = $self->{FontAFM});

    my $line;
    my $rscidx = pack ("I", $rscidx);
    while ( defined ($line = _readLine ()) ) {
	return 1 if $line =~ /^\.$/;

	# PostScriptName=the/file.afm
	if ( $line =~ /^([^=]+)=(.*)$/ ) {
	    $afm->{$1} = $rscidx.$2 unless $afm->{$1};
	    next;
	}
	warn ($fn, "[$.]: Invalid FontAFM entry\n")
	  unless $error eq "ignore";
    }
    return 1;
}

sub x_loadFontFamily ($) {
    my ($self) = @_;
    print STDERR ($fn, "[$.]: Loading section $section\n") if $trace;

    my $fam;
    $fam = $self->{FontFamily} = {}
      unless defined ($fam = $self->{FontFamily});

    my $line;
    while ( defined ($line = _readLine ()) ) {
	return 1 if $line =~ /^\.$/;

	# Familiyname=Type1,PostScriptName1,Type2,PostScriptName2,...
	if ( $line =~ /^([^=]+)==?(.*)$/ ) {
	    $fam->{$1} = { split (',', $2) };
	    next;
	}
	warn ($fn, "[$.]: Invalid FontFamily entry\n")
	  unless $error eq "ignore";
    }
    return 1;
}

sub _loadFontOutline ($) {
    my ($self) = @_;
    print STDERR ($fn, "[$.]: Loading section $section\n") if $trace;

    my $pfa;
    $pfa = $self->{FontOutline} = {}
      unless defined ($pfa = $self->{FontOutline});

    my $line;
    my $rscidx = pack ("I", $rscidx);
    while ( defined ($line = _readLine ()) ) {
	return 1 if $line =~ /^\.$/;

	# PostScriptName=the/file.pfa
	if ( $line =~ /^([^=]+)=(.*)$/ ) {
	    $pfa->{$1} = $rscidx.$2 unless $pfa->{$1};
	    next;
	}
	warn ($fn, "[$.]: Invalid FontOutline entry\n")
	  unless $error eq "ignore";
    }
    return 1;
}

sub _skipSection ($) {
    my ($self) = (@_);
    $section ||= "list";
    print STDERR ($fn, "[$.]: Skipping section $section\n") if $trace;

    my $line;
    while ( defined ($line = _readLine ()) ) {
	return 1 if $line =~ /^\.$/;
    }
    return 1;
}

1;

__END__