# (X)Emacs mode: -*- cperl -*-
use strict;
=head1 Unit Test Package for Class::MethodMaker
This package tests the scalar type of Class::MethodMaker
=cut
use Data::Dumper qw( Dumper );
use Fatal 1.02 qw( sysopen close );
use Fcntl 1.03 qw( :DEFAULT );
use File::Spec::Functions qw( catfile );
use File::stat qw( stat );
use FindBin 1.42 qw( $Bin $Script );
use IO::File 1.08 qw( );
use POSIX 1.03 qw( S_ISREG );
use Test 1.13 qw( ok plan skip );
use lib $Bin;
use test qw( DATA_DIR
evcheck restore_output save_output );
BEGIN {
# 1 for compilation test,
plan tests => 314,
todo => [],
}
# ----------------------------------------------------------------------------
=head2 Test 1: compilation
This test confirms that the test script and the modules it calls compiled
successfully.
=cut
package X;
use Class::MethodMaker
[ scalar => [qw/ a b -static s /],
];
package main;
ok 1, 1, 'compilation';
# -------------------------------------
=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)';
}
# -------------------------------------
=head2 Tests 52--69: forward
=cut
{
my $n;
ok(evcheck(sub { package X;
Class::MethodMaker->import([scalar =>
[{ -type => 'File::stat',
-forward => [qw/ mode
size /],
},
qw( st1 ),
# Keeping the second call
# here ensures that we check
# that mode, size are
# forwarded to st1
{ -type => 'IO::Handle',
-forward => 'read', },
qw( st2 ),
]])},
'forward ( 1)'),
1, 'forward ( 1)');
ok(evcheck(sub { $n = $x->st1_isset; }, 'forward ( 2)'), 1, 'forward ( 2)');
ok ! $n; # forward ( 3)
ok(evcheck(sub { $x->st1(4); }, 'forward ( 4)'), 0, 'forward ( 4)');
ok(evcheck(sub { $n = $x->st1; }, 'forward ( 5)'), 1, 'forward ( 5)');
ok $n, undef, 'forward ( 6)';
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
=cut
{
my $n;
ok(evcheck(sub { package X;
Class::MethodMaker->import
([scalar => [[qw/ -static bs3 /], 'bs4'],]);
}, 'nested scope ( 1)'), 1, 'nested scope ( 1)');
my $y;
ok(evcheck(sub { $y = bless {}, 'X'; }, 'nested scope ( 2)'), 1,
'nested scope ( 2)');
ok evcheck(sub { $x->bs3(7); }, 'nested scope ( 3)'), 1,'nested scope ( 3)';
ok(evcheck(sub { $n = $x->bs3; }, 'nested scope ( 4)'), 1,
'nested scope ( 4)');
ok $n, 7, 'nested scope ( 5)';
ok(evcheck(sub { $n = $y->bs3; }, 'nested scope ( 6)'), 1,
'nested scope ( 6)');
ok $n, 7, 'nested scope ( 7)';
ok evcheck(sub { $x->bs4(9); }, 'nested scope ( 8)'), 1,'nested scope ( 8)';
ok(evcheck(sub { $n = $x->bs4; }, 'nested scope ( 9)'), 1,
'nested scope ( 9)');
ok $n, 9, 'nested scope (10)';
ok(evcheck(sub { $n = $y->bs4; }, 'nested scope (11)'), 1,
'nested scope (11)');
ok $n, undef, 'nested scope (12)';
}
# -------------------------------------
=head2 Tests 127--130: simple name
=cut
{
my $n;
ok(evcheck(sub { package X;
Class::MethodMaker->import
([scalar => 'simple',]);
}, 'simple name ( 1)'), 1, 'simple name ( 1)');
ok evcheck(sub { $x->simple(7); }, 'simple name ( 2)'),1,'simple name ( 2)';
ok evcheck(sub { $n = $x->simple },'simple name ( 3)'),1,'simple name ( 3)';
ok $n, 7, 'simple name ( 4)';
}
# -------------------------------------
=head2 Tests 131--142: repeated calls
=cut
{
my $n;
ok(evcheck(sub { package X;
Class::MethodMaker->import
([scalar => [qw/ -static bs5/ ],
scalar => 'bs6'
]);
}, 'repeated calls ( 1)'), 1, 'repeated calls ( 1)');
my $y;
ok(evcheck(sub { $y = bless {}, 'X'; }, 'repeated calls ( 2)'), 1,
'repeated calls ( 2)');
ok evcheck(sub { $x->bs5(7)},'repeated calls ( 3)'),1,'repeated calls ( 3)';
ok(evcheck(sub { $n = $x->bs5; }, 'repeated calls ( 4)'), 1,
'repeated calls ( 4)');
ok $n, 7, 'repeated calls ( 5)';
ok(evcheck(sub { $n = $y->bs5; }, 'repeated calls ( 6)'), 1,
'repeated calls ( 6)');
ok $n, 7, 'repeated calls ( 7)';
ok evcheck(sub { $x->bs6(9)},'repeated calls ( 8)'),1,'repeated calls ( 8)';
ok(evcheck(sub { $n = $x->bs6; }, 'repeated calls ( 9)'), 1,
'repeated calls ( 9)');
ok $n, 9, 'repeated calls (10)';
ok(evcheck(sub { $n = $y->bs6; }, 'repeated calls (11)'), 1,
'repeated calls (11)');
ok $n, undef, 'repeated calls (12)';
}
# -------------------------------------
=head2 Tests 143--153: *_clear
=cut
{
my $n;
ok(evcheck(sub { package X;
Class::MethodMaker->import
([scalar => [{'*_clear' => '*_clear'}, 'xc1'],]);
}, '*_clear ( 1)'), 1, '*_clear ( 1)');
ok evcheck(sub { $x->xc1(7); }, '*_clear ( 2)'), 1, '*_clear ( 2)';
ok evcheck(sub { $n = $x->xc1 }, '*_clear ( 3)'), 1, '*_clear ( 3)';
ok $n, 7, '*_clear ( 4)';
ok evcheck(sub { $n = $x->xc1_isset }, '*_clear ( 5)'), 1, '*_clear ( 5)';
ok $n; # *_clear ( 6)
ok evcheck(sub { $x->xc1_clear; }, '*_clear ( 7)'), 1, '*_clear ( 7)';
ok evcheck(sub { $n = $x->xc1 }, '*_clear ( 8)'), 1, '*_clear ( 8)';
ok $n, undef, '*_clear ( 9)';
ok evcheck(sub { $n = $x->xc1_isset }, '*_clear (10)'), 1, '*_clear (10)';
ok $n; # *_clear (11)
}
# -------------------------------------
=head2 Tests 154--202: rename
=cut
{
my $n;
ok(evcheck(sub { package Z;
Class::MethodMaker->import
([ scalar => [[{'*_get' => 'get_*', '*_set' => 'set_*'},
qw/ a -static b /],
'c'],
])
}, '*_clear ( 1)'), 1, 'rename ( 0)');
my ($x, $y);
ok evcheck(sub { $x = bless {}, 'Z'; }, 'rename ( 1)'), 1, 'rename ( 1)';
ok evcheck(sub { $y = bless {}, 'Z'; }, 'rename ( 1)'), 1, 'rename ( 2)';
{
# Perl 5.6.1 gets a bit over-zealous with the used only once warnings.
no warnings;
ok defined *{Z::get_a}{CODE}; # rename ( 3)
ok ! defined *{Z::a_get}{CODE}; # rename ( 4)
ok defined *{Z::get_b}{CODE}; # rename ( 5)
ok ! defined *{Z::b_get}{CODE}; # rename ( 6)
ok defined *{Z::a}{CODE}; # rename ( 7)
ok defined *{Z::a_reset}{CODE}; # rename ( 8)
ok defined *{Z::a_isset}{CODE}; # rename ( 9)
ok ! defined *{Z::a_ref}{CODE}; # rename (10)
ok defined *{Z::b}{CODE}; # rename (11)
ok defined *{Z::b_reset}{CODE}; # rename (12)
ok defined *{Z::b_isset}{CODE}; # rename (13)
ok ! defined *{Z::b_ref}{CODE}; # rename (14)
ok ! defined *{Z::get_c}{CODE}; # rename (15)
ok ! defined *{Z::c_get}{CODE}; # rename (16)
ok defined *{Z::c}{CODE}; # rename (17)
ok defined *{Z::c_reset}{CODE}; # rename (18)
ok defined *{Z::c_isset}{CODE}; # rename (19)
ok ! defined *{Z::c_ref}{CODE}; # rename (20)
}
ok evcheck(sub { $n = $x->set_a(7); }, 'rename (21)'), 1, 'rename (21)';
ok $n, undef, 'rename (22)';
ok evcheck(sub { $n = $x->get_a(9); }, 'rename (23)'), 1, 'rename (23)';
ok $n, 7, 'rename (24)';
ok evcheck(sub { $n = $x->get_a(9); }, 'rename (25)'), 1, 'rename (25)';
ok $n, 7, 'rename (26)';
ok evcheck(sub { $n = $x->get_b(9); }, 'rename (27)'), 1, 'rename (27)';
ok $n, undef, 'rename (28)';
ok evcheck(sub { $n = $y->get_a(9); }, 'rename (29)'), 1, 'rename (29)';
ok $n, undef, 'rename (30)';
ok evcheck(sub { $n = $y->set_b(5); }, 'rename (31)'), 1, 'rename (31)';
ok $n, undef, 'rename (32)';
ok evcheck(sub { $n = $y->get_b(9); }, 'rename (33)'), 1, 'rename (33)';
ok $n, 5, 'rename (34)';
ok evcheck(sub { $n = $y->get_b(9); }, 'rename (35)'), 1, 'rename (35)';
ok $n, 5, 'rename (36)';
ok evcheck(sub { $n = $x->get_b(9); }, 'rename (37)'), 1, 'rename (37)';
ok $n, 5, 'rename (38)';
ok evcheck(sub { $n = $y->c(4); }, 'rename (39)'), 1, 'rename (39)';
ok $n, 4, 'rename (40)';
ok evcheck(sub { $n = $y->c(6); }, 'rename (41)'), 1, 'rename (41)';
ok $n, 6, 'rename (42)';
ok evcheck(sub { $n = $y->get_b(9); }, 'rename (43)'), 1, 'rename (43)';
ok $n, 5, 'rename (44)';
ok evcheck(sub { $n = $x->get_a(9); }, 'rename (45)'), 1, 'rename (45)';
ok $n, 7, 'rename (46)';
ok evcheck(sub { $n = $y->c; }, 'rename (47)'), 1, 'rename (47)';
ok $n, 6, 'rename (48)';
}
# -------------------------------------
=head2 Tests 203--204: v1/2 check
=cut
my $if_MSWin = $^O =~ m/MSWin/ ? 'Skip if under MSWin' : '';
if ($if_MSWin) {
skip($if_MSWin, 1, 1, "v1/2 check ( 1)" );
skip($if_MSWin, 1, 1, "v1/2 check ( 2)" );
}
else
{
save_output('stderr', *STDERR{IO});
ok(evcheck(sub {
# Eval use statement to execute it at runtime
eval qq{ package Z1;
use Class::MethodMaker
scalar => [qw/ a b -static s /],
;
}; if ( $@ ) {
print STDERR $@;
die $@;
}
}, 'v1/2 check ( 1)'), 0, 'v1/2 check ( 1)');
my $stderr = restore_output('stderr');
print STDERR "stderr saved: $stderr\n"
if $ENV{TEST_DEBUG};
ok($stderr, qr!presenting your arguments to use/import!,
'v1/2 check ( 2)');
}
# -------------------------------------
=head2 Tests 205--221: tie
=cut
{
# @z is an audit trail
my @z;
package W;
use Tie::Scalar;
use base qw( Tie::StdScalar );
sub TIESCALAR { push @z, [ 'TIESCALAR' ]; $_[0]->SUPER::TIESCALAR }
sub FETCH { push @z, [ 'FETCH' ]; $_[0]->SUPER::FETCH }
sub STORE { push @z, [ STORE => $_[1] ]; $_[0]->SUPER::STORE($_[1]) }
sub DESTROY { push @z, [ 'DESTROY' ]; $_[0]->SUPER::DESTROY }
sub UNTIE { push @z, [ UNTIE => $_[1] ]; $_[0]->SUPER::UNTIE($_[1]) }
package main;
ok(evcheck(sub { package X;
Class::MethodMaker->import([scalar =>
[{ -type => 'File::stat',
-tie_class => 'W',
-forward => [qw/ mode
size /],
},
qw( tie1 ),
]])},
'tie ( 1)'),
1, 'tie ( 1)');
bless ((my $x = {}), 'X');
ok @z, 0, 'tie ( 2)';
my $stat1 = stat catfile($Bin,$Script);
my $stat2 = stat $Bin;
$x->tie1($stat1);
ok @z, 2, 'tie ( 3)';
ok $z[0][0], 'TIESCALAR', 'tie ( 4)';
ok $z[1][0], 'STORE' , 'tie ( 5)';
ok $z[1][1], $stat1 , 'tie ( 6)';
my $y;
ok evcheck(sub { $y = $x->tie1 }, 'tie ( 7)'), 1, 'tie ( 7)';
ok $y, $stat1, 'tie ( 8)';
ok @z, 3, 'tie ( 9)';
ok $z[2][0], 'FETCH', 'tie (10)';
ok evcheck(sub { $x->tie1($stat2) }, 'tie (11)'), 1, 'tie (11)';
ok @z, 4, 'tie (12)';
ok $z[3][0], 'STORE', 'tie (13)';
ok $z[3][1], $stat2, 'tie (14)';
ok evcheck(sub { $x->tie1_reset }, 'tie (15)'), 1, 'tie (15)';
ok @z, 5, 'tie (16)';
ok $z[4][0], 'DESTROY', 'tie (17)';
# Beware that indexing items off the end of @z above will auto-vivify the
# corresponding entries, so if you see empty members of @z, that's possibly
# the cause
print Dumper \@z, $x
if $ENV{TEST_DEBUG};
}
# -------------------------------------
=head Tests 222--230: tie_args
=cut
{
package V;
sub TIESCALAR {
my $type = shift;
my %args = @_ ;
my $self={} ;
if (defined $args{enum}) {
# store all enum values in a hash. This way, checking
# whether a value is present in the enum set is easier
map {; $self->{enum}{$_} = 1 } @{$args{enum}} ;
} else {
die ref($self)," error: no enum values defined when calling init";
}
$self->{default} = $args{default};
bless $self,$type;
}
sub STORE {
my ($self,$value) = @_ ;
die "cannot set ",ref($self)," item to $value. Expected ",
join(' ',keys %{$self->{enum}})
unless defined $self->{enum}{$value} ;
# we may want to check other rules here ... TBD
$self->{value} = $value ;
return $value;
}
sub FETCH {
my $self = shift ;
return defined $self->{value} ? $self->{value} : $self->{default} ;
}
package main;
ok(evcheck(sub { package X;
Class::MethodMaker->import
([scalar =>
[{ -tie_class => 'V',
-tie_args => [enum => [qw/A B C/],
default => 'B'],
},
qw( tie2 ),
]])},
'tie_args ( 1)'),
1, 'tie_args ( 1)');
ok $x->tie2, 'B', 'tie_args ( 2)';
my $y;
ok evcheck(sub { $y = $x->tie2('A') }, 'tie_args ( 3)'), 1, 'tie_args ( 3)';
ok $y, 'A', 'tie_args ( 4)';
ok evcheck(sub { $y = $x->tie2 }, 'tie_args ( 5)'), 1, 'tie_args ( 5)';
ok $y, 'A', 'tie_args ( 6)';
ok evcheck(sub { $y = $x->tie2('D') }, 'tie_args ( 7)'), 0, 'tie_args ( 7)';
ok evcheck(sub { $y = $x->tie2 }, 'tie_args ( 8)'), 1, 'tie_args ( 8)';
ok $y, 'A', 'tie_args ( 9)';
}
# -------------------------------------
=head tests 231--251: read_cb
=cut
TEST_231: {
my $n;
ok(evcheck(sub { package X;
Class::MethodMaker->import
([scalar =>
[{ -read_cb => sub { ($_[1]||0) + 1 } }, qw( rcb1 rcb2 ),]
])},
'read_cb ( 0)'),
1, 'read_cb ( 0)');
ok(evcheck(sub { $n = $x->rcb1_isset; }, 'read_cb ( 1)'), 1,
'read_cb ( 1)');
ok ! $n; # read_cb ( 2)
ok(evcheck(sub { $n = $x->rcb2_isset; }, 'read_cb ( 3)'), 1,
'read_cb ( 3)');
ok ! $n; # read_cb ( 4)
ok(evcheck(sub { $x->rcb1(4); }, 'read_cb ( 5)'),
1, 'read_cb ( 5)');
ok(evcheck(sub { $n = $x->rcb1; }, 'read_cb ( 6)'), 1,
'read_cb ( 6)');
ok $n, 5, 'read_cb ( 7)';
ok(evcheck(sub { $n = $x->rcb1(7); }, 'read_cb ( 8)'), 1,
'read_cb ( 8)');
ok $n, 8, 'read_cb ( 9)';
ok(evcheck(sub { $n = $x->rcb1_isset; }, 'read_cb (10)'), 1,
'read_cb (10)');
ok $n; # read_cb (11)
ok(evcheck(sub { $n = $x->rcb2_isset; }, 'read_cb (12)'), 1,
'read_cb (12)');
ok ! $n; # read_cb (13)
ok(evcheck(sub { $n = $x->rcb1_reset; }, 'read_cb (14)'), 1,
'read_cb (14)');
ok(evcheck(sub { $n = $x->rcb1_isset; }, 'read_cb (15)'), 1,
'read_cb (15)');
ok ! $n; # read_cb (16)
ok(evcheck(sub { $n = $x->rcb1; }, 'read_cb (17)'), 1,
'read_cb (17)');
ok $n, 1, 'read_cb (18)';
ok(evcheck(sub { $n = $x->rcb1_isset; }, 'read_cb (19)'), 1,
'read_cb (19)');
ok ! $n; # read_cb (20)
}
# -------------------------------------
=head tests 252--274: store_cb
=cut
TEST_231: {
my $n;
ok(evcheck(sub { package X;
Class::MethodMaker->import
([scalar =>
[{ -store_cb => sub { $_[1] + 1 } }, qw( scb1 scb2 ),]
])},
'store_cb ( 0)'),
1, 'store_cb ( 0)');
ok(evcheck(sub { $n = $x->scb1_isset; }, 'store_cb ( 1)'), 1,
'store_cb ( 1)');
ok ! $n; # store_cb ( 2)
ok(evcheck(sub { $n = $x->scb2_isset; }, 'store_cb ( 3)'), 1,
'store_cb ( 3)');
ok ! $n; # store_cb ( 4)
ok(evcheck(sub { $x->scb1(4); }, 'store_cb ( 5)'),
1, 'store_cb ( 5)');
ok(evcheck(sub { $n = $x->scb1; }, 'store_cb ( 6)'), 1,
'store_cb ( 6)');
ok $n, 5, 'store_cb ( 7)';
ok(evcheck(sub { $n = $x->scb1(7); }, 'store_cb ( 8)'), 1,
'store_cb ( 8)');
ok $n, 8, 'store_cb ( 9)';
ok(evcheck(sub { $n = $x->scb1_isset; }, 'store_cb (10)'), 1,
'store_cb (10)');
ok $n; # store_cb (11)
ok(evcheck(sub { $n = $x->scb2_isset; }, 'store_cb (12)'), 1,
'store_cb (12)');
ok ! $n; # store_cb (13)
ok(evcheck(sub { $n = $x->scb1_reset; }, 'store_cb (14)'), 1,
'store_cb (14)');
ok(evcheck(sub { $n = $x->scb1_isset; }, 'store_cb (15)'), 1,
'store_cb (15)');
ok ! $n; # store_cb (16)
ok(evcheck(sub { $n = $x->scb1; }, 'store_cb (17)'), 1,
'store_cb (17)');
ok $n, undef, 'store_cb (18)';
ok(evcheck(sub { $n = $x->scb1_isset; }, 'store_cb (19)'), 1,
'store_cb (19)');
ok ! $n; # store_cb (20)
ok(evcheck(sub { $x->scb1(4); }, 'store_cb (21)'),
1, 'store_cb (21)');
print Dumper $x
if $ENV{TEST_DEBUG};
ok $x->{scb1}, 5, 'store_cb(22)';
}
# -------------------------------------
=head Tests 275--294:
=cut
TEST_275: {
my $n;
ok(evcheck(sub { package X;
Class::MethodMaker->import([scalar =>
[{ -type => Class::MethodMaker::INTEGER },
qw( int ), ]])},
'INTEGER ( 1)'),
1, 'INTEGER ( 1)');
ok evcheck(sub { $n = $x->int_isset; }, 'INTEGER ( 2)'), 1, 'INTEGER ( 2)';
ok ! $n; # INTEGER ( 3)
ok evcheck(sub { $n = $x->int; }, 'INTEGER ( 4)'), 1, 'INTEGER ( 4)';
ok $n, 0, 'INTEGER ( 5)';
ok evcheck(sub { $x->int(4); }, 'INTEGER ( 6)'), 1, 'INTEGER ( 6)';
ok evcheck(sub { $n = $x->int; }, 'INTEGER ( 7)'), 1, 'INTEGER ( 7)';
ok $n, 4, 'INTEGER ( 8)';
ok(evcheck(sub { $x->int("5x"); }, 'INTEGER ( 9)'), 1, 'INTEGER ( 9)');
ok(evcheck(sub { $n = $x->int; }, 'INTEGER (10)'), 1, 'INTEGER (10)');
ok $n, 5, 'INTEGER (11)';
ok(evcheck(sub { $n = $x->int_incr; }, 'INTEGER (12)'), 1, 'INTEGER (12)');
ok $n, 6, 'INTEGER (13)';
# Check incr isn't installed by default on normal components
ok(evcheck(sub { $n = $x->st_incr; }, 'INTEGER (14)'), 0, 'INTEGER (14)');
ok(evcheck(sub { $n = $x->int_decr; }, 'INTEGER (15)'), 1, 'INTEGER (15)');
ok $n, 5, 'INTEGER (16)';
ok(evcheck(sub { $n = $x->int_zero; }, 'INTEGER (17)'), 1, 'INTEGER (17)');
ok $n, 0, 'INTEGER (18)';
ok(evcheck(sub { $n = $x->int; }, 'INTEGER (19)'), 1, 'INTEGER (19)');
ok $n, 0, 'INTEGER (20)';
}
# -------------------------------------
=head2 Tests 295--301: non-init ctor
This is to test that the default ctor or default is not assigned if a value is
supplied. This would particularly be a problem with v1 compatiblity use where
a value is explcitly supplied to prevent 'new' being called because there is
no 'new' (if the ctor is called anyway, the program barfs).
=cut
{
my $n;
ok(evcheck(sub { package X;
Class::MethodMaker->import([scalar =>
[{ -type => 'Y',
-default_ctor => 'newx',
},
qw( nic ),
],
]);
}, 'default ( 1)'), 1, 'non-init ctor ( 1)');
ok(evcheck(sub { $n = $x->nic_isset; }, 'non-init ctor( 2)'), 1,
'non-init ctor ( 2)');
ok $n; # non-init ctor ( 3)
ok(evcheck(sub { $n = $x->nic; }, 'non-init ctor( 4)'), 0,
'non-init ctor ( 4)');
ok(evcheck(sub { $x->nic(Y->new); }, 'non-init ctor( 5)'), 1,
'non-init ctor ( 5)');
ok(evcheck(sub { $n = $x->nic; }, 'non-init ctor( 6)'), 1,
'non-init ctor ( 6)');
ok ref $n, 'Y', 'non-init ctor ( 7)';
}
# -------------------------------------
=head2 Tests 302--314 default_ctor (arg)
=cut
TEST_302:
{
package S;
my $count;
sub new {
my ($class, $arg) = @_;
die sprintf "Expected an X, got a '%s'\n", defined($arg) ? ref $arg : '*undef*'
unless UNIVERSAL::isa($arg, 'X');
my $self = $arg->int;
return bless \$self, $class;
}
sub value {
return ${$_[0]};
}
}
{
my $n;
ok(evcheck(sub { package X;
Class::MethodMaker->import([scalar =>
[{ -type => 'S',
-default_ctor => 'new',
},
qw( dfx ),
],
]);
}, 'default_ctor (arg)( 1)'), 1, 'default_ctor (arg) ( 1)');
ok(evcheck(sub { $x->int(1) }, 'default_ctor (arg)( 2)'), 1,
'default_ctor (arg) ( 2)');
ok(evcheck(sub { $n = $x->dfx_isset; }, 'default_ctor (arg)( 3)'), 1,
'default_ctor (arg) ( 3)');
ok $n; # default_ctor (arg) ( 4)
ok(evcheck(sub { $n = $x->dfx->value; }, 'default_ctor (arg)( 5)'), 1,
'default_ctor (arg) ( 5)');
ok $n, 1, 'default_ctor (arg) ( 6)';
ok 1, 1, sprintf 'default_ctor (-%2d)', $_
for 7..8;
ok(evcheck(sub { $x->dfx_reset; },'default_ctor (arg)( 9)'), 1,
'default_ctor (arg) ( 9)');
ok(evcheck(sub { $n = $x->dfx_isset; }, 'default_ctor (arg)(10)'), 1,
'default_ctor (arg) (10)');
ok $n; # default_ctor (arg) (11)
ok(evcheck(sub { $n = $x->dfx->value; }, 'default_ctor (arg)(12)'), 1,
'default_ctor (arg) (12)');
ok $n, 1, 'default_ctor (arg) (13)';
}
# ----------------------------------------------------------------------------