package Safe::Caller;

use strict;
use warnings;

use Carp qw(croak);

our $VERSION = '0.08';

use constant FRAMES => 1;

sub new
{
    my ($self, $frames) = @_;
    $frames ||= FRAMES;

    my $caller = sub {
                          my ($f, $elem) = @_;
                          my $frames = defined $f ? $f : $frames;
                          return (caller($frames + 2))[$elem] || '';
                     };

    # all fields required because we need to maintain backwards compatibility
    my @sets = (['package','pkg'], ['filename', 'file'], 'line', ['subroutine', 'sub'],
                 'hasargs', 'wantarray', 'evaltext', 'is_require', 'hints', 'bitmask');

    my $i = 0; my %map;
    foreach my $set (@sets) {
        foreach my $lookup (ref $set eq 'ARRAY' ? @$set : $set) {
            $map{$lookup} = $i;
        }
        $i++;
    }

    my $accessors = {};
    foreach my $type (keys %map) {
        $accessors->{$type} = sub {
                                       my $frames = shift;
                                       return $caller->($frames, $map{$type})
                                  };
    }
    $accessors->{_frames} = $frames;

    return bless $accessors, ref($self) || $self;
}

sub called_from_package
{
    my ($self, $called_from_package) = @_;
    croak 'usage: $caller->called_from_package(\'PACKAGE\');'
      unless defined $called_from_package;

    return $self->{package}->() eq $called_from_package
      ? 1 : 0;
}

sub called_from_filename
{
    my ($self, $called_from_filename) = @_;
    croak 'usage: $caller->called_from_filename(\'file\');'
      unless defined $called_from_filename;

    return $self->{filename}->() eq $called_from_filename
      ? 1 : 0;
}

sub called_from_line
{
    my ($self, $called_from_line) = @_;
    croak 'usage: $caller->called_from_line(13);'
      unless defined $called_from_line && $called_from_line =~ /^\d+$/;

    return $self->{line}->() eq $called_from_line
      ? 1 : 0;
}

sub called_from_subroutine
{
    my ($self, $called_from_subroutine) = @_;
    croak 'usage: $caller->called_from_subroutine(\'sub\');'
      unless defined $called_from_subroutine;

    return $self->{subroutine}->($self->{_frames} + 1) eq $called_from_subroutine
      ? 1 : 0;
}

# backwards compatibility (deprecated)
*called_from_pkg  = \&called_from_package;
*called_from_file = \&called_from_filename;
*called_from_sub  = \&called_from_subroutine;

1;
__END__

=head1 NAME

Safe::Caller - A nicer interface to the built-in caller()

=head1 SYNOPSIS

 package abc;

 use Safe::Caller;

 $caller = Safe::Caller->new;

 a();

 sub a { b() }

 sub b {
     print $caller->{subroutine}->();
     if ($caller->called_from_subroutine('abc::a')) { # do stuff }
 }

=head1 DESCRIPTION

=head1 CONSTRUCTOR

=head2 new

 $caller = Safe::Caller->new(1);

Supplying how many frames to go back while running L<perlfunc/caller> is optional.
By default (if no suitable value is supplied) 1 will be assumed. The default
will be shared among all method calls (accessors & verification routines);
the accessors may optionally accept a frame as parameter, whereas verification
routines (C<called_from_*()>) don't.

=head1 METHODS

=head2 Accessors

 $caller->{package}->();
 $caller->{filename}->();
 $caller->{line}->();
 $caller->{subroutine}->();
 $caller->{hasargs}->();
 $caller->{wantarray}->();
 $caller->{evaltext}->();
 $caller->{is_require}->();
 $caller->{hints}->();
 $caller->{bitmask}->();

See L<perlfunc/caller> for the values they are supposed to return.

=head2 called_from_package

Checks whether the current sub was called within the appropriate package.

 $caller->called_from_package('main');

Returns 1 on success, 0 on failure.

=head2 called_from_filename

Checks whether the current sub was called within the appropriate filename.

 $caller->called_from_filename('foobar.pl');

Returns 1 on success, 0 on failure.

=head2 called_from_line

Checks whether the current sub was called on the appropriate line.

 $caller->called_from_line(13);

Returns 1 on success, 0 on failure.

=head2 called_from_subroutine

Checks whether the current sub was called by the appropriate subroutine.

 $caller->called_from_subroutine('foo');

Returns 1 on success, 0 on failure.

=head1 SEE ALSO

L<perlfunc/caller>, L<Perl6::Caller>, L<Devel::Caller>, L<Sub::Caller>

=head1 AUTHOR

Steven Schubiger <schubiger@cpan.org>

=head1 LICENSE

This program is free software; you may redistribute it and/or
modify it under the same terms as Perl itself.

See L<http://www.perl.com/perl/misc/Artistic.html>

=cut