1# 2# $Id: Gomor.pm 2000 2015-01-13 18:24:09Z gomor $ 3# 4package Class::Gomor; 5use strict; use warnings; 6 7our $VERSION = '1.03'; 8 9use Exporter; 10use base qw(Exporter); 11 12use Carp; 13 14no strict 'refs'; 15 16our $Debug = 0; 17our $NoCheck = 0; 18our @EXPORT_OK = qw($Debug $NoCheck); 19 20sub cgCheckParams { 21 my $self = shift; 22 my ($userParams, $accessors) = @_; 23 for my $u (keys %$userParams) { 24 my $valid; 25 my $defined; 26 for (@$accessors) { 27 ($u eq $_) ? $valid++ : next; 28 defined($userParams->{$u}) && do { $defined++; last }; 29 } 30 if (! $valid) { 31 carp("$self: parameter is invalid: `$u'"); 32 next; 33 } 34 if (! $defined) { 35 carp("$self: parameter is undef: `$u'"); 36 next; 37 } 38 } 39} 40 41sub cgGetIsaTree { 42 my $self = shift; 43 my ($classes) = @_; 44 for (@{$self.'::ISA'}) { 45 push @$classes, $_; 46 $_->cgGetIsaTree($classes) if $_->can('cgGetIsaTree'); 47 } 48} 49 50sub cgGetAttributes { 51 my $self = shift; 52 my $classes = [ $self ]; 53 $self->cgGetIsaTree($classes); 54 my @attributes = (); 55 { 56 # On perl 5.10.0, we have a warning message: 57 # "::AS" used only once: possible typo ... 58 no warnings; 59 for (@$classes) { 60 push @attributes, @{$_.'::AS'} if @{$_.'::AS'}; 61 push @attributes, @{$_.'::AA'} if @{$_.'::AA'}; 62 push @attributes, @{$_.'::AO'} if @{$_.'::AO'}; 63 } 64 } 65 \@attributes; 66} 67 68sub cgClone { 69 my $self = shift; 70 my $class = ref($self) || $self; 71 return bless([ @$self ], $class) 72 if UNIVERSAL::isa($self, 'Class::Gomor::Array'); 73 return bless({ %$self }, $class) 74 if UNIVERSAL::isa($self, 'Class::Gomor::Hash'); 75 $self; 76} 77 78sub cgFullClone { 79 my $self = shift; 80 my ($n) = @_; 81 return [ map { $self->cgFullClone } 1..$n ]; 82} 83 84sub cgBuildAccessorsScalar { 85 my $self = shift; 86 my ($accessors) = @_; 87 for my $a (@$accessors) { 88 *{$self.'::'.$a} = sub { shift->_cgAccessorScalar($a, @_) } 89 } 90} 91 92sub cgBuildAccessorsArray { 93 my $self = shift; 94 my ($accessors) = @_; 95 for my $a (@{$accessors}) { 96 *{$self.'::'.$a} = sub { shift->_cgAccessorArray($a, @_) } 97 } 98} 99 100sub cgDebugPrint { 101 my $self = shift; 102 my ($level, $msg) = @_; 103 return if $Debug < $level; 104 my $class = ref($self) || $self; 105 $class =~ s/^.*:://; 106 $msg =~ s/^/DEBUG: $class: /gm; 107 print STDERR $msg."\n"; 108} 109 1101; 111 112=head1 NAME 113 114Class::Gomor - another class and object builder 115 116=head1 DESCRIPTION 117 118This module is yet another class builder. This one adds parameter checking in B<new> constructor, that is to check for attributes existence, and definedness. 119 120In order to validate parameters, the module needs to find attributes, and that is the reason for declaring attributes in global variables named B<@AS>, B<@AA>, B<@AO>. They respectively state for Attributes Scalar, Attributes Array and Attributes Other. The last one is used to avoid autocreation of accessors, that is to let you declare your own ones. 121 122Attribute validation is performed by looking at classes hierarchy, by following @ISA tree inheritance. 123 124The loss in speed by validating all attributes is quite negligeable on a decent machine (Pentium IV, 2.4 GHz) with Perl 5.8.x. But if you want to avoid checking, you can do it, see below. 125 126This class is the base class for B<Class::Gomor::Array> and B<Class::Gomor::Hash>, so they will inherite the following methods. 127 128=head1 GLOBAL VARIABLES 129 130=over 4 131 132=item B<$NoCheck> 133 134Import it in your namespace like this: 135 136use Class::Gomor qw($NoCheck); 137 138If you want to disable B<cgCheckParams> to improve speed once your program is frozen, you can use this variable. Set it to 1 to disable parameter checking. 139 140=item B<$Debug> 141 142Import it in your namespace like this: 143 144use Class::Gomor qw($Debug); 145 146This variable is used by the B<cgDebugPrint> method. 147 148=back 149 150=head1 METHODS 151 152=over 4 153 154=item B<cgCheckParams> (hash ref, array ref) 155 156The attribute checking method takes two arguments, the first is user passed attributes (as a hash reference), the second is the list of valid attributes, gathered via B<cgGetAttributes> method (as an array ref). A message is displayed if passed parameters are not valid. 157 158=item B<cgGetIsaTree> (array ref) 159 160A recursive method. You pass a class in an array reference as an argument, and then the @ISA array is browsed, recursively. The array reference passed as an argument is increased with new classes, pushed into it. It returns nothing, result is stored in the array ref. 161 162=item B<cgGetAttributes> 163 164This method returns available attributes for caller's object class. It uses B<cgGetIsaTree> to search recursively in class hierarchy. It then returns an array reference with all possible attributes. 165 166=item B<cgBuildAccessorsScalar> (array ref) 167 168Accessor creation method. Takes an array reference containing all scalar attributes to create. Scalar accessors are stored in a global variable names B<@AS>. So you call this method at the beginning of your class like that: 169 170__PACKAGE__->cgBuildAccessorsScalar(\@AS); 171 172=item B<cgBuildAccessorsArray> (array ref) 173 174Accessor creation method. Takes an array reference containing all array attributes to create. Array accessors are stored in a global variable names B<@AA>. So you call this method at the beginning of your class like that: 175 176__PACKAGE__->cgBuildAccessorsArray(\@AA); 177 178=item B<cgClone> [ (scalar) ] 179 180You can clone one of your objects by calling this method. An optional parameter may be used to create multiple clones. Cloning will occure only on the first level attributes, that is, if you have attributes containing other objects, they will not be cloned. 181 182=item B<cgFullClone> [ (scalar) ] 183 184This method is the same as B<cgClone>, but will clone all attributes recursively, but only if they are subclassed from B<Class::Gomor>. So, objects created with other modules than B<Class::Gomor::Array> or B<Class::Gomor::Hash> will not be cloned. 185 186Another thing to note, there is no catch for cycling references (when you link two objects with each others). You have been warned. 187 188=item B<cgDebugPrint> (scalar, scalar) 189 190First argument is a debug level. It is compared with global B<$Debug>, and if it is less than it, the second argument (a message string) is displayed. This method exists because I use it, maybe you will not like it. 191 192=back 193 194=head1 SEE ALSO 195 196L<Class::Gomor::Array>, L<Class::Gomor::Hash> 197 198=head1 AUTHOR 199 200Patrice E<lt>GomoRE<gt> Auffret 201 202=head1 COPYRIGHT AND LICENSE 203 204Copyright (c) 2004-2015, Patrice E<lt>GomoRE<gt> Auffret 205 206You may distribute this module under the terms of the Artistic license. 207See LICENSE.Artistic file in the source distribution archive. 208 209=cut 210