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
      );
  };

[download]

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.

[download]

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

[download]

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

[download]

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.

[download]

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";

[download]

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

Replies are listed 'Best First'.
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.

[reply]
      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!
[reply]
Re: Testing -- making a new constructor behave differently for one package
by tobyink (Canon) 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;
};

    [download]

    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);
  };
}

    [download]

    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.)

[reply]
[d/l]
[select]

      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 :)

[reply]

        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.

[reply]
[d/l]
[select]
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

[reply]
      Yep, excellent plan. Doing so now.
[reply]
        Updated the thread above. The problem does show up in a Moose test case. So my question is...why?
[reply]

Back to Seekers of Perl Wisdom