view release on metacpan or  search on metacpan

lib/Module/Generic/Global.pm  view on Meta::CPAN

    sub STORABLE_thaw { CORE::return( CORE::shift->THAW( @_ ) ); }

    sub THAW
    {
        my( $self, undef, @args ) = @_;
        my( $class, $str );
        if( CORE::scalar( @args ) == 1 && CORE::ref( $args[0] ) eq 'ARRAY' )
        {
            ( $class, $str ) = @{$args[0]};
        }
        else
        {
            $class = CORE::ref( $self ) || $self;
            $str = CORE::shift( @args );
        }
        my $new;
        # Storable pattern requires to modify the object it created rather than returning a new one
        if( CORE::ref( $self ) )
        {
            $$self = $str;
            $new = $self;
        }
        else
        {
            $new = CORE::return( $class->new( $str ) );
        }
        CORE::return( $new );
    }

    sub TO_JSON { CORE::return( ${$_[0]} ); }
}

{
    # NOTE: Module::Generic::Global::Exception
    package
        Module::Generic::Global::Exception;
    BEGIN
    {
        use strict;
        use warnings;
        use vars qw( $VERSION $CALLER_LEVEL $CALLER_INTERNAL );
        use Scalar::Util;
        use Devel::StackTrace;
        use overload (
            '""'    => 'as_string',
            bool    => sub{1},
            fallback => 1,
        );
        $CALLER_LEVEL = 0;
        $CALLER_INTERNAL->{'Module::Generic::Global'}++;
        $CALLER_INTERNAL->{'Module::Generic::Global::Exception'}++;
        our $VERSION = 'v0.1.0';
    };
    use strict;
    use warnings;

    sub new
    {
        my $this = shift( @_ );
        my $class = ref( $this ) || $this;
        my $self = bless( {} => $class );
        my $args = {};
        if( @_ )
        {
            if( Scalar::Util::blessed( $_[0] ) && $_[0]->isa( 'Module::Generic::Exception' ) )
            {
                $args->{object} = shift( @_ );
            }
            elsif( ref( $_[0] ) eq 'HASH' )
            {
                $args  = shift( @_ );
            }
            else
            {
                $args->{message} = join( '', map( ref( $_ ) eq 'CODE' ? $_->() : $_, @_ ) );
            }
        }

        unless( length( $args->{skip_frames} ) )
        {
            # NOTE: Taken from Carp to find the right point in the stack to start from
            no strict 'refs';
            my $caller_func;
            $caller_func = \&{"CORE::GLOBAL::caller"} if( defined( &{"CORE::GLOBAL::caller"} ) );
            my $call_pack = $caller_func ? $caller_func->() : caller();
            ## Check if this is an internal package or a package inheriting from us
            local $CALLER_LEVEL = ( $CALLER_INTERNAL->{ $call_pack } || bless( {} => $call_pack )->isa( 'Module::Generic::Exception' ) ) 
                ? $CALLER_LEVEL 
                : $CALLER_LEVEL + 1;
            my $error_start_frame = sub 
            {
                my $i;
                my $lvl = $CALLER_LEVEL;
                {
                    ++$i;
                    my @caller = $caller_func ? $caller_func->( $i ) : caller( $i );
                    my $pkg = $caller[0];
                    unless( defined( $pkg ) ) 
                    {
                        if( defined( $caller[2] ) ) 
                        {
                            # this can happen when the stash has been deleted
                            # in that case, just assume that it's a reasonable place to
                            # stop (the file and line data will still be intact in any
                            # case) - the only issue is that we can't detect if the
                            # deleted package was internal (so don't do that then)
                            # -doy
                            redo unless( 0 > --$lvl );
                            last;
                        }
                        else 
                        {
                            return(2);
                        }
                    }
                    redo if( $CALLER_INTERNAL->{ $pkg } );
                    redo unless( 0 > --$lvl );
                }
                return( $i - 1 );
            };