[p5sagit/p5-mst-13.2.git] / lib / CPANPLUS / t / 08_CPANPLUS-Backend.t

### 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 File::Basename  'dirname';

use Data::Dumper;
use CPANPLUS::Error;
use CPANPLUS::Internals::Constants;

my $conf = gimme_conf();

### purposely avert messages and errors to a file? ###
my $Trap_Output = @ARGV ? 0 : 1;

my $Class = 'CPANPLUS::Backend';
### D::C has troubles with the 'use_ok' -- it finds the wrong paths.
### for now, do a 'use' instead
#use_ok( $Class ) or diag "$Class not found";
use CPANPLUS::Backend;

my $cb = $Class->new( $conf );
isa_ok( $cb, $Class );

my $mt = $cb->module_tree;
my $at = $cb->author_tree;
ok( scalar keys %$mt,       "Module tree has entries" ); 
ok( scalar keys %$at,       "Author tree has entries" ); 

### module_tree tests ###
my $Name = TEST_CONF_MODULE;
my $mod  = $cb->module_tree($Name);

### XXX SOURCEFILES FIX
{   my @mods = $cb->module_tree($Name,$Name);
    my $none = $cb->module_tree( TEST_CONF_INVALID_MODULE );
    
    ok( IS_MODOBJ->(mod => $mod),           "Module object found" );
    is( scalar(@mods), 2,                   "   Module list found" );
    ok( IS_MODOBJ->(mod => $mods[0]),       "   ISA module object" );
    ok( !IS_MODOBJ->(mod => $none),         "   Bogus module detected");
}

### author_tree tests ###
{   my @auths = $cb->author_tree( $mod->author->cpanid,
                                  $mod->author->cpanid );
    my $none  = $cb->author_tree( 'fnurk' );
    
    ok( IS_AUTHOBJ->(auth => $mod->author), "Author object found" );
    is( scalar(@auths), 2,                  "   Author list found" );
    ok( IS_AUTHOBJ->( author => $auths[0] ),"   ISA author object" );
    is( $mod->author, $auths[0],            "   Objects are identical" );
    ok( !IS_AUTHOBJ->( author => $none ),   "   Bogus author detected" );
}

my $conf_obj = $cb->configure_object;
ok( IS_CONFOBJ->(conf => $conf_obj),    "Configure object found" );


