#!/usr/bin/perl


use Getopt::Long qw(:config no_ignore_case);

@procsets=();
@downloadFonts=();
$compositeProcset = 1;
$eurify = 0; 
$download = 1;
$printFontResource = 1;
$norecode = 0;
%fontinfo = ();

unless ( GetOptions (

	"config|c=s"	=> \$config,
	"help|h"	=> \$usage,

	"procsets|p=s"	=> \@procsets,

	"encoding|e=s"	=> \$encoding,

	"fontrc|o!"	=> \$printFontResource,
	"norecode|n"	=> \$norecode,

	"remap|m=s"	=> \&optremap,  # so, --remap ping=pong or --remap bill ...
	"recode|r=s"	=> \@recodes,
	"download|d=s"	=> \@downloads,

	"rm|f=s"	=> \&rmd,  # recode+remap alias
	"rmd|F=s"	=> \&rmd,  # recode+remap+download alias

	"eurify"	=> sub { $compositeProcset = 1; $eurify = 1 },
	"composite!"	=> sub { shift; my $v = shift;
				if ($eurify) { warn "Ignoring --[no]composite when --eurify is active.\n" }
				else { $compositeProcset = $v }
				},
	
	"RS|S"		=> \$recode_standard,
	"RA|A"		=> \$recode_all,


	"netscape|N"	=> \$doNetscape,
	"staroffice|SO"	=> \$doStarOffice,
	"applixware|AX"	=> \$doApplixWare,
	"mosaic|M"	=> \$doMosaic,
	"mp|MP"		=> \$doMp,
	"xfig|X"	=> \$doXfig

)) { Usage(); exit(1); }
#
# Load in config
$config = "$ENV{CROPS_CONFIG}" unless ($config);
$config = "/etc/crops/crops.conf" unless ($config);
do "$config" or die "Can't load '$config' ($!)";

# Retrieve available encodings and their scheme names
opendir (ENCDIR, "$ENCDIR") or die "Can't open encoding directory '$ENCDIR' ($!)\n";
while (my $n = my $na = readdir(ENCDIR) ) {
	if ($n =~ s/\.afm$// ) {
		$fname = "$ENCDIR" . "/" . "$na";
		open (AFM2, "< $fname") or die "Can't open encoding file '$fname' ($!)\n";
		while (<AFM2>) {
			if ( /^EncodingScheme (.*)$/ ) {
				$encodingvecs{$n} = $1;
				last;
			};
		}
		close(AFM2);
	}
}
closedir(ENCDIR);

# Process our mighty fonts.info list
# filename / oldname / newname
open (FI, "< $FONTINFO") or die "Can't open crops font information list '$FONTINFO' ($!).\n";
while (<FI>) {
	chomp;
	my ($fontfil, $fontname, $newname) = split /\s+/;
	my $fontfile = "${FONTDIR}/${fontfil}-o.ps";
	warn "Font '$fontname' in fonts.info, but '$fontfile' not found.\n" unless ( -e "$fontfile" );
	push ( @{$fontinfo{$fontname}}, "$newname", "$fontfile");
}
close(FI);

@procsets = split( /,/, join( ',', @procsets ));
@recodes = split( /,/, join( ',', @recodes ));
@downloads = split( /,/, join( ',', @downloads ));
$encoding = 'latin2' unless $encoding;  # Reasonable default ;p


if ( $recode_standard) {
	if (defined(@standard_fonts)) { &rmd("rmd", $_) foreach(@standard_fonts); }
	else { print STDERR "-S flag was specified, but no standard fonts defined." };
}
if ( $recode_all) { &rmd("rmd", $_) foreach(keys %fontinfo) };

( $more_processing = 1 ) if  # Do we need this anyway ?
	( $doNetscape or $doStarOffice or $doApplixWare or $doMosaic or $doMp or $doXfig );


# Work starts here :)
&optremap_real($_->[0], $_->[1]) foreach (@optremaps); # Unfortunate neccessity.

