1 ### make sure we can find our conf.pl file
4 require "$FindBin::Bin/inc/conf.pl";
8 use Test::More 'no_plan';
10 use CPANPLUS::Configure;
11 use CPANPLUS::Backend;
12 use CPANPLUS::Internals::Constants;
13 use Module::Load::Conditional qw[can_load];
16 my $cb = CPANPLUS::Backend->new( CPANPLUS::Configure->new() );
18 isa_ok($cb, 'CPANPLUS::Internals');
19 is($cb->_id, $cb->_last_id, "Comparing ID's");
21 ### delete/store/retrieve id tests ###
22 { my $del = $cb->_remove_id( $cb->_id );
23 ok( $del, "ID deleted" );
24 isa_ok( $del, "CPANPLUS::Internals" );
25 is( $del, $cb, " Deleted ID matches last object" );
27 my $id = $cb->_store_id( $del );
28 ok( $id, "ID stored" );
29 is( $id, $cb->_id, " Stored proper ID" );
31 my $obj = $cb->_retrieve_id( $id );
32 ok( $obj, "Object retrieved from ID" );
33 isa_ok( $obj, 'CPANPLUS::Internals' );
34 is( $obj->_id, $id, " Retrieved ID properly" );
36 my @obs = $cb->_return_all_objects();
37 ok( scalar(@obs), "Returned objects" );
38 is( scalar(@obs), 1, " Proper amount of objects found" );
39 is( $obs[0]->_id, $id, " Proper ID found on object" );
41 my $lid = $cb->_last_id;
42 ok( $lid, "Found last registered ID" );
43 is( $lid, $id, " ID matches last object" );
45 my $iid = $cb->_inc_id;
46 ok( $iid, "Incremented ID" );
47 is( $iid, $id+1, " ID matched last ID + 1" );
52 my $host = $cb->configure_object->get_conf('hosts')->[0];
54 is( $cb->_host_ok( host => $host ), 1, "Host ok" );
55 is( $cb->_add_fail_host(host => $host), 1, " Host now marked as bad" );
56 is( $cb->_host_ok( host => $host ), 0, " Host still bad" );
57 ok( $cb->_flush( list => ['hosts'] ), " Hosts flushed" );
58 is( $cb->_host_ok( host => $host ), 1, " Host now ok again" );
62 { my $mod = 'Benchmark';
63 my $file = $mod . '.pm';
65 ### XXX whitebox test -- mark this module as unloadable
66 $Module::Load::Conditional::CACHE->{$mod}->{usable} = 0;
68 ok( !can_load( modules => { $mod => 0 }, verbose => 0 ),
69 "'$mod' not loaded" );
71 ok( $cb->flush('load'), " 'load' cache flushed" );
72 ok( can_load( modules => { $mod => 0 }, verbose => 0 ),
76 ### add to inc path tests
77 { my $meth = '_add_to_includepath';
80 my $p5lib = $ENV{PERL5LIB} || '';
82 ok( $cb->$meth( directories => [$$] ),
85 my $new_p5lib = $ENV{PERL5LIB};
87 isnt( $p5lib, $new_p5lib, " PERL5LIB is now: $new_p5lib" );
88 like( $new_p5lib, qr/$$/, " Matches $$" );
90 isnt( $inc, $new_inc, ' @INC is expanded with: ' . $$ );
91 like( $new_inc, qr/$$/, " Matches $$" );
93 ok( $cb->$meth( directories => [$$] ),
94 " CB->$meth( $$ ) again" );
95 is( "@INC", $new_inc, ' @INC unchanged' );
96 is( $new_p5lib, $ENV{PERL5LIB},
97 " PERL5LIB unchanged" );
100 ### callback registering tests ###
101 { my $callback_map = {
102 ### name default value
103 install_prerequisite => 1, # install prereqs when 'ask' is set?
104 edit_test_report => 0, # edit the prepared test report?
105 send_test_report => 1, # send the test report?
106 munge_test_report => $$, # munge the test report
107 filter_prereqs => $$, # limit prereqs
108 proceed_on_test_failure => 0, # continue on failed 'make test'?
109 munge_dist_metafile => $$, # munge the metailfe
112 for my $callback ( keys %$callback_map ) {
114 { my $rv = $callback_map->{$callback};
116 is( $rv, $cb->_callbacks->$callback->( $0, $$ ),
117 "Default callback '$callback' called" );
118 like( CPANPLUS::Error->stack_as_string, qr/DEFAULT '\S+' HANDLER/s,
119 " Default handler warning recorded" );
120 CPANPLUS::Error->flush;
123 ### try to register the callback
124 my $ok = $cb->_register_callback(
126 code => sub { return $callback }
129 ok( $ok, "Registered callback '$callback' ok" );
131 my $sub = $cb->_callbacks->$callback;
132 ok( $sub, " Retrieved callback" );
133 ok( IS_CODEREF->($sub), " Callback is a sub" );
136 ok( $rv, " Callback called ok" );
137 is( $rv, $callback, " Got expected return value" );
143 # c-indentation-style: bsd
145 # indent-tabs-mode: nil
147 # vim: expandtab shiftwidth=4: