File Coverage

blib/lib/Util/H2O/More.pm

Criterion	Covered	Total	%
statement	98	108	90.7
branch	12	16	75.0
condition			n/a
subroutine	20	21	95.2
pod	6	6	100.0
total	136	151	90.0

use strict;
use warnings;

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

our $VERSION = q{0.1};

our @EXPORT_OK = (qw/baptise opt2h2o h2o o2h h3o o3h/);

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;
}

# 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/;

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

# return a dereferences hash (non-recursive); reverse of `h2o'
sub o2h($) {

    # makes internal package name more generic for baptise created references
    $Util::H2O::_PACKAGE_REGEX = qr/::_[0-9A-Fa-f]+\z/;
    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;
}

# traverses a all ARRAY and HASH references in a data structure reference,
# looking for HASH references to bless using h2o; basically it's C
# on performance enhancing drugs

## Notes on implementation
# * Interface - should accept all things h2o does [what about default accessors?]
# * All hash refs should get accessors (what about default accessors?)
# * all arrays to get an vmethod that returns all elements in it
# * anything not ARRAY or HASH should be untouched

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

sub h3o($) {
    my $thing = shift;
    my $isa   = ref $thing;
    if ( $isa eq q{ARRAY} ) {

        # uses lexical scop of the 'if' to a bless $thing (an ARRAY ref)
        # and assigns to it some virtual methods for making dealing with
        # the "lists of C references easier, as a container
        no strict 'refs';
        my $a2o_pkg = sprintf( qq{%s::_a2o_%d}, __PACKAGE__, int rand 100_000 );    # internal a2o
        bless $thing, $a2o_pkg;

        # add vmethod to wrap around things
        my $GET    = sub { my ( $self, $i ) = @_; return $self->[$i]; };
        my $ALL    = sub { my $self = shift; return @$self; };
        my $SCALAR = sub { my $self = shift; return scalar @$self; };

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

        # 'pop' intentionally does NOT apply "o3h" to anything pop'd
        my $POP = sub { my $self = shift; return pop @$self };

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

        # 'shift' intentionally does NOT apply "o3h" to anything shift'd
        my $SHIFT = sub { my $self = shift; return shift @$self };
        *{"${a2o_pkg}::get"}     = $GET;
        *{"${a2o_pkg}::all"}     = $ALL;
        *{"${a2o_pkg}::scalar"}  = $SCALAR;
        *{"${a2o_pkg}::push"}    = $PUSH;
        *{"${a2o_pkg}::pop"}     = $POP;
        *{"${a2o_pkg}::unshift"} = $UNSHIFT;
        *{"${a2o_pkg}::shift"}   = $SHIFT;

        foreach my $element (@$thing) {
            h3o $element;
        }
    }
    elsif ( $isa eq q{HASH} ) {
        foreach my $keys ( keys %$thing ) {
            h3o( $thing->{$keys} );
        }

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

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

sub o3h($) {
    my $thing = shift;
    no warnings 'prototype';
    return $thing if not $thing;
    my $isa = ref $thing;
    if ( $isa eq q{ARRAY} ) {
        my @_thing = @$thing;
        foreach my $element (@_thing) {
            $element = o3h($element);
        }
    }
    elsif ( $isa eq q{HASH} ) {
        my %_thing = %$thing;
        foreach my $key ( keys %_thing ) {
            $_thing{$key} = o3h( $_thing{$key} );
        }
        $thing = Util::H2O::o2h \%_thing;
    }
    return Util::H2O::o2h $thing;
}

1;

__END__