|
49
|
1 package IMPL::Object::Autofill;
|
|
|
2 use strict;
|
|
|
3 use IMPL::Class::Property;
|
|
|
4
|
|
|
5 sub CTOR {
|
|
|
6 my $this = shift;
|
|
|
7 no strict 'refs';
|
|
|
8
|
|
|
9 my $fields = @_ == 1 ? $_[0] : {@_};
|
|
|
10
|
|
|
11 $this->_fill(ref $this,$fields);
|
|
|
12 }
|
|
|
13
|
|
|
14 sub _fill {
|
|
|
15 my ($this,$class,$fields) = @_;
|
|
|
16
|
|
|
17 $class->_autofill_method->($this,$fields);
|
|
|
18
|
|
|
19 no strict 'refs';
|
|
|
20 $this->_fill($_,$fields) foreach grep $_->isa('IMPL::Object::Autofill'), @{"${class}::ISA"};
|
|
|
21 }
|
|
|
22
|
|
|
23 sub DisableAutofill {
|
|
|
24 my $self = shift;
|
|
|
25
|
|
|
26 my $class = ref $self || $self;
|
|
|
27
|
|
|
28 *{"${class}::_impl_object_autofill"} = sub {};
|
|
|
29 }
|
|
|
30
|
|
|
31 sub _autofill_method {
|
|
|
32 my ($class) = @_;
|
|
|
33
|
|
|
34 $class = ref $class if ref $class;
|
|
|
35
|
|
|
36 # для автозаполнения нужен свой метод верхнего уровня
|
|
|
37 my $method;
|
|
|
38 {
|
|
|
39 no strict 'refs';
|
|
|
40 $method = ${$class.'::'}{_impl_object_autofill};
|
|
|
41 }
|
|
|
42
|
|
|
43 if ($method) {
|
|
|
44 return $method;
|
|
|
45 } else {
|
|
|
46 my $text = <<HEADER;
|
|
|
47 package $class;
|
|
|
48 sub _impl_object_autofill {
|
|
|
49 my (\$this,\$fields) = \@_;
|
|
|
50 HEADER
|
|
|
51
|
|
|
52
|
|
|
53 if ($class->can('get_meta')) {
|
|
|
54 # meta supported
|
|
|
55 foreach my $prop_info (grep {
|
|
|
56 my $mutators = $_->Mutators;
|
|
|
57 ref $mutators ? (exists $mutators->{set}) : ($mutators & prop_set || $_->Implementor->isa('IMPL::Class::Property::Direct'));
|
|
|
58 } $class->get_meta('IMPL::Class::PropertyInfo')) {
|
|
|
59 my $name = $prop_info->Name;
|
|
|
60 if (ref $prop_info->Mutators || !$prop_info->Implementor->isa('IMPL::Class::Property::Direct')) {
|
|
|
61 $text .= "\t\$this->$name(\$fields->{$name}) if exists \$fields->{$name};\n";
|
|
|
62 } else {
|
|
|
63 my $fld = $prop_info->Implementor->FieldName($prop_info);
|
|
|
64 if ($prop_info->Mutators & prop_list) {
|
|
|
65 $text .= "\t\$this->{$fld} = ref \$fields->{$name} ? \$fields->{$name} : [\$fields->{$name}] if exists \$fields->{$name};\n";
|
|
|
66 } else {
|
|
|
67 $text .= "\t\$this->{$fld} = \$fields->{$name} if exists \$fields->{$name};\n";
|
|
|
68 }
|
|
|
69 }
|
|
|
70 }
|
|
|
71 } else {
|
|
|
72 # meta not supported
|
|
|
73 #$text .= "\t".'$this->$_($fields->{$_}) foreach keys %$fields;'."\n";
|
|
|
74 }
|
|
|
75 $text .= "}\n\\&_impl_object_autofill;";
|
|
|
76 return eval $text;
|
|
|
77 }
|
|
|
78 }
|
|
|
79
|
|
|
80 1;
|
|
|
81
|
|
|
82 __END__
|
|
|
83
|
|
|
84 =pod
|
|
|
85 =head1 SYNOPSIS
|
|
|
86 package MyClass;
|
|
|
87 use base qw(IMPL::Object IMPL::Object::Autofill);
|
|
|
88
|
|
|
89 BEGIN {
|
|
|
90 private property PrivateData => prop_all;
|
|
|
91 public property PublicData => prop_get;
|
|
|
92 }
|
|
|
93
|
|
|
94 sub CTOR {
|
|
|
95 my $this = shift;
|
|
|
96 $this->superCTOR(@_);
|
|
|
97 # or eqvivalent
|
|
|
98 # $this->supercall::CTOR(@_);
|
|
|
99
|
|
|
100 print $this->PrivateData,"\n";
|
|
|
101 print $this->PublicData,"\n";
|
|
|
102 }
|
|
|
103
|
|
|
104 my $obj = new MyClass(PrivateData => 'private', PublicData => 'public', Other => 'some data');
|
|
|
105
|
|
|
106 will print
|
|
|
107 private
|
|
|
108 public
|
|
|
109
|
|
|
110 =cut
|
