package Glitch;

use 5.006;
use strict;
use warnings;
use Data::Dumper;
our %GLITCHES;

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

sub import {
	my $package = caller();
	no strict 'refs';
	*{"${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/ ? "''" :  _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.02

=cut

our $VERSION = '0.02';

=head1 SYNOPSIS

	use Glitch;

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

	...

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

=head1 EXPORT

=head2 glitch

=cut

=head1 AUTHOR

LNATION, C<< <email at lnation.org> >>

=head1 BUGS

Please report any bugs or feature requests to C<bug-glitch at rt.cpan.org>, or through
the web interface at L<https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Glitch>.  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<https://rt.cpan.org/NoAuth/Bugs.html?Dist=Glitch>

=item * CPAN Ratings

L<https://cpanratings.perl.org/d/Glitch>

=item * Search CPAN

L<https://metacpan.org/release/Glitch>

=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
