File Coverage

blib/lib/Lexical/Failure/Objects.pm

Criterion	Covered	Total	%
statement	50	173	28.9
branch	2	2	100.0
condition	1	2	50.0
subroutine	16	77	20.7
pod	5	5	100.0
total	74	259	28.5

package Lexical::Failure::Objects;

use 5.014;
use warnings;
use Hash::Util::FieldHash 'fieldhash';

our $VERSION = '0.000001';

# Be invisible to Carp...
our @CARP_NOT = __PACKAGE__;

# Attribute storage...
fieldhash my %msg_for;
fieldhash my %context_for;
fieldhash my %checked_for;

# Constructor...
sub new {
    my ($class, %option) = @_;
    my $newobj = bless do{ \my $impl }, $class;

    $msg_for{$newobj}     = $option{msg};
    $context_for{$newobj} = $option{context};

    return $newobj;
}

# Utilities for error generation...
sub _croak {
    require Carp;
    Carp::croak(@_);
}

sub _cant_use {
    my ($obj, $as) = @_;
    $as //= q{};

    my (undef, $file, $line, $subname) = @{$context_for{$obj}};
    $checked_for{$obj} = 1;
    _croak("$msg_for{$obj} at $file line $line\nAttempt to use failure returned by $subname" . $as);
}

