Beefy Boxes and Bandwidth Generously Provided by pair Networks
Pathologically Eclectic Rubbish Lister
 
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
  • Outside of code tags, you may need to use entities for some characters:
            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 having an uproarious good time at the Monastery: (11)
    As of 2014-07-14 10:59 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      When choosing user names for websites, I prefer to use:








      Results (257 votes), past polls