package Sub::Called;

use warnings;
use strict;

use B;
use Exporter;

our @ISA = qw(Exporter);
our @EXPORT_OK = qw(with_ampersand already_called not_called);

=head1 NAME

Sub::Called - get information about how the subroutine is called

=head1 VERSION

Version 0.03

=cut

our $VERSION = '0.03';

=head1 SYNOPSIS


    use Sub::Called;
    
    sub test {
        if( Sub::Called::with_ampersand() ){
            print "you called this subroutine this way: &test\n",
                  "note that this disables prototypes!\n";
        }
    }


    use Sub::Called 'already_called', 'not_called';
    
    sub user {
        unless (already_called) {   # only gets called once
            My::Fixtures::Users->load;
        }
        ...
    }
    
    sub schema {
        if ( not_called ) {
            # setup schema
        }
        else {
            return $schema;
        }
    }

=head1 EXPORTS

There are no subroutines exported by default, but you can export all subroutines
explicitly

  use Sub::Called qw(with_ampersand already_called not_called);

=head2 C<already_called>

This function must be called from inside a subroutine.  It will return false
if the subroutine has not yet been called.  It will only return false once.

This subroutine is only exported on demand.

=head2 C<not_called>

This function must be called from inside a subroutine.  It returns the
opposite value of C<already_called>.  Aside from this, there is no difference.
You may find aesthetically more pleasing.

This subroutine is only exported on demand.

=head2 C<with_ampersand>

This function must be called from inside a subroutine. It returns 1 if the subroutine
was called with an ampersand (e.g. C<&subroutine()>).

This subroutine is only exported on demand.

=head1 FUNCTIONS

=head2 C<with_ampersand>

=cut

sub with_ampersand {
    
    my $sub  = (caller(2))[3] || "main"; 
    my $line = (caller(1))[2];

    my $func = (caller(1))[3];
    
    my $svref = \&{$sub};
    my $obj   = B::svref_2object( $svref );
    
    my $op      = $sub eq 'main' ? B::main_start() : $obj->START;
    my $is_line = 0;
    my $retval  = 0;
    my $is_gv   = 0;

    my $test = B::main_cv;

    for(; $$op; $op = $op->next ){
        my $name    = $op->name;
        if( $name eq 'nextstate' ){
            $is_line = ( $op->line == $line );
        }
        elsif( $name eq 'gv' ){
           my $stash    = "";
           my $globname = "";

           if( B::class( $op ) eq 'PADOP' ){
               my $sv = (( $test->PADLIST->ARRAY)[1]->ARRAY)[ $op->padix ];
               if( $sv ){
                   my $class = B::class( $sv );
                   if( $class eq 'GV' ){
                       $stash    = $sv->STASH->NAME;
                       $globname = $sv->SAFENAME;
                   }
               }
           }
           else {
              $globname = $op->gv->NAME;
              $stash    = $op->gv->STASH->NAME; 
           }

           my $check = $stash . '::' . $globname;
           $is_gv    = 1 if $check eq $func;
        }
        
        next unless $is_line and $is_gv and $name eq 'entersub';
        
        my $priv = $op->private;

        my $key = 8;
        if( ( $key & $priv) == $key and $priv > $key ){
            $retval = 1;
        }
        last;
    }

    return $retval;
}

=head2 C<already_called>

=cut

my %called;

sub already_called() {
    my ( $package, $filename, $line, $subroutine ) = caller(1);
    my $called = $called{$package}{$subroutine};
    $called{$package}{$subroutine} = 1;
    return $called;
}

=head2 C<not_called>

=cut

sub not_called() {
    my ( $package, $filename, $line, $subroutine ) = caller(1);
    my $called = $called{$package}{$subroutine};
    $called{$package}{$subroutine} = 1;
    return not $called;
}

=head1 LIMITATIONS / TODO

There are limitations and I don't know if I can solve these "problems".
So this section is also named "TODO". If you know a solution for any
of these limitations, please let me know.

=head2 Subroutine References

It seems that there are some problems with subroutine references.

This may not work:

  sub test2 {
      if( Sub::Called::with_ampersand() ){
          die "die hard";
      }
  };
    
  my $sub2 = main->can( 'test2' );
  &$sub2();

=head2 Inside a module

If you call subroutines in a module but outside any subroutine (so
the subroutine calls are executed when the module is loaded), I cannot
give a correct answer ;-)

  package Check;
  
  use strict;
  use warnings;
  use Sub::Called qw(with_ampersand);
  
  &test;
  
  sub test {
      if( with_ampersand() ){
          print "yada yada yada\n";
      }
  }

=head1 AUTHOR

Renee Baecker, C<< <module at renee-baecker.de> >>

Curtis "Ovid" Poe, C<< <ovid at cpan.org> >>

=head1 BUGS

Please report any bugs or feature requests to
C<bug-sub-called at rt.cpan.org>, or through the web interface at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Sub-Called>.
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 Sub::Called

You can also look for information at:

=over 4

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/Sub-Called>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/Sub-Called>

=item * RT: CPAN's request tracker

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Sub-Called>

=item * Search CPAN

L<http://search.cpan.org/dist/Sub-Called>

=back

=head1 ACKNOWLEDGEMENTS

=head1 COPYRIGHT & LICENSE

Copyright 2008 Renee Baecker, Curtis "Ovid" Poe, all rights reserved.

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

=cut

1; # End of Sub::Called