note
clueless newbie
<p>Thanks to Eliya, I have the following which can eavesdrop on applications which perform simple io (NB: we are currently not eavesdropping on the DBI). It is intended that this module be used via perl's -M switch or via perl's PERL5OPT.</p>
<p>This module has not yet been thoroughly tested. The errors in this code are mine.</p>
<p><i>I ask forgiveness of all those giants whose toes I tripped on while coding this module.</i></p>
<c>
package IOSnitch;
use 5.10.1;
use Carp;
use Data::Dumper;
use DBI;
use Params::Validate qw(:all);
use strict;
use warnings;
# Don't complain about ...
$Carp::CarpInternal{(__PACKAGE__)}++;
#=========== The following code should be altered to suit ones needs ============#
# Uses SQLite for logging
my $Logname="$0.SQLite";
my ($LOG_dbh,$LOG_sth);
# Set the log's name
sub import {
my $package=shift();
$Logname=$_[0]
if (@_);
}; # import:
# Log a record
sub log {
@_=Params::Validate::validate_pos(@_,{ type=>SCALAR|ARRAYREF|SCALARREF,optional=>1 });
local $Data::Dumper::Indent=0;
if (@_ == 0) { # location only
$LOG_sth->execute((caller(1))[3],''.Carp::longmess,undef);
}
elsif (ref $_[0] eq 'ARRAY') { # array content
$LOG_sth->execute((caller(1))[3],''.Carp::longmess,''.Data::Dumper->Dump([\@{$_[0]}],[qw(*)]));
}
elsif (ref $_[0] eq 'SCALAR') { # scalar content
$LOG_sth->execute((caller(1))[3],''.Carp::longmess,''.Data::Dumper->Dump([\${$_[0]}],[qw(*)]));
}
elsif (!ref $_[0]) { # String
$LOG_sth->execute((caller(1))[3],''.Carp::longmess,$_[0]);
}
else {
Carp::confess("IOSnitch::log was called with bad parameters!");
};
}; # log:
INIT {
# Connect
$LOG_dbh=DBI->connect("DBI:SQLite:$Logname",'','',{ AutoCommit=>0,PrintError=>1,RaiseError=>1 });
# Create the table if necessary
$LOG_dbh->do(<<"__SQL__");
create table if not exists IO (
mode text,
stacktrace text,
message text
);
__SQL__
# Prepare an insert
$LOG_sth=$LOG_dbh->prepare(<<"__SQL__");
insert into IO (mode,stacktrace,message) values (?,?,?)
__SQL__
# Tie STDERR, STDIN, STDOUT
tie *STDERR,"TieSTDERR";
tie *STDIN,"TieSTDIN";
tie *STDOUT,"TieSTDOUT";
};
END {
# Commit the records
$LOG_dbh->commit();
# and disconnect
$LOG_dbh->disconnect();
# Email the resulting SQLite database to the user
# ...
};
#=========== The preceeding code should be altered to suit ones needs ===========#
package TieSTDERR;
use strict;
use warnings;
$Carp::CarpInternal{(__PACKAGE__)}++;
# Tie STDERR subs {
sub CLOSE { };
sub DESTROY { };
sub OPEN { };
sub PRINT {
my $self_O=shift;
my(@Arg_a)=@_;
IOSnitch::log(@_ == 1 ? \$_[0] : [@_]);
warn @Arg_a;
}; # PRINT:
sub PRINTF {
my $self_O=shift;
my($Format_s,@Arg_a)=@_;
IOSnitch::log([@_]);#'
warn sprintf($Format_s,@Arg_a);
}; # PRINTF:
sub TIEHANDLE {
my $Class_C=shift;
return bless [];
}; # TIEHANDLE:
sub UNTIE {
my ($self_O,$count_S)=@_;
return;
}; # UNTIE:
# }; # Internal (tie) Subs:
package TieSTDIN;
use strict;
use warnings;
$Carp::CarpInternal{(__PACKAGE__)}++;
# Tie STDIN subs {
my $stdin;
sub CLOSE { };
sub DESTROY { };
sub OPEN { };
sub READLINE {
my $self_O=shift;
if (wantarray()) {
my @_a=<$stdin>;
IOSnitch::log([@_a]);
return @_a;
} else {
my $_s=<$stdin>;
IOSnitch::log(\$_s);
return $_s;
};
}; # READLINE:
sub TIEHANDLE {
my $Class_C=shift;
# Point $stdin to the real thingie ...
open($stdin, "<&STDIN");
return bless [];
}; # TIEHANDLE:
sub UNTIE {
my ($self_O,$count_S)=@_;
return;
}; # UNTIE:
# }; # Internal (tie) Subs:
package TieSTDOUT;
use strict;
use warnings;
$Carp::CarpInternal{(__PACKAGE__)}++;
# Tie STDOUT subs {
my $stdout;
sub CLOSE { };
sub DESTROY { };
sub OPEN { };
sub PRINT {
my $self_O=shift;
my(@Arg_a)=@_;
# write on the log
IOSnitch::log(@_ == 1 ? \$_[0] : [@_]);
# write on the real thingie
print $stdout @Arg_a;
}; # PRINT:
sub PRINTF {
my $self_O=shift;
my($Format_s,@Arg_a)=@_;
# write on the log
IOSnitch::log([@_]);
# write on the real thingie
print $stdout sprintf($Format_s,@Arg_a);
}; # PRINTF:
sub TIEHANDLE {
my $Class_C=shift;
# Point $stdout to the real thingie ...
open($stdout, ">&STDOUT");
return bless [];
}; # TIEHANDLE:
sub UNTIE {
my ($self_O,$count_S)=@_;
return;
}; # UNTIE:
# }; # Internal (tie) Subs:
package TieIO;
use Data::Dumper;
use strict;
use warnings;
$Carp::CarpInternal{(__PACKAGE__)}++;
# Tie IO subs {
my @IO;
sub CLOSE {
my $self_O=shift;
my $fh=$IO[$self_O->{fhno}];
close($fh);
IOSnitch::log();
}; # CLOSE:
sub DESTROY { };
sub OPEN { };
sub PRINT {
my $self_O=shift;
my $fh=$IO[$self_O->{fhno}];
my(@Arg_a)=@_;
# write on the log
IOSnitch::log(@_ == 1 ? \$_[0] : [@_]);
# write on the real thingie
print $fh @Arg_a;
}; # PRINT:
sub PRINTF {
my $self_O=shift;
my $fh=$IO[$self_O->{fhno}];
my($Format_s,@Arg_a)=@_;
# write on the log
IOSnitch::log([@_]);
# write on the real thingie
print $fh sprintf($Format_s,@Arg_a);
}; # PRINTF:
sub READLINE {
my $self_O=shift;
my $fh=$IO[$self_O->{fhno}];
if (wantarray()) {
my @_a=<$fh>;
IOSnitch::log([@_a]);
return @_a;
} else {
my $_s=<$fh>;
IOSnitch::log(\$_s);
return $_s;
};
}; # READLINE:
sub TIEHANDLE {
my $Class_C=shift;
# Point $fh to the real thingie ...
open(my $IO,"+>&",$_[0]);
IOSnitch::log();
push(@IO,$IO);
return bless { fhno=>$#IO, name=>$_[1] };
}; # TIEHANDLE:
sub UNTIE { #say __PACKAGE__."::UNTIE<>\n";
my ($self_O,$count_S)=@_;
return;
}; # UNTIE:
# }; # Internal (tie) Subs:
BEGIN {
# Currently not checking to insure the file will be opened readonly
*CORE::GLOBAL::open=sub (*;$@) { # Thanks to Eliya
use Symbol();
my $handle;
if (defined $_[0]) {
$handle = Symbol::qualify_to_ref($_[0], scalar caller);
};
if (@_ == 1) {
CORE::open $handle
or warn $! and return 0;
}
elsif (@_ == 2) {
CORE::open $handle, $_[1]
or warn $! and return 0;
}
elsif (@_ == 3) {
if (defined $_[2]) {
CORE::open $handle, $_[1], $_[2]
or warn $! and return 0;
}
else {
CORE::open $handle, $_[1], undef # special case
or warn $! and return 0;
};
}
else {
CORE::open $handle, $_[1], $_[2], @_[3..$#_]
or warn $! and return 0;
};
$_[0]=$handle
unless defined $_[0]; # pass up to caller
tie *$handle,"TieIO",*$handle,$_[2]||'?'
};
};
0**0
__END__
=head1 NAME
IOSnitch - eavesdrop on applications simple io
=head1 VERSION
This documentation refers to IOSnitch version 0.0.1.
=head1 SYNOPSIS
perl -MIOSnitch <application> ...
or
export PERL5OPT='-MIOSnitch'
sqlite3 <application>.SQLite
=head1 LICENSE AND COPYRIGHT
This software is Copyright (c) 2012 by Clueless Newbie.
</c>
953722
953731