File Coverage

blib/lib/Util/H2O/More.pm

Criterion	Covered	Total	%
statement	192	204	94.1
branch	41	46	89.1
condition	22	35	62.8
subroutine	33	35	94.2
pod	17	19	89.4
total	305	339	89.9

use strict;
use warnings;

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

our @EXPORT_OK = (qw/baptise opt2h2o h2o o2h d2o o2d o2h2o ini2h2o ini2o h2o2ini HTTPTiny2h2o o2ini Getopt2h2o ddd dddie tr4h2o yaml2h2o yaml2o/);
our $VERSION = q{0.4.3};

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 $autoundef;
    if ( @_ && $_[0] && !ref$_[0] && $_[0]=~/^-autoundef/ ) {
      $autoundef = shift;
    }
    my ( $ARGV_ref, $defaults, @opts ) = @_;
    $defaults //= {};
    if ($autoundef) {
      $defaults->{AUTOLOAD} = sub {
        my $self = shift;
        our $AUTOLOAD;
        ( my $key = $AUTOLOAD ) =~ s/.*:://;
        die qq{Getopt2h2o: Won't set value for non-existing key. Need it? Let the module author know!\n} if @_;
        return undef;
      };
    }
    my $o = h2o -meth, $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{o2h: 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($);

# accepts '-autoundef' flag that will insert all keys/getters to be checked
# i.e., if (not $myref->doesntexist) { ... } rather than if (not exists $myref->{doesntexist}) { ... }
sub d2o(@) {
    my ($autoundef);
    # basically how Util::H2O::h2o does it, if we have more options
    # then we should use the `while` form of this ...
    if ( @_ && $_[0] && !ref$_[0] && $_[0]=~/^-autoundef/ ) {
      $autoundef = shift;
    }
    my $thing = shift;

    my $isa   = ref $thing;

    if ( $isa eq q{ARRAY} ) {
        a2o $thing;
        foreach my $element (@$thing) {
          if ($autoundef) { # 'd2o -autoundef, $hash'
            d2o $autoundef, $element;
          }
          else {
            d2o $element;
          }
        }
    }
    elsif ( $isa eq q{HASH} ) {
        foreach my $keys ( keys %$thing ) {
          if ($autoundef) { # 'd2o -autoundef, $hash'
            d2o $autoundef, $thing->{$keys};
          }
          else {
            d2o $thing->{$keys};
          }
        }
        if ($autoundef) { # 'd2o -autoundef, $hash'
          $thing->{AUTOLOAD} = sub {
            my $self = shift;
            our $AUTOLOAD;
            ( my $key = $AUTOLOAD ) =~ s/.*:://;
            die qq{d2o: Won't set value for non-existing key. Need it? Let the module author know!\n} if @_;
            return undef;
          };
          h2o -meth, $thing;
        }
        else {           # default behavior
          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 undef if $i > $#{$self}; # prevent ARRAY from growing just to get an undef back
      return $self->[$i];
    };
    *{"${a2o_pkg}::get"} = $GET;
    *{"${a2o_pkg}::i"}   = $GET;

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

    # returns value returned by the 'scalar' keyword, alias also to 'count'
    my $SCALAR = sub { my $self = shift; return scalar @$self; };
    *{"${a2o_pkg}::scalar"} = $SCALAR;
    *{"${a2o_pkg}::count"}  = $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 $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 yaml2h2o($) {
    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;
}

# back compat
sub yaml2o($) {
    return yaml2h2o(shift);
}

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

# This method assumes a response HASH reference returned by HTTP::Tiny; so
# it looks for $ref->{content}, and if anything is found there it will attempt
# to turn it into a Perl data structure usin JSON::XS::Maybe::decode_json; it
# them applies "d2o -autoundef" to it; if the JSON decode fails, the error will
# be hidden silently and the original content will be retained in the provided
# response reference (also available via ->content by virtu of h2o being applied).
# To force the JSON decode error to propagate up so that it may be caught, use
# the "-autothrow" option, e.g.;
#   HTTPTiny2h2o -autothrow, $ref_with_bad_JSON; # propagates decode_json exception from "malformed" JSON
#   HTTPTiny2h2o $ref_with_bad_JSON;             # hides bad decode, "->content" accessor created to return original content
#   HTTPTiny2h2o $ref_with_good_JSON;            # h2o applied to $ref, "d2o -autoundef" applied to value of ->{content}
sub HTTPTiny2h2o(@) {
  my $autothrow;
  if ( @_ && $_[0] && !ref$_[0] && $_[0]=~/^-autothrow/ ) {
    $autothrow = shift;
  }
  my $ref = shift;
  if (ref $ref eq q{HASH} and exists $ref->{content}) {
    require JSON::MaybeXS; # tries to load the JSON module you want, (by default, exports decode_json, encode_json)
    h2o $ref, qw/content/;
    if ($ref->content) {
      # allows exception from decode_json to be raised if -autothrow
      # and the JSON is determined to be malformed
      if ($autothrow) {
        # the JSON decode will die on bad JSON
        my $JSON = JSON::MaybeXS::decode_json($ref->content);
        my $content= d2o -autoundef, $JSON;
        $ref->content($content);
      }
      # default is hide any malformed JSON exception, effectively
      # leaving the ->content untouched
      else {
        eval {
          # the JSON decode will die on bad JSON
          my $JSON = JSON::MaybeXS::decode_json($ref->content);
          my $content= d2o -autoundef, $JSON;
          $ref->content($content);
        }
      }
    }
    else {
      my $content= d2o -autoundef, {};
      $ref->content($content);
    }
  }
  else {
    die qq{Provided parameter must be a proper HASH reference returned by HTTP::Tiny that contains a 'content' HASH key.};
  }

  return $ref;
}

1;

__END__