This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Retract #20548 and #20465.
[perl5.git] / lib / Test / Simple / t / More.t
CommitLineData
33459055
MS
1#!perl -w
2
3BEGIN {
a9153838
MS
4 if( $ENV{PERL_CORE} ) {
5 chdir 't';
6 @INC = '../lib';
7 }
33459055
MS
8}
9
2f71ccc2 10use Test::More tests => 41;
a9153838
MS
11
12# Make sure we don't mess with $@ or $!. Test at bottom.
13my $Err = "this should not be touched";
14my $Errno = 42;
15$@ = $Err;
16$! = $Errno;
3f2ec160
JH
17
18use_ok('Text::Soundex');
19require_ok('Test::More');
20
21
22ok( 2 eq 2, 'two is two is two is two' );
23is( "foo", "foo", 'foo is foo' );
24isnt( "foo", "bar", 'foo isnt bar');
25isn't("foo", "bar", 'foo isn\'t bar');
26
27#'#
28like("fooble", '/^foo/', 'foo is like fooble');
29like("FooBle", '/foo/i', 'foo is like FooBle');
d020a79a
JH
30like("/usr/local/pr0n/", '/^\/usr\/local/', 'regexes with slashes in like' );
31
a9153838
MS
32unlike("fbar", '/^bar/', 'unlike bar');
33unlike("FooBle", '/foo/', 'foo is unlike FooBle');
34unlike("/var/local/pr0n/", '/^\/usr\/local/','regexes with slashes in unlike' );
35
d020a79a
JH
36can_ok('Test::More', qw(require_ok use_ok ok is isnt like skip can_ok
37 pass fail eq_array eq_hash eq_set));
38can_ok(bless({}, "Test::More"), qw(require_ok use_ok ok is isnt like skip
39 can_ok pass fail eq_array eq_hash eq_set));
40
89c1e84a 41
d020a79a 42isa_ok(bless([], "Foo"), "Foo");
a9153838
MS
43isa_ok([], 'ARRAY');
44isa_ok(\42, 'SCALAR');
d020a79a 45
3f2ec160 46
89c1e84a
MS
47# can_ok() & isa_ok should call can() & isa() on the given object, not
48# just class, in case of custom can()
49{
50 local *Foo::can;
51 local *Foo::isa;
52 *Foo::can = sub { $_[0]->[0] };
53 *Foo::isa = sub { $_[0]->[0] };
54 my $foo = bless([0], 'Foo');
55 ok( ! $foo->can('bar') );
56 ok( ! $foo->isa('bar') );
57 $foo->[0] = 1;
58 can_ok( $foo, 'blah');
59 isa_ok( $foo, 'blah');
60}
61
62
3f2ec160
JH
63pass('pass() passed');
64
65ok( eq_array([qw(this that whatever)], [qw(this that whatever)]),
66 'eq_array with simple arrays' );
67ok( eq_hash({ foo => 42, bar => 23 }, {bar => 23, foo => 42}),
68 'eq_hash with simple hashes' );
69ok( eq_set([qw(this that whatever)], [qw(that whatever this)]),
70 'eq_set with simple sets' );
71
72my @complex_array1 = (
73 [qw(this that whatever)],
74 {foo => 23, bar => 42},
75 "moo",
76 "yarrow",
77 [qw(498 10 29)],
78 );
79my @complex_array2 = (
80 [qw(this that whatever)],
81 {foo => 23, bar => 42},
82 "moo",
83 "yarrow",
84 [qw(498 10 29)],
85 );
86
33459055 87is_deeply( \@complex_array1, \@complex_array2, 'is_deeply with arrays' );
3f2ec160
JH
88ok( eq_array(\@complex_array1, \@complex_array2),
89 'eq_array with complicated arrays' );
90ok( eq_set(\@complex_array1, \@complex_array2),
91 'eq_set with complicated arrays' );
92
93my @array1 = (qw(this that whatever),
94 {foo => 23, bar => 42} );
95my @array2 = (qw(this that whatever),
96 {foo => 24, bar => 42} );
97
98ok( !eq_array(\@array1, \@array2),
99 'eq_array with slightly different complicated arrays' );
100ok( !eq_set(\@array1, \@array2),
101 'eq_set with slightly different complicated arrays' );
102
103my %hash1 = ( foo => 23,
104 bar => [qw(this that whatever)],
105 har => { foo => 24, bar => 42 },
106 );
107my %hash2 = ( foo => 23,
108 bar => [qw(this that whatever)],
109 har => { foo => 24, bar => 42 },
110 );
111
33459055
MS
112is_deeply( \%hash1, \%hash2, 'is_deeply with complicated hashes' );
113ok( eq_hash(\%hash1, \%hash2), 'eq_hash with complicated hashes');
3f2ec160
JH
114
115%hash1 = ( foo => 23,
116 bar => [qw(this that whatever)],
117 har => { foo => 24, bar => 42 },
118 );
119%hash2 = ( foo => 23,
120 bar => [qw(this tha whatever)],
121 har => { foo => 24, bar => 42 },
122 );
123
124ok( !eq_hash(\%hash1, \%hash2),
125 'eq_hash with slightly different complicated hashes' );
a9153838
MS
126
127is( Test::Builder->new, Test::More->builder, 'builder()' );
128
129
130cmp_ok(42, '==', 42, 'cmp_ok ==');
131cmp_ok('foo', 'eq', 'foo', ' eq');
132cmp_ok(42.5, '<', 42.6, ' <');
133cmp_ok(0, '||', 1, ' ||');
134
135
136# Piers pointed out sometimes people override isa().
137{
138 package Wibble;
139 sub isa {
140 my($self, $class) = @_;
141 return 1 if $class eq 'Wibblemeister';
142 }
143 sub new { bless {} }
144}
145isa_ok( Wibble->new, 'Wibblemeister' );
146
147
148# These two tests must remain at the end.
149is( $@, $Err, '$@ untouched' );
150cmp_ok( $!, '==', $Errno, '$! untouched' );