File Coverage

blib/lib/Exporter/Handy/Util.pm

Criterion	Covered	Total	%
statement	70	105	66.6
branch	19	34	55.8
condition	23	70	32.8
subroutine	13	18	72.2
pod	0	2	0.0
total	125	229	54.5

package Exporter::Handy::Util;

# ABSTRACT: Routines useful when exporting symbols thru Exporter and friends
our $VERSION = '1.000002';

use utf8;
use strict;
use warnings;

# Automatically fall back to pure perl for older versions of List::Util (circa Perl version < 5.20)
use List::Util::MaybeXS qw( pairs unpairs uniq );
use Exporter::Extensible -exporter_setup => 1;

export(qw(
    =xtags
    =expand_xtags
));


# Generators for exported functions
sub _generate_xtags {
  my ($exporter, $symbol, $opts) = @_;
  sub {; xtags_($opts // {}, @_ ) } # curried
}

sub _generate_expand_xtags {
  my ($exporter, $symbol, $opts) = @_;
  sub {; expand_xtags_(@_, $opts // { }) } # curried
}




sub xtags_ { # useful for building export tags
  # say STDERR 'xtag ARGS: ' . np(@_);

  my %opt;   %opt  = ( %opt,  %{; shift   } ) while _is_plain_hashref($_[0]);  # merge options given by any leading hash-refs
  my @res;


  for (pairs @_) {
    my ($k ,$v) = @$_;

    if ( ref($v) =~ /^HASH$/ ) {
      push @res, _xtag_group( \%opt, $k => $v );
    } else {
      push @res, _xtag_group( \%opt, '' => { $k => $v } );
    }
  }
  wantarray ? @res : \@res; ## no critic
}

sub _xtag_group {
  # say STDERR '_xtag_group ARGS: ' . np(@_);

  # options may be given by one or more leading hash-refs (that we merge)
  my %opt;  %opt = ( %opt, %{; shift } ) while _is_plain_hashref($_[0]);

  my $group = ( @_ && !ref( $_[0] ) ) ? shift : undef;
  my %items = %{; shift };
     %opt   = ( %opt, %{; delete $items{'%'} // {} } );

  $group    = $group // delete $opt{group} // delete $opt{name} // '';
  $group    =~ s/^([:])//;

  my %subopt= %opt;
  my $sig   = delete $opt{sig} // $1 // '';  # like a sigil... It's typically either ':' or empty string.
  my $sep   = delete $opt{sep} // '_';
  my $nogroup   = delete $opt{nogroup} // 0;

  my @pfx   = _flat( delete $opt{pfx} // ( $group ? "${group}${sep}" : "" ));

  my %tags;
  for my $pfx (@pfx) {
    $pfx = $sig . $pfx if $sig && ($pfx !~ /^\Q$sig\E/);

    for my $k (sort keys %items) {
      my $v  = $items{$k};
      $k =~ s/^\Q$sig\E//;
      my $key = "${pfx}${k}";
      my %subtags = ( ref($v) =~ /^HASH$/ ) ? ( _xtag_group(\%subopt, $key => $v) ) : ( $key => $v);
      %tags = (%tags, %subtags);
    }
  }
  # umbrella entry (that encompasses all subtags)
  if (!$nogroup && defined $group && $group) {
    my $g = $group;
    $g = $sig . $g if $sig && ($g !~ /^\Q$sig\E/);
    $tags{$g} = [
      map {;
        my $item = $_;
        $item = ':' . $_ if defined $_ && $_ && !m/^[:]/;
        $item // ()
      } ( sort keys %tags ) ]
  }

  my @tags = _kv_sort(%tags);  # sort on keys
  wantarray ? @tags : \@tags; ## no critic
}



sub expand_xtags_ {
  local $_;
  my %tags;  %tags = ( %tags, %{; shift } ) while _is_plain_hashref($_[0]);   # tags at start
  my %opt;   %opt  = ( %opt,  %{; pop   } ) while _is_plain_hashref($_[-1]);  # options at the end.

  # Handle special requests given via options
  my @keys = _flat( delete $opt{key} // (), delete $opt{keys} // () );
  for (@keys) {
    if (_is_plain_scalarref($_) and ($$_ =~  /[*]|ALL/i ) ) {
      # A scalar ref indicates special handling!
      # If it deferences to '*' (or 'ALL'), it means "ALL KEYS".
      push @_, values %tags;
      next
    }
    push @_, $tags{$_};
  }
  @_ = uniq(@_);

  my %seen;
  my @res;

  while (@_) {
    $_ = shift;
    next unless defined;
    ref($_) eq 'ARRAY' and do { unshift @_, @$_; next };

    next if exists $seen{$_} && ( $seen{$_} // 0 );
    $seen{$_} = 1;

    m/^([:](.*))$/ and do {
      unshift @_, delete $tags{$1} // (), delete $tags{$2} // ();
      next;
    };
    push @res, $_;
  }
  @res
}


# PRIVATE routines
# ref
sub _is_plain_arrayref  { ref( $_[0] ) eq 'ARRAY'  }
sub _is_plain_hashref   { ref( $_[0] ) eq 'HASH'   }
sub _is_plain_scalarref { ref( $_[0] ) eq 'SCALAR' }
sub _is_plain_scalar    { !ref( $_[0] ) }

# List
sub _flat  { # shamelessly copied from: [List::_flat](https://metacpan.org/pod/List::_flat)
  my @results;

  while (@_) {
    if ( _is_plain_arrayref( my $element = shift @_ ) ) {
        unshift @_, @{$element};
    }
    else {
        push @results, $element;
    }
  }
  return wantarray ? @results : \@results;  ## no critic
}

sub _kv_sort {
  unpairs sort { $a->[0] cmp $b->[0] } pairs(@_)
}

1;

__END__