tracefile: --read + --write support.
This commit is contained in:
Ole Tange
parent
0621b812ce
commit
2598055fcb
|
|
@ -6,9 +6,9 @@ tracefile - list files being accessed
|
|||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
B<tracefile> [-adefnu] I<command>
|
||||
B<tracefile> [-adefnruw] I<command>
|
||||
|
||||
B<tracefile> [-adefnu] -p I<pid>
|
||||
B<tracefile> [-adefnruw] -p I<pid>
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
|
|
@ -48,7 +48,7 @@ List only existing files.
|
|||
|
||||
=item B<--file>
|
||||
|
||||
List only files.
|
||||
List only normal files.
|
||||
|
||||
|
||||
=item B<-n>
|
||||
|
|
@ -71,6 +71,21 @@ Trace process id.
|
|||
|
||||
List only files once.
|
||||
|
||||
|
||||
=item B<-r>
|
||||
|
||||
=item B<--read>
|
||||
|
||||
List only files being access for reading.
|
||||
|
||||
|
||||
=item B<-w>
|
||||
|
||||
=item B<--write>
|
||||
|
||||
List only files being access for writing.
|
||||
|
||||
|
||||
=back
|
||||
|
||||
|
||||
|
|
@ -98,7 +113,7 @@ Report bugs to <tange@gnu.org>.
|
|||
|
||||
=head1 AUTHOR
|
||||
|
||||
Copyright (C) 2012,2016,2017 Ole Tange, http://ole.tange.dk and Free
|
||||
Copyright (C) 2012-2019 Ole Tange, http://ole.tange.dk and Free
|
||||
Software Foundation, Inc.
|
||||
|
||||
|
||||
|
|
@ -227,7 +242,7 @@ $Global::progname = "tracefile";
|
|||
|
||||
Getopt::Long::Configure("bundling","require_order");
|
||||
get_options_from_array(\@ARGV) || die_usage();
|
||||
|
||||
init_functions();
|
||||
if(not ($opt::exists or $opt::nonexists or $opt::all or $opt::dir or $opt::file)) {
|
||||
$opt::all = 1;
|
||||
}
|
||||
|
|
@ -241,15 +256,30 @@ 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/) {
|
||||
# [pid 30817] stat("t/tar.gz", {st_mode=S_IFREG|0644, st_size=140853248, ...}) = 0
|
||||
# openat(AT_FDCWD, "/tmp/a", O_WRONLY|O_CREAT|O_NOCTTY|O_NONBLOCK, 0666) = 3
|
||||
if(/^(\[[^]]\])? # Match pid
|
||||
\s*([^\" ]+) # function
|
||||
[(] # (
|
||||
[^"]* # E.g. AT_FDCWD
|
||||
" # "
|
||||
(([^\\"]|\\[\\"nt])*) # content of string with \n \" \t \\
|
||||
"(.*)/x) # Rest
|
||||
{
|
||||
# Matches the strace structure for a file
|
||||
my $file = shell_unquote($1);
|
||||
my $function = $2;
|
||||
my $file = shell_unquote($3);
|
||||
my $addinfo = $5;
|
||||
# Relative to $dir
|
||||
$file =~ s:^([^/]):$dir/$1:;
|
||||
my $read = readfunc($function,$addinfo);
|
||||
my $write = writefunc($function,$addinfo);
|
||||
my $print = 1;
|
||||
if(($opt::dir and not -d $file)
|
||||
if(($opt::read and not $read)
|
||||
or
|
||||
($opt::write and not $write)
|
||||
or
|
||||
($opt::dir and not -d $file)
|
||||
or
|
||||
($opt::file and not -f $file)
|
||||
or
|
||||
|
|
@ -262,6 +292,69 @@ while(<IN>) {
|
|||
}
|
||||
$print and print $file,"\n";
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
{
|
||||
my %warned;
|
||||
my %funcs;
|
||||
|
||||
sub init_functions {
|
||||
# function name => r/w/rw/n/?
|
||||
# r = read
|
||||
# w = write
|
||||
# rw = read+write
|
||||
# n = neither (false match)
|
||||
# ? = TODO figure out what they do
|
||||
%funcs =
|
||||
qw(access r acct ? chdir r chmod w chown w chown16 w
|
||||
chroot r creat w execv r execve r execveat r faccessat
|
||||
r fanotify_mark ? fchmodat w fchownat w fstat r fstat64
|
||||
r fstatat64 r fstatfs r fstatfs64 r futimesat r getcwd
|
||||
r getxattr r inotify_add_watch r link w linkat w
|
||||
listxattr r lstat r lstat64 r mkdir w mkdirat w mknod w
|
||||
mknodat w mount r name_to_handle_at ? newfstatat r
|
||||
oldfstat r oldlstat r oldstat r open rw openat rw
|
||||
osf_fstatfs r osf_statfs r osf_utimes r perror n pivotroot r
|
||||
printargs ? printf n quotactl ? readlink r readlinkat r
|
||||
removexattr w rename w renameat w renameat2 w rmdir w
|
||||
setxattr w stat r stat64 r statfs r statfs64 r statx r
|
||||
swapoff w swapon w symlink w symlinkat w truncate w
|
||||
truncate64 w umount r umount2 r unlink w unlinkat w
|
||||
uselib r utime w utimensat w utimes w);
|
||||
}
|
||||
|
||||
sub readfunc {
|
||||
# The call is a call that would work on a RO file system
|
||||
my($func,$info) = @_;
|
||||
if($func eq "open" or $func eq "openat") {
|
||||
return ($info=~/O_RDONLY/);
|
||||
}
|
||||
if($funcs{$func}) {
|
||||
return ($funcs{$func} eq "r");
|
||||
} else {
|
||||
$warned{$func}++ or
|
||||
warning("'$func' is unknown. Please report at",
|
||||
"https://gitlab.com/ole.tange/tangetools/issues");
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
|
||||
sub writefunc {
|
||||
# The call is a call that would need RW file system
|
||||
my($func,$info) = @_;
|
||||
if($func eq "open" or $func eq "openat") {
|
||||
return ($info=~/O_WRONLY|O_APPEND|O_CREAT/);
|
||||
}
|
||||
if($funcs{$func}) {
|
||||
return ($funcs{$func} eq "w");
|
||||
} else {
|
||||
$warned{$func}++ or
|
||||
warning("$func is unknown. Please report at",
|
||||
"https://gitlab.com/ole.tange/tangetools/issues");
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub options_hash {
|
||||
|
|
@ -273,6 +366,8 @@ sub options_hash {
|
|||
"uniq|unique|u" => \$opt::unique,
|
||||
"exists|exist|e" => \$opt::exists,
|
||||
"nonexists|nonexist|non-exists|non-exist|n" => \$opt::nonexists,
|
||||
"read|r" => \$opt::read,
|
||||
"write|w" => \$opt::write,
|
||||
"all|a" => \$opt::all,
|
||||
"pid|p=i" => \$opt::pid,
|
||||
);
|
||||
|
|
@ -349,7 +444,7 @@ sub warning {
|
|||
my @w = @_;
|
||||
my $fh = $Global::original_stderr || *STDERR;
|
||||
my $prog = $Global::progname || "tracefile";
|
||||
print $fh $prog, ": Warning: ", @w;
|
||||
print $fh map { ($prog, ": Warning: ", $_, "\n"); } @w;
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -360,5 +455,29 @@ sub error {
|
|||
print $fh $prog, ": Error: ", @w;
|
||||
}
|
||||
|
||||
|
||||
sub my_dump(@) {
|
||||
# Returns:
|
||||
# ascii expression of object if Data::Dump(er) is installed
|
||||
# error code otherwise
|
||||
my @dump_this = (@_);
|
||||
eval "use Data::Dump qw(dump);";
|
||||
if ($@) {
|
||||
# Data::Dump not installed
|
||||
eval "use Data::Dumper;";
|
||||
if ($@) {
|
||||
my $err = "Neither Data::Dump nor Data::Dumper is installed\n".
|
||||
"Not dumping output\n";
|
||||
::status($err);
|
||||
return $err;
|
||||
} else {
|
||||
return Dumper(@dump_this);
|
||||
}
|
||||
} else {
|
||||
# Create a dummy Data::Dump:dump as Hans Schou sometimes has
|
||||
# it undefined
|
||||
eval "sub Data::Dump:dump {}";
|
||||
eval "use Data::Dump qw(dump);";
|
||||
return (Data::Dump::dump(@dump_this));
|
||||
}
|
||||
}
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue