Class-Generate

 view release on metacpan or  search on metacpan

lib/Class/Generate.pm  view on Meta::CPAN

            . 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

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 }

lib/Class/Generate.pm  view on Meta::CPAN

    );
    @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

lib/Class/Generate.pm  view on Meta::CPAN

    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

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];',