Class-MethodMaker
view release on metacpan or search on metacpan
- Add compatiblity support for singleton
- Add compatiblity support for get_concat
- Add basic support for INTEGER type
- Add compatiblity support for get_counter
- Bug fixes to read callback
- Add compatiblity support for key_{attrib,with_create}
2.00a09 Sep 18 11:04 AM GMT 2003
- Add tie_scalar, static_hash, tie_hash for V1
- Abandon lvalue methods
- Add read & store callbacks (incomplete implementation; just enough
for V1 methods)
- Add code for V1
- Add new_with_hash_with_init for V1
- Correct handling of default in array to auto-instantiate for prior
keys as needed
- fix object_tie_list
- add set_once from V1
- add singleton for V1
- add basic INTEGER handling
- add get_concat, get_counter for V1
components/array.m view on Meta::CPAN
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
%%STORDECL%%
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_reset *_index );
components/hash.m view on Meta::CPAN
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
%%STORDECL%%
# Predefine keys for subs we always want to exist (because they're
# referenced by other subs)
my %names = map {; $_ => undef } qw( * *_set *_reset *_index *_each );
components/scalar.m view on Meta::CPAN
$tie_class = $options->{tie_class};
if ( exists $options->{tie_args} ) {
my $tie_args = $options->{tie_args};
@tie_args = ref $tie_args ? @$tie_args : $tie_args;
}
} elsif ( exists $options->{tie_args} ) {
carp "tie_args option ignored in absence of tie_class(attribute $name)\n";
}
# callback options
my @read_callbacks = ref $options->{read_cb} eq 'ARRAY' ?
@{$options->{read_cb}} :
$options->{read_cb}
if exists $options->{read_cb};
my @store_callbacks = ref $options->{store_cb} eq 'ARRAY' ?
@{$options->{store_cb}} :
$options->{store_cb}
if exists $options->{store_cb};
# V1 Compatibility
my ($list, $key_create);
($list, $key_create) = @{$options}{qw/ _value_list key_create/}
if exists $options->{_value_list};
# the method definitions ------------
lib/Class/MethodMaker.pm view on Meta::CPAN
L<deep_copy|Class::MethodMaker::Engine/deep_copy> and
L<copy|Class::MethodMaker::Engine/copy> for object copies, and
L<abstract|Class::MethodMaker::Engine/abstract> for creating abstract methods.
Each of the components take common options. These include L<-static>, for
per-class rather than per-instance data, L<-type>, to restrict the data stored
to certain types (e.g., objects of a certain class), L<-forward> to forward
(proxy) given methods onto components, L<-default>/L<-default_ctor> to set
default values for components, L<-tie_class> to tie the storage of a data type
to a given class, L<-read_cb>/L<-store_cb> to call user-defined functions on
read/store (without the overhead/complexity of ties; and allowing callbacks on
existing tie classes).
=head2 Detailed Use
C<Class::MethodMaker> installs I<components> into a class, by means of methods
that interrogate and amend those components. A component, sometimes referred
in other documentation as a I<slot> is a group of one or more attributes
(variables) that are associated with an instance of a class (sometimes called
an object), or occasionally a class itself (often referred to as a I<static>
component). A component is intended as a cohesive unit of data that should
lib/Class/MethodMaker.pm view on Meta::CPAN
The return value of the given coderef is the value which is actually stored in
the component. Thus, the above example stores 1 greater than the value passed
in.
package main;
my $m = MyClass->new;
$m->scb1(4);
my $n = $x->scb1; # 5
Generally, store callbacks are cheaper than read callbacks, because values are
read more often than they are stored. But that is a generalization. YMMV.
=back
=head1 EXPERIMENTAL & COMPATIBILITY notes
Some new facilities may be marked as EXPERIMENTAL in the documentation.
These facilities are being trialled, and whilst it is hoped that they
will become mainstream code, no promises are made. They may change or
disappear at any time. Caveat Emptor. The maintainer would be
lib/Class/MethodMaker/OptExt.pm view on Meta::CPAN
untie %%STORAGE(__SIGIL__)%%;
END
},
v1_compat => { encode => 32,
},
read_cb => { encode => 64,
read => [(<<'END') x 2],
{ # Encapsulate scope to avoid redefined $v issues
my $v = __VALUE__;
$v = $_->($_[0], $v)
for @read_callbacks;
$v;
}
END
},
store_cb => { encode => 128,
store =><<'END',
my __NAME__ = __VALUE__;
if ( exists %%STORAGE%% ) {
my $old = %%STORAGE%%;
__NAMEREF__ = $_->($_[0], __NAMEREF__, $name, $old) %%V2ONLY%%
__NAMEREF__ = $_->($_[0], __NAMEREF__, $name, $old, __ALL__) %%V1COMPAT%%
for @store_callbacks;
} else {
__NAMEREF__ = $_->($_[0], __NAMEREF__, $name) %%V2ONLY%%
__NAMEREF__ = $_->($_[0], __NAMEREF__, $name, undef, __ALL__) %%V1COMPAT%%
for @store_callbacks;
}
END
},
typex => { encode => 256,
asgnchk => <<'END',
for (__FOO__) {
# $_ += 0;
# croak(sprintf("Incorrect type for attribute __ATTR__: %s\n" .
# " : should be '%s' (or subclass thereof)\n",
# (defined($_) ?
ok $n, 12, 'index ( 3)';
ok evcheck(sub { @n = $x->a_index(2, 0); }, 'index ( 4)'), 1, 'index ( 4)';
print STDERR Data::Dumper->Dump([$n], [qw($n)])
if $ENV{TEST_DEBUG};
ok @n, 2, 'index ( 5)';
ok $n[0], 13, 'index ( 6)';
ok $n[1], 11, 'index ( 7)';
# lvalue support has been dropped (I can't find a consistent way to support
# it in the presence of read callbacks).
ok(evcheck(sub { $x->a_set(2, 31) }, 'index ( 8)'), 1,
'index ( 8)');
ok evcheck(sub { @n = $x->a_index(2); }, 'index ( 9)'), 1, 'index ( 9)';
print STDERR Data::Dumper->Dump([\@n], [qw(@n)])
if $ENV{TEST_DEBUG};
ok @n, 1, 'index (10)';
ok $n[0], 31, 'index (11)';
# lvalue support has been dropped (I can't find a consistent way to support
# it in the presence of read callbacks).
ok(evcheck(sub { ($x->a_set(2, 23, 0, 21)) }, 'index (12)'), 1,
'index (12)');
ok evcheck(sub { @n = $x->a_index(0,1,2); }, 'index (13)'), 1, 'index (13)';
print STDERR Data::Dumper->Dump([\@n], [qw(@n)])
if $ENV{TEST_DEBUG};
ok @n, 3, 'index (14)';
ok $n[0], 21, 'index (15)';
ok $n[1], 12, 'index (16)';
ok $n[2], 23, 'index (17)';
# lvalue support has been dropped (I can't find a consistent way to support
# it in the presence of read callbacks).
ok(evcheck(sub { @n = ($x->a_set(4, 42, 1, 45)) }, 'index (18)'), 1,
'index (18)');
if ( 0 ) {
print STDERR Data::Dumper->Dump([\@n], [qw(@n)])
if $ENV{TEST_DEBUG};
ok @n, 2, 'index (19)';
ok $n[0], 42, 'index (20)';
ok $n[1], 45, 'index (21)';
} else {
ok 1, 1, sprintf('index (%2d)', $_)
1, 'count ( 8)');
ok @n, 4, 'count ( 9)';
ok $n[0], 14, 'count (10)';
ok $n[1], 15, 'count (11)';
ok $n[2], 16, 'count (12)';
ok $n[3], 17, 'count (13)';
ok evcheck(sub { $n = $x->a_count; }, 'count (14)'), 1, 'count (14)';
ok $n, 4, 'count (15)';
# lvalue support has been dropped (I can't find a consistent way to support
# it in the presence of read callbacks).
ok evcheck(sub { $x->a_set(8, 19); }, 'count (16)'), 1, 'count (16)';
ok evcheck(sub { $n = $x->a_count; }, 'count (17)'), 1, 'count (17)';
ok $n, 9, 'count (18)';
ok(evcheck(sub { @n = $x->a_index(7,8) }, 'count (19)'), 1, 'count (19)');
ok @n, 2, 'count (20)';
ok $n[0], undef, 'count (21)';
ok $n[1], 19, 'count (22)';
# check intermediate index still not set
ok $n, 7, 'default (38)';
# check that such items are now set
ok(evcheck(sub { $n = $x->df1_isset(0); }, 'default (39)'),1,'default (39)');
ok $n; # default (40)
ok(evcheck(sub { $n = $x->df1_isset(1); }, 'default (41)'),1,'default (41)');
ok $n; # default (42)
ok evcheck(sub { $n = $x->df1_count }, 'default (43)'), 1, 'default (43)';
ok $n, 2, 'default (44)';
# check this doesn't clobber undef items
# lvalue support has been dropped (I can't find a consistent way to support
# it in the presence of read callbacks).
ok(evcheck(sub { $n = $x->df1_set(0, undef) }, 'default (45)'), 1,
'default (45)');
ok $n, undef, 'default (46)';
ok evcheck(sub { $n = $x->df1_index(0) }, 'default (47)'), 1,'default (47)';
ok $n, undef, 'default (48)';
ok(evcheck(sub { $n = $x->df1_isset(0); }, 'default (49)'),1,'default (49)');
ok $n; # default (50)
ok(evcheck(sub { $n = $x->df1_isset(1); }, 'default (51)'),1,'default (51)');
ok $n; # default (52)
ok evcheck(sub { $n = $x->df1_count }, 'default (53)'), 1, 'default (53)';
ok $n, 2, 'default (54)';
ok evcheck(sub { $x->df1_reset(0) }, 'default (55)'), 1, 'default (55)';
ok evcheck(sub { $x->df1_reset(1) }, 'default (56)'), 1, 'default (56)';
# set i2 to value, test i2 & i0 & i1
print STDERR Data::Dumper->Dump([$x], [qw($x)])
if $ENV{TEST_DEBUG};
# lvalue support has been dropped (I can't find a consistent way to support
# it in the presence of read callbacks).
ok evcheck(sub { $x->df1_set(2, 9) }, 'default (57)'), 1, 'default (57)';
print STDERR Data::Dumper->Dump([$x], [qw($x)])
if $ENV{TEST_DEBUG};
ok(evcheck(sub { $n = $x->df1_isset; }, 'default (58)'), 1, 'default (58)');
ok $n; # default (59)
ok(evcheck(sub { $n = $x->df1_isset(0); }, 'default (60)'),1,'default (60)');
ok $n; # default (61)
ok(evcheck(sub { $n = $x->df1_isset(1); }, 'default (62)'),1,'default (62)');
ok $n; # default (63)
ok(evcheck(sub { $n = $x->df1_isset(2); }, 'default (64)'),1,'default (64)');
ok $n, undef, 'default (74)';
ok(evcheck(sub { $n = $x->df1_isset(0); }, 'default (75)'),1,'default (75)');
ok $n; # default (76)
ok(evcheck(sub { $n = $x->df1_isset(1); }, 'default (77)'),1,'default (77)');
ok $n; # default (78)
ok(evcheck(sub { $n = $x->df1_isset(2); }, 'default (79)'),1,'default (79)');
ok $n; # default (80)
# set value to empty
# lvalue support has been dropped (I can't find a consistent way to support
# it in the presence of read callbacks).
ok evcheck(sub { $x->df1_set(2, undef) },'default (81)'),1,'default (81)';
ok(evcheck(sub { $n = $x->df1_isset; }, 'default (82)'), 1, 'default (82)');
ok $n; # default (83)
ok(evcheck(sub { $n = $x->df1_isset(0); }, 'default (84)'),1,'default (84)');
ok $n; # default (85)
ok(evcheck(sub { $n = $x->df1_isset(1); }, 'default (86)'),1,'default (86)');
ok $n; # default (87)
ok(evcheck(sub { $n = $x->df1_isset(2); }, 'default (88)'),1,'default (88)');
ok $n; # default (89)
ok evcheck(sub { $n = $x->df1_count }, 'default (90)'), 1, 'default (90)';
ok $n; # default_ctor ( 3)
print STDERR Data::Dumper->Dump([$x], [qw($x)])
if $ENV{TEST_DEBUG};
ok(evcheck(sub { $n = $x->df2_index(1)->value; }, 'default_ctor( 4)'), 1,
'default_ctor ( 4)');
ok $n, 1, 'default_ctor ( 5)';
# This actually creates two Y instances; one explictly, and one not implictly
# by the _index method defaulting one (since it can't see the incoming)
# XXX not anymore XXX
# lvalue support has been dropped (I can't find a consistent way to support
# it in the presence of read callbacks).
ok(evcheck(sub { $x->df2_set(2, Y->new) }, 'default_ctor( 6)'), 1,
'default_ctor ( 6)');
ok(evcheck(sub { $n = $x->df2_index(2)->value; }, 'default_ctor( 7)'), 1,
'default_ctor ( 7)');
ok $n, 2, 'default_ctor ( 8)';
ok(evcheck(sub { $x->df2_reset; },'default_ctor( 9)'), 1,
'default_ctor ( 9)');
ok(evcheck(sub { $n = $x->df2_isset; }, 'default_ctor(10)'), 1,
'default_ctor (10)');
ok $n; # default_ctor (11)
ok $n; # default_ctor (arg) ( 3)
ok(evcheck(sub { $n = $x->dfx_index(1)->value; }, 'default_ctor (arg)( 4)'), 1,
'default_ctor (arg) ( 4)');
ok $n, 3, 'default_ctor (arg) ( 5)';
print STDERR Data::Dumper->Dump([$x], [qw($x)])
if $ENV{TEST_DEBUG};
# This actually creates two Y instances; one explictly, and one not implictly
# by the _index method defaulting one (since it can't see the incoming)
# XXX not anymore XXX
# lvalue support has been dropped (I can't find a consistent way to support
# it in the presence of read callbacks).
my $xx = bless {}, "X"; $xx->a(2);
ok(evcheck(sub { $x->dfx_set(2, S->new($xx)) }, 'default_ctor (arg)( 6)'), 1,
'default_ctor (arg) ( 6)');
ok(evcheck(sub { $n = $x->dfx_index(2)->value; }, 'default_ctor (arg)( 7)'), 1,
'default_ctor (arg) ( 7)');
ok $n, 2, 'default_ctor (arg) ( 8)';
ok(evcheck(sub { $x->dfx_reset; },'default_ctor (arg)( 9)'), 1,
'default_ctor (arg) ( 9)');
ok(evcheck(sub { $n = $x->dfx_isset; }, 'default_ctor (arg)(10)'), 1,
'default_ctor (arg) (10)');
ok evcheck(sub { @n = $x->a_index(qw(c a)); }, 'index ( 4)'),1,'index ( 4)';
print STDERR Data::Dumper->Dump([$n], [qw($n)])
if $ENV{TEST_DEBUG};
ok @n, 2, 'index ( 5)';
ok $n[0], 13, 'index ( 6)';
ok $n[1], 11, 'index ( 7)';
# test lvalue of index
# lvalue support has been dropped (I can't find a consistent way to support
# it in the presence of read callbacks).
ok(evcheck(sub { $x->a_set(2, 31) }, 'index ( 8)'), 1,
'index ( 8)');
ok evcheck(sub { @n = $x->a_index(2); }, 'index ( 9)'), 1, 'index ( 9)';
print STDERR Data::Dumper->Dump([\@n], [qw(@n)])
if $ENV{TEST_DEBUG};
ok @n, 1, 'index (10)';
ok $n[0], 31, 'index (11)';
# test index with multiple indices, also as lvalue
# lvalue support has been dropped (I can't find a consistent way to support
# it in the presence of read callbacks).
ok(evcheck(sub { ($x->a_set(2, 23, 0, 21)) }, 'index (12)'), 1,
'index (12)');
ok evcheck(sub { @n = $x->a_index(0,1,2); }, 'index (13)'), 1, 'index (13)';
print STDERR Data::Dumper->Dump([\@n], [qw(@n)])
if $ENV{TEST_DEBUG};
ok @n, 3, 'index (14)';
ok $n[0], 21, 'index (15)';
ok $n[1], undef, 'index (16)';
ok $n[2], 23, 'index (17)';
# test lvalue with return value, with previously unseen index
# lvalue support has been dropped (I can't find a consistent way to support
# it in the presence of read callbacks).
ok(evcheck(sub { @n = ($x->a_set(4, 42, 1, 45)) }, 'index (18)'), 1,
'index (18)');
if ( 0 ) {
print STDERR Data::Dumper->Dump([\@n], [qw(@n)])
if $ENV{TEST_DEBUG};
ok @n, 2, 'index (19)';
ok $n[0], 42, 'index (20)';
ok $n[1], 45, 'index (21)';
} else {
ok 1, 1, sprintf("index (%2d)", $_)
ok $n, 7, 'default (38)';
# check that such items are now set
ok(evcheck(sub { $n = $x->df1_isset(0); }, 'default (39)'),1,'default (39)');
ok $n; # default (40)
ok(evcheck(sub { $n = $x->df1_isset(1); }, 'default (41)'),1,'default (41)');
ok $n; # default (42)
ok evcheck(sub { $n = $x->df1_count }, 'default (43)'), 1, 'default (43)';
ok $n, 1, 'default (44)';
# check this doesn't clobber undef items
# lvalue support has been dropped (I can't find a consistent way to support
# it in the presence of read callbacks).
ok(evcheck(sub { $n = $x->df1_set(0, undef) }, 'default (45)'), 1,
'default (45)');
ok $n, undef, 'default (46)';
ok evcheck(sub { $n = $x->df1_index(0) }, 'default (47)'), 1,'default (47)';
ok $n, undef, 'default (48)';
ok(evcheck(sub { $n = $x->df1_isset(0); }, 'default (49)'),1,'default (49)');
ok $n; # default (50)
ok(evcheck(sub { $n = $x->df1_isset(1); }, 'default (51)'),1,'default (51)');
ok $n; # default (52)
ok evcheck(sub { $n = $x->df1_count }, 'default (53)'), 1, 'default (53)';
ok $n, 2, 'default (54)';
ok evcheck(sub { $x->df1_reset(0) }, 'default (55)'), 1, 'default (55)';
ok evcheck(sub { $x->df1_reset(1) }, 'default (56)'), 1, 'default (56)';
# set i2 to value, test i2 & i0 & i1
print STDERR Data::Dumper->Dump([$x], [qw($x)])
if $ENV{TEST_DEBUG};
# lvalue support has been dropped (I can't find a consistent way to support
# it in the presence of read callbacks).
ok evcheck(sub { $x->df1_set(2, 9) }, 'default (57)'), 1, 'default (57)';
print STDERR Data::Dumper->Dump([$x], [qw($x)])
if $ENV{TEST_DEBUG};
ok(evcheck(sub { $n = $x->df1_isset; }, 'default (58)'), 1, 'default (58)');
ok $n; # default (59)
ok(evcheck(sub { $n = $x->df1_isset(0); }, 'default (60)'),1,'default (60)');
ok $n; # default (61)
ok(evcheck(sub { $n = $x->df1_isset(1); }, 'default (62)'),1,'default (62)');
ok $n; # default (63)
ok(evcheck(sub { $n = $x->df1_isset(2); }, 'default (64)'),1,'default (64)');
ok $n, undef, 'default (74)';
ok(evcheck(sub { $n = $x->df1_isset(0); }, 'default (75)'),1,'default (75)');
ok $n; # default (76)
ok(evcheck(sub { $n = $x->df1_isset(1); }, 'default (77)'),1,'default (77)');
ok $n; # default (78)
ok(evcheck(sub { $n = $x->df1_isset(2); }, 'default (79)'),1,'default (79)');
ok $n; # default (80)
# set value to empty
# lvalue support has been dropped (I can't find a consistent way to support
# it in the presence of read callbacks).
ok evcheck(sub { $x->df1_set(2, undef)},'default (81)'),1,'default (81)';
ok(evcheck(sub { $n = $x->df1_isset; }, 'default (82)'), 1, 'default (82)');
ok $n; # default (83)
ok(evcheck(sub { $n = $x->df1_isset(0); }, 'default (84)'),1,'default (84)');
ok $n; # default (85)
ok(evcheck(sub { $n = $x->df1_isset(1); }, 'default (86)'),1,'default (86)');
ok $n; # default (87)
ok(evcheck(sub { $n = $x->df1_isset(2); }, 'default (88)'),1,'default (88)');
ok $n; # default (89)
ok evcheck(sub { $n = $x->df1_count }, 'default (90)'), 1, 'default (90)';
ok(evcheck(sub { $n = $x->df2_isset; }, 'default_ctor( 2)'), 1,
'default_ctor ( 2)');
ok $n; # default_ctor ( 3)
ok(evcheck(sub { $n = $x->df2_index(1)->value; }, 'default_ctor( 4)'), 1,
'default_ctor ( 4)');
ok $n, 1, 'default_ctor ( 5)';
# This actually creates two Y instances; one explictly, and one not implictly
# by the _index method defaulting one (since it can't see the incoming)
# XXX not anymore XXX
# lvalue support has been dropped (I can't find a consistent way to support
# it in the presence of read callbacks).
ok(evcheck(sub { $x->df2_set(2, Y->new); }, 'default_ctor( 6)'), 1,
'default_ctor ( 6)');
ok(evcheck(sub { $n = $x->df2_index(2)->value; }, 'default_ctor( 7)'), 1,
'default_ctor ( 7)');
ok $n, 2, 'default_ctor ( 8)';
ok(evcheck(sub { $x->df2_reset; },'default_ctor( 9)'), 1,
'default_ctor ( 9)');
ok(evcheck(sub { $n = $x->df2_isset; }, 'default_ctor(10)'), 1,
'default_ctor (10)');
ok $n; # default_ctor (11)
'default_ctor (arg) ( 2)');
ok $n; # default_ctor (arg) ( 3)
$x->a(a=>3);
ok(evcheck(sub { $n = $x->dfx_index(1)->value; }, 'default_ctor (arg)( 4)'), 1,
'default_ctor (arg) ( 4)');
ok $n, 3, 'default_ctor (arg) ( 5)';
# This actually creates two Y instances; one explictly, and one not implictly
# by the _index method defaulting one (since it can't see the incoming)
# XXX not anymore XXX
# lvalue support has been dropped (I can't find a consistent way to support
# it in the presence of read callbacks).
my $xx = bless {}, 'X'; $xx->a(a=>2);
ok(evcheck(sub { $x->dfx_set(2, S->new($xx)); }, 'default_ctor (arg)( 6)'), 1,
'default_ctor (arg) ( 6)');
ok(evcheck(sub { $n = $x->dfx_index(2)->value; }, 'default_ctor (arg)( 7)'), 1,
'default_ctor (arg) ( 7)');
ok $n, 2, 'default_ctor (arg) ( 8)';
ok(evcheck(sub { $x->dfx_reset; },'default_ctor (arg)( 9)'), 1,
'default_ctor (arg) ( 9)');
ok(evcheck(sub { $n = $x->dfx_isset; }, 'default_ctor (arg)(10)'), 1,
'default_ctor (arg) (10)');
ok(evcheck(sub { $n = $x->a_isset; }, 'simple non-static (19)'), 1,
'simple non-static (19)');
ok ! $n; # simple non-static (20)
}
# -------------------------------------
=head2 Tests 23--35: lvalue
lvalue support has been dropped (I can't find a consistent way to support it
in the presence of read callbacks).
=cut
TEST_23:
if ( 0 ) {
my $n;
# Test lvalueness of b
ok(evcheck(sub { $x->b = (); }, 'lvalue ( 1)'), 1, 'lvalue ( 1)');
qw( df1 ),
],
]);
}, 'default ( 1)'), 1, 'default ( 1)');
ok(evcheck(sub { $n = $x->df1_isset; }, 'default ( 2)'), 1, 'default ( 2)');
ok $n; # default ( 3)
ok(evcheck(sub { $n = $x->df1; }, 'default ( 4)'), 1, 'default ( 4)');
ok $n, 7, 'default ( 5)';
# lvalue support has been dropped (I can't find a consistent way to support
# it in the presence of read callbacks).
if ( 0 ) {
ok(evcheck(sub { $x->df1 = 13; }, 'default ( 6)'), 1, 'default ( 6)');
ok(evcheck(sub { $n = $x->df1; }, 'default ( 7)'), 1, 'default ( 7)');
ok $n, 13, 'default ( 8)';
} else {
ok 1, 1, sprintf 'default (-%2d)', $_
for 6..8;
}
ok(evcheck(sub { $x->df1_reset; }, 'default ( 9)'), 1, 'default ( 9)');
ok(evcheck(sub { $n = $x->df1_isset; }, 'default (10)'), 1, 'default (10)');
]);
}, 'default ( 1)'), 1, 'default_ctor ( 1)');
ok(evcheck(sub { $n = $x->df2_isset; }, 'default_ctor( 2)'), 1,
'default_ctor ( 2)');
ok $n; # default_ctor ( 3)
ok(evcheck(sub { $n = $x->df2->value; }, 'default_ctor( 4)'), 1,
'default_ctor ( 4)');
ok $n, 1, 'default_ctor ( 5)';
# lvalue support has been dropped (I can't find a consistent way to support
# it in the presence of read callbacks).
if ( 0 ) {
ok(evcheck(sub { $x->df2 = Y->new; }, 'default_ctor( 6)'), 1,
'default_ctor ( 6)');
ok(evcheck(sub { $n = $x->df2->value; }, 'default_ctor( 7)'), 1,
'default_ctor ( 7)');
ok $n, 2, 'default_ctor ( 8)';
} else {
ok (evcheck(sub { $x->df2(Y->new); }, 'default_ctor(- 6)'), 1,
'default_ctor (- 6)');
ok 1, 1, sprintf 'default_ctor (-%2d)', $_
( run in 0.342 second using v1.01-cache-2.11-cpan-9b1e4054eb1 )