view release on metacpan or  search on metacpan

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

    }->{$_[0]};
}

####

sub import {
    my $class = shift;
    my $options = {
           _NORMALIZE()      => 0,
           _NO_VALIDATION()  => 0,
           _DUMP()           => 0,
           };
    foreach my $item (@_) {
        if (not _legal_option($item)) {
            my $package = __PACKAGE__;
            require Carp;
            Carp::croak("'$item' not a valid option for 'use $package'\n");
        }
        $options->{$item} = 1;
    }
    $Acme::Sub::Parms::line_counter = 0;
    my $ref   = {'options' => $options, 'bind_block' => 0 };
    filter_add(bless $ref); # imported from Filter::Util::Call
}

####

sub _parse_bind_spec {
    my ($self, $raw_spec) = @_;

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

    ######################