/usr/share/perl5/Pristine/Tar.pm is in pristine-tar 1.33.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 | #!/usr/bin/perl
# pristine-tar utility library
package Pristine::Tar;
use warnings;
use strict;
use File::Temp;
use Getopt::Long;
use IPC::Open2;
use Exporter q{import};
our @EXPORT = qw(error message debug vprint doit try_doit doit_redir
tempdir dispatch comparefiles
$verbose $debug $keep);
our $verbose=0;
our $debug=0;
our $keep=0;
sub progname {
my $name=$0;
$name=~s!^.*/(.+)$!$1!;
return $name
}
sub error {
die progname().": @_\n";
}
sub message {
print STDERR progname().": @_\n";
}
sub debug {
message(@_) if $debug;
}
sub vprint {
message(@_) if $verbose;
}
sub doit {
if (try_doit(@_) != 0) {
error "command failed: @_";
}
}
sub try_doit {
vprint(@_);
return system(@_)
}
sub doit_redir {
no warnings 'once';
my ($in, $out, @args) = @_;
vprint(@args, "<", $in, ">", $out);
open INFILE, "<", $in or die("Could not open '$in' for reading: $!\n");
open OUTFILE, ">", $out or die("Could not open '$out' for reading: $!\n");
my $pid = open2(">&OUTFILE", "<&INFILE", @args);
waitpid $pid, 0;
if ($? != 0) {
error "command failed: @args";
}
}
sub tempdir {
return File::Temp::tempdir("pristine-tar.XXXXXXXXXX",
TMPDIR => 1, CLEANUP => !$keep);
}
# Workaround for bug #479317 in perl 5.10.
sub END {
chdir("/");
}
sub dispatch {
my %params=@_;
my %commands=%{$params{commands}};
my %options=%{$params{options}} if exists $params{options};
my $command;
Getopt::Long::Configure("bundling");
if (! GetOptions(%options,
"v|verbose!" => \$verbose,
"d|debug!" => \$debug,
"k|keep!" => \$keep) ||
! @ARGV) {
$command="usage";
}
else {
$command=shift @ARGV;
}
my $i=$commands{$command};
if (! defined $i) {
error "Unknown subcommand \"$command\"";
}
# Check that the right number of args were passed by user.
if (defined $i->[1] && @ARGV != $i->[1]) {
$command="usage";
$i=$commands{$command};
}
$i->[0]->(@ARGV);
}
sub comparefiles {
my ($old, $new) = (shift, shift);
system('cmp', '-s', $old, $new);
if ($? == -1 || $? & 127) {
die("Failed to execute cmp: $!\n");
}
return $? >> 8;
}
1
|