Beefy Boxes and Bandwidth Generously Provided by pair Networks
Your skill will accomplish
what the force of many cannot
 
PerlMonks  

Testing -- making a new constructor behave differently for one package

by tj_thompson (Scribe)
on Jan 27, 2012 at 22:25 UTC ( #950458=perlquestion: print w/ replies, xml ) Need Help??
tj_thompson has asked for the wisdom of the Perl Monks concerning the following question:

Hello monks. I have a testing problem I'm trying to sort out. So I'm doing a high level test of my code, and I'm using a sqlite database to fake some database accesses. However, I need one of my modules to be able to access the real database.

Database is accessed through a handle class DB::Handle::RapTTR::Test and is accessed at many points in the code. The constructor for the real db handle is DB::Handle::RapTTR::Test->new. My plan was to do this in my test file (where RapTTR is the package needing access to the real db handle):

# added some debug output *DB::Handle::RapTTR::Test::real_new = \&DB::Handle::RapTTR::Test::new; *DB::Handle::RapTTR::Test::new = sub { print STDERR "CALLER (".join(',',caller()).")\n"; if (caller() eq 'RapTTR') { print STDERR "RETURNING REAL_NEW.\n"; <STDIN>; return DB::Handle::RapTTR::Test->real_new; } print STDERR "RETURNING FAKE NEW.\n"; <STDIN>; cluck "TRACE:"; return DB::Handle->new( connect_string => 'DBI:SQLite:dbname=./t/sqlite/rapttr', username => undef, password => undef ); };

However, I'm finding that the call DB::Handle::RapTTR::Test->real_new is recursing back into this defined DB::Handle::RapTTR::Test::new subroutine. This is the output:

TRACE: at t/comprehensive_3digbn_8digtid.t line 54 main::__ANON__('DB::Handle::RapTTR::Test') called at t/compreh +ensive_3digbn_8digtid.t line 50 main::__ANON__('DB::Handle::RapTTR::Test') called at /nfs/pdx/ +disks/nehalem.pde.077/projects/2.0_rapttr/RapTTR/blib/lib/RapTTR.pm l +ine 688 RapTTR::download_pcd_revision('RapTTR=HASH(0x26931a0)') called + at /nfs/pdx/disks/nehalem.pde.077/projects/2.0_rapttr/RapTTR/blib/li +b/RapTTR.pm line 100 RapTTR::harness('RapTTR=HASH(0x26931a0)') called at t/comprehe +nsive_3digbn_8digtid.t line 63 DBD::SQLite::db prepare failed: no such table: pcf_master at /nfs/pdx/ +disks/nehalem.pde.077/perl/5.12.2/lib64/site_perl/DB/Handle.pm line 1 +65, <STDIN> line 2. prepare failed with DBI error (1):no such table: pcf_master at /nfs/pdx/disks/nehalem.pde.077/perl/5.12.2/lib64/site_perl/DB/SQL/ +Query.pm line 114 DB::SQL::Query::_prepare('DB::SQL::Query=HASH(0x29fa520)', 'DB +::Handle=HASH(0x29fecf0)', 'SELECT job_name FROM pcf_master \x{a}WHER +E revision = ?\x{a}') called at /nfs/pdx/disks/nehalem.pde.077/perl/5 +.12.2/lib64/site_perl/DB/SQL/Query.pm line 131 DB::SQL::Query::_init_sth('DB::SQL::Query=HASH(0x29fa520)') ca +lled at accessor sth defined at /nfs/pdx/disks/nehalem.pde.077/perl/5 +.12.2/lib64/site_perl/DB/SQL/Query.pm line 57 DB::SQL::Query::sth('DB::SQL::Query=HASH(0x29fa520)') called a +t /nfs/pdx/disks/nehalem.pde.077/perl/5.12.2/lib64/site_perl/DB/SQL/Q +uery.pm line 85 DB::SQL::Query::execute('DB::SQL::Query=HASH(0x29fa520)', 216) + called at /nfs/pdx/disks/nehalem.pde.077/projects/2.0_rapttr/RapTTR/ +blib/lib/RapTTR/Utils.pm line 571 RapTTR::Utils::get_rapttr_db_data('Job Name', 'DB::Handle=HASH +(0x29fecf0)', 'SELECT job_name FROM pcf_master \x{a}WHERE revision = +?\x{a}', 216) called at /nfs/pdx/disks/nehalem.pde.077/projects/2.0_r +apttr/RapTTR/blib/lib/RapTTR.pm line 699 RapTTR::download_pcd_revision('RapTTR=HASH(0x26931a0)') called + at /nfs/pdx/disks/nehalem.pde.077/projects/2.0_rapttr/RapTTR/blib/li +b/RapTTR.pm line 100 RapTTR::harness('RapTTR=HASH(0x26931a0)') called at t/comprehe +nsive_3digbn_8digtid.t line 63 # Looks like you planned 24 tests but ran 2. # Looks like your test exited with 2 just after 2.

So here is where it fails to find a table because it's accessing the sqlite db instead of the real one:

prepare failed with DBI error (1):no such table: pcf_master at /nfs/pdx/disks/nehalem.pde.077/perl/5.12.2/lib64/site_perl/DB/SQL/ +Query.pm line 114

and here is where it's calling back into itself on the callstack, where the original call comes from RapTTR.pm line 688 and the recursive call from the test file at line 50:

main::__ANON__('DB::Handle::RapTTR::Test') called at t/comprehensive_3 +digbn_8digtid.t line 50 main::__ANON__('DB::Handle::RapTTR::Test') called at /nfs/pdx/ +disks/nehalem.pde.077/projects/2.0_rapttr/RapTTR/blib/lib/RapTTR.pm l +ine 688

So it calls into the new redefined new from the RapTTR package. It then tries to get the real db handle, but ends up recursing back into itself. It then sees that it was not called from RapTTR any more, but from main in the test file, and returns the fake db handle. The code then fails with the wrong db handle.

I wrote up some short test code, and it seems to verify that you can save the original subroutine like I am and access the real subroutine from inside the faked subroutine:

use strict; use warnings; use lib 'C:\scripts'; package Foo; sub bar { print "I am bar from Foo.\n"; } package main; no warnings 'redefine'; *Foo::real_bar = \&Foo::bar; *Foo::bar = sub { print "I am bar NEW!\n"; Foo->real_bar; *Foo::bar = \&Foo::real_bar; }; &print_stuff; sub print_stuff { &print_bar1; &print_bar2; } sub print_bar1 { Foo->bar; } sub print_bar2 { Foo->bar; } #################### OUTPUT: plxc16479> $h2/scripts/tmp.pl # output from redefined sub I am bar NEW! # output from original sub called from inside redefined sub I am bar from Foo. # output from original sub after being redefined back I am bar from Foo.

I don't see the recursing happening here. I am uncertain as to why the difference, but I'm guessing it has something to do with RapTTR being a Moose module and the way the new method is created for it.

So my actual questions: 1) what's going on here? 2) is there a better way to do what I'm trying to do?

