—

              
use strict;
package HTML::FormFu::Util;
# ABSTRACT: various utilities
$HTML::FormFu::Util::VERSION = '2.07';
use warnings;
use HTML::FormFu::Constants qw( $SPACE );
use HTML::FormFu::Literal;
use Scalar::Util qw( blessed reftype );
use Readonly;
use Exporter qw/ import /;
use Carp qw/ croak /;
Readonly my $EMPTY_STR => q{};
Readonly my $SPACE     => q{ };
our $LAST_SUB = $EMPTY_STR;
our @EXPORT_OK = qw(
    DEBUG
    DEBUG_PROCESS
    DEBUG_CONSTRAINTS
    DEBUG_CONSTRAINTS_WHEN
    DEBUG_CONSTRAINTS_OTHERS
    debug
    append_xml_attribute
    has_xml_attribute
    remove_xml_attribute
    _parse_args
    require_class
    xml_escape
    literal
    _filter_components
    _get_elements
    process_attrs
    split_name
    _merge_hashes
);
# the empty prototype () means that when false, all debugging calls
# will be optimised out during compilation
sub DEBUG {
    $ENV{HTML_FORMFU_DEBUG} || 0;
}
sub DEBUG_PROCESS () {
    DEBUG
        || $ENV{HTML_FORMFU_DEBUG_PROCESS}
        || 0;
}
sub DEBUG_CONSTRAINTS {
    DEBUG
        || DEBUG_PROCESS
        || $ENV{HTML_FORMFU_DEBUG_CONSTRAINTS}
        || 0;
}
sub DEBUG_CONSTRAINTS_WHEN {
    DEBUG
        || DEBUG_PROCESS
        || $ENV{HTML_FORMFU_DEBUG_CONSTRAINTS}
        || $ENV{HTML_FORMFU_DEBUG_CONSTRAINTS_WHEN}
        || 0;
}
sub DEBUG_CONSTRAINTS_OTHERS {
    DEBUG
        || DEBUG_PROCESS
        || $ENV{HTML_FORMFU_DEBUG_CONSTRAINTS}
        || $ENV{HTML_FORMFU_DEBUG_CONSTRAINTS_OTHERS}
        || 0;
}
sub debug {
    my ($message) = @_;
    my ( undef, undef, undef, $sub ) = caller(1);
    require Data::Dumper;
    warn "\n" if $sub ne $LAST_SUB;
    if ( @_ > 1 ) {
        warn "$sub()\n" if $sub ne $LAST_SUB;
        while (@_) {
            my $key   = shift;
            my $value = shift;
            if ( !defined $value ) {
                $value = "is undef\n";
            }
            elsif ( ref $value ) {
                $value = Data::Dumper::Dumper($value);
                $value =~ s/^\$VAR1 = //;
            }
            else {
                $value = "'$value'\n";
            }
            warn "$key: $value";
        }
    }
    elsif ( ref $message ) {
        warn "$sub()\n" if $sub ne $LAST_SUB;
        $message = Data::Dumper::Dumper($message);
        $message =~ s/^\$VAR1 = /        /;
        warn "$message\n";
    }
    else {
        warn "$sub\n" if $sub ne $LAST_SUB;
        warn "$message\n";
    }
    $LAST_SUB = $sub;
    return;
}
sub _filter_components {
    my ( $args, $components ) = @_;
    for my $name ( keys %$args ) {
        # get_errors() handles this itself
        next if $name eq 'forced';
        my $value;
        @$components = grep {
                   $_->can($name)
                && defined( $value = $_->$name )
                && $value eq $args->{$name}
        } @$components;
    }
    return $components;
}
sub _get_elements {
    my ( $args, $elements ) = @_;
    for my $name ( keys %$args ) {
        my $value;
        next unless defined $args->{$name};
        @$elements = grep {
                   $_->can($name)
                && defined( $value = $_->$name )
                && (
                ref( $args->{$name} ) eq 'Regexp'
                ? $value =~ $args->{$name}
                : $value eq $args->{$name} )
        } @$elements;
    }
    return $elements;
}
sub append_xml_attribute {
    my ( $attrs, $key, $value ) = @_;
    croak '$attrs arg must be a hash reference'
        if ref $attrs ne 'HASH';
    my %dispatcher = _append_subs();
    if ( exists $attrs->{$key} && defined $attrs->{$key} ) {
        my $orig = 'string';
        if ( blessed $attrs->{$key}
            && $attrs->{$key}->isa('HTML::FormFu::Literal') )
        {
            $orig = 'literal';
        }
        my $new = 'string';
        if ( blessed $value
            && $value->isa('HTML::FormFu::Literal') )
        {
            $new = 'literal';
        }
        $attrs->{$key} = $dispatcher{$orig}->{$new}->( $attrs->{$key}, $value );
    }
    else {
        $attrs->{$key} = $value;
    }
    return $attrs;
}
sub _append_subs {
    return (
        literal => {
            string => sub {
                $_[0]->push( xml_escape(" $_[1]") );
                return $_[0];
            },
            literal => sub {
                $_[0]->push(" $_[1]");
                return $_[0];
            },
        },
        string => {
            string => sub {
                $_[0] .= " $_[1]";
                return $_[0];
            },
            literal => sub {
                $_[1]->unshift( xml_escape("$_[0] ") );
                return $_[1];
            },
        },
    );
}
sub has_xml_attribute {
    my ( $attrs, $key, $value ) = @_;
    croak '$attrs arg must be a hash reference'
        if ref $attrs ne 'HASH';
    my %dispatcher = _has_subs();
    if ( exists $attrs->{$key} && defined $attrs->{$key} ) {
        my $orig = 'string';
        if ( blessed $attrs->{$key}
            && $attrs->{$key}->isa('HTML::FormFu::Literal') )
        {
            $orig = 'literal';
        }
        my $new = 'string';
        if ( blessed $value
            && $value->isa('HTML::FormFu::Literal') )
        {
            $new = 'literal';
        }
        return $dispatcher{$orig}->{$new}->( $attrs->{$key}, $value );
    }
    return;
}
sub _has_subs {
    return (
        literal => {
            string => sub {
                my $x = "$_[0]";
                my $y = xml_escape("$_[1]");
                return
                       $x =~ /^\Q$y\E ?/
                    || $x =~ / \Q$y\E /
                    || $x =~ / ?\Q$y\E$/;
            },
            literal => sub {
                my $x = "$_[0]";
                my $y = "$_[1]";
                return
                       $x =~ /^\Q$y\E ?/
                    || $x =~ / \Q$y\E /
                    || $x =~ / ?\Q$y\E$/;
            },
        },
        string => {
            string => sub {
                my ( $x, $y ) = @_;
                return
                       $x =~ /^\Q$y\E ?/
                    || $x =~ / \Q$y\E /
                    || $x =~ / ?\Q$y\E$/;
            },
            literal => sub {
                my $x = xml_escape( $_[0] );
                my $y = "$_[1]";
                return
                       $x =~ /^\Q$y\E ?/
                    || $x =~ / \Q$y\E /
                    || $x =~ / ?\Q$y\E$/;
            },
        },
    );
}
sub remove_xml_attribute {
    my ( $attrs, $key, $value ) = @_;
    croak '$attrs arg must be a hash reference'
        if ref $attrs ne 'HASH';
    my %dispatcher = _remove_subs();
    if ( exists $attrs->{$key} && defined $attrs->{$key} ) {
        my $orig = 'string';
        if ( blessed $attrs->{$key}
            && $attrs->{$key}->isa('HTML::FormFu::Literal') )
        {
            $orig = 'literal';
        }
        my $new = 'string';
        if ( blessed $value
            && $value->isa('HTML::FormFu::Literal') )
        {
            $new = 'literal';
        }
        $attrs->{$key} = $dispatcher{$orig}->{$new}->( $attrs->{$key}, $value );
    }
    return $attrs;
}
sub _remove_subs {
    return (
        literal => {
            string => sub {
                my $x = "$_[0]";
                my $y = xml_escape("$_[1]");
                $x =~ s/^\Q$y\E ?//
                    || $x =~ s/ \Q$y\E / /
                    || $x =~ s/ ?\Q$y\E$//;
                return literal($x);
            },
            literal => sub {
                my $x = "$_[0]";
                my $y = "$_[1]";
                $x =~ s/^\Q$y\E ?//
                    || $x =~ s/ \Q$y\E / /
                    || $x =~ s/ ?\Q$y\E$//;
                return literal($x);
            },
        },
        string => {
            string => sub {
                my ( $x, $y ) = @_;
                $x =~ s/^\Q$y\E ?//
                    || $x =~ s/ \Q$y\E / /
                    || $x =~ s/ ?\Q$y\E$//;
                return $x;
            },
            literal => sub {
                my $x = xml_escape( $_[0] );
                my $y = "$_[1]";
                $x =~ s/^\Q$y\E ?//
                    || $x =~ s/ \Q$y\E / /
                    || $x =~ s/ ?\Q$y\E$//;
                return literal($x);
            },
        },
    );
}
sub _parse_args {
    if ( !@_ ) {
        return;
    }
    elsif ( @_ > 1 ) {
        return @_;
    }
    elsif ( ref $_[0] ) {
        return %{ $_[0] };
    }
    else {
        return ( name => $_[0] );
    }
}
sub require_class {
    my ($class) = @_;
    croak "class argument missing" if !defined $class;
    $class =~ s|::|/|g;
    $class .= ".pm";
    if ( !exists $::INC{$class} ) {
        eval { require $class };
        croak $@ if $@;
    }
    return;
}
sub xml_escape {
    my $val = shift;
    return undef if !defined $val;   ## no critic (ProhibitExplicitReturnUndef);
    if ( ref $val eq 'HASH' ) {
        my %val = %$val;
        while ( my ( $key, $value ) = each %val ) {
            $val{$key} = xml_escape($value);
        }
        return \%val;
    }
    elsif ( ref $val eq 'ARRAY' ) {
        my @val = @$val;
        my @new;
        for my $val (@val) {
            push @new, xml_escape($val);
        }
        return \@new;
    }
    elsif ( ref $val ) {
        return "$val";
    }
    return $val if !length $val;
    $val =~ s/&/&/g;
    $val =~ s/"/"/g;
    $val =~ s/'/'/g;
    $val =~ s/</&lt;/g;
    $val =~ s/>/&gt;/g;
    return $val;
}
sub literal {
    return HTML::FormFu::Literal->new(@_);
}
sub process_attrs {
    my ($attrs) = @_;
    croak 'argument to process_attrs() must be a hashref'
        if reftype($attrs) ne 'HASH';
    my @attribute_parts;
    for my $attribute ( sort keys %$attrs ) {
        my $value
            = defined $attrs->{$attribute}
            ? $attrs->{$attribute}
            : $EMPTY_STR;
        push @attribute_parts, sprintf '%s="%s"', $attribute, $value;
    }
    my $xml = join $SPACE, @attribute_parts;
    if ( length $xml ) {
        $xml = " $xml";
    }
    return $xml;
}
sub split_name {
    my ($name) = @_;
    croak "split_name requires 1 arg" if @_ != 1;
    return if !defined $name;
    if ( $name =~ /^ \w+ \[ /x ) {
        # copied from Catalyst::Plugin::Params::Nested::Expander
        # redistributed under the same terms as Perl
        return grep {defined} (
            $name =~ /
            ^  (\w+)      # root param
            | \[ (\w+) \] # nested
        /gx
        );
    }
    elsif ( $name =~ /\./ ) {
        # Copied from CGI::Expand
        # redistributed under the same terms as Perl
        # m// splits on unescaped '.' chars. Can't fail b/c \G on next
        # non ./ * -> escaped anything -> non ./ *
        $name =~ m/^ ( [^\\\.]* (?: \\(?:.|$) [^\\\.]* )* ) /gx;
        my $first = $1;
        $first =~ s/\\(.)/$1/g;    # remove escaping
        my (@segments) = $name =~
            # . -> ( non ./ * -> escaped anything -> non ./ * )
            m/\G (?:[\.]) ( [^\\\.]* (?: \\(?:.|$) [^\\\.]* )* ) /gx;
        # Escapes removed later, can be used to avoid using as array index
        return ( $first, @segments );
    }
    return ($name);
}
# sub _merge_hashes originally copied from Catalyst::Utils::merge_hashes()
# redistributed under the same terms as Perl
sub _merge_hashes {
    my ( $lefthash, $righthash ) = @_;
    return $lefthash if !defined $righthash || !keys %$righthash;
    my %merged = %$lefthash;
    while ( my ( $key, $right_value ) = each %$righthash ) {
        my $left_value = $lefthash->{$key};
        if ( exists $lefthash->{$key} ) {
            my $is_left_ref = exists $lefthash->{$key}
                && ref $lefthash->{$key} eq 'HASH';
            if ( ref $left_value eq 'HASH' && ref $right_value eq 'ARRAY' ) {
                $merged{$key} = _merge_hash_array( $left_value, $right_value );
            }
            elsif ( ref $left_value eq 'ARRAY' && ref $right_value eq 'HASH' ) {
                $merged{$key} = _merge_array_hash( $left_value, $right_value );
            }
            elsif ( ref $left_value eq 'ARRAY' && ref $right_value eq 'ARRAY' )
            {
                $merged{$key} = _merge_array_array( $left_value, $right_value );
            }
            elsif ( ref $left_value eq 'HASH' && ref $right_value eq 'HASH' ) {
                $merged{$key} = _merge_hashes( $left_value, $right_value );
            }
            else {
                $merged{$key} = $right_value;
            }
        }
        else {
            $merged{$key} = $right_value;
        }
    }
    return \%merged;
}
sub _merge_hash_array {
    my ( $left, $right ) = @_;
    return [ $left, @$right ];
}
sub _merge_array_hash {
    my ( $left, $right ) = @_;
    return [ @$left, $right ];
}
sub _merge_array_array {
    my ( $left, $right ) = @_;
    return [ @$left, @$right ];
}
1;
__END__
HideShow 25 lines of Pod
=pod
=encoding UTF-8
=head1 NAME
HTML::FormFu::Util - various utilities
=head1 VERSION
version 2.07
=head1 AUTHOR
Carl Franks <cpan@fireartist.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2018 by Carl Franks.
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