File Coverage

blib/lib/Exception/FFI/ErrorCode.pm

Criterion	Covered	Total	%
statement	91	101	90.1
branch	15	20	75.0
condition	4	8	50.0
subroutine	18	20	90.0
pod	1	1	100.0
total	129	150	86.0

package Exception::FFI::ErrorCode 0.02 {

  use warnings;
  use 5.020;
  use constant 1.32 ();
  use experimental qw( signatures postderef );
  use Ref::Util qw( is_plain_arrayref );

  # ABSTRACT: Exception class based on integer error codes common in C code


  my %human_codes;

  sub import ($, %args)
  {
    my $class       = delete $args{class}       || caller;
    my $const_class = delete $args{const_class} || $class;
    my $codes       = delete $args{codes}       || {};

    if(%args) {
      require Carp;
      Carp::croak("Unknown options: @{[ sort keys %args ]}");
    }

    {
      no strict 'refs';
      push @{ "$class\::ISA" }, 'Exception::FFI::ErrorCode::Base';
    }


    foreach my $name (keys $codes->%*)
    {
      my($code, $human) = do {
        my $v = $codes->{$name};
        is_plain_arrayref $v ? @$v : ($v,$name);
      };
      constant->import("$const_class\::$name", $code);
      $human_codes{$class}->{$code} = $human;
    }
  }

  sub detect ($class)
  {
    my $sub;
    if(Carp::Always->can('import'))
    {
      require Sub::Identify;
      $Carp::CarpInternal{"Exception::FFI::ErrorCode::Base"}++;
      $sub = sub {
        [Sub::Identify::get_code_info($SIG{__WARN__})]->[0] eq 'Carp::Always'
      };
    }
    else
    {
      $sub = sub { 0 };
    }
    no warnings 'redefine';
    *Exception::FFI::ErrorCode::Base::_carp_always = $sub;
  }

  __PACKAGE__->detect;

  package Exception::FFI::ErrorCode::Base 0.02 {

    sub _carp_always;

    use Class::Tiny qw( package filename line code trace _longmess );
    use Ref::Util qw( is_blessed_ref );
    use overload
        '""' => sub ($self,@) {
          if(_carp_always)
          {
            return $self->_longmess;
          }
          else
          {
            return $self->as_string . "\n";
          }
        },
        bool => sub { 1 }, fallback => 1;

    sub throw ($proto, @rest)
    {
      my($package, $filename, $line) = caller;

      my $self;
      if(is_blessed_ref $proto)
      {
        $self = $proto;
        $self->package($package);
        $self->filename($filename);
        $self->line($line);
      }
      else
      {
        $self = $proto->new(
          @rest,
          package  => $package,
          filename => $filename,
          line     => $line,
        );
      }
      my $trace = $self->get_stack_trace;
      $self->trace($trace) if $trace;
      $self->_longmess(Carp::longmess($self->strerror)) if _carp_always;
      die $self;
    }

    sub get_stack_trace ($)
    {
      if($ENV{EXCEPTION_FFI_ERROR_CODE_STACK_TRACE})
      {
        require Devel::StackTrace;
        return Devel::StackTrace->new(
          ignore_package => 'Exception::FFI::ErrorCode::Base',
        );
      }
      else
      {
        return undef;
      }
    }

    sub strerror ($self)
    {
      my $code = $self->code;
      $code = 0 unless defined $code;
      my $str = $human_codes{ref $self}->{$code};
      $str = sprintf "%s error code %s", ref $self, $self->code unless defined $str;
      return $str;
    }

    sub as_string ($self)
    {
      sprintf "%s at %s line %s.", $self->strerror, $self->filename, $self->line;
    }
  }
}

1;

__END__