Current File : //bin/epsffit

#!/usr/bin/perl
# -*- perl -*-
my $version_banner = <<END;
epsffit 2.07
Copyright (c) Reuben Thomas 2016.
Released under the GPL version 3, or (at your option) any later version.
END

use v5.10;
use warnings;
use strict;

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 List::Util qw(min);

use PSUtils;

our $program_name = basename($0);
my ($help_flag, $version_flag, $center, $rotate, $aspect, $maximize, $showpage);

sub usage {
  my ($exit_code) = @_;
  print STDERR <<END;
Usage: $program_name [OPTION...] LLX LLY URX URY [INFILE [OUTFILE]]
Fit an Encapsulated PostScript file to a given bounding box.

  -c, --center         center the image in the given bounding box
  -r, --rotate         rotate the image by 90 degrees counter-clockwise
  -a, --aspect         adjust the aspect ratio to fit the bounding box
  -m, --maximize       rotate the image to fill more of the page if possible
  -s, --showpage       append a /showpage to the file to force printing
      --help           display this help and exit
      --version        display version information and exit

(LLX, LLY) are the coordinates of the lower left corner of the box, and
(URX, URY) the upper right.

If OUTFILE is not specified, writes to standard output.
If INFILE is not specified, reads from standard input.
END
  exit $exit_code;
}

# Get arguments
Getopt::Long::Configure("bundling");
# Having configured bundling, must give short option names explicitly
my $opts = GetOptions(
  "center|centre|c" => \$center,
  "rotate|r" => \$rotate,
  "aspect|a" => \$aspect,
  "maximize|maximise|m" => \$maximize,
  "showpage|s" => \$showpage,
  "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 < 3 || $#ARGV > 5;

my $bbfound = 0;              # %%BoundingBox: found
my ($urx, $ury, $llx, $lly) = (0, 0, 0, 0);

my $fllx = singledimen(shift);
my $flly = singledimen(shift);
my $furx = singledimen(shift);
my $fury = singledimen(shift);

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

while (<$infile>) {
  if (/^%[%!]/) {
    # still in comment section
    if (/^%%BoundingBox:/) {
      if (/^%%BoundingBox: +([\d.]+) +([\d.]+) +([\d.]+) +([\d.]+)$/) {
        $bbfound = 1;
        $llx = int($1); # accept doubles, but convert to int
        $lly = int($2);
        $urx = int($3 + 0.5);
        $ury = int($4 + 0.5);
      }
    } elsif (/^%%EndComments/) {
      # don't repeat %%EndComments
      last;
    } else {
      print $outfile $_;
    }
  } else {
    last;
  }
}

Die("no %%BoundingBox:", 2) unless $bbfound;

# put BB, followed by scale & translate
my ($xoffset, $yoffset) = ($fllx, $flly);
my ($width, $height) = ($urx - $llx, $ury - $lly);

$rotate = 1 if $maximize &&
  (($width > $height && $fury - $flly > $furx - $fllx) ||
   ($width < $height && $fury - $flly < $furx - $fllx));

my ($fwidth, $fheight) = ($furx - $fllx, $fury - $flly);
($fwidth, $fheight) = ($fheight, $fwidth) if $rotate;

my ($xscale, $yscale) = ($fwidth / $width, $fheight / $height);

$xscale = $yscale = min($xscale, $yscale) if !$aspect; # preserve aspect ratio?
$width *= $xscale; # actual width and height after scaling
$height *= $yscale;
if ($center) {
   if ($rotate) {
      $xoffset += ($fheight - $height) / 2;
      $yoffset += ($fwidth - $width) / 2;
   } else {
      $xoffset += ($fwidth - $width) / 2;
      $yoffset += ($fheight - $height) / 2;
   }
}
say $outfile "%%BoundingBox: " . int($xoffset) . " " . int($yoffset) . " " .
  int($xoffset + ($rotate ? $height : $width)) . " " .
  int($yoffset + ($rotate ? $width : $height));
if ($rotate) { # compensate for original image shift
   $xoffset += $height + $lly * $yscale; # displacement for rotation
   $yoffset -= $llx * $xscale;
} else {
   $xoffset -= $llx * $xscale;
   $yoffset -= $lly * $yscale;
}
say $outfile "%%EndComments";
if ($showpage) {
  say $outfile "save /showpage{}def /copypage{}def /erasepage{}def";
} else {
  say $outfile "%%BeginProcSet: epsffit 1 0";
}
say $outfile "gsave " . (sprintf "%.3f %.3f translate", $xoffset, $yoffset);
say $outfile "90 rotate" if $rotate;
say $outfile (sprintf "%.3f %.3f scale", $xscale, $yscale);
say $outfile "%%EndProcSet" unless $showpage;
while (<$infile>) {
   print $outfile $_;
}
say $outfile "grestore";
say $outfile "restore showpage" if $showpage; # just in case

1; # exit with a true value (value of previous statement may be false)