view release on metacpan or  search on metacpan

lib/Banal/Mini/Utils.pm  view on Meta::CPAN

    polyvalent

    hash_access
    hash_lookup
    hash_lookup_staged

    inverse_dict
    inverse_mapping

    maybe
    maybe_kv
    peek

    tidy_arrayify
    first_viable
    invoke_first_existing_method

    affixed
    prefixed
    suffixed

    sanitize_env_var_name
    sanitize_subroutine_name
    sanitize_identifier_name
  );

  # Add function aliases with underscore prefixes (single & double)
  my @ok = @EXPORT_OK;
  foreach my $pfx ('_', '__') {
    { no strict 'refs';
      *{ __PACKAGE__ . '::' . $pfx . $_ } = \&{ __PACKAGE__ . '::' . $_ } for @ok ;
    }
    push @EXPORT_OK, ( map {; $pfx . $_ } (@ok) );
  }
}
#say STDERR 'EXPORT_OK : ' . np @EXPORT_OK;



#$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
# UTILITY FUNCTIONS
#$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$

#----------------------------------------------------------
# CLASS / OBJECT related functions
#----------------------------------------------------------

#######################################
sub polyvalent     {  # Helps with the parameter processing of polyvalent (object or class) methods
#######################################
  my $proto     = shift;
  my $self      = blessed $proto ? $proto : $proto->new();
  my $class     = blessed $self;
  wantarray ? ($self, $class, $proto) : $self;
}


#######################################
sub msg(@) {  # Message text builder to be used in error output (warn, die, ...)
#######################################
  my $o = blessed ($_[0]) ? shift : caller();
  state $pfx = eval { $o->_msg_pfx(@_) } // '';
  join ('', $pfx, @_, "\n")
}


#..........................................................
# STRING/TEXT processing functions
#..........................................................

sub prefixed ($@)  {
  my %opts = %{ ref ($_[0]) eq 'HASH' ? shift : +{ prefix => shift} };
  affixed(\%opts, @_ )
}

sub suffixed ($@)  {
  my %opts = %{ ref ($_[0]) eq 'HASH' ? shift : +{ suffix => shift} };
  affixed(\%opts, @_ )
}

sub affixed ($@)  {
    my %opts = %{ ref ($_[0]) eq 'HASH' ? shift : +{} };
    my $pfx  = exists $opts{prefix} ? ( $opts{prefix} // '') : '';
    my $sfx  = exists $opts{suffix} ? ( $opts{suffix} // '') : '';
    map {; $pfx . $_ . $sfx } @_
}

#&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
sub sanitize_env_var_name    (;$) { &sanitize_identifier_name  }
sub sanitize_subroutine_name (;$) { &sanitize_identifier_name  }
sub sanitize_identifier_name (;$) {
#&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
  # cleanse (sanitize) the name by replacing non-alphanumeric chars with underscores.
  my $name = (@_) ? shift : $_;    # If no argument is given, use the default SCALAR variable as our argument.

  $name  =~ s/[^_A-Za-z0-9]/_/g;
  return $name;
}


#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# HASH related functions
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

#&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
sub peek     {
#&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
  my ($h, $keys)   = @_;
  my @keys = tidy_arrayify($keys);
  my $v;

  foreach my $key (@keys) {
    $v = exists $h->{$key} ? $h->{$key} : undef;
    return $v if defined($v);
  }

  # Allow falling back to a set of defaults
  # In scalar context, the first one defined wins.
  # In list context, we return a list that contains all of the defined results
  wantarray ? ( grep { defined } @_ ) : first { defined } @_;
}

lib/Banal/Mini/Utils.pm  view on Meta::CPAN

  return $res;
}




#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# ARRAY & LIST related functions
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

######################################
sub tidy_arrayify(;@)  { local $_;  my @res = ( grep { defined $_ } ( uniq( arrayify( @_) ))) }
#######################################

#=begin STOLEN_FROM_List_MoreUtils
# ------------------------------------------------------
# TAU:  The two routines, as well as the comment about 'leaks' were stolen from C<List::MoreUtils>
#       The only thing I did was privatizing names and turning 'flatten' into a proper subroutine (instead of a scalar CODE closure)
#       That allowed me to get rid of a warning.
# ------------------------------------------------------
# "leaks" when lexically hidden in arrayify.
# sub flatten   { map { (ref $_ and ("ARRAY" eq ref $_ or overload::Method($_, '@{}'))) ? (flatten(@{$_})) : ($_) } @_; }
# sub arrayify  { map { flatten($_) } @_; }
# #=cut


#&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
sub first_viable (&@) {
#&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
  my  $f    = shift;  # CODE BLOCK or subroutine ref. A closure is OK, too.
  my  @e    = ();
  local $_;

  #local $@; # so that we don't mess up caller's eval/error handling.
  eval { 1 };   # resets $@ to whatever perl considers to be 'success';

  # This part, as well as the general flow, is copied shamelessly from the 'first()' function in C<List::Util::PP>.
  unless ( length ref $f && eval { $f = \&$f; 1 } ) {
    require Carp;
    Carp::croak("Not a subroutine reference");
  }

  # Return the result of the first viable evaluation (i.e. first one that doesn't die on us, for whatever reason )
  foreach ( @_) {
    my ($item) = ($_);

    if (wantarray)  {  my @v = ( eval { $f->() } );  return @v unless $@;   }
    else            {  my $v =   eval { $f->() }  ;  return $v unless $@;   }

    # No luck. Save the error, for an eventual error stack output if we die.
    push @e, {
        item => $item, err => $@,
        msg=> "Failed to invoke CODE BLOCK on item '$item', with the error : '$@'\n",
      };
  }

  # NO LUCK with any invocation.
  # At this point, '$@' would normally be set to a true value by the last failed eval.
  if (@e) {
    my @emsg = map { $_->{msg} } @e;
    my $name = (caller(0))[3];  # The name of this particular subroutine.
    croak "$name : Failed to sucessfully invoke any of the given code blocks!\n"
      . "Here's the list of all errors:\n\n @emsg"
  }
  return;
}

#&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
sub invoke_first_existing_method {
#&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
  my  $o        = shift;
  my  @methods  = arrayify(@_);
  my  @args     = ();

  first_viable { $o->$_(@args) } @methods;
}




1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Banal::Mini::Utils - Provide several MUNGER functions that may be use in conjunction with C<MooseX::MungeHas>.

=head1 VERSION

version 0.002

=head1 SUPPORT

Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=Banal-Mini-Utils>
(or L<bug-Banal-Mini-Utils@rt.cpan.org|mailto:bug-Banal-Mini-Utils@rt.cpan.org>).

I am also usually active on irc, as 'ether' at C<irc.perl.org>.

=head1 AUTHOR

Tabulo <tabulo@cpan.org>

=head1 CONTRIBUTOR

=for stopwords Ayhan

Ayhan <dev@tabulo.net>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2018 by Tabulo.

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