$where = 0;
while(<>) {

	if ( $where == 0 ) {  # (! ( $where ))?

		print;
		if ( /^%%EndComments/ && ($doMosaic || $doMp)) {
			$_ = "%%BeginProlog\n";
			print;
		}
		if(/^%%BeginProlog/) {
			$where = 1;
			&procset("encoding", $encoding);
			if($compositeProcset) {
				&procset("compose");
				&procset("encoding", "ogonki");
			}
			&procset("fullpath", $_) foreach (@procsets);

			# High voltage
			if ($eurify) { foreach (@recodes) { &eurifyFont($_) }}; 
			&downloadFont($_) foreach (@downloads);

			my @arr;
			for (my $p = 0; $p < scalar (@remappings); $p ++) {

				$_ = $remappings[$p];
				my  $r = ( $norecode ? 0 : $recodes[$p]); 

				if ($r) {
					&remap($_->[0], $_->[1]);
					&remap($r, $r, $encodingvecs{$encoding});
				} else {
					push (@arr, $_);
				}
			}
			&remap($_->[0], $_->[1]) foreach (@arr);
			undef @arr;
		}


	} elsif( $where == 1 ) {

		if(/^%%EndProlog/) {

			$where=2;

		} elsif ($more_processing) {

			if ($doNetscape && m|/Encoding[ \t]+isolatin1encoding[ \t]*def|) {
				s/isolatin1encoding/$encodingvecs{$encoding}/;
			
			} elsif ($doMosaic && m|/Encoding[ \t]+ISOLatin1Encoding[ \t]*D|) {
				s/ISOLatin1Encoding/$encodingvecs{$encoding}/;
			
			} elsif ($doMp && m|/Encoding[ \t]+ISOLatin1Encoding[ \t]*def|) {
				s/ISOLatin1Encoding/$encodingvecs{$encoding}/;

			} elsif ($doStarOffice && m/ISOLatin1Encoding/) {
				s/ISOLatin1Encoding/$encodingvecs{$encoding}/;

			} elsif ($doXfig && m|/([^ \t]+)[ \t]+/([^ \t]+)[ \t]+isovec[ \t]+ReEncode|) {
				&remap($2,$1,$encodingvecs{$encoding});
				next;
			}

		}
		print;

	} elsif ( $where == 2 ) {

		print;

	}

}

exit(0);

# HELPER FUNCTIONS

sub Usage {
	print STDERR "See crops(1) man page for usage instructions\n";
}

sub procset {
	# Possible types are: encoding, compose, standard
	my ($type, $arg) = (shift, shift);
	my $f = '';

	if ("$type" eq "encoding") {
		$f = "${ENCDIR}/${arg}.enc";  # Just for clearer error report.
		die "Missing $arg $type file '$f'\n" unless ($encodingvecs{${arg}});

	} elsif ("$type" eq "compose" ) {
		$f = "${DATADIR}/compose.ps";
		die "Missing $type file '$f'\n" unless (-e "$f" );

	} elsif ("$type" eq "fullpath" ) {
		$f = "$arg";
		die "Missing $type file '$f'\n" unless (-e "$f" );

	}

	open(PROCSET, "< $f") or die "Can't open $type file '$f' ($!)\n";
	print while(<PROCSET>); close (PROCSET);
}

sub downloadFont {
	my $name = shift;

	print("%%BeginResource: font $ps\n") if ($printFontResource); # this is not DSC conforming
	
	warn "Font '$name' not known in fonts.info, not downloading.\n" unless $fontinfo{$name};

	$fp = $fontinfo{$name}->[1];  # .ps fontfile location
	open(PROCSET, "< ${fp}") or die "Can't open file '$fp' ($!)\n";
	print while(<PROCSET>); print("%%EndResource\n"); close(PROCSET);
}

sub remap {
	my ( $from, $to, $newencoding ) = (shift, shift, shift);

	print <<__ENDF__;
/$to findfont
dup length 1 add dict begin
{1 index /FID ne {def} {pop pop} ifelse} forall
__ENDF__

	if($newencoding) {
		print "/Encoding $newencoding def\n";
	}

	print <<__ENDF__;
currentdict end
/$from exch definefont pop
__ENDF__

}


sub eurifyFont {
	my $name = shift;
	print "/$name /$name eurifyFont\n";
}


sub rmd ($$) {
	my ($act, $arg) = ( shift, shift);
	@args = split (/,/, $arg);

	for (my $k = 0; $k < scalar @args; $k++) {
		chomp ($args[$k]);  # Just to be sure.
		if ( $args[$k] =~ /=/ ) {
			warn "Can't use equal sign inside $act option. Deleting '$arg[$k]' list.\n";
			splice(@args, $k, 1);
		}
	}

	optremap("from_rmd", $_) foreach (@args);  # We know we want to remap it rmd was called

	if ( ($act =~ /d/) or ($act =~ /F/) ) { push (@downloads, @args); }  # Download optionally.

}

# This is a hack. optremap() gets called from perl getopt and looks for information that has not
# been initialized yet. So, we save arguments and re-call the real optremap later.
sub optremap ($$) {
	push (@optremaps, [shift, shift] );
}

sub optremap_real ($$) {
	my $datasrc = shift; my $arg = shift; @args = split(/,/, $arg);
	my ($src, $dest);

	foreach (@args) {
		my $o = $_;

		if ( /(\S+)=(\S+)/ ) { ( $src, $dest ) = ( $1, $2 ) }
		else { $src = $o;  $dest = $fontinfo{$src}->[0] };

		if ($dest) { push( @remappings, [$src, $dest]) }
		else { die "No remapping rules found in fonts.info for '$src' and no suggestions specified on the command line.\n" };

 		if ( "$datasrc" ne "from_rmd" ) { push (@recodes, 0 ); }
		else { push (@recodes, $src); }


	}
}