# -*- perl -*-
# Eps.pm $Id: Eps.pm,v 1.15 1999/01/30 15:42:28 jens Exp $
# (C) Copyright Jens G Jensen <jens@arcade.mathematik.uni-freiburg.de>
# This file is part of epsmerge and is distributed under GNU GPL


package Eps;

use strict;



sub new {
    my $class = ref($_[0]) || $_[0];
    my $fname = $_[1];
    # An eps has boundingbox, orientation (default portrait) and a filename
    # - also knows name of save variable
    my $self = { fn => $fname, save => 'eps_Inc_Save_the_State' };
    bless $self, $class;

    unless( open(HELLO, "<$fname") ) {
	print STDERR "Creating $class: can't open $fname for reading\n";
	exit(5);
    }
    $_ = <HELLO>;
    unless( /^%!PS-Adobe-(\d+)\.(\d+) EPSF-\d+\.\d+/ ) {
	print STDERR "It seems that $fname is not encapsulated postscript\n";
	exit(5);
    }

    # Simple parser: parse DSCs in the header looking in particular for the boundingbox.
    # Uh -- the parser is getting a bit ugly
    # atend says: 0 = ignore trailer, 1 = must read trailer, 2 = reading trailer
    my $atend = 0;
    # emblevel counts depth of embedded documents
    my $emblevel = 0;
    # Reading_List specifies which DSCs we are looking for and their parsed
    # values (keeping the first in the Header or the last in the Trailer).
    # Each entry has a name as the key, a regexp saying how to parse the
    # value, and sometimes a default value
    my %Reading_List = (
		        'BoundingBox:' => { re => '(\d+\s*){4}', },
		        'Orientation:' => { re => 'Portrait|Landscape', df => ['Portrait'] },
		        'LanguageLevel:' => { re => '\d+', df => ['3.0'] },
		        'Extensions:' => { re => '.+', },
			'Title:' => { re => '.+', df => ['(no title)'] },
			'CreationDate:' => { re => '.+', },
		       );		  
  PARSE:
    while( <HELLO> ) {
	--$emblevel if /^%%EndDocument/;
	++$emblevel if /^%%BeginDocument/;
	next if $emblevel;
	# stop parsing?
	if( &endofheader($_) ) {
	    if( $atend ) {
		# skip forward to trailer and parse that
		while( <HELLO>) {
		    if( /^%%Trailer/ ) {
			$atend = 2;
			next PARSE;
		    }
		}
		print STDERR "$fname requires a trailer but does not have one\n";
		exit(5);
	    }
	    else {
		last PARSE;
	    }
	}
	last if /^%%EOF/;

	# identify comment
	my ($name, $arg, $item);
	next unless ($name, $arg) = /^%%([a-zA-Z\.\?\!]+:?)\s*(.*)$/;
	# strip leading and trailing spaces
	$arg =~ s/^\s*//; $arg =~ s/\s*$//;
	$item = $Reading_List{ $name };
	next unless $item;
	if( $arg eq '(atend)' ) {
	    if( $atend == 2 ) {
		print STDERR "$fname: Huh? Can't have (atend) ref in the trailer!\n";
		exit(5);
	    }
	    $atend = 1;
	    $item->{ value } = '(atend)';
	    next;
	}
	if( $arg =~ /$item->{re}/ ) {
	    # The DSC that counts is the _first_ in _headers_, _last_ in _trailers_
	    # Here the trailer one (only if available and someone prompts us to read trailer)
	    # takes precedence over the header one
	    next if $self->{ $name } && $atend != 2;
	    $self->{ $name } = [ split /\s+/, $arg ];
	    # Handle %%+ statements; slightly ugly (and not done yet!)
	    $_ = <HELLO>;
	    redo unless m{^%%\+\s};
	    
	}
	else {
	    print STDERR "$fname: Cannot read DSC $name";
	    exit(5);
	}
    }

    # Test data
    if( $#{ $self->{ 'BoundingBox:' } } != 3 ) {
	print STDERR "It seems that $fname doesn't have a proper boundingbox\n";
	exit(5);
    }
    for (keys %$self) {
	print STDERR "Warning: $fname: option $_ was not specified\n"
	    if $self->{$_} eq '(atend)';
    }

    # check that everything from the reading-list was defined;
    # at least those that might be used as labels *must* be def'd
    foreach (keys %Reading_List) {
	next if defined $self->{ $_ };
	my $ref = $Reading_List{$_};
	if( defined $ref->{df} ) {
	    $self->{ $_ } = $ref->{df};
	}
	elsif( $_ eq 'CreationDate:' ) {
	    # get file's mtime (last modified)
	    my $date = (stat( $self->{fn} ))[9];
	    # if no mtime, shouldn't ever happen, use now()
	    $date = scalar localtime( $date ? $date : time() );
	    $self->{$_} = [ split /\s+/, $date ];
	}
    }

    close HELLO;
    return $self;
}

