| Current File : //proc/thread-self/root/bin/extractres |
#!/usr/bin/perl
# -*- perl -*-
my $version_banner = <<END;
extractres 2.07
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
# The functions in this file provide support for relocatability of
# Perl scripts. They should be included near the beginning of each
# Perl script in a relocatable program, by adding @relocatable_pl@
# and causing the script to be expanded with AC_CONFIG_FILES. A
# small amount of additional code must be added and adapted to the
# package by hand; see doc/relocatable-maint.texi (in Gnulib) for
# details.
#
# This code is based on relocatable.sh.in, and design changes (and
# bugs) should probably be cross-checked with it.
#
# Copyright (C) 2013, 2015-2022 Free Software Foundation, Inc.
#
# 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 3 of the License, 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
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see <https://www.gnu.org/licenses/>.
#
use Config;
use File::Basename;
use File::Spec::Functions;
use Cwd 'realpath';
# Support for relocatability.
sub find_curr_installdir {
# Determine curr_installdir, even taking into account symlinks.
my $curr_executable = $0;
my $basename = basename($0);
if ($curr_executable eq $basename) {
LOOP: for my $dir (split /$Config{path_sep}/, $ENV{PATH}) {
$dir = "." unless $dir;
for my $ext ('') {
my $filename = catfile($dir, "$curr_executable$ext");
if (-f $filename) {
$curr_executable = $filename;
last LOOP;
}
}
}
}
# Resolve symlinks and canonicalize.
return realpath(dirname($curr_executable));
}
sub find_prefixes {
# Compute the original/current installation prefixes by stripping the
# trailing directories off the original/current installation directories.
my ($orig_installprefix, $curr_installprefix) = @_;
my $orig_last = basename($orig_installprefix);
my $curr_last = basename($curr_installprefix);
if ($orig_last && $curr_last && $orig_last eq $curr_last) {
$orig_installprefix = dirname($orig_installprefix);
$curr_installprefix = dirname($curr_installprefix);
}
return $orig_installprefix, $curr_installprefix;
}
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;