As always, thanks for the time and I appreciate any and all insight!

UPDATE: As suggested by the kind anonymous monk below, I made a focused Moose based test case and do see the same problem there. Here is the Moose case:

#! /usr/intel/pkgs/perl/5.12.2/bin/perl use strict; use warnings; package Foo; use Moose; package FakeFoo; use Moose; package main; no warnings 'redefine'; *Foo::real_new = \&Foo::new; *Foo::new = sub { if (caller() eq 'Bar') { print "Returning real Foo.\n"; return Foo->real_new; } print "Returning fake Foo.\n"; return FakeFoo->new; }; my $obj = Foo->new; print STDERR __PACKAGE__.": FOO IS (".ref($obj).")\n"; package Bar; $obj = Foo->new; print STDERR __PACKAGE__.": FOO IS (".ref($obj).")\n"; package Other; $obj = Foo->new; print STDERR __PACKAGE__.": FOO IS (".ref($obj).")\n";

I should see a real Foo for the package Bar Foo object, but I instead see the call recurse and return a FakeFoo instead.

Comment on Testing -- making a new constructor behave differently for one package
Select or Download Code
Re: Testing -- making a new constructor behave differently for one package
by Anonymous Monk on Jan 27, 2012 at 22:42 UTC

    I don't see the recursing happening here. I am uncertain as to why the difference, but I'm guessing it has something to do with RapTTR being a Moose module and the way the new method is created for it.

    Well, the next step would be to make Foo a moose class, ie make Foo fail the same way as your real class

      Yep, excellent plan. Doing so now.
        Updated the thread above. The problem does show up in a Moose test case. So my question is...why?
Re: Testing -- making a new constructor behave differently for one package
by chromatic (Archbishop) on Jan 27, 2012 at 23:23 UTC

    I wrote about the way I solve this problem in You're Already Using Dependency Injection. In short, rather than hardcoding the name of a class to construct within your constructor, make the constructed object parametric—whether from passing an allomorphic equivalent to the constructor, using the default object, or overriding the accessor/builder from a subclass.


    Improve your skills with Modern Perl: the free book.

      Actually the name of the class I'm using is not hardcoded, and I believe the accessor where I get the name of the package to use might be an easier point to hijack the object creation instead of the actual new method. Thanks Chromatic!
Re: Testing -- making a new constructor behave differently for one package
by tobyink (Abbot) on Jan 28, 2012 at 13:39 UTC

    Given that you're already using Moose, which has method modifiers, don't mess around with rubbish like this:

    no warnings 'redefine'; *Foo::real_new = \&Foo::new; *Foo::new = sub { if (caller() eq 'Bar') { print "Returning real Foo.\n"; return Foo->real_new; } print "Returning fake Foo.\n"; return FakeFoo->new; };

    Use the features of your framework:

    { package Foo; use Moose; around new => sub { my ($orig, $class, @args) = @_; if (caller() eq 'Bar') { print "Returning real Foo.\n"; return $class->$orig(@args); } print "Returning fake Foo.\n"; return FakeFoo->new(@args); }; }

    Be aware that putting method modifiers on new can interfere with class immutability, so avoid doing this in production code. It should work fine for testing though.

    (Also be aware that the call stack can have various Moosey things in it when you use method modifiers. So checking caller() might not be enough - you might need to walk up the call stack a little.)

      Yeah, but that assumes that when you're designing Foo you want to hard code this test hook into the class. This seems like a bad plan for a number of reasons. Problem here is you need to test Foo after it's been created.

      I actually tried to figure out how to add a method modifier from the Foo meta class so it only existed during my test case, but couldn't quite figure how to do that yet...so this was my plan B...but I eventually went to plan C after realizing (thanks Chromatic) I could hijack the accessor to the class name. That turned out to be far simpler :)

        Why does it assume that? The around new => sub {}; stuff doesn't need to be in the same file where the Foo class is defined. I'd probably put it in the ".t" file.

Log In?
Username:
Password:

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

How do I use this? | Other CB clients
Other Users?
Others exploiting the Monastery: (14)
As of 2014-07-29 13:18 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    My favorite superfluous repetitious redundant duplicative phrase is:









    Results (217 votes), past polls