1#!/usr/bin/perl 2 3use v5.14; 4use warnings; 5 6use Test::More; 7 8use Scalar::Util qw( reftype ); 9 10use Object::Pad; 11 12class Point { 13 has $x = 0; 14 has $y = 0; 15 16 BUILD { 17 ( $x, $y ) = @_; 18 } 19 20 method where { sprintf "(%d,%d)", $x, $y } 21} 22 23{ 24 my $p = Point->new( 10, 20 ); 25 is( $p->where, "(10,20)", '$p->where' ); 26} 27 28my @buildargs; 29my @build; 30 31class WithBuildargs { 32 sub BUILDARGS { 33 @buildargs = @_; 34 return ( 4, 5, 6 ); 35 } 36 37 BUILD { 38 @build = @_; 39 } 40} 41 42{ 43 WithBuildargs->new( 1, 2, 3 ); 44 45 is_deeply( \@buildargs, [qw( WithBuildargs 1 2 3 )], '@_ to BUILDARGS' ); 46 is_deeply( \@build, [qw( 4 5 6 )], '@_ to BUILD' ); 47} 48 49{ 50 my @called; 51 52 class WithAdjust { 53 BUILD { 54 push @called, "BUILD"; 55 } 56 57 ADJUST { 58 push @called, "ADJUST"; 59 } 60 } 61 62 WithAdjust->new; 63 is_deeply( \@called, [qw( BUILD ADJUST )], 'ADJUST invoked after BUILD' ); 64} 65 66{ 67 my @called; 68 my $paramsref; 69 70 class WithAdjustParams { 71 ADJUST { 72 push @called, "ADJUST"; 73 } 74 75 ADJUSTPARAMS { 76 my ( $href ) = @_; 77 push @called, "ADJUSTPARAMS"; 78 $paramsref = $href; 79 } 80 81 ADJUST { 82 push @called, "ADJUST"; 83 Test::More::ok( !scalar @_, 'ADJUST block received no arguments' ); 84 } 85 } 86 87 WithAdjustParams->new( key => "val" ); 88 is_deeply( \@called, [qw( ADJUST ADJUSTPARAMS ADJUST )], 'ADJUST and ADJUSTPARAMS invoked together' ); 89 is_deeply( $paramsref, { key => "val" }, 'ADJUSTPARAMS received HASHref' ); 90} 91 92{ 93 my $paramvalue; 94 95 class StrictlyWithParams :strict(params) { 96 ADJUSTPARAMS { 97 my ($href) = @_; 98 $paramvalue = delete $href->{param}; 99 } 100 } 101 102 StrictlyWithParams->new( param => "thevalue" ); 103 is( $paramvalue, "thevalue", 'ADJUSTPARAMS captured the value' ); 104 105 ok( !defined eval { StrictlyWithParams->new( unknown => "name" ) }, 106 ':strict(params) complains about unrecognised param' ); 107 like( $@, qr/^Unrecognised parameters for StrictlyWithParams constructor: unknown at /, 108 'message from unrecognised param to constructor' ); 109} 110 111{ 112 my $newarg_destroyed; 113 my $buildargs_result_destroyed; 114 package DestroyWatch { 115 sub new { bless [ $_[1] ], $_[0] } 116 sub DESTROY { ${ $_[0][0] }++ } 117 } 118 119 class RefcountTest { 120 sub BUILDARGS { 121 return DestroyWatch->new( \$buildargs_result_destroyed ) 122 } 123 } 124 125 RefcountTest->new( DestroyWatch->new( \$newarg_destroyed ) ); 126 127 is( $newarg_destroyed, 1, 'argument to ->new destroyed' ); 128 is( $buildargs_result_destroyed, 1, 'result of BUILDARGS destroyed' ); 129} 130 131# Create a base class with HASH representation 132{ 133 class NativelyHash :repr(HASH) { 134 has $slot = "value"; 135 method slot { $slot } 136 } 137 138 my $o = NativelyHash->new; 139 is( reftype $o, "HASH", 'NativelyHash is natively a HASH reference' ); 140 is( $o->slot, "value", 'native HASH objects still support slots' ); 141} 142 143# Subclasses without BUILD shouldn't double-invoke superclass 144{ 145 my $BUILD_invoked; 146 class One { 147 BUILD { $BUILD_invoked++ } 148 } 149 class Two :isa(One) {} 150 151 Two->new; 152 is( $BUILD_invoked, 1, 'One::BUILD invoked only once for Two->new' ); 153} 154 155done_testing; 156