# -*- Mode: Perl -*- 
#
# Type1Utils.pm 
# Copyright (C) 1997 Federico Di Gregorio.
#
# This module is part of the Debian Type Manager package.  
#
# Some (small?) parts of it are derived from type1inst 
# Copyright (C) 1996-1997 James Macnicol. 
#
# This program 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; either version 2, or (at your option) any later
# version.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTIBILITY
# or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
# for more details.

=head1 NAME

DTM::Type1Utils - Some small usefull functions to analyze type1 fonts 

=cut

package DTM::Type1Utils;

require 5.004;
use DTM::Utils;
use DTM::Snippet;
use strict;

require Exporter;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
$VERSION     = 0.1;
@ISA         = qw(Exporter);
@EXPORT      = qw(&build_type1snippet);
%EXPORT_TAGS = ();
@EXPORT_OK   = qw();


# The build_type1snippet method need some information like the mappings 
# for font foundries, styles, weights et al.

my @foundries = ("Adobe:adobe:Adobe",
		 "Publishers' Paradise:paradise:Publishers' Paradise",
		 "PUBLISHERS' PARADISE:paradise:Publishers' Paradise",
		 "Bigelow & Holmes:b&h:Bigelow & Holmes",
	         "Bitstream:bitstream:Bitstream",
		 "International Typeface Corporation:itc:ITC",
	         "IBM:ibm:IBM",
	         "LETRASET:letraset:LETRASET",
		 "Monotype Corporation:monotype:Monotype Corporation",
		 "SoftMaker:softmaker:SoftMaker",
		 "URW:urw:URW",
		 "Jonathan Brecher:brecher:J.Brecher",
		 "Brendel Informatik:brendel:Brendel Informatik",
		 "A. Carr:carr:A.Carr",
		 "FontBank:fontbank:FontBank",
		 "Hershey:hershey:Hershey",
		 "A.S.Meit:meit:A.S.Meit",
		 "Andrew s. Meit:meit:A.S.Meit",
		 "S.G. Moye:moye:S.G.Moye",
		 "S. G. Moye:moye:S.G.Moye",
		 "D. Rakowski:rakowski:D.Rakowski",
		 "David Rakowski:rakowski:D.Rakowski",
		 "Reasonable Solutions:reasonable:Reasonable Solutions",
		 "Southern Software:southern:Southern Software",
		 "Title Wave:titlewave:Title Wave",
		 "ZSoft:zsoft:ZSoft",
		 "Henry Churchyard:churchyard:H.Churchyard");

my @weights = ("book:book",
	       "extrabold:extrabold",
	       "boldface:bold",
	       "bold:bold",
	       "heavyface:heavy",
	       "heavy:heavy",
	       "ultrablack:ultra",
	       "extrablack:ultra",
	       "ultra:ultra",
	       "black:black",
	       "extralight:extralight",
	       "super:super",
	       "thin:hairline",
	       "hairline:hairline",
	       "light:light",
	       "demi:demibold",
	       "semi:semibold",
	       "demibold:demibold",
	       "semibold:semibold",
	       "medium:medium",
	       "normal:medium",
	       "regular:regular",
	       "roman:regular");

my @widths = ("extracondensed:extracondensed",
	      "ultracondensed:ultracondensed",   
	      "condensed:condensed",
	      "cond:condensed",
	      "cn:condensed",
	      "extracompressed:extracompressed",
	      "ultracompressed:extracompressed",
	      "compressed:compressed",
	      "comp:compressed",
	      "narrow:narrow",
	      "regular:regular",
	      "normal:regular",
	      "extended:extended",
	      "expanded:expanded",
	      "wide:wide",
	      "extraextended:wide");

