Commit | Line | Data |
6aaee015 |
1 | ### make sure we can find our conf.pl file |
2 | BEGIN { |
3 | use FindBin; |
4 | require "$FindBin::Bin/inc/conf.pl"; |
5 | } |
6 | |
7 | use strict; |
8 | use Test::More 'no_plan'; |
9 | |
10 | use CPANPLUS::Configure; |
11 | use CPANPLUS::Backend; |
12 | use CPANPLUS::Internals::Constants; |
13 | use Module::Load::Conditional qw[can_load]; |
14 | use Data::Dumper; |
15 | |
16 | my $cb = CPANPLUS::Backend->new( CPANPLUS::Configure->new() ); |
17 | |
18 | isa_ok($cb, 'CPANPLUS::Internals'); |
19 | is($cb->_id, $cb->_last_id, "Comparing ID's"); |
20 | |
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" ); |
26 | |
27 | my $id = $cb->_store_id( $del ); |
28 | ok( $id, "ID stored" ); |
29 | is( $id, $cb->_id, " Stored proper ID" ); |
30 | |
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" ); |
35 | |
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" ); |
40 | |
41 | my $lid = $cb->_last_id; |
42 | ok( $lid, "Found last registered ID" ); |
43 | is( $lid, $id, " ID matches last object" ); |
44 | |
45 | my $iid = $cb->_inc_id; |
46 | ok( $iid, "Incremented ID" ); |
47 | is( $iid, $id+1, " ID matched last ID + 1" ); |
48 | } |
49 | |
50 | ### host ok test ### |
51 | { |
52 | my $host = $cb->configure_object->get_conf('hosts')->[0]; |
53 | |
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" ); |
59 | } |
60 | |
61 | ### flush loads test |
62 | { my $mod = 'Benchmark'; |
63 | my $file = $mod . '.pm'; |
64 | |
65 | ### XXX whitebox test -- mark this module as unloadable |
66 | $Module::Load::Conditional::CACHE->{$mod}->{usable} = 0; |
67 | |
68 | ok( !can_load( modules => { $mod => 0 }, verbose => 0 ), |
69 | "'$mod' not loaded" ); |
70 | |
71 | ok( $cb->flush('load'), " 'load' cache flushed" ); |
72 | ok( can_load( modules => { $mod => 0 }, verbose => 0 ), |
73 | " '$mod' loaded" ); |
74 | } |
75 | |
20afcebf |
76 | ### add to inc path tests |
77 | { my $meth = '_add_to_includepath'; |
78 | can_ok( $cb, $meth ); |
79 | |
80 | my $p5lib = $ENV{PERL5LIB} || ''; |
81 | my $inc = "@INC"; |
82 | ok( $cb->$meth( directories => [$$] ), |
83 | " CB->$meth( $$ )" ); |
84 | |
85 | my $new_p5lib = $ENV{PERL5LIB}; |
86 | my $new_inc = "@INC"; |
87 | isnt( $p5lib, $new_p5lib, " PERL5LIB is now: $new_p5lib" ); |
88 | like( $new_p5lib, qr/$$/, " Matches $$" ); |
89 | |
90 | isnt( $inc, $new_inc, ' @INC is expanded with: ' . $$ ); |
91 | like( $new_inc, qr/$$/, " Matches $$" ); |
92 | |
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" ); |
98 | } |
99 | |
6aaee015 |
100 | ### callback registering tests ### |
101 | { my $callback_map = { |
622d31ac |
102 | ### name default value |
6aaee015 |
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 |
622d31ac |
108 | proceed_on_test_failure => 0, # continue on failed 'make test'? |
502c7995 |
109 | munge_dist_metafile => $$, # munge the metailfe |
6aaee015 |
110 | }; |
111 | |
112 | for my $callback ( keys %$callback_map ) { |
113 | |
983ffab6 |
114 | { my $rv = $callback_map->{$callback}; |
6aaee015 |
115 | |
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; |
121 | } |
122 | |
123 | ### try to register the callback |
124 | my $ok = $cb->_register_callback( |
125 | name => $callback, |
126 | code => sub { return $callback } |
127 | ); |
128 | |
129 | ok( $ok, "Registered callback '$callback' ok" ); |
130 | |
131 | my $sub = $cb->_callbacks->$callback; |
132 | ok( $sub, " Retrieved callback" ); |
133 | ok( IS_CODEREF->($sub), " Callback is a sub" ); |
134 | |
135 | my $rv = $sub->(); |
136 | ok( $rv, " Callback called ok" ); |
137 | is( $rv, $callback, " Got expected return value" ); |
138 | } |
139 | } |
140 | |
141 | |
142 | # Local variables: |
143 | # c-indentation-style: bsd |
144 | # c-basic-offset: 4 |
145 | # indent-tabs-mode: nil |
146 | # End: |
147 | # vim: expandtab shiftwidth=4: |