view release on metacpan or  search on metacpan

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

        } 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