Class-Generate
view release on metacpan or search on metacpan
lib/Class/Generate.pm view on Meta::CPAN
# Next for user-defined instance methods...
@names = accessible_user_defined_method_regexps($class);
if ( !@names )
{
undef $user_defined_methods_regexp;
}
else
{
$user_defined_methods_regexp = '&('
. join( '|', sort { length $b <=> length $a } @names )
. ')\b(?:\s*\()?';
}
# Next for protected and private members, and instance methods in class methods...
if ( $class->class_methods )
{
@names = (
map( $_->accessor_names( $class, $_->name ),
grep $class->protected( $_->name )
|| $class->private( $_->name ),
$class->members_values ),
grep( $class->private($_) || $class->protected($_),
map( $_->name, $class->instance_methods ) )
);
if ( !@names )
{
undef $nonpublic_member_regexp;
}
else
{
$nonpublic_member_regexp =
join( '|', sort { length $b <=> length $a } @names );
}
}
else
{
undef $nonpublic_member_regexp;
}
# Finally for private class methods invoked from class and instance methods.
if (
my @private_class_methods =
grep $_->isa('Class::Generate::Class_Method')
&& $class->private( $_->name ), $class->user_defined_methods
)
{
$private_class_methods_regexp =
$class->name
. '\s*->\s*('
. join( '|', map $_->name, @private_class_methods ) . ')'
. '(\s*\((?:\s*\))?)?';
}
else
{
undef $private_class_methods_regexp;
}
}
sub substituted($)
{ # Within a code fragment, replace
my $code = $_[0]; # member names and accessors with the
# appropriate forms.
$code =~ s/$member_regexp/member_invocation($1, $&)/eg
if defined $member_regexp;
$code =~ s/$accessor_regexp/accessor_invocation($1, $+, $&)/eg
if defined $accessor_regexp;
$code =~ s/$user_defined_methods_regexp/accessor_invocation($1, $1, $&)/eg
if defined $user_defined_methods_regexp;
$code =~
s/$private_class_methods_regexp/nonpublic_method_invocation("'" . $class->name . "'", $1, $2)/eg
if defined $private_class_methods_regexp;
return $code;
}
# Perform the actual substitution
sub member_invocation($$)
{ # for member references.
my ( $member_reference, $match ) = @_;
my ( $name, $type, $form, $index );
return $member_reference
if $match =~ /\A(?:my|local)\b[^=;()]+$member_reference$/s;
$member_reference =~ /^(\W+)(\w+)$/;
$name = $2;
return $member_reference
if !defined( $index = member_index( $class, $name ) );
$type = $1;
$form = $class->instance_var . '->' . $index;
return $type eq '$' ? $form : $type . '{' . $form . '}';
}
# Perform the actual substitution for
sub accessor_invocation($$$)
{ # accessor and user-defined method references.
my ( $accessor_name, $element_name, $match ) = @_;
my $prefix = $class->instance_var . '->';
my $c = class_of( $element_name, $class );
if ( !( $c->protected($element_name) || $c->private($element_name) ) )
{
return
$prefix
. $accessor_name
. ( substr( $match, -1 ) eq '(' ? '(' : '' );
}
if ( $c->private($element_name) || $c->name eq $class->name )
{
return "$prefix\$$accessor_name(" if substr( $match, -1 ) eq '(';
return "$prefix\$$accessor_name()";
}
my $form =
"&{$prefix"
. $class->protected_members_info_index
. qq|->{'$accessor_name'}}(|;
$form .= $class->instance_var . ',';
return substr( $match, -1 ) eq '(' ? $form : $form . ')';
}
sub substituted_in_class_method
{
my $method = $_[0];
my ( @objs, $code, @private_class_methods );
lib/Class/Generate.pm view on Meta::CPAN
for my $member ( $class->members_values )
{
next
if $class->private( $member_name = $member->name )
&& $disallow_private_members;
for my $accessor_name ( grep $class->include_method($_),
$member->accessor_names( $class, $member_name ) )
{
$accessor_name =~ s/$member_name/($&)/;
push @accessor_names, $accessor_name;
}
}
return (
@accessor_names,
map( accessible_accessor_regexps( $_, 1 ),
grep( ref $_, $class->parents ) )
);
}
sub accessible_user_defined_method_regexps($;$)
{
my ( $class, $disallow_private_methods ) = @_;
return (
(
$disallow_private_methods
? grep !$class->private($_),
$class->user_defined_methods_keys
: $class->user_defined_methods_keys
),
map( accessible_user_defined_method_regexps( $_, 1 ),
grep( ref $_, $class->parents ) )
);
}
# Given element E and class C, return C if E is an
sub class_of($$;$)
{ # element of C; if not, search parents recursively.
my ( $element_name, $class, $disallow_private_members ) = @_;
return $class
if ( defined $class->members($element_name)
|| defined $class->user_defined_methods($element_name) )
&& ( !$disallow_private_members || !$class->private($element_name) );
for my $parent ( grep ref $_, $class->parents )
{
my $c = class_of( $element_name, $parent, 1 );
return $c if defined $c;
}
return undef;
}
package Class::Generate::Code_Checker; # This package encapsulates
$Class::Generate::Code_Checker::VERSION = '1.18';
use strict; # checking for warnings and
use Carp; # errors in user-defined code.
my $package_decl;
my $member_error_message = '%s, member "%s": In "%s" code: %s';
my $method_error_message = '%s, method "%s": %s';
sub create_code_checking_package($);
sub fragment_as_sub($$\@;\@);
sub collect_code_problems($$$$@);
# Check each user-defined code fragment in $class for errors. This includes
# pre, post, and assert code, as well as user-defined methods. Set
# $errors_found according to whether errors (not warnings) were found.
sub check_user_defined_code($$$$)
{
my ( $class, $class_name_label, $warnings, $errors ) = @_;
my ( $code, $instance_var, @valid_variables, @class_vars, $w, $e, @members,
$problems_in_pre, %seen );
create_code_checking_package $class;
@valid_variables = map {
$seen{ $_->name } ? () : do { $seen{ $_->name } = 1; $_->as_var }
} (
( @members = $class->members_values ),
Class::Generate::Member_Names::accessible_members($class)
);
@class_vars = $class->class_vars;
$instance_var = $class->instance_var;
@$warnings = ();
undef $$errors;
for my $member ( $class->constructor, @members )
{
if ( defined( $code = $member->pre ) )
{
$code = fragment_as_sub $code, $instance_var, @class_vars,
@valid_variables;
collect_code_problems $code,
$warnings, $errors,
$member_error_message, $class_name_label, $member->name, 'pre';
$problems_in_pre = @$warnings || $$errors;
}
# Because post shares pre's scope, check post with pre prepended.
# Strip newlines in pre to preserve line numbers in post.
if ( defined( $code = $member->post ) )
{
my $pre = $member->pre;
if ( defined $pre && !$problems_in_pre )
{ # Don't report errors
$pre =~ s/\n+/ /g; # in pre again.
$code = $pre . $code;
}
$code = fragment_as_sub $code, $instance_var, @class_vars,
@valid_variables;
collect_code_problems $code,
$warnings, $errors,
$member_error_message, $class_name_label, $member->name, 'post';
}
if ( defined( $code = $member->assert ) )
{
$code = fragment_as_sub "unless($code){die}", $instance_var,
@class_vars, @valid_variables;
collect_code_problems $code,
$warnings, $errors,
$member_error_message, $class_name_label, $member->name,
'assert';
}
}
for my $method ( $class->user_defined_methods_values )
{
if ( $method->isa('Class::Generate::Class_Method') )
{
$code = fragment_as_sub $method->body, $class->class_var,
@class_vars;
}
else
{
$code = fragment_as_sub $method->body, $instance_var, @class_vars,
@valid_variables;
}
collect_code_problems $code, $warnings, $errors, $method_error_message,
$class_name_label, $method->name;
}
}
sub create_code_checking_package($)
{ # Each class with user-defined code gets
my $class = $_[0]; # its own package in which that code is
# evaluated. Create said package.
$package_decl = 'package ' . __PACKAGE__ . '::check::' . $class->name . ";";
$package_decl .= 'use strict;' if $class->strict;
my $packages = '';
if ( $class->check_params )
{
$packages .= 'use Carp;';
$packages .= join( ';', $class->warnings_pragmas );
}
$packages .= join( '', map( 'use ' . $_ . ';', $class->use_packages ) );
$packages .= 'use vars qw(@ISA);' if $class->parents;
eval $package_decl . $packages;
}
# Evaluate a code fragment, passing on
sub collect_code_problems($$$$@)
{ # warnings and errors.
my ( $code_form, $warnings, $errors, $error_message, @params ) = @_;
my @warnings;
local $SIG{__WARN__} = sub { push @warnings, $_[0] };
local $SIG{__DIE__};
eval $package_decl . $code_form;
push @$warnings,
map( filtered_message( $error_message, $_, @params ), @warnings );
$$errors .= filtered_message( $error_message, $@, @params ) if $@;
}
sub filtered_message
{ # Clean up errors and messages
my ( $message, $error, @params ) = @_; # a little by removing the
$error =~ s/\(eval \d+\) //g; # "(eval N)" forms that perl
return sprintf( $message, @params, $error ); # inserts.
}
sub fragment_as_sub($$\@;\@)
{
my ( $code, $id_var, $class_vars, $valid_vars ) = @_;
my $form;
$form = "sub{my $id_var;";
if ( $#$class_vars >= 0 )
{
$form .= 'my('
. join( ',', map( ( ref $_ ? keys %$_ : $_ ), @$class_vars ) )
. ');';
}
if ( $valid_vars && $#$valid_vars >= 0 )
{
$form .= 'my(' . join( ',', @$valid_vars ) . ');';
}
$form .= '{' . $code . '}};';
}
package Class::Generate::Array; # Given a string or an ARRAY, return an
$Class::Generate::Array::VERSION = '1.18';
use strict; # object that is either the ARRAY or
use Carp; # the string made into an ARRAY by
# splitting the string on white space.
sub new
{
my $class = shift;
my $self;
if ( !ref $_[0] )
{
$self = [ split /\s+/, $_[0] ];
}
elsif ( UNIVERSAL::isa( $_[0], 'ARRAY' ) )
{
$self = $_[0];
}
else
{
croak 'Expected string or array reference';
}
bless $self, $class;
return $self;
}
sub values
{
my $self = shift;
return @$self;
}
package Class::Generate::Hash; # Given a string or a HASH and a key
$Class::Generate::Hash::VERSION = '1.18';
use strict; # name, return an object that is either
use Carp; # the HASH or a HASH of the form
# (key => string). Also, if the object
sub new
{ # is a HASH, it *must* contain the key.
my $class = shift;
my $self;
my ( $value, $key ) = @_;
lib/Class/Generate.pm view on Meta::CPAN
if the string is an expression with side effects.
Furthermore, your program will behave differently depending on
whether warnings are in effect.
If you set the C<check_default> option to false,
C<class> and C<subclass> will not check the types of default values.
It's common to do so after you have debugged a class.
=head2 Creating New Objects From Instances
By default, C<Class::Generate> lets you create a new object instance only
from a class name, i.e., C<Class-E<gt>new>.
However, some Perl programmers prefer another style,
wherein you can create an object from either a class or an instance
(see L<perlobj>).
The C<nfi> (I<n>ew I<f>rom I<i>nstance) option controls whether
you can use both:
class C => { ... };
$o = C->new; # Always works.
$p = $o->new; # Works if nfi option is true.
=head2 Checking Parameter Values
Several sections have mentioned errors
that will cause your classes to croak if used incorrectly.
Examples include constructor invocation that omits a required member's value
and passing a scalar where a reference is expected.
These checks are useful, especially during debugging,
but they can slow your code.
If you set the C<check_params> option to a false value,
C<Class::Generate> will omit these checks.
Furthermore, if you set C<check_params> to C<undef>,
C<Class::Generate> will omit assertions too.
A class that checks parameters automatically includes the
L<Carp> package.
C<Class::Generate> generates code that uses methods in this package,
especially C<croak>, to report errors.
The downside of changing the default C<check_params> value should be
obvious to any experienced programmer.
=head1 DIAGNOSTICS
The following is a list of the diagnostics the C<class> and C<subclass>
functions can produce.
Each diagnostic is prefixed with "(F)" or "(W)",
indicating that it is fatal or a warning, respectively.
Warning messages are only emitted if you use the C<warnings> pragma.
Classes that contain user defined code can yield Perl errors and warnings.
These messages are prefixed by one of the following phrases:
Class class_name, member "name": In "<x>" code:
Class class_name, method "name":
where C<E<lt>xE<gt>> is one of C<pre>, C<post>, or C<assert>.
See L<perldiag> for an explanation of such messages.
The message will include a line number that is relative to the
lines in the erroneous code fragment,
as well as the line number on which the class begins.
For instance, suppose the file C<stacks.pl> contains the following code:
#! /bin/perl
use warnings;
use Class::Generate 'class';
class Stack => [
top_e => { type => '$', private => 1, default => -1 },
elements => { type => '@', private => 1, default => '[]' },
'&push' => '$elements[++$top_e] = $_[0];',
'&pop' => '$top_e--;',
'&top' => 'return $elements[$top_e];'
];
class Integer_Stack => [
'&push' => q{die 'Not an integer' if $_[0] !~ /^-?\d+$/;
$self->SUPER:push($_[0]);} # Meant "::", not ":".
], -parent => 'Stack';
Executing this file yields:
Subclass "Integer_Stack", method "push": syntax error at line 2,
near "->SUPER:"
at stacks.pl line 11
meaning the error occurs in the second line of the C<push> method.
=head2 Compile-Time Diagnostics
The C<class> and C<subclass> functions emit the following diagnostics:
=over 4
=item "-class_vars" flag must be string or array reference
(F) The value of the C<-class_vars> flag must be a string
containing a space-separated list of class variables,
or a reference to an array of strings,
each of which specifies one or more class variables.
=item "-exclude" flag must be string or array reference
(F) The value of the C<-exclude> flag must be a string
containing a space-separated list of regular expressions,
or a reference to an array of strings,
each of which specifies one or more regular expressions.
=item "-pod" flag must be scalar value or hash reference
(F) The value of the C<-pod> flag must be either a scalar
that evaluates to a boolean value or a hash reference
whose elements denote sections of POD documentation.
=item "-use" flag must be string or array reference
(F) The value of the C<-use> flag must be a string
containing a space-separated list of packages to use,
or a reference to an array of strings,
each of which is a package to use.
=item %s: "%s" is reserved
( run in 0.765 second using v1.01-cache-2.11-cpan-364913b4093 )