Dave Cross: Still Munging Data With Perl: Online event - Mar 27 Learn more

THALJEF / Pinto-0.14 / t / 02-bowels / 05-compare.t 

            

              
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

              
#!perl
use strict;
use warnings;
use Test::More;
use Test::Exception;
use lib 't/lib';
use Pinto::Tester::Util qw(make_dist_obj make_pkg_obj);
#------------------------------------------------------------------------------
# Test package specification is as follows:
#
#   dist_name-dist_mtime/pkg_name-pkg_version
#
# For example:
#
#   Foo-1/Bar-0.3
#
# Means pacakge Bar version 0.3 in dist Foo with mtime 1
#------------------------------------------------------------------------------
package_compare_ok( 'Dist-1/Pkg-undef', 'Dist-1/Pkg-1' );
package_compare_ok( 'Dist-1/Pkg-0',     'Dist-1/Pkg-1' );
package_compare_ok( 'Dist-1/Pkg-1',     'Dist-1/Pkg-2' );
package_compare_ok( 'Dist-1/Pkg-1',     'Dist-2/Pkg-1' );
package_compare_ok( 'Dist-1/Pkg-1.1.1', 'Dist-1/Pkg-1.1.2' );
package_compare_ok( 'Dist-1/Pkg-1.1.1', 'Dist-2/Pkg-1.1.1' );
# Exceptions
throws_ok { package_compare_ok( 'Dist-1/Foo-1-0', 'Dist-1/Bar-1-1' ) } qr/packages with different names/;
throws_ok { package_compare_ok( 'Dist-1/Foo-1-1', 'Dist-1/Foo-1-1' ) } qr/Unable to determine ordering/;
throws_ok { package_compare_ok( 'Dist-1/Foo-1-0', 'Dist-1/Foo-1-0' ) } qr/Unable to determine ordering/;
#===============================================================================
sub package_compare_ok {
    my ( $spec_A, $spec_B, $test_name ) = @_;
    $test_name = "Package A sorts before package B";
    my ( $pkg_A, $pkg_B ) = map { _make_pkg($_) } ( $spec_A, $spec_B );
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    my $ok = is( $pkg_A <=> $pkg_B, -1, $test_name );
    diag("  A: $spec_A \n  B: $spec_B") if not $ok;
    return $ok;
}
#------------------------------------------------------------------------------
my $id = 0;
sub _make_pkg {
    my ($spec) = @_;
    my ( $dist_spec, $pkg_spec ) = split '/', $spec;
    my ( $dist_name, $mtime ) = split '-', $dist_spec;
    my ( $pkg_name, $pkg_version, $is_local ) = split '-', $pkg_spec;
    my $dist = make_dist_obj(
        author  => 'AUTHOR',
        archive => "$dist_name-0.00.tar.gz",
        mtime   => $mtime || 0,
        id      => $id++,
    );
    my $pkg = make_pkg_obj(
        name         => $pkg_name,
        version      => $pkg_version,
        distribution => $dist,
        id           => $id++,
    );
    return $pkg;
}
#------------------------------------------------------------------------------
done_testing;