1#!/usr/bin/perl 2 3BEGIN { 4 die "The PERCONA_TOOLKIT_BRANCH environment variable is not set.\n" 5 unless $ENV{PERCONA_TOOLKIT_BRANCH} && -d $ENV{PERCONA_TOOLKIT_BRANCH}; 6 unshift @INC, "$ENV{PERCONA_TOOLKIT_BRANCH}/lib"; 7}; 8 9use strict; 10use warnings FATAL => 'all'; 11use English qw(-no_match_vars); 12use Test::More; 13 14sub throws_ok (&;$) { 15 my ( $code, $pat, $msg ) = @_; 16 eval { $code->(); }; 17 like ( $EVAL_ERROR, $pat, $msg ); 18} 19 20{ 21 package Metatest; 22 use Lmo; 23 24 has stuff => ( is => 'rw', required => 1 ); 25 has init_stuff1 => ( is => 'rw', init_arg => undef ); 26 has init_stuff2 => ( is => 'rw', init_arg => 'fancy_name' ); 27} 28{ 29package Metatest::child; 30 use Lmo; 31 extends 'Metatest'; 32 33 has more_stuff => ( is => 'rw' ); 34} 35 36my $obj = Metatest->new( stuff => 100 ); 37 38can_ok($obj, 'meta'); 39 40my $meta = $obj->meta(); 41 42is_deeply( 43 [ sort $meta->attributes ], 44 [ sort qw(stuff init_stuff1 init_stuff2) ], 45 "->attributes works" 46); 47 48is_deeply( 49 [ sort $meta->attributes_for_new ], 50 [ sort qw(stuff fancy_name) ], 51 "->attributes_for_new works" 52); 53 54# Do these BEFORE initializing ::extends 55my $meta2 = Metatest::child->meta(); 56is_deeply( 57 [ sort $meta2->attributes ], 58 [ sort qw(stuff init_stuff1 init_stuff2 more_stuff) ], 59 "->attributes works on a child class" 60); 61 62is_deeply( 63 [ sort $meta2->attributes_for_new ], 64 [ sort qw(stuff fancy_name more_stuff) ], 65 "->attributes_for_new works in a child class" 66); 67 68my $meta3 = Metatest::child->new(stuff => 10)->meta(); 69is_deeply( 70 [ sort $meta3->attributes ], 71 [ sort qw(stuff init_stuff1 init_stuff2 more_stuff) ], 72 "->attributes works on an initialized child class" 73); 74 75is_deeply( 76 [ sort $meta3->attributes_for_new ], 77 [ sort qw(stuff fancy_name more_stuff) ], 78 "->attributes_for_new works in an initialized child class" 79); 80 81throws_ok { Metatest::child->new() } qr/\QAttribute (stuff) is required for Metatest::child/; 82 83done_testing; 84