tangetools/tracefile/tracefile

#!/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;
}