Class-MethodMaker
view release on metacpan or search on metacpan
# -------------------------------------
=head2 Test 2: bless
=cut
my $x;
ok evcheck(sub { $x = bless {}, 'X'; }, 'bless ( 1)'), 1, 'bless ( 1)';
goto "TEST_$ENV{START_TEST}"
if $ENV{START_TEST};
# -------------------------------------
=head2 Tests 3--22: simple non-static
=cut
{
my $n;
ok(evcheck(sub { $n = $x->a_isset; }, 'simple non-static ( 1)'), 1,
'simple non-static ( 1)');
ok ! $n; # simple non-static ( 2)
ok(evcheck(sub { $n = $x->b_isset; }, 'simple non-static ( 3)'), 1,
'simple non-static ( 3)');
ok ! $n; # simple non-static ( 4)
ok(evcheck(sub { $x->a(4); }, 'simple non-static ( 5)'),
1, 'simple non-static ( 5)');
ok(evcheck(sub { $n = $x->a; }, 'simple non-static ( 6)'), 1,
'simple non-static ( 6)');
ok $n, 4, 'simple non-static ( 7)';
ok(evcheck(sub { $n = $x->a(7); }, 'simple non-static ( 8)'), 1,
'simple non-static ( 8)');
ok $n, 7, 'simple non-static ( 9)';
ok(evcheck(sub { $n = $x->a_isset; }, 'simple non-static (10)'), 1,
'simple non-static (10)');
ok $n; # simple non-static (11)
ok(evcheck(sub { $n = $x->b_isset; }, 'simple non-static (12)'), 1,
'simple non-static (12)');
ok ! $n; # simple non-static (13)
ok(evcheck(sub { $n = $x->a_reset; }, 'simple non-static (14)'), 1,
'simple non-static (14)');
ok(evcheck(sub { $n = $x->a_isset; }, 'simple non-static (15)'), 1,
'simple non-static (15)');
ok ! $n; # simple non-static (16)
ok(evcheck(sub { $n = $x->a; }, 'simple non-static (17)'), 1,
'simple non-static (17)');
ok $n, undef, 'simple non-static (18)';
ok(evcheck(sub { $n = $x->a_isset; }, 'simple non-static (19)'), 1,
'simple non-static (19)');
ok ! $n; # simple non-static (20)
}
# -------------------------------------
=head2 Tests 23--35: lvalue
lvalue support has been dropped (I can't find a consistent way to support it
in the presence of read callbacks).
=cut
TEST_23:
if ( 0 ) {
my $n;
# Test lvalueness of b
ok(evcheck(sub { $x->b = (); }, 'lvalue ( 1)'), 1, 'lvalue ( 1)');
ok(evcheck(sub { $n = $x->b_isset; }, 'lvalue ( 2)'), 1, 'lvalue ( 2)');
ok $n; # lvalue ( 3)
ok(evcheck(sub { $n = $x->b; }, 'lvalue ( 4)'), 1, 'lvalue ( 4)');
ok $n, undef, 'lvalue ( 5)';
ok(evcheck(sub { $x->b = undef; }, 'lvalue ( 6)'), 1, 'lvalue ( 6)');
ok(evcheck(sub { $n = $x->b_isset; }, 'lvalue ( 7)'), 1, 'lvalue ( 7)');
ok $n; # lvalue ( 8)
ok(evcheck(sub { $n = $x->b; }, 'lvalue ( 9)'), 1, 'lvalue ( 9)');
ok $n, undef, 'lvalue (10)';
ok(evcheck(sub { $x->b = 13 }, 'lvalue (11)'), 1, 'lvalue (11)');
ok(evcheck(sub { $n = $x->b; }, 'lvalue (12)'), 1, 'lvalue (12)');
ok $n, 13, 'lvalue (13)';
} else {
ok 1, 1, sprintf 'lvalue (-%2d)', $_
for 1..13;
}
# -------------------------------------
=head2 Tests 36--51: typed
=cut
TEST_36: {
my $n;
ok(evcheck(sub { package X;
Class::MethodMaker->import([scalar =>
[{ -type => 'File::stat' },
qw( st ), ]])},
'typed ( 1)'),
1, 'typed ( 1)');
ok(evcheck(sub { $n = $x->st_isset; }, 'typed ( 2)'), 1, 'typed ( 2)');
ok ! $n; # typed ( 3)
ok(evcheck(sub { $x->st(4); }, 'typed ( 4)'), 0, 'typed ( 4)');
ok(evcheck(sub { $n = $x->st; }, 'typed ( 5)'), 1, 'typed ( 5)');
ok $n, undef, 'typed ( 6)';
ok(evcheck(sub { $n = $x->st_isset; }, 'typed ( 7)'), 1, 'typed ( 7)');
ok ! $n; # typed ( 8)
ok(evcheck(sub { $x->st(undef); }, 'typed ( 9)'), 1, 'typed ( 9)');
ok(evcheck(sub { $n = $x->st_isset; }, 'typed (10)'), 1, 'typed (10)');
ok $n; # typed (11)
ok(evcheck(sub { $n = $x->st; }, 'typed (12)'), 1, 'typed (12)');
ok $n, undef, 'typed (13)';
ok(evcheck(sub { $x->st(stat catfile($Bin,$Script)) }, 'typed (14)'),
1, 'typed (14)');
ok(evcheck(sub { $n = $x->st; }, 'typed (15)'), 1, 'typed (15)');
ok S_ISREG($n->mode), 1, 'typed (16)';
}
ok(evcheck(sub { $n = $x->st1_isset; }, 'forward ( 7)'), 1, 'forward ( 7)');
ok ! $n; # forward ( 8)
ok(evcheck(sub { $x->st1(undef); }, 'forward ( 9)'), 1, 'forward ( 9)');
ok(evcheck(sub { $n = $x->st1_isset; }, 'forward (10)'), 1, 'forward (10)');
ok $n; # forward (11)
ok(evcheck(sub { $n = $x->st1; }, 'forward (12)'), 1, 'forward (12)');
ok $n, undef, 'forward (13)';
ok(evcheck(sub { $x->st1(stat catfile($Bin,$Script)) }, 'forward (14)'),
1, 'forward (14)');
ok(evcheck(sub { $n = $x->mode; }, 'forward (15)'), 1, 'forward (15)');
ok S_ISREG($n), 1, 'forward (16)';
ok(evcheck(sub { $n = $x->size; }, 'forward (17)'), 1, 'forward (17)');
{
sysopen my $fh, catfile($Bin,$Script), O_RDONLY;
local $/ = undef;
my $text = <$fh>;
close $fh;
ok $n, length($text), 'forward (18)';
}
}
# -------------------------------------
=head2 Tests 70--72: forward_args
=cut
{
my $n;
# Instantiate st2 as IO::File, which is a subclass of IO::Handle. This
# should be fine
ok(evcheck(sub { $x->st2(IO::File->new(catfile($Bin,$Script))) },
'forward_args ( 1)'), 1, 'forward_args ( 1)');
ok(evcheck(sub { $x->read($n, 30); }, 'forward_args ( 2)'), 1,
'forward_args ( 2)');
ok $n, '# (X)Emacs mode: -*- cperl -*-', 'forward_args ( 3)';
}
# -------------------------------------
=head2 Tests 73--85: default
=cut
{
my $n;
ok(evcheck(sub { package X;
Class::MethodMaker->import([scalar =>
[{ -default => 7,
},
qw( df1 ),
],
]);
}, 'default ( 1)'), 1, 'default ( 1)');
ok(evcheck(sub { $n = $x->df1_isset; }, 'default ( 2)'), 1, 'default ( 2)');
ok $n; # default ( 3)
ok(evcheck(sub { $n = $x->df1; }, 'default ( 4)'), 1, 'default ( 4)');
ok $n, 7, 'default ( 5)';
# lvalue support has been dropped (I can't find a consistent way to support
# it in the presence of read callbacks).
if ( 0 ) {
ok(evcheck(sub { $x->df1 = 13; }, 'default ( 6)'), 1, 'default ( 6)');
ok(evcheck(sub { $n = $x->df1; }, 'default ( 7)'), 1, 'default ( 7)');
ok $n, 13, 'default ( 8)';
} else {
ok 1, 1, sprintf 'default (-%2d)', $_
for 6..8;
}
ok(evcheck(sub { $x->df1_reset; }, 'default ( 9)'), 1, 'default ( 9)');
ok(evcheck(sub { $n = $x->df1_isset; }, 'default (10)'), 1, 'default (10)');
ok $n; # default (11)
ok(evcheck(sub { $n = $x->df1; }, 'default (12)'), 1, 'default (12)');
ok $n, 7, 'default (13)';
}
# -------------------------------------
=head2 Tests 86--102: default_ctor
=cut
{
package Y;
my $count;
sub new {
my $class = shift;
my $i = shift;
my $self = @_ ? $_[0] : ++$count;
return bless \$self, $class;
}
sub value {
return ${$_[0]};
}
}
{
my $n;
ok(evcheck(sub { package X;
Class::MethodMaker->import([scalar =>
[{ -type => 'Y',
-default_ctor => 'new',
},
qw( df2 ),
{ -type => 'Y',
-default_ctor =>
sub {
Y->new(undef, -3);
},
},
qw( df3 ),
],
]);
}, 'default ( 1)'), 1, 'default_ctor ( 1)');
ok(evcheck(sub { $n = $x->df2_isset; }, 'default_ctor( 2)'), 1,
'default_ctor ( 2)');
ok $n; # default_ctor ( 3)
ok(evcheck(sub { $n = $x->df2->value; }, 'default_ctor( 4)'), 1,
'default_ctor ( 4)');
ok $n, 1, 'default_ctor ( 5)';
# lvalue support has been dropped (I can't find a consistent way to support
# it in the presence of read callbacks).
if ( 0 ) {
ok(evcheck(sub { $x->df2 = Y->new; }, 'default_ctor( 6)'), 1,
'default_ctor ( 6)');
ok(evcheck(sub { $n = $x->df2->value; }, 'default_ctor( 7)'), 1,
'default_ctor ( 7)');
ok $n, 2, 'default_ctor ( 8)';
} else {
ok (evcheck(sub { $x->df2(Y->new); }, 'default_ctor(- 6)'), 1,
'default_ctor (- 6)');
ok 1, 1, sprintf 'default_ctor (-%2d)', $_
for 7..8
}
ok(evcheck(sub { $x->df2_reset; },'default_ctor( 9)'), 1,
'default_ctor ( 9)');
ok(evcheck(sub { $n = $x->df2_isset; }, 'default_ctor(10)'), 1,
'default_ctor (10)');
ok $n; # default_ctor (11)
ok(evcheck(sub { $n = $x->df2->value; }, 'default_ctor(12)'), 1,
'default_ctor (12)');
ok $n, 3, 'default_ctor (13)';
ok(evcheck(sub { $n = $x->df3_isset; }, 'default_ctor(14)'), 1,
'default_ctor (14)');
ok $n; # default_ctor (15)
ok(evcheck(sub { $n = $x->df3->value; }, 'default_ctor(16)'), 1,
'default_ctor (16)');
ok $n, -3, 'default_ctor (17)';
}
# -------------------------------------
=head2 Tests 103--114: !syntax
=cut
{
my $n;
ok(evcheck(sub { package X;
Class::MethodMaker->import
([scalar => [qw/ -static bs1 !static bs2 /],]);
}, '!syntax ( 1)'), 1, '!syntax ( 1)');
my $y;
ok evcheck(sub { $y = bless {}, 'X'; }, '!syntax ( 2)'), 1, '!syntax ( 2)';
ok evcheck(sub { $x->bs1(7); }, '!syntax ( 3)'), 1, '!syntax ( 3)';
ok evcheck(sub { $n = $x->bs1; }, '!syntax ( 4)'), 1, '!syntax ( 4)';
ok $n, 7, '!syntax ( 5)';
ok evcheck(sub { $n = $y->bs1; }, '!syntax ( 6)'), 1, '!syntax ( 6)';
ok $n, 7, '!syntax ( 7)';
ok evcheck(sub { $x->bs2(9); }, '!syntax ( 8)'), 1, '!syntax ( 8)';
ok evcheck(sub { $n = $x->bs2; }, '!syntax ( 9)'), 1, '!syntax ( 9)';
ok $n, 9, '!syntax (10)';
ok evcheck(sub { $n = $y->bs2; }, '!syntax (11)'), 1, '!syntax (11)';
ok $n, undef, '!syntax (12)';
}
# -------------------------------------
=head2 Tests 115--126: nested scope
( run in 0.785 second using v1.01-cache-2.11-cpan-140bd7fdf52 )