File Coverage

blib/lib/Exception/FFI/ErrorCode.pm

Criterion	Covered	Total	%
statement	62	67	92.5
branch	6	8	75.0
condition	2	6	33.3
subroutine	14	15	93.3
pod			n/a
total	84	96	87.5

package Exception::FFI::ErrorCode 0.01 {

  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 = $args{class} || caller;

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

    my $const_class = $args{const_class} || $class;

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

  package Exception::FFI::ErrorCode::Base 0.01 {

    use Class::Tiny qw( package filename line code );
    use Ref::Util qw( is_blessed_ref );
    use overload
        '""' => sub { shift->as_string },
        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
        );
      }
      die $self;
    }

    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__