Class-Generate
view release on metacpan or search on metacpan
lib/Class/Generate.pm view on Meta::CPAN
my %valid_option =
map( substr( $_, 0, 1 ) eq '$' ? ( substr( $_, 1 ) => 1 ) : (),
@EXPORT_OK );
my %class_to_ref_map = (
'Class::Generate::Array_Class' => 'ARRAY',
'Class::Generate::Hash_Class' => 'HASH'
);
my %warnings_keys = map( ( $_ => 1 ), qw(use no register) );
sub class(%)
{ # One of the three interface
my %params = @_; # routines to the package.
if ( defined $params{-parent} )
{ # Defines a class or a
subclass(@_); # subclass.
return;
}
&$initialize();
&$parse_any_flags( \%params );
croak "Missing/extra arguments to class()" if scalar( keys %params ) != 1;
( $class_name, undef ) = %params;
$cm = qq|Class "$class_name"|;
&$verify_class_type( $params{$class_name} );
croak "$cm: A package of this name already exists"
if !$allow_redefine_for_class && &$class_defined($class_name);
&$set_class_type( $params{$class_name} );
&$process_class( $params{$class_name} );
}
sub subclass(%)
{ # One of the three interface
my %params = @_; # routines to the package.
&$initialize(); # Defines a subclass.
my ( $p_spec, $parent );
if ( defined( $p_spec = $params{-parent} ) )
{
delete $params{-parent};
}
else
{
lib/Class/Generate.pm view on Meta::CPAN
) if warnings::enabled() && eval "! exists \$" . $p . '::{_cginfo}';
}
&$set_class_type( $params{$class_name}, $parent );
for my $p ( $parent->values )
{
$class->add_parents( Class::Generate::Class_Holder::get($p) );
}
&$process_class( $params{$class_name} );
}
sub delete_class(@)
{ # One of the three interface routines
for my $class (@_)
{ # to the package. Deletes a class
next if !eval '%' . $class . '::'; # declared using Class::Generate.
if ( !eval '%' . $class . '::_cginfo' )
{
croak $class, ': Class was not declared using ', __PACKAGE__;
}
delete_package($class);
Class::Generate::Class_Holder::remove($class);
lib/Class/Generate.pm view on Meta::CPAN
@_;
};
package Class::Generate::Class_Holder; # This package encapsulates functions
$Class::Generate::Class_Holder::VERSION = '1.18';
use strict; # related to storing and retrieving
# information on classes. It lets classes
# saved in files be reused transparently.
my %classes;
sub store($)
{ # Given a class, store it so it's
my $class = $_[0]; # accessible in future invocations of
$classes{ $class->name } = $class; # class() and subclass().
}
# Given a class name, try to return an instance of Class::Generate::Class
# that models the class. The instance comes from one of 3 places. We
# first try to get it from wherever store() puts it. If that fails,
# we check to see if the variable %<class_name>::_cginfo exists (see
# form(), below); if it does, we use the information it contains to
# create an instance of Class::Generate::Class. If %<class_name>::_cginfo
# doesn't exist, the package wasn't created by Class::Generate. We try
# to infer some characteristics of the class.
sub get($;$)
{
my ( $class_name, $default_type ) = @_;
return $classes{$class_name} if exists $classes{$class_name};
return undef if !eval '%' . $class_name . '::'; # Package doesn't exist.
my ( $class, %info );
if ( !eval "exists \$" . $class_name . '::{_cginfo}' )
{ # Package exists but is
return undef if !defined $default_type; # not a class generated
lib/Class/Generate.pm view on Meta::CPAN
$class->constructor->style(
new Class::Generate::Own( @{ $info{own_style} } ) );
last CONSTRUCTOR_STYLE;
};
}
$classes{$class_name} = $class;
return $class;
}
sub remove($)
{
delete $classes{ $_[0] };
}
sub form($)
{
my $class = $_[0];
my $form = qq|use vars qw(\%_cginfo);\n| . '%_cginfo = (';
if ( $class->isa('Class::Generate::Array_Class') )
{
$form .= q|base => 'ARRAY', last => | . $class->last;
}
else
{
$form .= q|base => 'HASH'|;
lib/Class/Generate.pm view on Meta::CPAN
$form .= ', own_style => []';
}
last STYLE;
};
}
}
$form .= ');' . "\n";
return $form;
}
sub member($)
{
my $member = $_[0];
my $base;
my $form = $member->name . ' => {';
$form .= " type => '"
. (
$member->isa('Class::Generate::Scalar_Member') ? "\$"
: $member->isa('Class::Generate::Array_Member') ? '@'
: '%'
) . "'";
if ( defined( $base = $member->base ) )
{
$form .= ", base => '$base'";
}
return $form . '}';
}
sub list_of_values($@)
{
my ( $key, @list ) = @_;
return '' if !@list;
return "$key => [" . join( ', ', map( "'$_'", @list ) ) . ']';
}
sub comma_prefixed_list_of_values($@)
{
return $#_ > 0 ? ', ' . list_of_values( $_[0], @_[ 1 .. $#_ ] ) : '';
}
package Class::Generate::Member_Names; # This package encapsulates functions
$Class::Generate::Member_Names::VERSION = '1.18';
use strict; # to handle name substitution in
# user-defined code.
my (
$member_regexp, # Regexp of accessible members.
$accessor_regexp, # Regexp of accessible member accessors (x_size, etc.).
$user_defined_methods_regexp
, # Regexp of accessible user-defined instance methods.
$nonpublic_member_regexp
, # (For class methods) Regexp of accessors for protected and private members.
$private_class_methods_regexp
); # (Ditto) Regexp of private class methods.
sub accessible_member_regexps($;$);
sub accessible_members($;$);
sub accessible_accessor_regexps($;$);
sub accessible_user_defined_method_regexps($;$);
sub class_of($$;$);
sub member_index($$);
sub set_element_regexps()
{ # Establish the regexps for
my @names; # name substitution.
# First for members...
@names = accessible_member_regexps($class);
if ( !@names )
{
undef $member_regexp;
}
else
lib/Class/Generate.pm view on Meta::CPAN
. '\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 '(' ? '(' : '' );
lib/Class/Generate.pm view on Meta::CPAN
$form .= ', ';
}
}
else
{
$form .= ')';
}
return $form;
}
sub member_index($$)
{
my ( $class, $member_name ) = @_;
return $class->index($member_name) if defined $class->members($member_name);
for my $parent ( grep ref $_, $class->parents )
{
my $index = member_index( $parent, $member_name );
return $index if defined $index;
}
return undef;
}
sub accessible_member_regexps($;$)
{
my ( $class, $disallow_private_members ) = @_;
my @members;
if ($disallow_private_members)
{
@members = grep !$class->private( $_->name ), $class->members_values;
}
else
{
@members = $class->members_values;
}
return (
map( $_->method_regexp($class), @members ),
map( accessible_member_regexps( $_, 1 ),
grep( ref $_, $class->parents ) )
);
}
sub accessible_members($;$)
{
my ( $class, $disallow_private_members ) = @_;
my @members;
if ($disallow_private_members)
{
@members = grep !$class->private( $_->name ), $class->members_values;
}
else
{
@members = $class->members_values;
}
return ( @members,
map( accessible_members( $_, 1 ), grep( ref $_, $class->parents ) ) );
}
sub accessible_accessor_regexps($;$)
{
my ( $class, $disallow_private_members ) = @_;
my ( $member_name, @accessor_names );
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 ) )
lib/Class/Generate.pm view on Meta::CPAN
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;
lib/Class/Generate.pm view on Meta::CPAN
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)
lib/Class/Generate.pm view on Meta::CPAN
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 ) )
. ');';
}
lib/Class/Generate.pm view on Meta::CPAN
{
return $parent;
}
return class_containing_method( $method, $parent );
}
return undef;
}
my %map = ( '@' => 'ARRAY', '%' => 'HASH' );
sub verify_value($$)
{ # Die if a given value (ref or string)
my ( $value, $type ) = @_; # is not the specified type.
# The following code is not wrong, but it could be smarter.
if ( $type =~ /^\w/ )
{
$map{$type} = $type;
}
else
{
$type = substr $type, 0, 1;
t/A_Class.pm view on Meta::CPAN
# This is a valid class, not declared using Class::Generate.
# It cannot however be a superclass of something declared
# through that package, because it is based on a reference
# to a scalar, not to an array or hash.
package A_Class;
use strict;
my $instances_declared = 0;
sub init()
{
$instances_declared = 0;
}
sub new
{
my $class = shift;
my $v = ++$instances_declared;
return bless \$v, $class;
}
t/Test_Framework.pm view on Meta::CPAN
use warnings;
use strict;
use Exporter;
use vars qw(@ISA @EXPORT);
@ISA = qw(Exporter);
@EXPORT = qw(&Test &Test_Failure &Report_Results &Arrays_Equal);
my $test_no = 1;
my @results;
sub Test(&)
{
my $code = $_[0];
push @results, test_succeeds($code);
if ( !$results[$#results] )
{
print STDERR $@, "\n" if $@;
}
}
sub Test_Failure(&)
{
my $code = $_[0];
push @results, !test_succeeds($code);
}
sub Report_Results()
{
print '1..', ( $#results + 1 ), "\n";
for ( my $i = 0 ; $i <= $#results ; $i++ )
{
print $results[$i] ? 'ok' : 'not ok', ' ', $i + 1, "\n";
}
}
sub test_succeeds
{
my $code = $_[0];
my $result;
eval { $result = &$code };
return $result && !$@;
}
sub Arrays_Equal($$)
{
my ( $a1, $a2 ) = @_;
return 0 if $#$a1 != $#$a2;
for ( my $i = 0 ; $i <= $#$a1 ; $i++ )
{
return 0 if $$a1[$i] ne $$a2[$i];
}
return 1;
}
t/constructor.t view on Meta::CPAN
use Test_Framework;
use Class::Generate qw(&class &subclass);
# Test some options of the constructor:
# -- Required members.
# -- Assertions.
# -- "Post" code.
my @members = ( m1 => "\$", m2 => '@', m3 => '%' );
sub param_assignment($)
{
my $member = $_[0];
return ( m1 => 1 ) if $member == 1;
return ( m2 => [2] ) if $member == 2;
return ( m3 => { v => 3 } ) if $member == 3;
}
sub members(@)
{
return map( param_assignment($_), @_ );
}
sub eval_invalid_forms($@)
{
my ( $class, @forms ) = @_;
for my $invalid_form (@forms)
{
Test_Failure { new $class map param_assignment $_, @$invalid_form };
}
}
Test
{
t/param_styles.t view on Meta::CPAN
use lib qw(./t);
use warnings;
use strict;
use Test_Framework;
use Class::Generate qw(&class &subclass);
# Test the different constructor styles (key/value, positional, mix).
use constant SPEC => { type => "\$", readonly => 1, required => 1 };
sub members_valid($$)
{
my ( $obj, $max ) = @_;
for ( my $i = 1 ; $i <= $max ; $i++ )
{
return 0 if !eval "\$obj->m$i == $i";
}
return 1;
}
Test
( run in 0.589 second using v1.01-cache-2.11-cpan-65fba6d93b7 )