view release on metacpan or  search on metacpan

lib/Acme/Sub/Parms.pm  view on Meta::CPAN

# 
# It takes two parameters: 
#
#  $raw_spec             - this is the content of the [....] block (not including the '[' and ']' block delimitters)
#  $field_name           - the hash key for the field being processed
# 
# As each line of the BindParms block is processed the two parameters for each line are passed to the bind_spec
# method for evaluation. bind_spec should return a string containing any Perl code generated as a result of
# the bind specification.
#
# Good style dictates that the returned output should be *ONE* line (it could be a very *long* line)
# so that line numbering in the source file is preserved for any error messages.
#
sub bind_spec {
    my $self = shift;
    my ($raw_spec, $field_name) = @_;

    my $options        = $self->{'options'};
    my $no_validation  = $options->{_NO_VALIDATION()};

    my $spec_tokens = $self->_parse_bind_spec($raw_spec);

    my $has_side_effects = 0;
    my $output = '';

    my @spec_tokens_list = keys %$spec_tokens;
    if ((0 == @spec_tokens_list) || ((1 == @spec_tokens_list) && ($spec_tokens->{'optional'}))) {
        return;
    }

    ######################
    # default="some value"
    if (defined $spec_tokens->{'default'}) {
        if ($spec_tokens->{'optional'}) {
            $output .= "unless (exists (\$Acme::Sub::Parms::args\{'$field_name'\})) \{ \$Acme::Sub::Parms::args\{'$field_name'\} = " . $spec_tokens->{'default'} . ";\} ";
        } else { # required
            $output .= "unless (defined (\$Acme::Sub::Parms::args\{'$field_name'\})) \{ \$Acme::Sub::Parms::args\{'$field_name'\} = " . $spec_tokens->{'default'} . ";\} ";
        }
        $has_side_effects = 1;
    }

    ######################
    # callback="some_subroutine"
    if ($spec_tokens->{'callback'}) {
        $output .= "\{ my (\$callback_is_valid, \$callback_error) = "
                    . $spec_tokens->{'callback'}
                    . "(\'$field_name\', \$Acme::Sub::Parms::args\{\'$field_name\'\}, \\\%Acme::Sub::Parms::args);"
                    . "unless (\$callback_is_valid) { require Carp; Carp::croak(\"$field_name error: \$callback_error\"); }} ";
        $has_side_effects = 1;
    }

    ######################
    # required 
    if ((! $no_validation) && $spec_tokens->{'required'}) {
        $output .= "unless (exists (\$Acme::Sub::Parms::args\{\'$field_name\'\})) { require Carp; Carp::croak(\"Missing required parameter \'$field_name\'\"); } ";
    }

    ######################
    # is_defined 
    if ($spec_tokens->{'is_defined'}) {
        $output .= "if (exists (\$Acme::Sub::Parms::args\{\'$field_name\'\}) and (! defined (\$Acme::Sub::Parms::args\{\'$field_name\'\}))) { require Carp; Carp::croak(\"parameter \'$field_name\' cannot be undef\"); } ";
    }

    my $type_requirements = $spec_tokens->{'type'};
    my $isa_requirements  = $spec_tokens->{'isa'};
    my $can_requirements  = $spec_tokens->{'can'};

    if (defined ($type_requirements ) || defined($isa_requirements) || defined($can_requirements)) {
        $output .=  "if (exists (\$Acme::Sub::Parms::args\{\'$field_name\'\})) \{";

        #####################
        # type="SomeRefType" or type="SomeRefType, SomeOtherRefType, ..."
        if (defined $type_requirements) {
            $type_requirements =~ s/^['"]//;
            $type_requirements =~ s/['"]$//;
            my @type_classes = split(/[,\s]+/, $type_requirements);
            $output .= "unless (";
            my @type_tests = ();
            foreach my $class_name (@type_classes) {
                push (@type_tests, "ref(\$Acme::Sub::Parms::args\{'$field_name'\}) eq '$class_name')");
            }
            $output .= join(' || ',@type_tests) . " \{ require Carp; Carp::croak(\'parameter \\\'$field_name\\\' must be a " . join(' or ',@type_classes) . "\'); \}";
        }

        #####################
        # isa="SomeRefType" or isa="SomeRefType, SomeOtherRefType, ..."
        if (defined $isa_requirements) {
            $isa_requirements =~ s/^['"]//;
            $isa_requirements =~ s/['"]$//;
            my @isa_classes = split(/[,\s]+/, $isa_requirements);
            $output .= "unless (";
            my @isa_tests = ();
            foreach my $class_name (@isa_classes) {
                push (@isa_tests, "\$Acme::Sub::Parms::args\{'$field_name'\}->isa('$class_name')");
            }
            $output .= join(' || ',@isa_tests) . ") \{ require Carp; Carp::croak(\'parameter \\\'$field_name\\\' must be a " . join(' or ',@isa_classes) . " instance or subclass\'); \}";
        }

        #####################
        # can="somemethod" or can="somemethod, someothermethod, ..."
        if (defined $can_requirements) {
            $can_requirements =~ s/^['"]//;
            $can_requirements =~ s/['"]$//;
            my @can_methods = split(/[,\s]+/, $can_requirements);
            $output .= "unless ("; 
            my @can_tests = ();
            foreach my $method_name (@can_methods) {
                push (@can_tests, "\$Acme::Sub::Parms::args\{'$field_name'\}->can('$method_name')");
            }
            $output .= join(' && ',@can_tests) . ") \{ require Carp; Carp::croak(\'parameter \\\'$field_name\\\' must be an object with a " . join(' and a ',@can_methods) . " method\'); \}";
        }

        $output .= "\}";
    }

    return ($has_side_effects,$output);
}

####

sub filter {

lib/Acme/Sub/Parms.pm  view on Meta::CPAN

                    } else { # Otherwise make a seperate entry for this binding
                        push (@hard_var_declarations, "$raw_var = \$Acme::Sub::Parms::args\{$field_name\};");
                    }
                }
                my $hard_args = join(' ',@hard_var_declarations);
                my $arg_line  = '';
                if (0 < @var_declarations) {
                 
                    if ($simple_bind && (! $normalize) && $no_validation && (0 == $side_effects) && (0 == @hard_var_declarations)) {
                       $args = "\n    my (" . join(",", @var_declarations) . ') = @{{@_}}{' . join(',',@field_declarations) . '}; ';

                    } else {
    
                        $arg_line  = 'my (' . join(",", @var_declarations) . ') = @Acme::Sub::Parms::args{' . join(',',@field_declarations) . '}; ';
                    }
                }
                my $unknown_parms_check = '';
                unless ($no_validation) {
                    $unknown_parms_check = 'delete @Acme::Sub::Parms::args{' . join(',',@fields_list) . '}; if (0 <  @Acme::Sub::Parms::args) { require Carp; Carp::croak(\'Unexpected parameters passed: \' . join(\', \',@Acme::Sub::Parms::args)); } ';

                }
                $self->{'bind_block'} = 0;
                my $original_block_length = $Acme::Sub::Parms::line_counter - $self->{'line_block_start'};
                my $new_block = $args . join(' ',$arg_line, $hard_args, $unknown_parms_check) . "$block_trailing_comment\n";
                $new_block =~ s/\n+/\n/gs;
                my $new_block_lines = $new_block =~ m/\n/gs;
                
                my $additional_lines = $original_block_length - $new_block_lines;
                #warn("Need $additional_lines extra lines\n---\n$new_block---\n");
                if ($additional_lines > 0) {
                    $_ = $new_block . ("\n" x $additional_lines);	
                } else {
                    $_ = $new_block;	
                }

            ########################
            # Bind block parameter line
            } elsif (my($bind_var, $bind_field,$trailing_comment) = m/^\s*(\S.*?)\s+:\s+([^'"\s\[]+.*?)\s*(;\s*|;\s*#.*)$/) {
            	$trailing_comment = defined($trailing_comment) ? $trailing_comment : '';
            	$trailing_comment =~ s/[\r\n]+$//s;
            	$trailing_comment =~ s/^;//;
                my $bind_entry = { 'variable' => $bind_var, 'field' => $bind_field, trailing_comment => $trailing_comment };
                push (@$bind_entries, $bind_entry);
                if ($bind_var !~ m/^my \$\S+$/) {
                    $self->{'simple_bind'} = 0;
                }
                if ($bind_field =~ m/^(\S+)\s*\[(.*)\]$/) { # Complex spec
                    $bind_entry->{'field'} = $1;
                    $bind_entry->{'spec'}  = $2;
                    unless ($no_validation && ($bind_field !~ m/[\s\[,](default|callback)\s*=\s*/)) {
                        $self->{'simple_bind'} = 0;
                    }
                } elsif ($bind_field =~ m/^\w+$/) { # my $thing : something;
                	$bind_entry->{'spec'}  = 'required';
                	unless ($no_validation) {
                		$self->{'simple_bind'} = 0;	
                    }
                } else {
                	die("Failed to parse BindParms block line $Acme::Sub::Parms::line_counter: $_");
                }
                undef $trailing_comment;
                undef $bind_var;
                undef $bind_field;
                $_ = '';

            ############################
            # Blank and comment only lines
            } elsif (m/^(\s*|\s*#.*)$/) {
            	my $trailing_comment = $1;
            	$trailing_comment = defined ($trailing_comment) ? $trailing_comment : '';
            	$trailing_comment =~ s/[\r\n]+$//s;
            	
                my $bind_entry = { spec => '', trailing_comment => $trailing_comment};
                push (@$bind_entries, $bind_entry);
                $_ = '';
                
            } else {
                die("Failed to parse BindParms block line $Acme::Sub::Parms::line_counter: $_");
            }

        } else { # Start of a bind block
            if (m/^\s*BindParms\s+:\s+\((\s*#.*$|\s*$)/) {
                $self->{'simple_bind'}  = 1;
                $self->{'bind_entries'} = [];
                $self->{'bind_block'}   = 1;
                $self->{'line_block_start'} = $Acme::Sub::Parms::line_counter;
                my $block_head_comment = $2;
                $block_head_comment = defined ($block_head_comment) ? $block_head_comment : '';
                $block_head_comment =~ s/[\r\n]+$//s;
                $_ = $block_head_comment;

#######
#            ################################
#            # Invokation : $self;
#            } elsif (my ($ihead,$ivar,$itail) = m/^(\s*)Invokation\s+:\s+(\S+.*?)\s*;(.*)$/) {
#                $_ = $ihead . " my $ivar = shift @_;$itail\n";
#
#            ################################
#            # ParmsHash : %args;
#            } elsif (my ($fhead,$func_hash_ident,$ftail) = m/^(\s*)ParmsHash\s+:\s+(\S+.*?)\s*;(.*)$/) {
#                if ($normalize) {
#                    $_ = "${fhead}my $func_hash_ident; { local \%Acme::Sub::Parms::raw_args = \@\_; $func_hash_ident = map \{ lc(\$\_\) \=\> \$Acme::Sub::Parms::raw_args\{\$\_\} \} keys \%Acme::Sub::Parms::raw_args; } $ftail\n";
#                } else {
#                    $_ = "${fhead}my $func_hash_ident = \@\_;$ftail\n";
#                }
#
#            ################################
#            # MethodParms : $self, %args;
#            } elsif (my ($mhead,$method_invokation,$method_hash_ident,$mtail) = m/^(\s*)MethodParms\s+:\s+(\S+.*?)\s*,\s*(\S+.*?)\s*;(.*)$/) {
#                if ($normalize) {
#                    $_ = "${mhead}my $method_invokation = shift; my $method_hash_ident; { local \$_; local \%Acme::Sub::Parms::raw_args = \@\_; $method_hash_ident = map \{ lc(\$\_\) \=\> \$Acme::Sub::Parms::raw_args\{\$\_\} \} keys \%Acme::Sub::Parm...
#                } else {
#                    $_ = "${mhead}my $method_invokation = shift; my $method_hash_ident = \@\_; $mtail\n";
#                }
#######
            }
        }
    }
    if (_DEBUG) {
    	print STDERR "output as: $_";	
    }
    if ($dump_to_stdout) { print $_; }