vcs.maemo.org Git - dh-make-perl/blob - dev/arm/libclass-accessor-perl/libclass-accessor-perl-0.31/t/accessors.t

   1 #!perl
   2 use strict;
   3 use Test::More tests => 42;
   4
   5 for my $class (qw(Class::Accessor Class::Accessor::Fast Class::Accessor::Faster)) {
   6     require_ok($class);
   7     my $silly = "Silly::$class";
   8     {
   9         no strict 'refs';
  10         @{"${silly}::ISA"} = ($class);
  11         *{"${silly}::car"} = sub { shift->_car_accessor(@_); };
  12         *{"${silly}::mar"} = sub { return "Overloaded"; };
  13         $silly->mk_accessors(qw( foo bar yar car mar ));
  14         $silly->mk_ro_accessors(qw(static unchanged));
  15         $silly->mk_wo_accessors(qw(sekret double_sekret));
  16     }
  17
  18     my $test = $silly->new({
  19             static       => "variable",
  20             unchanged    => "dynamic",
  21         });
  22
  23     $test->foo(42);
  24     $test->bar('Meep');
  25
  26     is($test->foo, 42, "foo accessor");
  27     is($test->{foo}, 42, "foo hash element") unless $class eq 'Class::Accessor::Faster';
  28
  29     is($test->static, 'variable', 'ro accessor');
  30     eval { $test->static('foo'); };
  31     like(scalar $@,
  32         qr/^'main' cannot alter the value of 'static' on objects of class '$silly'/,
  33         'ro accessor write protection');
  34
  35     $test->double_sekret(1001001);
  36     is( $test->{double_sekret}, 1001001, 'wo accessor') unless $class eq 'Class::Accessor::Faster';
  37     eval { () = $test->double_sekret; };
  38     like(scalar $@,
  39         qr/^'main' cannot access the value of 'double_sekret' on objects of class '$silly'/,
  40         'wo accessor read protection' );
  41
  42     is($test->_foo_accessor, 42, 'accessor alias');
  43
  44     $test->car("AMC Javalin");
  45     is($test->car, 'AMC Javalin', 'internal override access');
  46     is($test->mar, 'Overloaded', 'internal override constant');
  47
  48     # Make sure bogus accessors die.
  49     eval { $test->gargle() };
  50     ok($@, 'bad accessor');
  51
  52     # Test that the accessor works properly in list context with a single arg.
  53     my $test2 = $silly->new;
  54     my @args = ($test2->foo, $test2->bar);
  55     is(@args, 2, 'accessor get in list context');
  56
  57     # test array setters
  58     $test->foo(qw(1 2 3));
  59     is_deeply($test->foo, [qw(1 2 3)], "set an array ref via foo accessor");
  60
  61     $test->sekret(qw(1 2 3));
  62     is_deeply($test->{'sekret'}, [qw(1 2 3)], "array ref")
  63         unless $class eq 'Class::Accessor::Faster';
  64
  65     {
  66         my $eeek;
  67         local $SIG{__WARN__} = sub { $eeek = shift };
  68         $silly->mk_accessors(qw(DESTROY));
  69         like($eeek,
  70             qr/a data accessor named DESTROY/i,
  71             'mk DESTROY accessor warning');
  72     };
  73
  74 }