### parse_module tests ###
{   my @map = (     # author                package             version
        $Name   => [ $mod->author->cpanid,  $mod->package_name, $mod->version ],
        $mod    => [ $mod->author->cpanid,  $mod->package_name, $mod->version ],
        'Foo-Bar-EU-NOXS'
                => [ $mod->author->cpanid,  $mod->package_name, $mod->version ],
        'Foo-Bar-EU-NOXS-0.01'
                => [ $mod->author->cpanid,  $mod->package_name, '0.01' ],
        'EUNOXS/Foo-Bar-EU-NOXS'
                => [ 'EUNOXS',              $mod->package_name, $mod->version ],
        'EUNOXS/Foo-Bar-EU-NOXS-0.01'
                => [ 'EUNOXS',              $mod->package_name, '0.01' ],
        'Foo-Bar-EU-NOXS-0.09'
                => [ $mod->author->cpanid,  $mod->package_name, '0.09' ],
        'MBXS/Foo-Bar-EU-NOXS-0.01'
                => [ 'MBXS',                $mod->package_name, '0.01' ],
        'EUNOXS/Foo-Bar-EU-NOXS-0.09'
                => [ 'EUNOXS',              $mod->package_name, '0.09' ],
        'EUNOXS/Foo-Bar-EU-NOXS-0.09.zip'
                => [ 'EUNOXS',              $mod->package_name, '0.09' ],
        'FROO/Flub-Flob-1.1.zip'
                => [ 'FROO',                'Flub-Flob',        '1.1' ],
        'G/GO/GOYALI/SMS_API_3_01.tar.gz'
                => [ 'GOYALI',              'SMS_API',          '3_01' ],
        'E/EY/EYCK/Net/Lite/Net-Lite-FTP-0.091'
                => [ 'EYCK',                'Net-Lite-FTP',     '0.091' ],
        'EYCK/Net/Lite/Net-Lite-FTP-0.091'
                => [ 'EYCK',                'Net-Lite-FTP',     '0.091' ],
        'M/MA/MAXDB/DBD-MaxDB-7.5.00.24a'
                => [ 'MAXDB',               'DBD-MaxDB',        '7.5.00.24a' ],
        'EUNOXS/perl5.005_03.tar.gz'
                => [ 'EUNOXS',              'perl',             '5.005_03' ],
        'FROO/Flub-Flob-v1.1.0.tbz'
                => [ 'FROO',                'Flub-Flob',        'v1.1.0' ],
        'FROO/Flub-Flob-1.1_2.tbz'
                => [ 'FROO',                'Flub-Flob',        '1.1_2' ],   
        'LDS/CGI.pm-3.27.tar.gz'
                => [ 'LDS',                 'CGI',              '3.27' ],
        'FROO/Text-Tabs+Wrap-2006.1117.tar.gz'
                => [ 'FROO',                'Text-Tabs+Wrap',   '2006.1117' ],   
        'JETTERO/Crypt-PBC-0.7.20.0-0.4.9',
                => [ 'JETTERO',             'Crypt-PBC',    '0.7.20.0-0.4.9' ],   
                
    );       

    while ( my($guess, $attr) = splice @map, 0, 2 ) {
        my( $author, $pkg, $version ) = @$attr;

        ok( $guess,             "Attempting to parse $guess" );

        my $obj = $cb->parse_module( module => $guess );
        
        ok( $obj,               "   Result returned" );
        ok( IS_MODOBJ->( mod => $obj ), 
                                "   parse_module success by '$guess'" );     
        
        is( $obj->version, $version,
                                "   Proper version found: $version" );
        is( $obj->package_version, $version,
                                "       Found in package_version as well" );
        is( $obj->package_name, $pkg,
                                "   Proper package found: $pkg" );
        unlike( $obj->package_name, qr/\d/,
                                "       No digits in package name" );
        like( $obj->author->cpanid, "/$author/i", 
                                "   Proper author found: $author");
        like( $obj->path,           "/$author/i", 
                                "   Proper path found: " . $obj->path );
    }


    ### test for things that look like real modules, but aren't ###
    {   local $CPANPLUS::Error::MSG_FH    = output_handle() if $Trap_Output;
        local $CPANPLUS::Error::ERROR_FH  = output_handle() if $Trap_Output;
        
        my @map = (
            [  $Name . $$ => [
                [qr/does not contain an author/,"Missing author part detected"],
                [qr/Cannot find .+? in the module tree/,"Unable to find module"]
            ] ],
            [ {}, => [
                [ qr/module string from reference/,"Unable to parse ref"] 
            ] ],
        );

        for my $entry ( @map ) {
            my($mod,$aref) = @$entry;
            
            my $none = $cb->parse_module( module => $mod );
            ok( !IS_MODOBJ->(mod => $none),     
                                "Non-existant module detected" );
            ok( !IS_FAKE_MODOBJ->(mod => $none),
                                "Non-existant fake module detected" );
        
            my $str = CPANPLUS::Error->stack_as_string;
            for my $pair (@$aref) {
                my($re,$diag) = @$pair;
                like( $str, $re,"   $diag" );
            }
        }    
    }
    
    ### test parsing of arbitrary URI
    for my $guess ( qw[ http://foo/bar.gz
                        http://a/b/c/d/e/f/g/h/i/j
                        flub://floo ]
    ) {
        my $obj = $cb->parse_module( module => $guess );
        ok( IS_FAKE_MODOBJ->(mod => $obj), "parse_module success by '$guess'" );
        is( $obj->status->_fetch_from, $guess,
                                            "   Fetch from set ok" );
    }                                       
}         

### RV tests ###
{   my $method = 'readme';
    my %args   = ( modules => [$Name] );  
    
    my $rv = $cb->$method( %args );
    ok( IS_RVOBJ->( $rv ),              "Got an RV object" );
    ok( $rv->ok,                        "   Overall OK" );
    cmp_ok( $rv, '==', 1,               "   Overload OK" );
    is( $rv->function, $method,         "   Function stored OK" );     
    is_deeply( $rv->args, \%args,       "   Arguments stored OK" );
    is( $rv->rv->{$Name}, $mod->readme, "   RV as expected" );
}

### reload_indices tests ###
{
    my $file = File::Spec->catfile( $conf->get_conf('base'),
                                    $conf->_get_source('mod'),
                                );
  
    ok( $cb->reload_indices( update_source => 0 ),  "Rebuilding trees" );                              
    my $age = -M $file;
    
    ### make sure we are 'newer' on faster machines with a sleep..
    ### apparently Win32's FAT isn't granual enough on intervals
    ### < 2 seconds, so it may give the same answer before and after
    ### the sleep, causing the test to fail. so sleep atleast 2 seconds.
    sleep 2;
    ok( $cb->reload_indices( update_source => 1 ),  
                                    "Rebuilding and refetching trees" );
    cmp_ok( $age, '>', -M $file,    "    Source file '$file' updated" );                                      
}

### flush tests ###
{
    for my $cache( qw[methods hosts modules lib all] ) {
        ok( $cb->flush($cache), "Cache $cache flushed ok" );
    }
}

### installed tests ###
{   
    ok( scalar $cb->installed,    "Found list of installed modules" );
}    
                
### autobudle tests ###
{
    my $where = $cb->autobundle;
    ok( $where,     "Autobundle written" );
    ok( -s $where,  "   File has size" );
}

### local_mirror tests ###
{   ### turn off md5 checks for the 'fake' packages we have 
    my $old_md5 = $conf->get_conf('md5');
    $conf->set_conf( md5 => 0 );

    ### otherwise 'status->fetch' might be undef! ###
    my $rv = $cb->local_mirror( path => 'dummy-localmirror' );
    ok( $rv,                        "Local mirror created" );
    
    for my $mod ( values %{ $cb->module_tree } ) {
        my $name    = $mod->module;
        
        my $cksum   = File::Spec->catfile(
                        dirname($mod->status->fetch),
                        CHECKSUMS );
        ok( -e $mod->status->fetch, "   Module '$name' fetched" );
        ok( -s _,                   "       Module '$name' has size" );
        ok( -e $cksum,              "   Checksum fetched for '$name'" );
        ok( -s _,                   "       Checksum for '$name' has size" );
    }      

    $conf->set_conf( md5 => $old_md5 );
}    

### check ENV variable
{   ### process id
    {   my $name = 'PERL5_CPANPLUS_IS_RUNNING';
        ok( $ENV{$name},            "Env var '$name' set" );
        is( $ENV{$name}, $$,        "   Set to current process id" );
    }

    ### Version    
    {   my $name = 'PERL5_CPANPLUS_IS_VERSION';
        ok( $ENV{$name},            "Env var '$name' set" );

        ### version.pm formats ->VERSION output... *sigh*
        is( $ENV{$name}, $Class->VERSION,        
                                    "   Set to current process version" );
    }
    
}

__END__    
                                          
# Local variables:
# c-indentation-style: bsd
# c-basic-offset: 4
# indent-tabs-mode: nil
# End:
# vim: expandtab shiftwidth=4:
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	use File::Basename 'dirname';
	10
	11	use Data::Dumper;
	12	use CPANPLUS::Error;
	13	use CPANPLUS::Internals::Constants;
	14
	15	my $conf = gimme_conf();
	16
	17	### purposely avert messages and errors to a file? ###
	18	my $Trap_Output = @ARGV ? 0 : 1;
	19
	20	my $Class = 'CPANPLUS::Backend';
	21	### D::C has troubles with the 'use_ok' -- it finds the wrong paths.
	22	### for now, do a 'use' instead
	23	#use_ok( $Class ) or diag "$Class not found";
	24	use CPANPLUS::Backend;
	25
	26	my $cb = $Class->new( $conf );
	27	isa_ok( $cb, $Class );
	28
	29	my $mt = $cb->module_tree;
	30	my $at = $cb->author_tree;
	31	ok( scalar keys %$mt, "Module tree has entries" );
	32	ok( scalar keys %$at, "Author tree has entries" );
	33
	34	### module_tree tests ###
	35	my $Name = TEST_CONF_MODULE;
	36	my $mod = $cb->module_tree($Name);
	37
	38	### XXX SOURCEFILES FIX
	39	{ my @mods = $cb->module_tree($Name,$Name);
	40	my $none = $cb->module_tree( TEST_CONF_INVALID_MODULE );
	41
	42	ok( IS_MODOBJ->(mod => $mod), "Module object found" );
	43	is( scalar(@mods), 2, " Module list found" );
	44	ok( IS_MODOBJ->(mod => $mods[0]), " ISA module object" );
	45	ok( !IS_MODOBJ->(mod => $none), " Bogus module detected");
	46	}
	47
	48	### author_tree tests ###
	49	{ my @auths = $cb->author_tree( $mod->author->cpanid,
	50	$mod->author->cpanid );
	51	my $none = $cb->author_tree( 'fnurk' );
	52
	53	ok( IS_AUTHOBJ->(auth => $mod->author), "Author object found" );
	54	is( scalar(@auths), 2, " Author list found" );
	55	ok( IS_AUTHOBJ->( author => $auths[0] )," ISA author object" );
	56	is( $mod->author, $auths[0], " Objects are identical" );
	57	ok( !IS_AUTHOBJ->( author => $none ), " Bogus author detected" );
	58	}
	59
	60	my $conf_obj = $cb->configure_object;
	61	ok( IS_CONFOBJ->(conf => $conf_obj), "Configure object found" );
	62
	63
	64	### parse_module tests ###
65	{ my @map = ( # author package version
66	$Name => [ $mod->author->cpanid, $mod->package_name, $mod->version ],
67	$mod => [ $mod->author->cpanid, $mod->package_name, $mod->version ],
68	'Foo-Bar-EU-NOXS'
69	=> [ $mod->author->cpanid, $mod->package_name, $mod->version ],
70	'Foo-Bar-EU-NOXS-0.01'
71	=> [ $mod->author->cpanid, $mod->package_name, '0.01' ],
72	'EUNOXS/Foo-Bar-EU-NOXS'
73	=> [ 'EUNOXS', $mod->package_name, $mod->version ],
74	'EUNOXS/Foo-Bar-EU-NOXS-0.01'
75	=> [ 'EUNOXS', $mod->package_name, '0.01' ],
76	'Foo-Bar-EU-NOXS-0.09'
77	=> [ $mod->author->cpanid, $mod->package_name, '0.09' ],
78	'MBXS/Foo-Bar-EU-NOXS-0.01'
79	=> [ 'MBXS', $mod->package_name, '0.01' ],
80	'EUNOXS/Foo-Bar-EU-NOXS-0.09'
81	=> [ 'EUNOXS', $mod->package_name, '0.09' ],
82	'EUNOXS/Foo-Bar-EU-NOXS-0.09.zip'
83	=> [ 'EUNOXS', $mod->package_name, '0.09' ],
84	'FROO/Flub-Flob-1.1.zip'
85	=> [ 'FROO', 'Flub-Flob', '1.1' ],
86	'G/GO/GOYALI/SMS_API_3_01.tar.gz'
87	=> [ 'GOYALI', 'SMS_API', '3_01' ],
88	'E/EY/EYCK/Net/Lite/Net-Lite-FTP-0.091'
89	=> [ 'EYCK', 'Net-Lite-FTP', '0.091' ],
90	'EYCK/Net/Lite/Net-Lite-FTP-0.091'
91	=> [ 'EYCK', 'Net-Lite-FTP', '0.091' ],
92	'M/MA/MAXDB/DBD-MaxDB-7.5.00.24a'
93	=> [ 'MAXDB', 'DBD-MaxDB', '7.5.00.24a' ],
94	'EUNOXS/perl5.005_03.tar.gz'
95	=> [ 'EUNOXS', 'perl', '5.005_03' ],
96	'FROO/Flub-Flob-v1.1.0.tbz'
97	=> [ 'FROO', 'Flub-Flob', 'v1.1.0' ],
98	'FROO/Flub-Flob-1.1_2.tbz'
99	=> [ 'FROO', 'Flub-Flob', '1.1_2' ],
100	'LDS/CGI.pm-3.27.tar.gz'
101	=> [ 'LDS', 'CGI', '3.27' ],
102	'FROO/Text-Tabs+Wrap-2006.1117.tar.gz'
103	=> [ 'FROO', 'Text-Tabs+Wrap', '2006.1117' ],
104	'JETTERO/Crypt-PBC-0.7.20.0-0.4.9',
105	=> [ 'JETTERO', 'Crypt-PBC', '0.7.20.0-0.4.9' ],
106
107	);
108
109	while ( my($guess, $attr) = splice @map, 0, 2 ) {
110	my( $author, $pkg, $version ) = @$attr;
111
112	ok( $guess, "Attempting to parse $guess" );
113
114	my $obj = $cb->parse_module( module => $guess );
115
116	ok( $obj, " Result returned" );
117	ok( IS_MODOBJ->( mod => $obj ),
118	" parse_module success by '$guess'" );
119
120	is( $obj->version, $version,
121	" Proper version found: $version" );
122	is( $obj->package_version, $version,
123	" Found in package_version as well" );
124	is( $obj->package_name, $pkg,
125	" Proper package found: $pkg" );
126	unlike( $obj->package_name, qr/\d/,
127	" No digits in package name" );
128	like( $obj->author->cpanid, "/$author/i",
129	" Proper author found: $author");
130	like( $obj->path, "/$author/i",
131	" Proper path found: " . $obj->path );
132	}
133
134
135	### test for things that look like real modules, but aren't ###
136	{ local $CPANPLUS::Error::MSG_FH = output_handle() if $Trap_Output;
137	local $CPANPLUS::Error::ERROR_FH = output_handle() if $Trap_Output;
138
139	my @map = (
140	[ $Name . $$ => [
141	[qr/does not contain an author/,"Missing author part detected"],
142	[qr/Cannot find .+? in the module tree/,"Unable to find module"]
143	] ],
144	[ {}, => [
145	[ qr/module string from reference/,"Unable to parse ref"]
146	] ],
147	);
148
149	for my $entry ( @map ) {
150	my($mod,$aref) = @$entry;
151
152	my $none = $cb->parse_module( module => $mod );
153	ok( !IS_MODOBJ->(mod => $none),
154	"Non-existant module detected" );
155	ok( !IS_FAKE_MODOBJ->(mod => $none),
156	"Non-existant fake module detected" );
157
158	my $str = CPANPLUS::Error->stack_as_string;
159	for my $pair (@$aref) {
160	my($re,$diag) = @$pair;
161	like( $str, $re," $diag" );
162	}
163	}
164	}
165
166	### test parsing of arbitrary URI
167	for my $guess ( qw[ http://foo/bar.gz
168	http://a/b/c/d/e/f/g/h/i/j
169	flub://floo ]
170	) {
171	my $obj = $cb->parse_module( module => $guess );
172	ok( IS_FAKE_MODOBJ->(mod => $obj), "parse_module success by '$guess'" );
173	is( $obj->status->_fetch_from, $guess,
174	" Fetch from set ok" );
175	}
176	}
177
178	### RV tests ###
179	{ my $method = 'readme';
180	my %args = ( modules => [$Name] );
181
182	my $rv = $cb->$method( %args );
183	ok( IS_RVOBJ->( $rv ), "Got an RV object" );
184	ok( $rv->ok, " Overall OK" );
185	cmp_ok( $rv, '==', 1, " Overload OK" );
186	is( $rv->function, $method, " Function stored OK" );
187	is_deeply( $rv->args, \%args, " Arguments stored OK" );
188	is( $rv->rv->{$Name}, $mod->readme, " RV as expected" );
189	}
190
191	### reload_indices tests ###
192	{
193	my $file = File::Spec->catfile( $conf->get_conf('base'),
194	$conf->_get_source('mod'),
195	);
196
197	ok( $cb->reload_indices( update_source => 0 ), "Rebuilding trees" );
198	my $age = -M $file;
199
200	### make sure we are 'newer' on faster machines with a sleep..
201	### apparently Win32's FAT isn't granual enough on intervals
202	### < 2 seconds, so it may give the same answer before and after
203	### the sleep, causing the test to fail. so sleep atleast 2 seconds.
204	sleep 2;
205	ok( $cb->reload_indices( update_source => 1 ),
206	"Rebuilding and refetching trees" );
207	cmp_ok( $age, '>', -M $file, " Source file '$file' updated" );
208	}
209
210	### flush tests ###
211	{
212	for my $cache( qw[methods hosts modules lib all] ) {
213	ok( $cb->flush($cache), "Cache $cache flushed ok" );
214	}
215	}
216
217	### installed tests ###
218	{
219	ok( scalar $cb->installed, "Found list of installed modules" );
220	}
221
222	### autobudle tests ###
223	{
224	my $where = $cb->autobundle;
225	ok( $where, "Autobundle written" );
226	ok( -s $where, " File has size" );
227	}
228
229	### local_mirror tests ###
230	{ ### turn off md5 checks for the 'fake' packages we have
231	my $old_md5 = $conf->get_conf('md5');
232	$conf->set_conf( md5 => 0 );
233
234	### otherwise 'status->fetch' might be undef! ###
235	my $rv = $cb->local_mirror( path => 'dummy-localmirror' );
236	ok( $rv, "Local mirror created" );
237
238	for my $mod ( values %{ $cb->module_tree } ) {
239	my $name = $mod->module;
240
241	my $cksum = File::Spec->catfile(
242	dirname($mod->status->fetch),
243	CHECKSUMS );
244	ok( -e $mod->status->fetch, " Module '$name' fetched" );
245	ok( -s _, " Module '$name' has size" );
246	ok( -e $cksum, " Checksum fetched for '$name'" );
247	ok( -s _, " Checksum for '$name' has size" );
248	}
249
250	$conf->set_conf( md5 => $old_md5 );
251	}
252
253	### check ENV variable
254	{ ### process id
255	{ my $name = 'PERL5_CPANPLUS_IS_RUNNING';
256	ok( $ENV{$name}, "Env var '$name' set" );
257	is( $ENV{$name}, $$, " Set to current process id" );
258	}
259
260	### Version
261	{ my $name = 'PERL5_CPANPLUS_IS_VERSION';
262	ok( $ENV{$name}, "Env var '$name' set" );
263
264	### version.pm formats ->VERSION output... sigh
265	is( $ENV{$name}, $Class->VERSION,
266	" Set to current process version" );
267	}
268
269	}
270
271	__END__
272
273	# Local variables:
274	# c-indentation-style: bsd
275	# c-basic-offset: 4
276	# indent-tabs-mode: nil
277	# End:
278	# vim: expandtab shiftwidth=4:
279