# getlabel returns a label string as follows:
# f: filename
# d: the date of creation (er, of the eps file)
# T: the title of the eps file, as described by the DSC
sub getlabel {
    my $self = shift;
    $_ = shift;
    if( /f/ ) {
	return $self->{fn};
    }
    elsif( /d/ ) {
	return join( ' ', @{$self->{'CreationDate:'}} );
    }
    elsif( /T/ ) {
	return join( ' ', @{$self->{'Title:'}} );
    }
    else {
	print STDERR "$self->{fn}: Warning: unknown label specifier $_ ignored\n";
    }
    return "";
}

sub box {
    my $self = shift;
    my @bbox = @{$self->{ 'BoundingBox:' }};
    my ($w, $h) = ($bbox[2]-$bbox[0], $bbox[3]-$bbox[1]);
    if( $self->{'Orientation:'}->[0] eq 'Landscape' ) {
	my $tmp = $w;
	$w = $h;
	$h = $tmp;
    }
    return ($bbox[0], $bbox[1], $bbox[0]+$w, $bbox[1]+$h);
}

# write must be passed (1) a boundingbox (integers) and
# (2) scaling parameters (possibly floats).
# It writes clipping things and the EPS file itself
sub write {
    my $self = shift;
    my ($llx, $lly, $urx, $ury, $xsc, $ysc) = @_;
    open(DATA, "<$$self{fn}") or die $!;
    print <<HERE;
/$self->{save} save def
newpath $llx $lly moveto
$llx $ury lineto $urx $ury lineto $urx $lly lineto
closepath
clip
newpath
HERE
    if( $self->{ 'Orientation:' }->[0] eq 'Landscape' ) {
	print "$llx $ury translate -90 rotate\n";
	my $tmp = $xsc; $xsc = $ysc; $ysc = $tmp;
    }
    else {
	print "$llx $lly translate\n";
    }
    print <<HERE;
$xsc $ysc scale
${$self->{'BoundingBox:'}}[0] neg ${$self->{'BoundingBox:'}}[1] neg translate
%Epsmerge included file: $$self{fn}
HERE
    ;
    while( !endofheader( $_ = <DATA> ) ) { };
    print unless /^%%EndComments/;
    my $atend = 0;
    my $emblevel = 0;
    while(<DATA>) {
	--$emblevel if /^%%EndDocument/;
	++$emblevel if /^%%BeginDocument/;
	next if $emblevel && /^%%/; # ignore embedded documents' DSC
        s/showpage//;
	if( /^%%Trailer/ ) {
	    $atend = 1;
	    next;
	}
	next if $atend && /^%%/;
	last if /^%%EOF/;
	print;
    }
    print "$self->{save} restore\n";
    close DATA;
}

# Return true if the input could be the first non-header line (*not* a method!)
sub endofheader {
    my $data = shift;
    return ($data =~ /^%%EndComments/) || ($data !~ /^%\S/);
}

1;