File Coverage

blib/lib/CGI/Expand.pm

Criterion	Covered	Total	%
statement	93	94	98.9
branch	37	44	84.0
condition	3	3	100.0
subroutine	15	15	100.0
pod	7	7	100.0
total	155	163	95.0

package CGI::Expand;
$VERSION = '2.05';
use strict;
use warnings;

# NOTE: Exporter is not actually used
our @EXPORT = qw(expand_cgi);
our @EXPORT_OK = qw(expand_hash collapse_hash);
my %is_exported = map { $_ => 1 } @EXPORT, @EXPORT_OK;

use Carp qw(croak carp);

sub import {
    my $from_pkg = shift;
    my $to_pkg = caller;

    if(@_) {
        for my $sub (@_) {
            croak "Can't export symbol $sub" unless $is_exported{$sub};
        }
    } else {
        @_ = @EXPORT;
    }

    _export_curried($from_pkg, $to_pkg, @_);
}

sub _export_curried {
    my $from_pkg = shift;
    my $to_pkg   = shift;

    no strict 'refs';
    for my $sub (@_) {
        # export requested subs with class arg curried
        *{$to_pkg.'::'.$sub} = sub { $from_pkg->$sub(@_) };
        # get inherited implementation with interface backward compatibility
    }
}

sub separator {
    if( defined $CGI::Expand::Separator ) {
        carp '$CGI::Expand::Separator is deprecated'
                        unless $CGI::Expand::BackCompat;
        return $CGI::Expand::Separator;
    }
    return '.';
}

sub max_array {
    if( defined $CGI::Expand::Max_Array ) {
        carp '$CGI::Expand::Max_Array is deprecated'
                        unless $CGI::Expand::BackCompat;
        return $CGI::Expand::Max_Array;
    }
    return 100;
}

sub expand_cgi {
    my $class = shift;
    my $cgi = shift; # CGI or Apache::Request
    my %args;

    # permit multiple values CGI style
    for ($cgi->param) {
        next if (/\.[xy]$/); # img_submit=val & img_submit.x=20 -> clash
        my @vals = $cgi->param($_);
        $args{$_} = @vals > 1 ? \@vals : $vals[0];
    }
    return $class->expand_hash(\%args);
}

sub split_name {
    my $class = shift;
    my $name  = shift;
    my $sep = $class->separator();
    $sep = "\Q$sep";

    # 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 $class = shift;
    my $flat = shift;
    my $deep = {};
    my $sep = $class->separator;

    for my $name (keys %$flat) {

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

        my $box_ref = \$deep->{$first};
        for (@segments) {
            if($class->max_array && /^(0|[1-9]\d*)$/) {
                croak "CGI param array limit exceeded $1 for $name=$_"
                    if($1 >= $class->max_array);
                $$box_ref = [] unless defined $$box_ref;
                croak "CGI 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;
                croak "CGI param clash for $name=$_"
                    unless ref $$box_ref eq 'HASH';
                $box_ref = \($$box_ref->{$_});
            }
        }
        croak "CGI param clash for $name value $flat->{$name}"
            if defined $$box_ref;
        $$box_ref = $flat->{$name};
    }
    return $deep;
}

{

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

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

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

sub _collapse_hash {
    my $class  = shift;
    my $deep  = shift;
    my $flat  = shift;
    # @_ is now segments

    if(! ref $deep) {
        my $name = $class->join_name(@_);
        $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 = $class->separator)) {
                $sep = "\Q$sep";
                $name =~ s/([\\$sep])/\\$1/g
            }
            $class->_collapse_hash($deep->{$_}, $flat, @_, $name);
        }
    } elsif(ref $deep eq 'ARRAY') {
        croak "CGI param array limit exceeded $#$deep for ",
                                            $class->join_name(@_)
                    if($#$deep+1 >= $class->max_array);

        for (0 .. $#$deep) {
            $class->_collapse_hash($deep->[$_], $flat, @_, $_)
                                                if defined $deep->[$_];
        }
    } else {
        croak "Unknown reference type for ",$class->join_name(@_),":",ref $deep;
    }
}

}

1;
__END__