view release on metacpan or  search on metacpan

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

    my $spec = $raw_spec;

    my $spec_tokens = {
        'is_defined' => 0,
        'required'   => 1,
        'optional'   => 0,
    };
    while ($spec ne '') {
        if ($spec =~ s/^required(\s*,\s*|$)//) { # 'required' flag
            $spec_tokens->{'required'} = 1;
            $spec_tokens->{'optional'} = 0;

        } elsif ($spec =~ s/^optional(\s*,\s*|$)//) { # 'optional' flag
            $spec_tokens->{'required'} = 0;
            $spec_tokens->{'optional'} = 1;

        } elsif ($spec =~ s/^is_defined(\s*,\s*|$)//) { # 'is_defined' flag
            $spec_tokens->{'is_defined'} = 1;

        } elsif ($spec =~ s/^(can|isa|type|callback|default)\s*=\s*//) { # 'something="somevalue"'
            my $spec_key = $1;

            # Simple unquoted text with no embedded ws
            if ($spec =~ s/^([^\s"',]+)(\s*,\s*|$)//) {
                $spec_tokens->{$spec_key} = $1;

            # Single quoted text with no embedded quotes
            } elsif ($spec =~ s/^'([^'\/]+)'\s*,\s*//) {
                $spec_tokens->{$spec_key} = "'$1'";

            # Double quoted text with no embedded quotes or escapes
            } elsif ($spec =~ s/^"([^"\/]+)"\s*,\s*//) {
                $spec_tokens->{$spec_key} = '"' . $1 . '"';

            # It is a tricky case with quoted characters. One character at a time it is.
            } elsif ($spec =~ s/^(['"])//) {
                my $quote = $1;
                my $upend_spec  = reverse $spec;
                my $block_done  = 0;
                my $escape_next = 0;
                my $token       = $quote;
                until ($block_done || ($upend_spec eq '')) {
                    my $ch = chop $upend_spec;
                    if ($escape_next) {
                        $token      .= $ch;
                        $escape_next = 0;

                    } elsif (($ch eq "\\") && (not $escape_next)) {
                        $token      .= $ch;
                        $escape_next = 1;

                    } elsif ($ch eq $quote) {
                        $block_done = 1;

                    } else {
                        $token .= $ch;
                    }
                }
                if ($escape_next) {
                    die("Syntax error in BindParms spec: $raw_spec\n");
                }
                $spec = reverse $upend_spec;
                $spec_tokens->{$spec_key} = $token . $quote;

            } else {
                die("Syntax error in BindParms spec: $raw_spec\n");
            }
        } else {
            die("Syntax error in BindParms spec: $raw_spec\n");
        }
    }
    return $spec_tokens;
}

###############################################################################
# bind_spec is intentionally a a non-POD documented'public' method. It can be overridden in a sub-class
# to provide alternative features.
# 
# 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')");