File Coverage

blib/lib/Util/H2O/More.pm

Criterion	Covered	Total	%
statement	141	152	92.7
branch	18	20	90.0
condition	2	5	40.0
subroutine	28	31	90.3
pod	14	17	82.3
total	203	225	90.2

use strict;
use warnings;

package Util::H2O::More;
use parent q/Exporter/;

our $VERSION = q{0.3.1};

our @EXPORT_OK = (qw/baptise opt2h2o h2o o2h d2o o2d o2h2o ini2h2o ini2o h2o2ini o2ini Getopt2h2o ddd dddie tr4h2o yaml2o/);

use Util::H2O ();

use feature 'state';

# quick hack to export h2o, uses proper
# Util::H2O::h2o called with full namespace
sub h2o {
    return Util::H2O::h2o @_;
}

# maintains basically a count to create non-colliding
# unique $pkg names (basically what Util::H2O::h2o does
# if $pkg is not specified using -class
# monatomically increasing uuid
sub _uuid {
    state $uuid = 0;
    return ++$uuid;
}

# non-recursive option
sub baptise ($$@) {
    my ( $ref, $pkg, @default_accessors );
    my $pos0 = shift;

    # check pos0 for '-recurse'
    if ( $pos0 eq q{-recurse} ) {
        ( $ref, $pkg, @default_accessors ) = @_;
    }
    else {
        $ref = $pos0;
        ( $pkg, @default_accessors ) = @_;
    }

    my $self;
    my $real_pkg = sprintf qq{%s::_%s}, $pkg, _uuid;

    # uses -isa to inherit from $pkg; -class to bless with a package name
    # derived from $pkg
    if ( $pos0 eq q{-recurse} ) {
        $self = h2o -recurse, -isa => $pkg, -class => $real_pkg, $ref, @default_accessors;
    }
    else {
        $self = h2o -isa => $pkg, -class => $real_pkg, $ref, @default_accessors;
    }

    return $self;
}

# make keys legal for use as accessor, provides original keys via "__og_keys" accessor
sub tr4h2o($) {
    my $hash_ref    = shift;
    my $new_hashref = {};

    # List::Util::pairmap was not happy being require'd for some reason
    # so iterate and replace keys explicitly; store original key in resulting
    # hashref via __og_keys
    foreach my $og_k ( keys %$hash_ref ) {
        my $k = $og_k;
        $k =~ tr/a-zA-Z0-9/_/c;
        $new_hashref->{$k} = $hash_ref->{$og_k};

        # save old key via __og_keys
        $new_hashref->{__og_keys}->{$k} = $og_k;
    }
    return $new_hashref;
}

# preconditioner for use with Getopt::Long flags; returns just the flag name given
# a list of option descriptors, e.g., qw/option1=s option2=i option3/;

# Getopt to keys
sub opt2h2o(@) {
    my @getopt_def = @_;
    my @flags_only = map { m/([^=|\s]+)/g; $1 } @getopt_def;
    return @flags_only;
}

# wrapper around opt2h2o (yeah!)
sub Getopt2h2o(@) {
    my ( $ARGV_ref, $defaults, @opts ) = @_;
    $defaults //= {};
    my $o = h2o $defaults, opt2h2o(@opts);
    require Getopt::Long;
    Getopt::Long::GetOptionsFromArray( $ARGV_ref, $o, @opts );    # Note, @ARGV is passed by reference
    return $o;
}

# general form of method used to give accessors to Config::Tiny in Util::H2O's
# POD documentation
sub o2h2o($) {
    my $ref = shift;
    return h2o -recurse, { %{$ref} };
}

# more specific helper app that uses Config::Tiny->read and o2h2o to get a config
# object back from an .ini; requries Config::Tiny
sub ini2h2o($) {
    my $filename = shift;
    require Config::Tiny;
    return o2h2o( Config::Tiny->read($filename) );
}

# back compat
sub ini2o($) {
    return ini2h2o(shift);
}

# write out the INI file
sub h2o2ini($$) {
    my ( $config, $filename ) = @_;
    require Config::Tiny;
    return Config::Tiny->new( Util::H2O::o2h $config)->write($filename);
}

# back compat
sub o2ini($$) {
    return h2o2ini( shift, shift );
}

# return a dereferences hash (non-recursive); reverse of `h2o'
sub o2h($) {
    $Util::H2O::_PACKAGE_REGEX = qr/::_[0-9A-Fa-f]+\z/;    # makes internal package name more generic for baptise created references
    my $ref = Util::H2O::o2h @_;
    if ( ref $ref ne q{HASH} ) {
        die qq{Could not fully remove top-level reference. Probably an issue with \$Util::H2O_PACKAGE_REGEX\n};
    }
    return $ref;
}

sub d2o($);    # forward declaration to get rid of "too early" warning
sub a2o($);