my @variants = ("sans:sans",
		"sansserifs:sans",
		"alt:alternate",
		"beginning:beginning",
		"display:display",
		"dfr:dfr",
		"ending:ending",
		"ep:expert",
		"exp:expert",
		"ornaments:ornaments",
		"osf:oldstylefigures",
		"outline:outline",
		"smallcaps:smallcaps",
		"sc:smallcaps",
		"shaded:shaded",
		"shadowed:shadowed",
		"stencil:stencil",
		"swash:swash",
		"sw:swash",
		"stone:stone",
		"one:one",
		"two:two",
		"three:three",
		"four:four", 
		"alternate:alternate");

my @slants = ("roman:regular:r",
	      "regular:regular:r",
	      "upright:regular:r",
	      "italic:italic:i",
	      "cursive:italic:i",
	      "kursiv:italic:i",
	      "oblique:slanted:o",
	      "obl:slanted:o",
	      "slanted:slanted:o",
	      "inclined:slanted:o");


# build_type1snippet() analyzes a type1 font and returns
# a valid snippet (in perl format, not textual one)

sub build_type1snippet {
    my ($realpath, $realfile) = (@_);
    my ($fontfile, $tmpfile);
    my ($gsfont, $mm, $notice, $encoding, $axis, $psname);
    my ($fullname, $strippedfullname, $name, $foundry, $family);
    my ($weight, $slant, $width, $var, $allstyle);
    my ($fixedpitch);
    my @fields;

    # gets real path and name of the font and
    # convert it to .pfa if it is a .pfb
    if ($realfile =~ /\.pfb\s*$/) {
	$tmpfile = `tempfile`;
	safe_system("pfb2pfa $realpath/$realfile $tmpfile");
	$fontfile = $tmpfile;
    }
    else {
	$fontfile = "$realpath/$realfile";
    }
    
    # check to see if this is a ghostscript font
    $gsfont = $fontfile =~ /\.gsf\s*$/ ? 1 : 0;
    
    # default is not MultipleMaster
    $mm = 0;

    open(IN, $fontfile) or do {
	warning("can't open `$fontfile' for reading");
	return ();
    };
 
    $name = "NONAME";
    $family = "NOFAMILY";
    $foundry = "unknown";

    while(<IN>) {
      
	# fixed pitch? (only X11 needs that)
	if (/\/isFixedPitch\s+(.+)\s+def\s*/) {
	    if ($1 =~ /true/) {
		$fixedpitch = 'm';
	    } else {
		$fixedpitch = 'p';
	    }
	}

	# First we get the full name of the font (that has to be there)
	# and we save it. /FullName might contain useful information 
	# in determining the properties of a font.
	if (/\/FullName\s*\((.+)\)\s+readonly\s+def\s*/) {
	    $fullname = $strippedfullname = $1;
	    # some names got extra numerical information at the start
	    # let's remove it
	    $fullname =~ s/\*//g;
	    $fullname =~ s/^\d*\s*(.+)/$1/;
	    # removes dashes (replaces with spaces) from the fullname
	    $fullname =~ s/-/ /g;
	}

	# gets the font name and separate it from the style
	# the /FontName *has* to be here, for sure
	if (/\/FontName\s*\/(.+)\s+def\s*/) {
	    $name = $1;
	    # remove spaces (necessary?) and saves away a copy
	    # of the real postscript name
	    $psname = $name;
	    $name =~ s/\s//g;

	    # split the name into fontname and fontstyle instead 
	    # and handle them separate.
	    ($name, $allstyle) = split(/-/, $name);
	    # remove "-", makes styles lower case
	    $name =~ s/-//g;
	    $allstyle =~ s/-//g;
	    $allstyle = lc $allstyle;
	}

	# extract the family name if possible, else will use $fontname
	if (/\/FamilyName\s*\((.+)\)\s+readonly\s+def\s*/) {
	    $family = $1;
	}

	# extract weight
	if (/\/Weight\s*\((.+)\)\s+readonly\s+def\s*/) {
	    $weight = $1;
	    # coverts and removes white space
	    $weight = lc $weight;
	    $weight =~ s/\s*//g;

	    # remember if it's a MultipleMaster font
	    $mm = 1 if ($weight =~ /^all$/);
	  
	    # removes style info in the weight field...
	    foreach my $i (@variants, @slants) {
		@fields = split(/:/, $i);
		$weight =~ s/$fields[0]//;
	    }
	}

	# extract the encoding 
	if (/^\/Encoding\s+(\S+)\s*/) {
	    if ($1 =~ /StandardEncoding/) {
		$encoding = "standard";
	    } else {
		$encoding = ($encoding =~ /\d+/ ?
			     'fontspecific' : $1);
	    }
	}

	# extract foundry name from notice
	if (/^\s*\/Notice\s*(.*)$/) {
	    $notice = $1;
	    $notice =~ s/readonly def//g;

	    foreach my $i (@foundries) {
		@fields = split(/:/, $i);
		if ($notice =~ /$fields[0]/) {
		    $foundry = $fields[2];
		}
	    }
	}

	# multipleMaster fonts have this field.
	if (/\/BlendAxisTypes\s+\[([^\]]+)\]\s*def/) {
	    $axis = $1;
	    # remove axises we don't need
	    $axis =~ s/\/Weight\s+//;
	    $axis =~ s/\/Width\s+//;
	    # are there still some axises left?
	    if ($axis =~ /\//) {
		# remove trailing spaces
		$axis =~ s/^(.*?)\s*$/$1/;
		$axis =~ s/\/\S+/0/g;
		$axis= "[$axis]";
	    }
	}

	# break out of loop if we've passed the interesting stuff
	# we should have gathered all the intersting stuff by now
	# this is for .pfa and .pfb fonts
	if ((! $gsfont) && (/currentfile\s+eexec/)) {
	    last;
	} 
	# this is for ghostscript .gsf fonts
	elsif (($gsfont) && (/currentdict\s+end/)) {
	    last;
	}
    }
    close(IN);  # *END OF THE FILE SCAN*

    # here we do some little tricks with the family name,
    # first we set it to the initial part of fontname if not
    # yet set.
    if ($family =~ /NOFAMILY/) {
	($family, undef) = split(/-/, $name);
	$family =~ s/-//g;
    }

    # creates an alternate style, by stripping the family name
    # from the full name of the font. then look for other attributes
    # like width, weight, etc...
    if ($strippedfullname =~ s/^$family\s*(\d\d+)?\s*(.*)/$2/) {
	# removes whitespace and convert to lowercase
	$strippedfullname =~ s/\s+//g;
	$strippedfullname = lc $strippedfullname;
    } else {
	$strippedfullname = "";
    }	

    # check for weight modifiers in the name...
    my $name_weight = "medium";
    foreach my $i (@weights) {
	my @fields = split(/:/, $i);
	# we try first with the fullname...
	if ($strippedfullname =~ /$fields[0]/) {
	    $name_weight = $fields[1];
	    # we put it in weight
	    if (! $weight) {
		$weight = $name_weight; 
	    }
	} 
	# remove matched word
	$strippedfullname =~ s/$fields[0]//;

	# ...then with the style from the name
	if ($allstyle =~ /$fields[0]/) {
	    $name_weight = $fields[1];
	    # we put it in weight
	    if (! $weight) {
		$weight = $name_weight; 
	    }
	} 
	# remove matched word from the font's name
	$allstyle =~ s/$fields[0]//;
    }
    # puts the medium one if none was found
    $weight = $name_weight unless $weight;
    
    # check for slantness (italic, roman, oblique)
    $slant = "regular";
    foreach my $i (@slants) {
	my @fields = split(/:/, $i);
	if ($strippedfullname =~ /$fields[0]/) {
	    $slant = $fields[1];
	}
	# remove matched word from the font's name
	$strippedfullname =~ s/$fields[0]//;

	if ($allstyle =~ /$fields[0]/) {
	    $slant = $fields[1];
	}
	# remove matched word from the font's name
	$allstyle =~ s/$fields[0]//;
    }
    
    # check for width (condensed, normal, wide, ...)
    $width = "regular";
    foreach my $i (@widths) {
	@fields = split(/:/, $i);
	if ($strippedfullname =~ /$fields[0]/) {
	    $width = $fields[1];
	}
	# remove matched word from the font's name
	$strippedfullname =~ s/$fields[0]//;

	if ($allstyle =~ /$fields[0]/) {
	    $width = $fields[1];
	}
	# remove matched word from the font's name
	$allstyle =~ s/$fields[0]//;
    }
    
    # check for additional style variants (alternate, smallcaps):
    # what's left of fullname is probably additional style information.
    # Some fontnames have some strange numerical information here too.
    # If it's just one number, it usually refers to some variant of the
    # fontfamily, otherwise, just get rid of it.
    $strippedfullname = "" if ($strippedfullname =~ /^\d\d+$/);
    $var = 'none';
    foreach my $i (@variants) {
	@fields = split(/:/, $i);
	if ($strippedfullname =~ /$fields[0]/) {
	    $var = $fields[1];
	}
	if ($allstyle =~ /$fields[0]/) {
	    $var = $fields[1];
	}
    }   
    
    # couldn't get family name right
    if ($family =~ /NONAME/) {
	warning("couldn't get font name from " .
		 "file `$fontfile' (is this a Type1 font?)");
	return ();
    }

    # builds the x line for the font, here we should replace some of the
    # information retrieved with more X11-ish one.

    # FIX: only iso8859-1 supported at now, all others
    # are `adobe-fontspecific'
    $encoding = 'fontspecific' if $encoding =~ /\d+/;
    my $xencoding;
    if ($encoding =~ /standard/) {
	$xencoding = 'iso8859-1';
    }
    else
    {
	$xencoding = 'fontspecific';
    }

    # a better X11 foundry name
    my $xfoundry;
    foreach my $i (@foundries) {
	@fields = split(/:/, $i);
	if ($foundry =~ /$fields[2]/) {
	    $xfoundry = $fields[1];
	}
    }

    # slantness
    my $xslant;
    foreach my $i (@slants) {
	@fields = split(/:/, $i);
	if ($slant =~ /$fields[1]/) {
	    $xslant = $fields[2];
	}
    }

    # makes a lowercase copy of familyname (X11 again) and eats 
    # dashes (sometimes in fullname or familyname)
    my $xfamily = lc $family;
    $xfamily =~ s/-//g;
    
    my $xweight = $weight;
    my $xfixedpitch = $fixedpitch;
    my $xaddstyle = ($var =~ /none/ ? '' : $var);;

    # X manpage shows 'normal' and not 'regular'
    my $xstyle = ($width =~ /regular/ ? 'normal' : $width);

    # we are dealing with a MultipleMaster font...
    if ($mm) {
	$xweight = "0";
	$xstyle = "0";
	$xaddstyle .= $axis;
    }
	
    my $xline = "-$xfoundry-$xfamily-$xweight-$xslant-$xstyle-$xaddstyle-0-0-0-0-$xfixedpitch-0-$xencoding";

    # builds the ID
    my $id = "type1$foundry$family$weight$slant$xstyle$xaddstyle";
    $id =~ s/\s//g;
    $id = lc $id;

    # deletes the temporary file if it exists
    safe_system("rm $tmpfile") if $tmpfile;

    #and finally creates the catalog snippet
    my $snippet = new DTM::Snippet;
    $snippet->set_attrs(undef,  # this was the class
			ID => $id,
			Foundry => $foundry,
			Typeface => $family,
			Weight => $weight,
			Slantness => $slant,
			Width => $width,
			Variant => $var,
			Encoding => $encoding,
			Name => $fullname,
			FontFile => $realfile,
			FontPath => $realpath);
    $snippet->set_attr('Name', $xline, 'x11specific');
    $snippet->set_attr('Name', $psname, 'psspecific');
    return $snippet;
}


# return true
1