Beefy Boxes and Bandwidth Generously Provided by pair Networks
Keep It Simple, Stupid
 
PerlMonks  

Comment on

( #3333=superdoc: print w/ replies, xml ) Need Help??

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.

In reply to Re^2: Implicitly file tying ... by clueless newbie
in thread Implicitly file tying ... by clueless newbie

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?
    Username:
    Password:

    What's my password?
    Create A New User
    Chatterbox?
    and the web crawler heard nothing...

    How do I use this? | Other CB clients
    Other Users?
    Others perusing the Monastery: (13)
    As of 2015-07-28 21:23 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 (259 votes), past polls