Current File : //bin/paper

#!/usr/bin/perl
# -*- perl -*-

use 5.10.1;
use strict;
use warnings;
use locale;

# Relocatable header (see after for copyright)

# 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 $libexecdir = &relocate("/usr/libexec");
my $sysconfdir = &relocate("/etc");

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


use Scalar::Util qw(looks_like_number);
use File::Basename;
use File::Spec::Functions;
use Getopt::Long;


my $program_name = basename($0);
$program_name =~ s/\Q.pl\E$//;
my $version_banner = <<END;
$program_name 2.3

Copyright (c) 2013-2020 Reuben Thomas <rrt\@sc3d.org>.
Released under the GPL version 3, or (at your option) any later version.
END

sub Die {
  say STDERR "$program_name: $_[0]";
  exit(1);
}

my %units = (
  "pt" => 1,
  "mm" => 72 * .1 / 2.54,
  "in" => 72,
 );
my $unit_err = "bad unit (valid units: " . join(", ", keys %units) . ")";

sub usage {
  my ($exit_code) = @_;
  print STDERR <<END;
Usage: $program_name [OPTION...] [PAPER...|--all]
Print paper size information.

  --all                print information about all known paper sizes
  --name               print paper names (by default, the name is not
                       printed when only one paper argument is given)
  --size               print paper sizes (width followed by height)
  --unit=UNIT          print dimensions in the given unit
                       [default: PostScript points]
  --help               display this help and exit
  --version            display version information and exit
END
  exit $exit_code;
}

# Parse command-line options
my ($opt_all, $opt_name, $opt_size, $opt_help, $opt_version);
my $unit = "pt";
my $opts = GetOptions(
  "all" => \$opt_all,
  "name" => \$opt_name,
  "size" => \$opt_size,
  "unit=s" => \$unit,
  "help" => \$opt_help,
  "version" => \$opt_version,
 ) or usage(1);
if ($opt_version) {
  print STDERR $version_banner;
  exit 0;
}
usage(0) if $opt_help;
my $dim = $units{$unit} or Die($unit_err);
usage(1) if $opt_all && $#ARGV >= 0;

# Initialise papers list
sub readspecs {
  my ($file) = @_;
  my @papers;
  return unless open(PAPERSPECS, $file);
  while (<PAPERSPECS>) {
    chomp $_;
    my ($name, $w, $h, $unit) = split /,/;
    $name =~ s/ //;
    local *local_die = sub { Die("$_[0] in line $. of $file"); };
    local_die("missing field") if !defined($name) || !defined($w) || !defined($h) || !defined($unit);
    local_die("bad width") unless looks_like_number($w);
    local_die("bad height") unless looks_like_number($h);
    my $dim = $units{$unit};
    local_die($unit_err) unless $dim;
    push @papers, {name => $name, width => $w * $dim, height => $h * $dim};
  }
  close(PAPERSPECS);
  return @papers;
}

my (@papers, @user_papers, @system_papers, $default_paper);
my $xdg_config_home = $ENV{XDG_CONFIG_HOME};
unless ($xdg_config_home) {
  my $home = $ENV{HOME};
  $xdg_config_home = catfile($home, ".config") if $home;
}
@user_papers = readspecs(catfile($xdg_config_home, "paperspecs"));
@system_papers = readspecs(catfile($sysconfdir, "paperspecs"));
$default_paper = $system_papers[0] || $user_papers[0] || Die("no paper sizes configured");
push @papers, @user_papers, @system_papers;

# Get paper type from the locale
sub mm_to_pt { int(($_[0] * 72 / 2.54 / 10) + 0.5); }

sub trim {
  my ($s) = @_;
  $s =~ s/^\s+|\s+$//g;
  return $s;
}

sub papernamefile {
  my ($file) = @_;
  open(PAPERSIZE, $file) or return;
  my $output = do {local $/, <PAPERSIZE>} or return;
  return trim($output);
}

sub localepapername {
  my $localepaper = catfile($libexecdir, "localepaper");
  my $dims = `$localepaper` or return;
  chomp $dims;
  return if !defined($dims);
  my ($w, $h) = split /\s/, $dims;
  return if !looks_like_number($w) || !looks_like_number($h);
  ($w, $h) = map { mm_to_pt($_) } $w, $h;
  foreach my $p (@papers) {
    return $p->{name} if int($p->{width} + 0.5) == $w && int($p->{height} + 0.5) == $h;
  }
}

# Work out user's current paper size
sub currentpaper {
  return $ENV{PAPERSIZE} ||
    papernamefile(catfile($xdg_config_home, "papersize")) ||
    localepapername() ||
    papernamefile(catfile($sysconfdir, "papersize")) ||
    $default_paper->{name};
}

sub paperinfo {
  my ($paper) = @_;
  foreach my $p (@papers) {
    return $p if $p->{name} =~ /^$paper$/i;
  }
}

# Output requested information
map { push @ARGV, $_->{name} } @papers if $opt_all;
$opt_name = 1 if $#ARGV > 0;
if ($#ARGV == -1) {
  my $paper = currentpaper() or Die("no default paper size is set");
  push @ARGV, $paper;
}
foreach my $name (@ARGV) {
  my $p = paperinfo($name) or Die("unknown paper `$name'");
  my @out;
  push @out, $p->{name} if $opt_name || $opt_all || !$opt_size;
  push @out, $p->{width} / $dim, $p->{height} / $dim if $opt_size;
  say join(' ', @out);
}