File Coverage

blib/lib/HTML/FormHandler/Params.pm

Criterion	Covered	Total	%
statement	39	62	62.9
branch	14	30	46.6
condition	2	6	33.3
subroutine	5	8	62.5
pod	0	4	0.0
total	60	110	54.5

package    # hide from Pause
    HTML::FormHandler::Params;
# ABSTRACT: params handling

use Moose;
use Carp;

has 'separator' => ( isa => 'Str', is => 'rw', default => '.' );

sub split_name {
    my ( $self, $name, $sep ) = @_;

    $sep ||= $self->separator;
    $sep = "\Q$sep";

    if ( $sep eq '[]' ) {
        return grep { defined } (
            $name =~ /
                  ^ (\w+)        # root param
                  | \[ (\w+) \]  # nested
                  /gx
        );
    }

    # These next two regexes are the escaping aware equivalent
    # to the following:
    # my ($first, @segments) = split(/\./, $name, -1);

    # m// splits on unescaped '.' chars. Can't fail b/c \G on next
    # non ./ * -> escaped anything -> non ./ *
    $name =~ m/^ ( [^\\$sep]* (?: \\(?:.|$) [^\\$sep]* )* ) /gx;
    my $first = $1;
    $first =~ s/\\(.)/$1/g;    # remove escaping

    my (@segments) = $name =~
        # . -> ( non ./ * -> escaped anything -> non ./ * )
        m/\G (?:[$sep]) ( [^\\$sep]* (?: \\(?:.|$) [^\\$sep]* )* ) /gx;
    # Escapes removed later, can be used to avoid using as array index

    return ( $first, @segments );
}

sub expand_hash {
    my ( $self, $flat, $sep ) = @_;

    my $deep = {};
    $sep ||= $self->separator;

    for my $name ( keys %$flat ) {

        my ( $first, @segments ) = $self->split_name( $name, $sep );

        my $box_ref = \$deep->{$first};
        for (@segments) {
            if ( /^(0|[1-9]\d*)$/ ) {
                $$box_ref = [] unless defined $$box_ref;
                croak "HFH: param clash for $name=$_"
                    unless ref $$box_ref eq 'ARRAY';
                $box_ref = \( $$box_ref->[$1] );
            }
            else {
                s/\\(.)/$1/g if $sep;    # remove escaping
                $$box_ref = {} unless defined $$box_ref;
                $$box_ref = { '' => $$box_ref } if ( !ref $$box_ref );
                croak "HFH: param clash for $name=$_"
                    unless ref $$box_ref eq 'HASH';
                $box_ref = \( $$box_ref->{$_} );
            }
        }
        if ( defined $$box_ref ) {
            croak "HFH: param clash for $name value $flat->{$name}"
                if ref $$box_ref ne 'HASH';
            $box_ref = \( $$box_ref->{''} );
        }
        $$box_ref = $flat->{$name};
    }
    return $deep;
}

sub collapse_hash {
    my $self = shift;
    my $deep = shift;
    my $flat = {};

    $self->_collapse_hash( $deep, $flat, () );
    return $flat;
}

sub join_name {
    my ( $self, @array ) = @_;
    my $sep = substr( $self->separator, 0, 1 );
    return join $sep, @array;
}

sub _collapse_hash {
    my ( $self, $deep, $flat, @segments ) = @_;

    if ( !ref $deep ) {
        my $name = $self->join_name(@segments);
        $flat->{$name} = $deep;
    }
    elsif ( ref $deep eq 'HASH' ) {
        for ( keys %$deep ) {
            # escape \ and separator chars (once only, at this level)
            my $name = $_;
            if ( defined( my $sep = $self->separator ) ) {
                $sep = "\Q$sep";
                $name =~ s/([\\$sep])/\\$1/g;
            }
            $self->_collapse_hash( $deep->{$_}, $flat, @segments, $name );
        }
    }
    elsif ( ref $deep eq 'ARRAY' ) {
        for ( 0 .. $#$deep ) {
            $self->_collapse_hash( $deep->[$_], $flat, @segments, $_ )
                if defined $deep->[$_];
        }
    }
    else {
        croak "Unknown reference type for ", $self->join_name(@segments), ":", ref $deep;
    }
}

__PACKAGE__->meta->make_immutable;
use namespace::autoclean;
1;

__END__

=pod

=encoding UTF-8

=head1 NAME

HTML::FormHandler::Params - params handling

=head1 VERSION

version 0.40067

=head1 AUTHOR

FormHandler Contributors - see HTML::FormHandler

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2016 by Gerda Shank.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut