File Coverage

blib/lib/Object/Base.pm
Criterion Covered Total %
statement 10 12 83.3
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 14 16 87.5


line stmt bran cond sub pod time code
1             package Object::Base;
2             =head1 NAME
3              
4             Object::Base - Multi-threaded base class to establish a class deriving relationship with base classes
5              
6             =head1 VERSION
7              
8             version 1.02
9              
10             =head1 ABSTRACT
11              
12             Multi-threaded base class to establish a class deriving relationship with base classes
13              
14             package Foo;
15             use Object::Base;
16            
17             package Bar;
18             use Object::Base qw('Foo', 'Baz');
19             attributes 'attr1', 'attr2', ':shared';
20              
21             =head1 DESCRIPTION
22              
23             Object::Base provides blessed and thread-shared(with :shared attribute) object with in B method. B method
24             can be used as a constructor and overridable in derived classes. B should be called in derived class
25             constructors to create and bless self-object. Derived classes own module automatically uses strict, warnings, threads,
26             threads::shared with using Object::Base. Import parameters of Object::Base, define parent classes of derived class.
27             If none of parent classes derived from Object::Base or any parent isn't defined, Object::Base is automatically added
28             in parent classes.
29              
30             Attributes define read-write accessors binded value of same named key in objects own hash if attribute names is
31             valid subroutine identifiers. Otherwise, attribute is special to get new features into class.
32              
33             Attributes;
34              
35             =over
36              
37             =item *
38              
39             Lvaluable
40              
41             =item *
42              
43             Inheritable
44              
45             =item *
46              
47             Overridable
48              
49             =back
50              
51             Examples;
52              
53             package Foo;
54             use Object::Base;
55             attributes ':shared', 'attr1', 'attr2';
56            
57             package Bar;
58             use Object::Base 'Foo';
59             attributes 'attr3', ':shared' => undef, 'attr2' => undef;
60            
61             package main;
62             use threads;
63             use threads::shared;
64            
65             # object of Foo
66             my $foo = Foo->new();
67            
68             # usage of attribute
69             $foo->attr1(1);
70             print $foo->attr1, "\n"; # prints '1'
71            
72             # attributes are lvalued
73             $foo->attr1++;
74             print $foo->attr1, "\n"; # prints '2'
75            
76             # special attribute ':shared'
77             print "\$foo is ", is_shared($foo)? "shared": "not shared", "\n";
78            
79             # object of derived class Bar
80             my $bar = Bar->new();
81            
82             # attributes can be added derived classes
83             $bar->attr3(3);
84            
85             # attributes are inheritable
86             $bar->attr1(3);
87            
88             # attributes are overridable #1
89             eval { $bar->attr2 = 4 }; print "Eval: $@"; # prints error 'Eval: Attribute attr2 is not defined in Bar at ...'
90            
91             # attributes are overridable #2
92             print "\$bar is ", is_shared($bar)? "shared": "not shared", "\n"; # prints '$bar is not shared'
93            
94             # assigning ref values to shared class attributes
95             eval { $foo->attr2 = { key1 => 'val1' } }; print "Eval: $@"; # prints error 'Eval: Invalid value for shared scalar at ...'
96             $foo->attr2({ key2 => 'val2' }); # uses shared_clone assigning ref value
97             print $foo->attr2->{key2}, "\n"; # prints 'val2'
98              
99             =cut
100 1     1   14122 use strict;
  1         2  
  1         26  
101 1     1   3 no strict qw(refs);
  1         2  
  1         22  
102 1     1   3 use warnings;
  1         4  
  1         22  
103 1     1   538 use threads;
  0            
  0            
104             use threads::shared;
105              
106              
107             BEGIN
108             {
109             require 5.008;
110             $Object::Base::VERSION = '1.02';
111             $Object::Base::ISA = ();
112             }
113              
114              
115             my $package = __PACKAGE__;
116             my $context = $package;
117             $context =~ s/\Q::\E//g;
118              
119              
120             sub import
121             {
122             my $importer = shift;
123             my $caller = caller;
124             return unless $importer eq $package;
125             eval join "\n",
126             "package $caller;",
127             "use strict;",
128             "use warnings;",
129             "use threads;",
130             "use threads::shared;",
131             "\$${caller}::attributes = undef;",
132             "\*${caller}::attributes = \\\&${package}::attributes;",
133             "\%${caller}::${context} = () unless defined(\\\%${caller}::${context});",
134             (
135             map {
136             my $p = (defined and not ref)? $_: "";
137             $p and /^[^\W\d]\w*(\:\:[^\W\d]\w*)*\z/s or die "Invalid package name $p";
138             << "EOF";
139             eval { require $_ };
140             push \@${caller}::ISA, '$_';
141             if ($_->isa('$package'))
142             {
143             \$${caller}::${context}{\$_} = \$$_::${context}{\$_} for (keys \%$_::${context});
144             }
145             EOF
146             } @_
147             ),
148             "push \@${caller}::ISA, '$package' unless UNIVERSAL::isa('${caller}', '$package');";
149             die "Failed to import $package in $caller: $@" if $@;
150             return 1;
151             }
152              
153             sub attributes
154             {
155             my $caller = caller;
156             die "$caller is not $package class" unless UNIVERSAL::isa($caller, $package);
157             %{"${caller}::${context}"} = () unless defined(\%{"${caller}::${context}"});
158             my $l;
159             for (@_)
160             {
161             if (not defined($_) or ref($_))
162             {
163             next if not defined($l) or ref($l);
164             ${"${caller}::${context}"}{$l} = $_;
165             next;
166             }
167             ${"${caller}::${context}"}{$_} = {};
168             } continue
169             {
170             $l = $_;
171             }
172             eval join "\n",
173             "package $caller;",
174             map {
175             << "EOF";
176             sub $_(\$) :lvalue
177             {
178             my \$self = shift;
179             die 'Attribute $_ is not defined in $caller' if not defined(\$self) or
180             not UNIVERSAL::isa(ref(\$self), '$package') or
181             not \$${caller}::${context}{"\Q$_\E"};
182             if (\@_ >= 1)
183             {
184             if (ref(\$_[0]) and \$${caller}::${context}{':shared'})
185             {
186             \$self->{"\Q$_\E"} = shared_clone(\$_[0]);
187             } else
188             {
189             \$self->{"\Q$_\E"} = \$_[0];
190             }
191             }
192             return \$self->{"\Q$_\E"};
193             }
194             EOF
195             } grep /^[^\W\d]\w*\z/s, keys %{"${caller}::${context}"};
196             die "Failed to generate attributes in $caller: $@" if $@;
197             return 1;
198             }
199              
200             sub new
201             {
202             my $class = shift;
203             my $self = {};
204             $self = &share($self) if ${"${class}::${context}"}{":shared"};
205             bless $self, $class;
206             return $self;
207             }
208              
209              
210             1;
211             __END__