File Coverage

lib/Class/STL/ClassMembers/SingletonConstructor.pm
Criterion Covered Total %
statement 94 105 89.5
branch 10 24 41.6
condition 2 12 16.6
subroutine 12 13 92.3
pod 0 1 0.0
total 118 155 76.1


line stmt bran cond sub pod time code
1             # vim:ts=4 sw=4
2             # ----------------------------------------------------------------------------------------------------
3             # Name : Class::STL::ClassMembers::SingletonConstructor.pm
4             # Created : 9 May 2006
5             # Author : Mario Gaffiero (gaffie)
6             #
7             # Copyright 2006-2007 Mario Gaffiero.
8             #
9             # This file is part of Class::STL::Containers(TM).
10             #
11             # Class::STL::Containers is free software; you can redistribute it and/or modify
12             # it under the terms of the GNU General Public License as published by
13             # the Free Software Foundation; version 2 of the License.
14             #
15             # Class::STL::Containers is distributed in the hope that it will be useful,
16             # but WITHOUT ANY WARRANTY; without even the implied warranty of
17             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18             # GNU General Public License for more details.
19             #
20             # You should have received a copy of the GNU General Public License
21             # along with Class::STL::Containers; if not, write to the Free Software
22             # Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
23             # ----------------------------------------------------------------------------------------------------
24             # Modification History
25             # When Version Who What
26             # ----------------------------------------------------------------------------------------------------
27             # TO DO:
28             # ----------------------------------------------------------------------------------------------------
29             require 5.005_62;
30 1     1   1006 use strict;
  1         3  
  1         51  
31 1     1   7 use warnings;
  1         3  
  1         54  
32 1     1   6 use vars qw($VERSION $BUILD);
  1         2  
  1         62  
33             $VERSION = '0.27';
34             $BUILD = 'Tuesday May 16 23:08:34 GMT 2006';
35 1     1   8 use Class::STL::ClassMembers::DataMember;
  1         2  
  1         12  
36             # ----------------------------------------------------------------------------------------------------
37             {
38             package Class::STL::ClassMembers::SingletonConstructor;
39 1         7 use Class::STL::ClassMembers qw( _caller _trace ),
40             Class::STL::ClassMembers::DataMember->new(name => 'debug_on', default => 0),
41 1     1   83 Class::STL::ClassMembers::DataMember->new(name => 'ctor_name', default => 'new');
  1         2  
42 1     1   6 use Carp qw(confess);
  1         3  
  1         51  
43 1     1   7 use Class::STL::Trace;
  1         2  
  1         8  
44             sub import
45             {
46 1     1   15 my $proto = shift;
47 1   33     9 my $class = ref($proto) || $proto;
48 1         3 my $self = {};
49 1         4 bless($self, $class);
50 1         47 $self->members_init(@_, _caller => (caller())[0]);
51 1         7 $self->_trace(Class::STL::Trace->new());
52 1 50       29 $self->_trace()->debug_on($self->debug_on()) if ($self->debug_on());
53 1 0 0 1   6 eval($self->code());
  1 0 33 1   2  
  1 100   0   256  
  1 50   2   12  
  1 50       2  
  1         124  
  1         4  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  2         40  
  2         10  
  1         3  
  1         10  
  1         6  
  1         4  
  1         38  
  1         5  
  1         5  
54 1 50       6 confess "**Error in eval for @{[ $self->_caller() ]} FunctionMember singleton constructor function creation:\n$@" if ($@);
  0         0  
55 1         48 return $self;
56             }
57             sub code
58             {
59 1     1 0 3 my $self = shift;
60 1         2 my $tab = ' ' x 4;
61 1         2 my $code;
62 1         29 my $c = $self->_caller();
63            
64             # Extract named parameter/value pairs and pass on...
65 1         3 my @p;
66 1 0 0     6 while (@_) { my $p=shift; push(@p, $p, shift) if (!ref($p) && @_); }
  0         0  
  0         0  
67 1         4 my %p = @p;
68            
69 1         5 my $sname = '__' . lc($c);
70 1         2 $sname =~ s/:+/_/g;
71            
72 1         3 $code = "{\npackage $c;\n";
73 1         2 $code .= "sub _@{[ $self->ctor_name() ]}\n";
  1         31  
74 1         3 $code .= "{\n";
75 1         3 $code .= "${tab}our \$$sname;\n";
76 1         4 $code .= "${tab}return \$$sname if (defined(\$$sname));\n";
77 1         3 $code .= "${tab}use vars qw(\@ISA);\n";
78 1         4 $code .= "${tab}my \$proto = shift;\n";
79 1         2 $code .= "${tab}my \$class = ref(\$proto) || \$proto;\n";
80 1         4 $code .= "${tab}\$$sname = int(\@ISA) ? \$class->SUPER::_@{[ $self->ctor_name() ]}(\@_) : {};\n";
  1         30  
81 1         4 $code .= "${tab}bless(\$$sname, \$class);\n";
82 1 50       3 $code .= "${tab}\$$sname->members_init(@{[ @p ? join(', ', '@_', map(qq/'$_'/, %p)) : '@_' ]});\n";
  1         7  
83 1         3 $code .= "${tab}return \$$sname;\n";
84 1         2 $code .= "}\n";
85 1         3 $code .= "}\n";
86            
87 1         2 $code .= "{\npackage $c;\n";
88 1         2 $code .= "sub @{[ $self->ctor_name() ]}\n";
  1         31  
89 1         3 $code .= "{\n";
90 1         4 $code .= "${tab}our \$$sname;\n";
91 1         4 $code .= "${tab}return \$$sname if (defined(\$$sname));\n";
92 1         19 $code .= "${tab}use vars qw(\@ISA);\n";
93 1         4 $code .= "${tab}my \$proto = shift;\n";
94 1         2 $code .= "${tab}my \$class = ref(\$proto) || \$proto;\n";
95 1         4 $code .= "${tab}\$$sname = int(\@ISA) ? \$class->SUPER::@{[ $self->ctor_name() ]}(\@_) : {};\n";
  1         27  
96 1         4 $code .= "${tab}bless(\$$sname, \$class);\n";
97 1 50       5 $code .= "${tab}\$$sname->members_init(@{[ @p ? join(', ', '@_', map(qq/'$_'/, %p)) : '@_' ]});\n";
  1         8  
98 1 50       5 $code .= "${tab}$c\::new_extra(\$$sname, @{[ @p ? join(', ', '@_', map(qq/'$_'/, %p)) : '@_' ]})\n";
  1         5  
99 1         3 $code .= "${tab}${tab}if (defined(&$c\::new_extra));\n";
100 1         3 $code .= "${tab}return \$$sname;\n";
101 1         3 $code .= "}\n";
102 1         1 $code .= "}\n";
103 1 50       35 $self->_trace()->print($c, $code) if ($self->_trace()->debug_on());
104 1         252 return $code;
105             }
106             }
107             # ----------------------------------------------------------------------------------------------------
108             1;