view release on metacpan or  search on metacpan

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

            }
            $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 {
    my $self = shift;

    my $options        = $self->{'options'};
    my $dump_to_stdout = $options->{_DUMP()};
    my $normalize      = $options->{_NORMALIZE()};
    my $no_validation  = $options->{_NO_VALIDATION()};
    my $bind_block     = $self->{'bind_block'};

    my $status;

    if ($status = filter_read() > 0) { # imported from Filter::Util::Call
    	$Acme::Sub::Parms::line_counter++;
        
        if (_DEBUG) {
            print STDERR "input line $Acme::Sub::Parms::line_counter: $_";	
        }
   
        #############################################
        # If we are in a bind block, handle it
        if ($bind_block) {
            my $bind_entries = $self->{'bind_entries'};
            my $simple_bind  = $self->{'simple_bind'};

            ##############################
            # Last line of the bind block? Generate the working code.
            if (m/^\s*\)(\s*$|\s*#.*$)/) {
            	
            	my $block_trailing_comment = $2;
            	$block_trailing_comment = defined($block_trailing_comment) ? $block_trailing_comment : '';
            	$block_trailing_comment =~ s/[\r\n]+$//s;
                my $side_effects = 0;
                my $args = 'local %Acme::Sub::Parms::args; '; # needed?
                if ($normalize) {
                    $args .= '{ local $_; local %Acme::Sub::Parms::raw_args = @_; %Acme::Sub::Parms::args = map { lc($_) => $Acme::Sub::Parms::raw_args{$_} } keys %Acme::Sub::Parms::raw_args; }' . "\n";
                } else {
                    $args .= '%Acme::Sub::Parms::args = @_;' . "\n";
                }
                # If we have validation or defaults, handle them
                my $padding_lines = 0;
                if (! $simple_bind) { 
                    my @parm_declarations = ();
                    foreach my $entry (@$bind_entries) {
                        my $variable_decl    = $entry->{'variable'};
                        my $field_name       = $entry->{'field'};
                        my $spec             = $entry->{'spec'};
                        my $trailing_comment = $entry->{'trailing_comment'};
                        if ( (! defined($spec)) || ($spec eq '')) {
                            # push(@parm_declarations, $trailing_comment);
                            next;
                        }
                        # The hard case. We have validation requirements.
                        my ($has_side_effects, $bind_spec_output) = $self->bind_spec($spec, $field_name);
                        $side_effects += $has_side_effects;
                        push (@parm_declarations, "$bind_spec_output$trailing_comment");
                    }
                    $args .=  join("\n",@parm_declarations,'');
                }

                # Generate the actual parameter data binding
                my @var_declarations      = ();
                my @hard_var_declarations = ();
                my @field_declarations    = ();
                my @fields_list           = ();
                foreach my $entry (@$bind_entries) {
                	my $spec       = $entry->{'spec'};
                	next if ((not defined $spec) || ($spec eq ''));
                    my $raw_var    = $entry->{'variable'};
                    my $field_name = $entry->{'field'};
                    
                    push (@fields_list, "'$field_name'");
                    my ($variable_name) = $raw_var =~ m/^my\s+(\S+)$/;
                    if (defined $variable_name) { # simple 'my $variable :' entries are special-cased for performance
                        push (@var_declarations,   $variable_name);
                        push (@field_declarations, "'$field_name'");

                    } 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)); } ';

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

                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 $_; }

    return $status;
}

####

1;