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

clueless newbie has asked for the wisdom of the Perl Monks concerning the following question:

Ave:

I'm trying to create a module that for all practical purposes "sits astride" an application recording all of the application's input. (For this discussion let us assume that the application is file-wise relatively simple: open a file for reading only or open a file for writing only.)

STDIN is easily handled, but implicitly tying files being opened for input has me stumped. I've started by writing a tie package and overriding CORE::GLOBAL::open (thanks Eliya) with one that performs the tie. In the simplest case, opening one file and reading from it appears to work. Getting it to work when more than one file is opened is another story.

Let's begin with the tying package (call it TieInput.pm)

package TieInput; use Data::Dumper; use strict; use warnings; # TieInput subs { my @In; sub CLOSE { my $self_O=shift; my $fh=$In[$self_O->{fhno}]; close($fh); }; # CLOSE: sub DESTROY { }; # DESTROY: sub OPEN { }; # OPEN: sub READLINE { my $self_O=shift; my $fh=$In[$self_O->{fhno}]; if (wantarray()) { my @_a=<$fh>; warn __PACKAGE__,": ",Data::Dumper->Dump([\@_a],[qw(*_a)] +); return @_a; } else { my $_s=<$fh>; warn __PACKAGE__,": ",Data::Dumper->Dump([\$_s],[qw(*_s)] +); return $_s; }; }; # READLINE: sub TIEHANDLE { my $Class_C=shift; # Point $fh to the real thingie ... open(my $In,"<&",$_[0]); push(@In,$In); return bless { fhno=>$#In }; }; # TIEHANDLE: sub UNTIE { #say __PACKAGE__."::UNTIE<>\n"; my ($self_O,$count_S)=@_; return; }; # UNTIE: # }; # Internal (tie) Subs: BEGIN { # Thanks to Eliya # Currently not checking to insure the file will be opened readonl +y *CORE::GLOBAL::open=sub (*;$@) { #use Symbol(); #my $handle=Symbol::qualify_to_ref($_[0], scalar caller); # #$_[0]=$handle # unless defined $_[0]; # pass up to caller my $handle; 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; }; tie *$handle,"TieInput",*$handle; }; # CORE::GLOBAL::open }; __PACKAGE__ __END__

Example.pl: perl Example.pl or perl -MTieInput Example.pl

#! use Data::Dumper; use strict; use warnings; { # open one input - works with TieInput warn "opening in1.txt:\n"; open my $in1,"<","in1.txt" or die $!; my $s=<$in1>; warn Data::Dumper->Dump([\$s],[qw(*s)]).' '; my @a=<$in1>; warn Data::Dumper->Dump([\@a],[qw(*a)]).' '; close $in1; }; { # open two inputs - fails with TieInput warn "opening in1.txt and in2.txt:\n"; open my $in1,"<","in1.txt" or die $!; open my $in2,"<","in2.txt" or die $!; my $s=<$in1>; warn Data::Dumper->Dump([\$s],[qw(*s)]).' '; $s=<$in2>; warn Data::Dumper->Dump([\$s],[qw(*s)]).' '; my @a=<$in1>; warn Data::Dumper->Dump([\@a],[qw(*a)]).' '; @a=<$in2>; warn Data::Dumper->Dump([\@a],[qw(*a)]).' '; close $in1; close $in2; }; exit;

With in1.txt

in1 A in1 B in1 C

and in2.txt

in2 A in2 B in2 C

Obviously I've done something wrong! What would be appreciated!

Replies are listed 'Best First'.
Re: Implicitly file tying ...
by Eliya (Vicar) on Feb 14, 2012 at 17:18 UTC

    You've commented out an essential statement :)

    $_[0]=$handle unless defined $_[0]; # pass up to caller

    This sets the $fh in open my $fh, ...  Without it, $fh won't be the handle created in *CORE::GLOBAL::open.

    Putting this near the end of that routine should suffice, but if you want the overridden open() to work for other forms too (not only 3-args open with lexical file handle), you should also re-enable the qualify_to_ref(...), i.e. the routine should then look like

    *CORE::GLOBAL::open=sub (*;$@) { 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,"TieInput",*$handle; };

    With this change, I get the following output:

    $ ./953722.pl opening in1.txt: TieInput: $_s = \'in1 A '; $s = \'in1 A '; at ./953722.pl line 107, <$In> line 1. TieInput: @_a = ( 'in1 B ', 'in1 C ' ); @a = ( 'in1 B ', 'in1 C ' ); at ./953722.pl line 109, <$In> line 3. opening in1.txt and in2.txt: TieInput: $_s = \'in1 A '; $s = \'in1 A '; at ./953722.pl line 118, <$In> line 1. TieInput: $_s = \'in2 A '; $s = \'in2 A '; at ./953722.pl line 120, <$In> line 1. TieInput: @_a = ( 'in1 B ', 'in1 C ' ); @a = ( 'in1 B ', 'in1 C ' ); at ./953722.pl line 122, <$In> line 3. TieInput: @_a = ( 'in2 B ', 'in2 C ' ); @a = ( 'in2 B ', 'in2 C ' ); at ./953722.pl line 124, <$In> line 3.

      Thank you! Thank you!

      I'm sure I tried it with that line(s) uncommented without success. At least I think I'm sure!

      Thanks again!

      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.