File Coverage

blib/lib/Exception/Stringy.pm

Criterion	Covered	Total	%
statement	101	107	94.3
branch	40	46	86.9
condition	2	3	66.6
subroutine	24	27	88.8
pod	6	8	75.0
total	173	191	90.5

#
# This file is part of Exception-Stringy
#
# This software is Copyright (c) 2014 by Damien Krotkine.
#
# This is free software, licensed under:
#
#   The Artistic License 2.0 (GPL Compatible)
#
# ABSTRACT: a Perl Exceptions module where exceptions are not objects but simple strings.

package Exception::Stringy;
{
  $Exception::Stringy::VERSION = '0.20';
}
use strict;
use warnings;
use 5.8.9;

use Scalar::Util qw(blessed);
use Carp;


our ( $_symbol_throw, $_symbol_rethrow, $_symbol_raise, $_symbol_class,
      $_symbol_isa, $_symbol_fields, $_symbol_field, $_symbol_message,
      $_symbol_error);

my @symbols = qw( throw rethrow raise class isa fields field message error );

# regexp to extract header's type and flags
my $only_header_r = qr/(\[[^]|]+\|[^]]*\|\])/;
my $header_r = qr/\[([^]|]+)(\|([^]]*)\|)\]/;
my $klass_r  = qr/^([_a-zA-Z:][_a-zA-Z0-9:]*)$/;
my $field_name_r = qr/^([_a-zA-Z][_a-zA-Z0-9]*)$/;
my $field_value_r = qr/^([^\034:|]*)$/;
my $field_value_b64_r = qr|^\034([A-Za-z0-9+/=]+)$|;
my $is_b64 = qr|^(\034[A-Za-z0-9+/=]*)$|;

no strict 'refs';
no warnings qw(once);

my %registered;
my %throw_aliases;
my %name_aliases;

use MIME::Base64;

sub _encode {
    defined $_[0]
      or return '';
    $_[0] =~ $field_value_r
      and return $_[0];
    "\034" . encode_base64($_[0], '');
}

sub _decode {
    my ($t) = $_[0] =~ $field_value_b64_r
      or return $_[0];
    decode_base64($t);
}

sub dor ($$) { defined $_[0] ? $_[0] : $_[1] }

sub Fields { return (); }

sub _fields_hashref { +{ map { $_ => 1 } $_[0]->Fields() } }

sub import {
    my ($class, %options) = @_;
    my $caller = caller;

    my $method_prefix = dor($options{method_prefix}, 'x');

    foreach (@symbols) {
        defined ${"${caller}::${method_prefix}$_"}
          and next;
        defined ${"${class}::_symbol_$_"}
          or next;
        *{"${caller}::${method_prefix}$_"} = \${"${class}::_symbol_$_"}
    }

    foreach my $k (keys %throw_aliases) {
        my $v = $throw_aliases{$k};
        $caller->can($k)
          or *{"${caller}::$k"} = sub { $v->throw(@_) };
    }

    foreach my $k (keys %name_aliases) {
        my $v = $name_aliases{$k};
        $caller->can($k)
          or *{"${caller}::$k"} = sub () { $v };
    }
}

