http://www.perlmonks.org?node_id=953939


in reply to Re: Implicitly file tying ...
in thread Implicitly file tying ...

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.

This module has not yet been thoroughly tested. The errors in this code are mine.

I ask forgiveness of all those giants whose toes I tripped on while coding this module.

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|S +CALARREF,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 parameter +s!"); }; }; # 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 readonl +y *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.