view release on metacpan or  search on metacpan

lib/Config/IOD/Base.pm  view on Meta::CPAN

    my $double_quoted;
    my $single_quoted;

    for my $char (split //, $str) {
        if ($escaped) {
            $buf .= $char;
            $escaped = undef;
            next;
        }

        if ($char eq '\\') {
            if ($single_quoted) {
                $buf .= $char;
            }
            else {
                $escaped = 1;
            }
            next;
        }

        if ($char =~ /\s/) {
            if ($single_quoted || $double_quoted) {
                $buf .= $char;
            }
            else {
                push @argv, $buf if defined $buf;
                undef $buf;
            }
            next;
        }

        if ($char eq '"') {
            if ($single_quoted) {
                $buf .= $char;
                next;
            }
            $double_quoted = !$double_quoted;
            next;
        }

        if ($char eq "'") {
            if ($double_quoted) {
                $buf .= $char;
                next;
            }
            $single_quoted = !$single_quoted;
            next;
        }

        $buf .= $char;
    }
    push @argv, $buf if defined $buf;

    if ($escaped || $single_quoted || $double_quoted) {
        return undef; ## no critic: Subroutines::ProhibitExplicitReturnUndef
    }

    \@argv;
}

# return ($err, $res, $decoded_val)
sub _parse_raw_value {
    my ($self, $val, $needs_res) = @_;

    if ($val =~ /\A!/ && $self->{enable_encoding}) {

        $val =~ s/!(\w+)(\s+)// or return ("Invalid syntax in encoded value");
        my ($enc, $ws1) = ($1, $2);

        my $res; $res = [
            "!$enc", # COL_V_ENCODING
            $ws1, # COL_V_WS1
            $1, # COL_V_VALUE
            $2, # COL_V_WS2
            $3, # COL_V_COMMENT_CHAR
            $4, # COL_V_COMMENT
        ] if $needs_res;

        # canonicalize shorthands
        $enc = "json" if $enc eq 'j';
        $enc = "hex"  if $enc eq 'h';
        $enc = "expr" if $enc eq 'e';

        if ($self->{allow_encodings}) {
            return ("Encoding '$enc' is not in ".
                        "allow_encodings list")
                unless grep {$_ eq $enc} @{$self->{allow_encodings}};
        }
        if ($self->{disallow_encodings}) {
            return ("Encoding '$enc' is in ".
                        "disallow_encodings list")
                if grep {$_ eq $enc} @{$self->{disallow_encodings}};
        }

        if ($enc eq 'json') {

            # XXX imperfect regex for simplicity, comment should not contain
            # "]", '"', or '}' or it will be gobbled up as value by greedy regex
            # quantifier
            $val =~ /\A
                     (".*"|\[.*\]|\{.*\}|\S+)
                     (\s*)
                     (?: ([;#])(.*) )?
                     \z/x or return ("Invalid syntax in JSON-encoded value");
            my $decode_res = $self->_decode_json($val);
            return ($decode_res->[1]) unless $decode_res->[0] == 200;
            return (undef, $res, $decode_res->[2]);

        } elsif ($enc eq 'path' || $enc eq 'paths') {

            my $decode_res = $self->_decode_path_or_paths($val, $enc);
            return ($decode_res->[1]) unless $decode_res->[0] == 200;
            return (undef, $res, $decode_res->[2]);

        } elsif ($enc eq 'hex') {

            $val =~ /\A
                     ([0-9A-Fa-f]*)
                     (\s*)
                     (?: ([;#])(.*) )?
                     \z/x or return ("Invalid syntax in hex-encoded value");