1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
|
### make sure we can find our conf.pl file
BEGIN {
use FindBin;
require "$FindBin::Bin/inc/conf.pl";
}
use strict;
use Test::More 'no_plan';
use CPANPLUS::Configure;
use CPANPLUS::Backend;
use CPANPLUS::Internals::Constants;
use Module::Load::Conditional qw[can_load];
use Data::Dumper;
my $cb = CPANPLUS::Backend->new( CPANPLUS::Configure->new() );
isa_ok($cb, 'CPANPLUS::Internals');
is($cb->_id, $cb->_last_id, "Comparing ID's");
### delete/store/retrieve id tests ###
{ my $del = $cb->_remove_id( $cb->_id );
ok( $del, "ID deleted" );
isa_ok( $del, "CPANPLUS::Internals" );
is( $del, $cb, " Deleted ID matches last object" );
my $id = $cb->_store_id( $del );
ok( $id, "ID stored" );
is( $id, $cb->_id, " Stored proper ID" );
my $obj = $cb->_retrieve_id( $id );
ok( $obj, "Object retrieved from ID" );
isa_ok( $obj, 'CPANPLUS::Internals' );
is( $obj->_id, $id, " Retrieved ID properly" );
my @obs = $cb->_return_all_objects();
ok( scalar(@obs), "Returned objects" );
is( scalar(@obs), 1, " Proper amount of objects found" );
is( $obs[0]->_id, $id, " Proper ID found on object" );
my $lid = $cb->_last_id;
ok( $lid, "Found last registered ID" );
is( $lid, $id, " ID matches last object" );
my $iid = $cb->_inc_id;
ok( $iid, "Incremented ID" );
is( $iid, $id+1, " ID matched last ID + 1" );
}
### host ok test ###
{
my $host = $cb->configure_object->get_conf('hosts')->[0];
is( $cb->_host_ok( host => $host ), 1, "Host ok" );
is( $cb->_add_fail_host(host => $host), 1, " Host now marked as bad" );
is( $cb->_host_ok( host => $host ), 0, " Host still bad" );
ok( $cb->_flush( list => ['hosts'] ), " Hosts flushed" );
is( $cb->_host_ok( host => $host ), 1, " Host now ok again" );
}
### flush loads test
{ my $mod = 'Benchmark';
my $file = $mod . '.pm';
### XXX whitebox test -- mark this module as unloadable
$Module::Load::Conditional::CACHE->{$mod}->{usable} = 0;
ok( !can_load( modules => { $mod => 0 }, verbose => 0 ),
"'$mod' not loaded" );
ok( $cb->flush('load'), " 'load' cache flushed" );
ok( can_load( modules => { $mod => 0 }, verbose => 0 ),
" '$mod' loaded" );
}
### callback registering tests ###
{ my $callback_map = {
### name default value
install_prerequisite => 1, # install prereqs when 'ask' is set?
edit_test_report => 0, # edit the prepared test report?
send_test_report => 1, # send the test report?
munge_test_report => $$, # munge the test report
filter_prereqs => $$, # limit prereqs
proceed_on_test_failure => 0, # continue on failed 'make test'?
munge_dist_metafile => $$, # munge the metailfe
};
for my $callback ( keys %$callback_map ) {
{ my $rv = $callback_map->{$callback};
is( $rv, $cb->_callbacks->$callback->( $0, $$ ),
"Default callback '$callback' called" );
like( CPANPLUS::Error->stack_as_string, qr/DEFAULT '\S+' HANDLER/s,
" Default handler warning recorded" );
CPANPLUS::Error->flush;
}
### try to register the callback
my $ok = $cb->_register_callback(
name => $callback,
code => sub { return $callback }
);
ok( $ok, "Registered callback '$callback' ok" );
my $sub = $cb->_callbacks->$callback;
ok( $sub, " Retrieved callback" );
ok( IS_CODEREF->($sub), " Callback is a sub" );
my $rv = $sub->();
ok( $rv, " Callback called ok" );
is( $rv, $callback, " Got expected return value" );
}
}
# Local variables:
# c-indentation-style: bsd
# c-basic-offset: 4
# indent-tabs-mode: nil
# End:
# vim: expandtab shiftwidth=4:
|