sub d2o($) {
    my $thing = shift;
    my $isa   = ref $thing;
    if ( $isa eq q{ARRAY} ) {
        a2o $thing;
        foreach my $element (@$thing) {
            d2o $element;
        }
    }
    elsif ( $isa eq q{HASH} ) {
        foreach my $keys ( keys %$thing ) {
            d2o( $thing->{$keys} );
        }

        # package level wrapper, so this can be monkey patched
        # if so desired, per documentation
        h2o $thing;
    }
    return $thing;
}

# blesses ARRAY ref as a container and gives it some virtual methods
# useful in the context of containing HASH refs that get objectified
# by h2o
sub a2o($) {
    no strict 'refs';

    my $array_ref = shift;

    # uses lexical scop of the 'if' to a bless $array_ref (an ARRAY ref)
    # and assigns to it some virtual methods for making dealing with
    # the "lists of C references easier, as a container

    my $a2o_pkg = sprintf( qq{%s::__a2o_%d::vmethods}, __PACKAGE__, int rand 100_000_000 );    # internal a2o

    bless $array_ref, $a2o_pkg;

    ## add vmethod to wrap around array_refs

    # return item at index INDEX
    my $GET = sub { my ( $self, $i ) = @_; return $self->[$i]; };
    *{"${a2o_pkg}::get"} = $GET;

    # return rereferenced ARRAY
    my $ALL = sub { my $self = shift; return @$self; };
    *{"${a2o_pkg}::all"} = $ALL;

    # returns value returned by the 'scalar' keyword
    my $SCALAR = sub { my $self = shift; return scalar @$self; };
    *{"${a2o_pkg}::scalar"} = $SCALAR;

    # 'push' will apply "d2o" to all elements pushed
    my $PUSH = sub { my ( $self, @i ) = @_; d2o \@i; push @$self, @i; return \@i };
    *{"${a2o_pkg}::push"} = $PUSH;

    # 'pop' intentionally does NOT apply "o2d" to anyarray_ref pop'd
    my $POP = sub { my $self = shift; return pop @$self };
    *{"${a2o_pkg}::pop"} = $POP;

    # 'unshift' will apply "d2o" to all elements unshifted
    my $UNSHIFT = sub { my ( $self, @i ) = @_; d2o \@i; unshift @$self, @i; return \@i };
    *{"${a2o_pkg}::unshift"} = $UNSHIFT;

    # 'shift' intentionally does NOT apply "o2d" to anyarray_ref shift'd
    my $SHIFT = sub { my $self = shift; return shift @$self };
    *{"${a2o_pkg}::shift"} = $SHIFT;

    return $array_ref;
}

# includes internal dereferencing so to be compatible
# with the behavior of Util::H2O::o2h
sub o2d($);    # forward declaration to get rid of "too early" warning

sub o2d($) {
    my $thing = shift;
    return $thing if not $thing;
    my $isa = ref $thing;
    if ( $isa =~ m/^Util::H2O::More::__a2o/ ) {
        my @_thing = @$thing;
        $thing = \@_thing;
        foreach my $element (@$thing) {
            $element = o2d $element;
        }
    }
    elsif ( $isa =~ m/^Util::H2O::_/ ) {
        foreach my $key ( keys %$thing ) {
            $thing->{$key} = o2d $thing->{$key};
        }
        $thing = Util::H2O::o2h $thing;
    }
    return Util::H2O::o2h $thing;
}

# handy, poor man's debug wrappers

sub ddd(@) {
    require Data::Dumper;
    foreach my $ref (@_) {
        print STDERR Data::Dumper::Dumper($ref);
    }
}

sub dddie(@) {
    require Data::Dumper;
    foreach my $ref (@_) {
        print STDERR Data::Dumper::Dumper($ref);
    }
    die qq{died due to use of dddie};
}

# YAML configuration support - may return more than 1 reference
sub yaml2o($) {
    require YAML;
    my $file_or_yaml = shift; # may be a file or a string
    my @yaml         = ();    # yaml can have multiple objects serialized, via ---

    # determine if YAML or file name
    my @lines = split /\n/, $file_or_yaml;

    # if a file, use YAML::LoadFile
    if ( @lines == 1 and -e $file_or_yaml ) {
        @yaml = YAML::LoadFile($file_or_yaml);
    }

    # if not a file, assume YAML string and use YAML::Load
    elsif ($lines[0] eq q{---}) {
        @yaml = YAML::Load($file_or_yaml);
    }

    # die because not supported content $file_or_yaml - it is neither
    else {
        die qq{Provided parameter looks like neither a file name nor a valid YAML snippet.\n};
    }

    # iterate over 1 or more serialized objects that were deserialized
    # from the YAML, applie C to it due to the potential presence
    # of ARRAY references
    my @obs = ();
    foreach my $y (@yaml) {
        push @obs, d2o $y;
    }

    return @obs;
}

# NOTE: no o2yaml, but can add one if somebody needs it ... please file an issue on the tracker (GH these days)

1;

__END__