File Coverage

lib/Unexpected/Functions.pm

Criterion	Covered	Total	%
statement	81	81	100.0
branch	44	44	100.0
condition	21	23	95.6
subroutine	22	22	100.0
pod	11	11	100.0
total	179	181	99.4

package Unexpected::Functions;

use strict;
use warnings;
use parent 'Exporter::Tiny';

use Carp         qw( croak );
use Package::Stash;
use Scalar::Util qw( blessed reftype );
use Sub::Install qw( install_sub );

our @EXPORT_OK = qw( catch_class exception has_exception
                     inflate_message inflate_placeholders is_class_loaded
                     is_one_of_us parse_arg_list throw throw_on_error );

my $Exception_Class = 'Unexpected'; my $Should_Quote = 1;

# Private functions
my $_catch = sub {
   my $block = shift; return ((bless \$block, 'Try::Tiny::Catch'), @_);
};

my $_clone_one_of_us = sub {
   return $_[ 1 ] ? { %{ $_[ 0 ] }, %{ $_[ 1 ] } } : { error => $_[ 0 ] };
};

my $_dereference_code = sub {
   my ($code, @args) = @_;

   $args[ 0 ] and ref $args[ 0 ] eq 'ARRAY' and unshift @args, 'args';

   return { class => $code->(), @args };
};

my $_exception_class_cache = {};

my $_exception_class = sub {
   my $caller = shift;

   exists $_exception_class_cache->{ $caller }
      and defined $_exception_class_cache->{ $caller }
      and return  $_exception_class_cache->{ $caller };

   my $code  = $caller->can( 'EXCEPTION_CLASS' );
   my $class = $code ? $code->() : $Exception_Class;

   return $_exception_class_cache->{ $caller } = $class;
};

my $_match_class = sub {
   my ($e, $ref, $blessed, $does, $key) = @_;

   return !defined $key                        ? !defined $e
        : $key eq '*'                          ? 1
        : $key eq ':str'                       ? !$ref
        : $key eq $ref                         ? 1
        : $blessed && $e->can( 'instance_of' ) ? $e->instance_of( $key )
        : $blessed && $e->$does( $key )        ? 1
                                               : 0;
};

my $_quote_maybe = sub {
   return $Should_Quote ? "'".$_[ 0 ]."'" : $_[ 0 ];
};

my $_gen_checker = sub {
   my @prototable = @_;

   return sub {
      my $e       = shift;
      my $ref     = ref $e;
      my $blessed = blessed $e;
      my $does    = ($blessed && $e->can( 'DOES' )) || 'isa';
      my @table   = @prototable;

      while (my ($key, $value) = splice @table, 0, 2) {
         $_match_class->( $e, $ref, $blessed, $does, $key ) and return $value
      }

      return;
   }
};

# Package methods
sub import {
   my $class       = shift;
   my $global_opts = { $_[ 0 ] && ref $_[ 0 ] eq 'HASH' ? %{+ shift } : () };
   my $ex_class    = delete $global_opts->{exception_class};
   # uncoverable condition false
   my $target      = $global_opts->{into} //= caller;
   my @want        = @_;
   my @args        = ();

   $ex_class or $ex_class = $_exception_class->( $target );

   for my $sym (@want) {
      if ($ex_class->can( 'is_exception' ) and $ex_class->is_exception( $sym )){
         my $code = sub { sub { $sym } };

         install_sub { as => $sym, code => $code, into => $target, };
      }
      else { push @args, $sym }
   }

   $class->SUPER::import( $global_opts, @args );
   return;
}

sub quote_bind_values { # Deprecated. Use third arg in inflate_placeholders defs
   defined $_[ 1 ] and $Should_Quote = !!$_[ 1 ]; return $Should_Quote;
}

# Public functions
sub parse_arg_list (;@) { # Coerce a hash ref from whatever was passed
   my $n = 0; $n++ while (defined $_[ $n ]);

   return (                $n == 0) ? {}
        : (is_one_of_us( $_[ 0 ] )) ? $_clone_one_of_us->( @_ )
        : ( ref $_[ 0 ] eq  'CODE') ? $_dereference_code->( @_ )
        : ( ref $_[ 0 ] eq  'HASH') ? { %{ $_[ 0 ] } }
        : (                $n == 1) ? { error => $_[ 0 ] }
        : ( ref $_[ 1 ] eq 'ARRAY') ? { error => (shift), args => @_ }
        : ( ref $_[ 1 ] eq  'HASH') ? { error => $_[ 0 ], %{ $_[ 1 ] } }
        : (            $n % 2 == 1) ? { error => @_ }
                                    : { @_ };
}

sub catch_class ($@) {
   my $check = $_gen_checker->( @{+ shift }, '*' => sub { die $_[ 0 ] } );

   wantarray or croak 'Useless bare catch_class()';

   return $_catch->( sub { ($check->( $_[ 0 ] ) || return)->( $_[ 0 ] ) }, @_ );
}

sub exception (;@) {
   return $_exception_class->( caller )->caught( @_ );
}

sub has_exception ($;@) {
   my ($name, %args) = @_; my $exception_class = caller;

   return $exception_class->add_exception( $name, \%args );
}

sub inflate_message ($;@) { # Expand positional parameters of the form [_]
   return inflate_placeholders( [ '[?]', '[]' ], @_ );
}

sub inflate_placeholders ($;@) { # Sub visible strings for null and undef
   my $defaults = shift;
   my $msg      = shift;
   my @vals     = map { $defaults->[ 2 ] ? $_ : $_quote_maybe->( $_ ) }
                  # uncoverable condition false
                  map { (length) ? $_ :  $defaults->[ 1 ] }
                  map {            $_ // $defaults->[ 0 ] } @_,
                  map {                  $defaults->[ 0 ] } 0 .. 9;

   $msg =~ s{ \[ _ (\d+) \] }{$vals[ $1 - 1 ]}gmx;
   return $msg;
}

sub is_class_loaded ($) { # Lifted from Class::Load
   my $class = shift; my $stash = Package::Stash->new( $class );

   if ($stash->has_symbol( '$VERSION' )) {
      my $version = ${ $stash->get_symbol( '$VERSION' ) };

      if (defined $version) {
         not ref $version and return 1;
         # Sometimes $VERSION ends up as a reference to undef (weird)
         reftype $version eq 'SCALAR' and defined ${ $version } and return 1;
         blessed $version and return 1; # A version object
      }
   }

   $stash->has_symbol( '@ISA' ) and @{ $stash->get_symbol( '@ISA' ) }
      and return 1;
   # Check for any method
   return $stash->list_all_symbols( 'CODE' ) ? 1 : 0;
}

sub is_one_of_us ($) {
   return $_[ 0 ] && (blessed $_[ 0 ]) && $_[ 0 ]->isa( $Exception_Class );
}

sub throw (;@) {
   $_exception_class->( caller )->throw( @_ );
}

sub throw_on_error (;@) {
   return $_exception_class->( caller )->throw_on_error( @_ );
}

1;

__END__