1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
|
#!/usr/bin/perl
use Test;
BEGIN { plan tests => 6 }
use Class::MakeMethods;
package Class::MakeMethods::UpperCase;
use Class::MakeMethods::Template '-isasubclass';
# Alias to another type of meta-method
sub regular_scalar { return 'Template::Hash:scalar' }
# Structured meta-method definition
sub uc_scalar {
return {
'interface' => {
default => { '*'=>'uc_get_set' }
},
'behavior' => {
'uc_get_set' => sub { my $m_info = $_[0]; sub {
my $self = shift;
if ( scalar @_ ) { $self->{ $m_info->{'name'} } = uc shift }
$self->{ $m_info->{'name'} };
}},
}
}
}
sub auto_detect {
my $mm_class = shift;
my @rewrite = ( [ 'Template::Hash:scalar' ], [ 'UpperCase:uc_scalar' ] );
foreach ( @_ ) {
push @{ $rewrite[ ( $_ eq uc($_) ? 1 : 0 ) ] }, $_
}
return @rewrite;
}
package MyObject;
Class::MakeMethods::UpperCase->import(
'Template::Hash:new' => [ 'new' ],
'regular_scalar' => [ 'name' ],
'uc_scalar' => [ 'id' ],
'auto_detect' => [ 'foo', 'Bar', 'BAZ' ],
);
package main;
my $obj;
ok do { $obj = MyObject->new(
name=>'Alice', id=>'al01', foo=>'Foozle', Bar=>'Barrel', BAZ=>'Bazillion'
) };
ok( $obj->id() eq 'AL01' ); #1
ok( $obj->foo() eq "Foozle" ); #2
ok( $obj->Bar("Bamboozle") ); #3
ok( $obj->Bar() eq 'Bamboozle' ); #4
ok( $obj->BAZ() eq uc('Bazillion') ); #5
|
