Beefy Boxes and Bandwidth Generously Provided by pair Networks
"be consistent"
 
PerlMonks  

Re^2: Implicitly file tying ...

by clueless newbie (Hermit)
on Feb 15, 2012 at 12:58 UTC ( #953939=note: print w/ replies, xml ) Need Help??


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.


Comment on Re^2: Implicitly file tying ...
Download Code

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: note [id://953939]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others musing on the Monastery: (14)
As of 2015-07-06 16:13 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









    Results (77 votes), past polls