# How failure objects behave...
use overload (
    # Fail when used as a boolean...
    bool     => sub { my ($self) = @_;  $checked_for{$self} = 1; return;   },
    q[!]     => sub { my ($self) = @_;  $checked_for{$self} = 1; return 1; },

    # Croak when used any other way...
    q[neg]   => sub { my ($self) = @_;  _cant_use($self, " as negative value");       },
    q[~]     => sub { my ($self) = @_;  _cant_use($self, " in bitwise complement");   },
    q[""]    => sub { my ($self) = @_;  _cant_use($self, " as string");               },
    q[0+]    => sub { my ($self) = @_;  _cant_use($self, " as number");               },
    q[qr]    => sub { my ($self) = @_;  _cant_use($self, " as regex");                },
    q[++]    => sub { my ($self) = @_;  _cant_use($self, " in increment");            },
    q[--]    => sub { my ($self) = @_;  _cant_use($self, " in decrement");            },
    q[atan2] => sub { my ($self) = @_;  _cant_use($self, " as argument to atan2");    },
    q[cos]   => sub { my ($self) = @_;  _cant_use($self, " as argument to cos");      },
    q[sin]   => sub { my ($self) = @_;  _cant_use($self, " as argument to sin");      },
    q[exp]   => sub { my ($self) = @_;  _cant_use($self, " as argument to exp");      },
    q[abs]   => sub { my ($self) = @_;  _cant_use($self, " as argument to abs");      },
    q[log]   => sub { my ($self) = @_;  _cant_use($self, " as argument to log");      },
    q[sqrt]  => sub { my ($self) = @_;  _cant_use($self, " as argument to sqrt");     },
    q[int]   => sub { my ($self) = @_;  _cant_use($self, " as argument to int");      },
    q[+]     => sub { my ($self) = @_;  _cant_use($self, " in addition");             },
    q[-]     => sub { my ($self) = @_;  _cant_use($self, " in subtraction");          },
    q[*]     => sub { my ($self) = @_;  _cant_use($self, " in multiplication");       },
    q[/]     => sub { my ($self) = @_;  _cant_use($self, " in division");             },
    q[%]     => sub { my ($self) = @_;  _cant_use($self, " in modulo");               },
    q[**]    => sub { my ($self) = @_;  _cant_use($self, " in exponentiation");       },
    q[<<]    => sub { my ($self) = @_;  _cant_use($self, " in left shift");           },
    q[>>]    => sub { my ($self) = @_;  _cant_use($self, " in right shift");          },
    q[x]     => sub { my ($self) = @_;  _cant_use($self, " in repetition");           },
    q[.]     => sub { my ($self) = @_;  _cant_use($self, " in string concatenation"); },
    q[<>]    => sub { my ($self) = @_;  _cant_use($self, " in <> iterator");          },
    q[-X]    => sub { my ($self) = @_;  _cant_use($self, " in filetest");             },
    q[${}]   => sub { my ($self) = @_;  _cant_use($self, " as scalar reference");     },
    q[@{}]   => sub { my ($self) = @_;  _cant_use($self, " as array reference");      },
    q[%{}]   => sub { my ($self) = @_;  _cant_use($self, " as hash reference");       },
    q[&{}]   => sub { my ($self) = @_;  _cant_use($self, " as subroutine reference"); },
    q[*{}]   => sub { my ($self) = @_;  _cant_use($self, " as typeglob reference");   },
    q[+=]    => sub { my ($self) = @_;  _cant_use($self, " in assignment");           },
    q[-=]    => sub { my ($self) = @_;  _cant_use($self, " in assignment");           },
    q[*=]    => sub { my ($self) = @_;  _cant_use($self, " in assignment");           },
    q[/=]    => sub { my ($self) = @_;  _cant_use($self, " in assignment");           },
    q[%=]    => sub { my ($self) = @_;  _cant_use($self, " in assignment");           },
    q[**=]   => sub { my ($self) = @_;  _cant_use($self, " in assignment");           },
    q[<<=]   => sub { my ($self) = @_;  _cant_use($self, " in assignment");           },
    q[>>=]   => sub { my ($self) = @_;  _cant_use($self, " in assignment");           },
    q[x=]    => sub { my ($self) = @_;  _cant_use($self, " in assignment");           },
    q[.=]    => sub { my ($self) = @_;  _cant_use($self, " in assignment");           },
    q[&=]    => sub { my ($self) = @_;  _cant_use($self, " in assignment");           },
    q[|=]    => sub { my ($self) = @_;  _cant_use($self, " in assignment");           },
    q[^=]    => sub { my ($self) = @_;  _cant_use($self, " in assignment");           },
    q[<]     => sub { my ($self) = @_;  _cant_use($self, " in numeric comparison");   },
    q[<=]    => sub { my ($self) = @_;  _cant_use($self, " in numeric comparison");   },
    q[>]     => sub { my ($self) = @_;  _cant_use($self, " in numeric comparison");   },
    q[>=]    => sub { my ($self) = @_;  _cant_use($self, " in numeric comparison");   },
    q[==]    => sub { my ($self) = @_;  _cant_use($self, " in numeric comparison");   },
    q[!=]    => sub { my ($self) = @_;  _cant_use($self, " in numeric comparison");   },
    q[<=>]   => sub { my ($self) = @_;  _cant_use($self, " in numeric comparison");   },
    q[cmp]   => sub { my ($self) = @_;  _cant_use($self, " in string comparison");    },
    q[lt]    => sub { my ($self) = @_;  _cant_use($self, " in string comparison");    },
    q[le]    => sub { my ($self) = @_;  _cant_use($self, " in string comparison");    },
    q[gt]    => sub { my ($self) = @_;  _cant_use($self, " in string comparison");    },
    q[ge]    => sub { my ($self) = @_;  _cant_use($self, " in string comparison");    },
    q[eq]    => sub { my ($self) = @_;  _cant_use($self, " in string comparison");    },
    q[ne]    => sub { my ($self) = @_;  _cant_use($self, " in string comparison");    },
    q[&]     => sub { my ($self) = @_;  _cant_use($self, " in bitwise and");          },
    q[|]     => sub { my ($self) = @_;  _cant_use($self, " in bitwise or");           },
    q[^]     => sub { my ($self) = @_;  _cant_use($self, " in bitwise xor");          },
    q[~~]    => sub { my ($self) = @_;  _cant_use($self, " in smartmatch");           },
);

# Throw an exception if still unchecked upon destruction...
sub DESTROY {
    my ($self) = @_;

    if (!$checked_for{$self}) {
        $checked_for{$self} = 1;
        say {*STDERR} "$msg_for{$self} at $context_for{$self}[1] line $context_for{$self}[2]\n";
        exit();
    }
}

# Context-enquiry interface...
sub subname { my ($self) = @_; return $context_for{$self}[3]; }
sub line    { my ($self) = @_; return $context_for{$self}[2]; }
sub file    { my ($self) = @_; return $context_for{$self}[1]; }

sub context {
    my ($self) = @_;
    my ($subname, $file, $line) = @{$context_for{$self}}[3,1,2];
    return "call to $subname at $file line $line";
}


1; # Magic true value required at end of module
__END__