BEGIN {
# Don't fail on P5.004
eval "package XYZ; sub foo {}; package ZYX; use base ( 'XYZ' ); ";
if ( $@ ) {
print "Skipping test on this platform (no base pragma).\n";
exit 0;
}
}
# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl test.pl'
######################### We start with some black magic to print on failure.
# Change 1..1 below to 1..last_test_to_print .
# (It may become useful if the test is moved to ./t subdirectory.)
use strict;
use vars qw($Total_tests);
my $loaded;
my $test_num;
BEGIN { $| = 1; $^W = 1; $test_num=1}
END {print "not ok $test_num\n" unless $loaded;}
print "1..$Total_tests\n";
use Class::MakeMethods::Emulator::AccessorFast;
$loaded = 1;
ok(1, 'compile()' );
######################### End of black magic.
# Insert your test code below (better if it prints "ok 13"
# (correspondingly "not ok 13") depending on the success of chunk 13
# of the test code):
sub ok {
my($test, $name) = @_;
print "not " unless $test;
print "ok $test_num";
print " - $name" if defined $name;
print "\n";
$test_num++;
}
sub eqarray {
my($a1, $a2) = @_;
return 0 unless @$a1 == @$a2;
my $ok = 1;
for (0..$#{$a1}) {
unless($a1->[$_] eq $a2->[$_]) {
$ok = 0;
last;
}
}
return $ok;
}
# Change this to your # of ok() calls + 1
BEGIN { $Total_tests = 20 }
# Set up a testing package.
package Foo;
@Foo::ISA = qw(Class::MakeMethods::Emulator::AccessorFast);
Foo->mk_accessors(qw( foo bar yar car mar ));
Foo->mk_ro_accessors(qw(static unchanged));
Foo->mk_wo_accessors(qw(sekret double_sekret));
sub car {
shift->_car_accessor(@_);
}
sub mar {
return "Overloaded";
}
package main;
my Foo $test = Foo->new({ static => "variable",
unchanged => "dynamic",
});
# Test accessors.
$test->foo(42);
$test->bar('Meep');
ok( $test->foo == 42 and
$test->{foo} == 42, 'accessor get/set' );
ok( $test->static eq 'variable', 'accessor read-only' );
eval {
$test->static('foo');
};
ok( scalar $@ =~ /(read-only)/, 'accessor read-only: write protection' );
$test->double_sekret(1001001);
ok( $test->{double_sekret} == 1001001, 'accessor write-only');
eval {
() = $test->double_sekret;
};
ok( scalar $@ =~ /(write-only)/, 'accessor write-only: read protection' );
ok( $test->_foo_accessor == 42, 'accessor alias' );
$test->car("AMC Javalin");
ok( $test->car eq 'AMC Javalin' );
# Make sure we can "override" accessors.
ok( $test->mar eq 'Overloaded' );
# Make sure bogus accessors die.
eval { $test->gargle() };
ok( $@, 'bad accessor()' );
# Test that the accessor works properly in list context with a single arg.
my Foo $test2 = Foo->new;
my @args = ($test2->foo, $test2->bar);
ok( @args == 2, 'accessor get in list context' );
# Make sure a DESTROY field won't slip through.
package Arrgh;
@Arrgh::ISA = qw(Foo);
eval {
local $SIG{__WARN__} = sub { die @_ };
Arrgh->mk_accessor(qw(DESTROY));
};
::ok( $@ and $@ =~ /Having a data accessor named DESTROY in 'Arrgh'/i,
'No DESTROY field' );
# Override &Arrgh::DESTROY to shut up the warning we intentionally created
#*Arrgh::DESTROY = sub {};
#() = *Arrgh::DESTROY; # shut up typo warning.
package Altoids;
@Altoids::ISA = qw(Class::MakeMethods::Emulator::AccessorFast);
use fields qw(curiously strong mints);
Altoids->mk_accessors(keys %Altoids::FIELDS);
::ok(defined &Altoids::curiously);
::ok(defined &Altoids::strong);
::ok(defined &Altoids::mints);
sub new {
my $proto = shift;
my $class = ref $proto || $proto;
return fields::new($class);
}
my Altoids $tin = Altoids->new;
$tin->curiously('Curiouser and curiouser');
::ok($tin->{curiously} eq 'Curiouser and curiouser');
# Subclassing works, too.
package Mint::Snuff;
use base qw(Altoids);
::ok(defined &Altoids::curiously);
::ok(defined &Altoids::strong);
::ok(defined &Altoids::mints);
my Mint::Snuff $pouch = Mint::Snuff->new;
$pouch->strong('Fuck you up strong!');
::ok($pouch->{strong} eq 'Fuck you up strong!');