139 lines
3.2 KiB
Perl
Executable file
139 lines
3.2 KiB
Perl
Executable file
#!/usr/bin/perl
|
|
|
|
use Getopt::Long;
|
|
|
|
$Global::progname = "tracefile";
|
|
|
|
Getopt::Long::Configure("bundling","pass_through");
|
|
get_options_from_array(\@ARGV) || die_usage();
|
|
|
|
if(not ($opt::exists or $opt::nonexists or $opt::all)) {
|
|
$opt::all = 1;
|
|
}
|
|
|
|
my @cmd = shell_quote(@ARGV);
|
|
my $dir = ".";
|
|
|
|
open(IN, "-|", "strace -ff -e trace=file @cmd 2>&1") || die;
|
|
while(<IN>) {
|
|
if(/chdir."(([^\\"]|\\[\\"nt])*)".\s*=\s*0/) {
|
|
$dir = $1;
|
|
}
|
|
|
|
# [pid 30817] stat("transpose/100000files.tar.gz", {st_mode=S_IFREG|0644, st_size=140853248, ...}) = 0
|
|
if(s/^[^\"]+"(([^\\"]|\\[\\"nt])*)".*/$1/) {
|
|
# Matches the strace structure for a file
|
|
my $file = shell_unquote($1);
|
|
# Relative to $dir
|
|
$file =~ s:^([^/]):$dir/$1:;
|
|
my $print = 0;
|
|
if($opt::all
|
|
or
|
|
($opt::exists and -e $file)
|
|
or
|
|
($opt::nonexists and not -e $file)) {
|
|
$print = 1;
|
|
}
|
|
if($opt::unique and $seen{$file}++) {
|
|
$print = 0;
|
|
}
|
|
$print and print $file,"\n";
|
|
}
|
|
}
|
|
|
|
sub options_hash {
|
|
# Returns a hash of the GetOptions config
|
|
return
|
|
("debug|D" => \$opt::debug,
|
|
"uniq|unique|u" => \$opt::unique,
|
|
"exists|exist|e" => \$opt::exists,
|
|
"nonexists|nonexist|non-exists|non-exist|n" => \$opt::nonexists,
|
|
"all|a" => \$opt::all,
|
|
);
|
|
}
|
|
|
|
sub get_options_from_array {
|
|
# Run GetOptions on @array
|
|
# Returns:
|
|
# true if parsing worked
|
|
# false if parsing failed
|
|
# @array is changed
|
|
my $array_ref = shift;
|
|
# A bit of shuffling of @ARGV needed as GetOptionsFromArray is not
|
|
# supported everywhere
|
|
my @save_argv;
|
|
my $this_is_ARGV = (\@::ARGV == $array_ref);
|
|
if(not $this_is_ARGV) {
|
|
@save_argv = @::ARGV;
|
|
@::ARGV = @{$array_ref};
|
|
}
|
|
my @retval = GetOptions(options_hash());
|
|
if(not $this_is_ARGV) {
|
|
@{$array_ref} = @::ARGV;
|
|
@::ARGV = @save_argv;
|
|
}
|
|
return @retval;
|
|
}
|
|
|
|
sub shell_unquote {
|
|
# Unquote strings from shell_quote
|
|
# Returns:
|
|
# string with shell quoting removed
|
|
my @strings = (@_);
|
|
my $arg;
|
|
for my $arg (@strings) {
|
|
if(not defined $arg) {
|
|
$arg = "";
|
|
}
|
|
$arg =~ s/'\n'/\n/g; # filenames with '\n' is quoted using \'
|
|
$arg =~ s/\\([\002-\011\013-\032])/$1/g;
|
|
$arg =~ s/\\([\#\?\`\(\)\{\}\*\>\<\~\|\; \"\!\$\&\'])/$1/g;
|
|
$arg =~ s/\\\\/\\/g;
|
|
}
|
|
return wantarray ? @strings : "@strings";
|
|
}
|
|
|
|
sub shell_quote {
|
|
my @strings = (@_);
|
|
for my $a (@strings) {
|
|
$a =~ s/([\002-\011\013-\032\\\#\?\`\(\)\{\}\[\]\*\>\<\~\|\; \"\!\$\&\'\202-\377])/\\$1/g;
|
|
$a =~ s/[\n]/'\n'/g; # filenames with '\n' is quoted using \'
|
|
}
|
|
return wantarray ? @strings : "@strings";
|
|
}
|
|
|
|
sub die_usage {
|
|
# Returns: N/A
|
|
usage();
|
|
wait_and_exit(255);
|
|
}
|
|
|
|
sub usage {
|
|
# Returns: N/A
|
|
print join
|
|
("\n",
|
|
"Usage:",
|
|
"$Global::progname [-u] [-a] [-n] [-e] command [arguments]",
|
|
"",
|
|
"See 'man $Global::progname' for details",
|
|
"");
|
|
}
|
|
|
|
sub warning {
|
|
my @w = @_;
|
|
my $fh = $Global::original_stderr || *STDERR;
|
|
my $prog = $Global::progname || "tracefile";
|
|
print $fh $prog, ": Warning: ", @w;
|
|
}
|
|
|
|
|
|
sub error {
|
|
my @w = @_;
|
|
my $fh = $Global::original_stderr || *STDERR;
|
|
my $prog = $Global::progname || "tracefile";
|
|
print $fh $prog, ": Error: ", @w;
|
|
}
|
|
|
|
|
|
|