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