#!/usr/bin/perl
# -*- perl -*-
my $version_banner = <<END;
extractres 2.04
Copyright (c) Reuben Thomas 2012-2019.
Copyright (c) Angus J. C. Duggan 1991-1997.
END
# This program is distributed under the following license (effectively, BSD
# 3-clause):
#
# It may be copied and used for any purpose (including distribution as part of
# a for-profit product), provided:
#
# 1) The original attribution of the program is clearly displayed in the product
#    and/or documentation, even if the program is modified and/or renamed as
#    part of the product.
#
# 2) The original source code of the program is provided free of charge (except
#    for reasonable distribution costs). For a definition of reasonable
#    distribution costs, see the Gnu General Public License or Larry Wall's
#    Artistic License (provided with the Perl 4 kit). The GPL and Artistic
#    License in NO WAY affect this license; they are merely used as examples of
#    the spirit in which it is intended.
#
# 3) This program is provided "as-is". No warranty or guarantee of their
#    fitness for any particular task is provided. Use of this program is
#    completely at your own risk.
#
# Basically, I don't mind how you use the program so long as you acknowledge
# the author, and give people the originals if they want them.
#
#                                                                 AJCD 4/4/95

use strict;
use warnings;

BEGIN
{
# Relocatable header

if ("no" eq "yes") {
  my $exec_prefix = "/usr";
  my $orig_installdir = "/usr/bin"; # see Makefile.am's *_SCRIPTS variables
  my ($orig_installprefix, $curr_installprefix) = find_prefixes($orig_installdir, find_curr_installdir());
  sub relocate { # the subroutine is defined whether or not the enclosing block is executed
    my ($dir) = @_;
    if ("no" eq "yes") {
      $dir =~ s%^$orig_installprefix/%$curr_installprefix/%;
      $dir =~ s,/$,,;
    }
    return $dir;
  }
}

# Relocate the directory variables that we use.
my $pkgdatadir = &relocate("/usr/share/psutils");

# End of relocatable header; "real" Perl starts here.

  unshift (@INC, '/usr/share/psutils') unless $ENV{PSUTILS_UNINSTALLED};
}

use File::Basename;
use Getopt::Long;

use PSUtils;

our $program_name = basename($0);
my ($help_flag, $version_flag, $merge);

sub usage {
  my ($exit_code) = @_;
  print STDERR <<END;
Usage: $program_name [OPTION...] [INFILE [OUTFILE]]
Extract resources from a PostScript document.

  -m, --merge          merge resources of the same name into one file
                       (needed e.g. for fonts output in multiple blocks)
      --help           display this help and exit
      --version        display version information and exit
END
  exit $exit_code;
}

# Get arguments
Getopt::Long::Configure("bundling");
# Having configured bundling, must give short option names explicitly
my $opts = GetOptions(
  "merge|m" => \$merge,
  "help" => \$help_flag,
  "version" => \$version_flag,
 ) or usage(1);
if ($version_flag) {
  print STDERR $version_banner;
  exit 0;
}
usage(0) if $help_flag;
usage(1) if $#ARGV > 1;

my ($infile, $outfile) = setup_input_and_output();
usage(1) if $#ARGV != -1; # Check no more arguments were given

# Resource types
sub type {
  my %types = ("%%BeginFile:" => "file", "%%BeginProcSet:" => "procset",
               "%%BeginFont:" => "font");
  return $types{$_[0]};
}

# Extract resources
my %resources = ();             # list of resources included
my %merge = ();                 # list of resources extracted this time
my $prolog = "";
my $body = "";
my $resource = "";
my $output = \$prolog;
my $saveout;

while (<$infile>) {
  if (/^%%Begin(Resource|Font|ProcSet):/) {
    my ($comment, @res) = split(/\s+/); # look at resource type
    my $type = defined(type($comment)) ? type($comment) : shift(@res);
    my $name = filename(@res, extn($type)); # make file name
    $saveout = $output;
    if (!defined($resources{$name})) {
      $prolog .= "%%IncludeResource: $type " . join(" ", @res) . "\n";
      if (!-e $name) {
        open RES, ">$name" or Die("can't write file `$name'", 2);
        $resources{$name} = "";
        $merge{$name} = $merge;
        $output = \$resources{$name};
      } else {                  # resource already exists
        close(RES);
        undef $output;
      }
    } elsif ($merge{$name}) {
      open RES, ">>$name" or Die("can't append to file `$name'", 2);
      $resources{$name} = "";
      $output = \$resources{$name};
    } else {			# resource already included
      undef $output;
    }
  } elsif (/^%%End(Resource|Font|ProcSet)/) {
    if (defined $output) {
      $$output .= $_;
      print RES $$output;
    }
    $output = $saveout;
    next;
  } elsif (/^%%End(Prolog|Setup)/ || /^%%Page:/) {
    $output = \$body;
  }
  $$output .= $_ if defined $output;
}

print $outfile $prolog . $body;