sub declare_exceptions {
    my $class = shift;
    my $caller = caller;

    while ( scalar @_ ) {
        my $klass = shift;
        dor($klass, '') =~ $klass_r or _croak(class => $klass);
        my $isa = $class;
        my ($override, @fields);
        if (my $r = ref $_[0] ) {
            $r eq 'HASH' or _croak('exception definition structure' => $r,
                                   'It should be HASH');
            my %h = %{shift()};
            $override = $h{override};
            @fields =
              map { dor($_, '') =~ $field_name_r or _croak(field => $_); $_ }
              @{ dor($h{fields}, []) };
            $h{isa} and $isa = $h{isa};

            if (length(dor( my $throw_alias = $h{throw_alias}, ''))) {
                defined $throw_aliases{$throw_alias}
                  and _croak(throw_alias => $throw_alias, 'It has already been defined');
                $throw_aliases{$throw_alias} = $klass;
            }

            if (length(dor( my $name_alias = $h{name_alias}, ''))) {
                defined $name_aliases{$name_alias}
                  and _croak(name_alias => $name_alias, 'It has already been defined');
                $name_aliases{$name_alias} = $klass;
            }
        }

        ! $override && $registered{$klass}
          and _croak(class => $klass, 'It has already been registered');

        unshift @{"${klass}::ISA"}, $isa;
        @{"${klass}::_internal_fields"} = @fields;
        eval "package $klass; sub Fields { (\$_[0]->SUPER::Fields, \@${klass}::_internal_fields) }";
        $registered{$klass} = 1;
    }

    foreach my $k (keys %throw_aliases) {
        my $v = $throw_aliases{$k};
        $caller->can($k)
          or *{"${caller}::$k"} = sub { $v->throw(@_) };
    }

    foreach my $k (keys %name_aliases) {
        my $v = $name_aliases{$k};
        $caller->can($k)
          or *{"${caller}::$k"} = sub () { $v };
    }

}

sub _croak { croak $_[0] . " '" . dor($_[1], '') . "' is invalid" . ($_[2] ? ". $_[2]" : '') }

# Class methods

sub new {
    my ($class, $message, %fields) = @_;
    $registered{$class} or croak "exception class '$class' has not been registered yet";
    '[' . $class . '|' . join('|',
      map  { $_ . ':' . _encode($fields{$_}) }
      grep { $class->_fields_hashref()->{$_}
             or croak "invalid field '$_', exception class '$class' didn't declare it"
           }
      keys %fields
    ) . '|]' . dor($message, '');
}

sub raise { croak shift->new(@_)}
sub throw { croak shift->new(@_)}

sub registered_fields {
    my ($class) = @_;
    $class->Fields();
}

sub registered_exception_classes { keys %registered }

# fake methods (class methods with exception as first argument)

$_symbol_throw   = sub { croak $_[0] };
$_symbol_rethrow = sub { die $_[0] };
$_symbol_raise   = sub { croak $_[0] };

$_symbol_class = sub {
    my ($class) = $_[0] =~ $header_r
      or _croak(exception => $_[0]);
    $class;
};

$_symbol_isa = sub {
    my $class = blessed($_[0]);
    if ( ! defined $class ) {
        ($class) = $_[0] =~ $header_r
          or return;
    }
    $class->isa($_[1]);
};

$_symbol_fields = sub {
    my ($class, $fields) = $_[0] =~ $header_r
      or _croak(exception => $_[0]);
    map { (split(/:/, $_))[0] } split(/\|/, $fields);
};

$_symbol_field = sub {
    my $f = $_[1];
    my ($class, $fields) = $_[0] =~ $header_r
      or _croak(exception => $_[0]);
    my $regexp = qr/\|$f:(.*?)\|/;
    $class->_fields_hashref()->{$f}
      or _croak(field => $f, "It is unknown for this exception class ('$class')");
    if (@_ < 3) {
        defined (my $value = ($fields =~ $regexp)[0])
          or return;
        return _decode( $value );
    }

    $fields =~ s/$regexp/|/;
    $fields =~ s/^\|\|$/|/;
    my $v = _encode($_[2]);
    my $was_ro = Internals::SvREADONLY($_[0]);
    Internals::SvREADONLY($_[0] => 0);
    $_[0] =~ s/$header_r/[$class$fields$f:$v|]/;
    Internals::SvREADONLY($_[0] => $was_ro);
    return;
};

$_symbol_message = sub {
    if (@_ < 2) {
        my $message = $_[0];
        $message =~ s/$only_header_r//
          or _croak(exception => $_[0]);
        return $message;
    }

    my ($header) = $_[0] =~ $only_header_r
      or _croak(exception => $_[0]);
    my $was_ro = Internals::SvREADONLY($_[0]);
    Internals::SvREADONLY($_[0] => 0);
    $_[0] = "$header$_[1]";
    Internals::SvREADONLY($_[0] => $was_ro);
    return $_[0];
};

$_symbol_error = $_symbol_message;

1;

__END__