File Coverage

blib/lib/Glitch.pm

Criterion	Covered	Total	%
statement	71	71	100.0
branch	19	28	67.8
condition	9	20	45.0
subroutine	17	20	85.0
pod	1	1	100.0
total	117	140	83.5

package Glitch;
our $VERSION = '0.04';
use 5.006; use strict; use warnings;
use Data::Dumper; use feature qw/state/;
state %GLITCHES;

BEGIN {
        $Data::Dumper::Deparse = 1;
}

sub import {
	my ($pkg, %import) = @_;
	if (keys %import) {
		_build_glitch(
			name => $_,
			%{ $import{$_} },
			map { $_ => '' } ("file", "filepath", "line", "stacktrace", "module")
		) for sort keys %import;
	}
	do {
		no strict 'refs';
		my $package = caller();
		*{"${package}::glitch"} = \&glitch;
	};
}

sub glitch {
	my %options = (
		name => shift,
		_stack(),
		@_
	);

	_build_glitch(%options) if (!$GLITCHES{$options{name}});

	die $GLITCHES{$options{name}}->new(%options);
}

sub _build_glitch {
	my (%options) = @_;
	my $class = sprintf q|%s::%s|, $options{object_name} ||= 'Glitch', $options{name};
	my @methods = map { my $struct = $_ =~ m/(file|filepath|line|stacktrace|module)/ ? "''" :  _stringify_struct($options{$_}); "sub $_ { return \$_[0]->{$_} || $struct; }" } sort keys %options;
	unshift @methods, 'sub new { my $self = shift; return bless {@_}, $self; }';
	push @methods, 'sub stringify { return $_[0]->message . " at " . $_[0]->filepath . " line " . $_[0]->line . "\n"; }';
	my $package = sprintf(q|package %s;
use overload '""' => \&stringify;
%s
1;|, $class, join( "\n", @methods) );
	eval $package;
	die $@ if ($@);
	$GLITCHES{$options{name}} = $class;
	return 1;
}

sub _stringify_struct {
        my ( $struct ) = @_;
        return 'undefined' unless defined $struct;
        $struct = ref $struct ? Dumper $struct : "'$struct'";
        $struct =~ s/\$VAR1 = //;
        $struct =~ s/\s*\n*\s*package Glitch\;|use warnings\;|use strict\;//g;
        $struct =~ s/{\s*\n*/{/;
        $struct =~ s/;$//;
        return $struct;
}

sub _stack {
	my @caller; my $i = 0; my @stack;
	while(@caller = caller($i++)){
		next if $caller[0] eq 'Glitch';
		$stack[$i+1]->{module} = $caller[0];
		$stack[$i+1]->{filepath} = $caller[1];
		$stack[$i+1]->{file} = $1 if $caller[1] =~ /([^\/]+)$/;;
		$stack[$i+1]->{line} = $1 if $caller[2] =~ /(\d+)/;
		$stack[$i]->{sub} = $1 if $caller[3] =~ /([^:]+)$/;
	}
	my $msg = $stack[-1];
	$msg->{stacktrace} = join '->', reverse map {
		my $module = $_->{module} !~ m/^main$/ ? $_->{module} : $_->{file};
		$_->{sub}
			? $module . '::' . $_->{sub} . ':' . $_->{line}
			: $module . ':' . $_->{line}
	} grep {
		$_ && $_->{module} && $_->{line} && $_->{file}
	} @stack;
	delete $msg->{stacktrace} unless $msg->{stacktrace};
	return %{$msg};
}

=head1 NAME

Glitch - Exception Handling.

=head1 VERSION

Version 0.04

=cut

=head1 SYNOPSIS

	package Foo;

	use Glitch;

	sub bar {
		do { ... } or glitch('one', message => 'Create a new glitch error message');

		... later in your code you can then reuse glitch 'one'

		do { ... } or glitch('one');
	}

...

	package Foo;

	use Glitch (
		one => {
			message => 'Create a new glitch error message'
		},
		two => {
			message => 'A different glitch error message',
			fileName => '',
		}
	);

	sub bar {
		eval {
			do { ... } or glitch('one');
			...
			do { ... } or glitch('two', fileName => 'abc');
		};
		if ($@) {
			do { ... } if $@->name eq 'one';
			do { ... } if $@->name eq 'two';
		}
	}

	1;

...

	package Glitches;

	use Glitch (
		one => {
			message => 'Create a new glitch error message'
		},
		two => {
			message => 'A different glitch error message',
			fileName => '',
		}
	);

	1;

	package Foo;

	use Glitch;
	use Glitches;

	sub bar {
		eval {
			do { ... } or glitch('one');
			...
			do { ... } or glitch('two', fileName => 'abc');
		};
		if ($@) {
			if ($@->name eq 'one') { ... }
			elsif ($@->name eq 'two') { ... }
		}
	}

	1;

=head1 EXPORT

=head2 glitch

=cut

=head1 AUTHOR

LNATION, C<<  >>

=head1 BUGS

Please report any bugs or feature requests to C, or through
the web interface at L.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Glitch

You can also look for information at:

=over 4

=item * RT: CPAN's request tracker (report bugs here)

L

=item * CPAN Ratings

L

=item * Search CPAN

L

=back

=head1 ACKNOWLEDGEMENTS

=head1 LICENSE AND COPYRIGHT

This software is Copyright (c) 2022 by LNATION.

This is free software, licensed under:

  The Artistic License 2.0 (GPL Compatible)

=cut

1; # End of Glitch