caller\( results from the CPAN

caller\(

App-SimpleBackuper

view release on metacpan or search on metacpan

local/lib/perl5/Devel/GlobalPhase.pm view on Meta::CPAN

    $global_phase = 'RUN';
  }

  # this is slow and can segfault, so skip it
  if (!_CALLER_CAN_SEGFAULT && $global_phase eq 'RUN' && $^S) {
    # END blocks are FILO so we can't install one to run first.
    # only way to detect END reliably seems to be by using caller.
    # I hate this but it seems to be the best available option.
    # The top two frames will be an eval and the END block.
    my $i = 0;
    $i++ while defined CORE::caller($i + 1);
    if ($i < 1) {
      # there should always be the sub call and an eval frame ($^S is true).
      # this will only happen if we're in END, but the outer frames are broken.
      $global_phase = 'END';
    }
    elsif ($i > 1) {
      my $top = CORE::caller($i);
      my $next = CORE::caller($i - 1);
      if (!$top || !$next) {
        $global_phase = 'END';
      }
      elsif ($top eq 'main' && $next eq 'main') {
        # If we're ENDing due to an exit or die in a sub generated in an eval,
        # these caller calls can cause a segfault.  I can't find a way to detect
        # this.
        my @top = CORE::caller($i);
        my @next = CORE::caller($i - 1);
        if (
          $top[3] eq '(eval)'
          && $next[3] =~ /::END$/
          && $top[2] == $next[2]
          && $top[1] eq $next[1]
        ) {
          $global_phase = 'END';
        }
      }
    }

local/lib/perl5/Devel/GlobalPhase.pm view on Meta::CPAN


  return $global_phase;
}

{
  package # hide
    Devel::GlobalPhase::_Tie;

  sub TIESCALAR { bless \(my $s), $_[0]; }
  sub STORE {
    die sprintf "Modification of a read-only value attempted at %s line %s.\n", (caller(0))[1,2];
  }
  sub FETCH {
    return undef
      if caller eq 'Devel::GlobalDestruction';
    Devel::GlobalPhase::global_phase;
  }
  sub DESTROY {
    my $tied = tied ${^GLOBAL_PHASE};
    if ($tied && $tied == $_[0]) {
      untie ${^GLOBAL_PHASE};

local/lib/perl5/Module/Build/Base.pm view on Meta::CPAN

}
sub log_debug {
  my $self = shift;
  print @_ if ref($self) && $self->debug;
}

sub log_warn {
  # Try to make our call stack invisible
  shift;
  if (@_ and $_[-1] !~ /\n$/) {
    my (undef, $file, $line) = caller();
    warn @_, " at $file line $line.\n";
  } else {
    warn @_;
  }
}


# install paths must be generated when requested to be sure all changes
# to config (from various sources) are included
sub _default_install_paths {

local/lib/perl5/Module/Implementation.pm view on Meta::CPAN

# version.
unless ( exists $Module::Implementation::{VERSION}
    && ${ $Module::Implementation::{VERSION} } ) {

    $Module::Implementation::{VERSION} = \42;
}

my %Implementation;

sub build_loader_sub {
    my $caller = caller();

    return _build_loader( $caller, @_ );
}

sub _build_loader {
    my $package = shift;
    my %args    = @_;

    my @implementations = @{ $args{implementations} };
    my @symbols = @{ $args{symbols} || [] };

local/lib/perl5/Module/Runtime.pm view on Meta::CPAN

	$module_name_rx is_module_name is_valid_module_name check_module_name
	module_notional_filename require_module
	use_module use_package_optimistically
	$top_module_spec_rx $sub_module_spec_rx
	is_module_spec is_valid_module_spec check_module_spec
	compose_module_name
);
my %export_ok = map { ($_ => undef) } @EXPORT_OK;
sub import {
	my $me = shift;
	my $callpkg = caller(0);
	my $errs = "";
	foreach(@_) {
		if(exists $export_ok{$_}) {
			# We would need to do "no strict 'refs'" here
			# if we had enabled strict at file scope.
			if(/\A\$(.*)\z/s) {
				*{$callpkg."::".$1} = \$$1;
			} else {
				*{$callpkg."::".$_} = \&$_;
			}
		} else {
			$errs .= "\"$_\" is not exported by the $me module\n";
		}
	}
	if($errs ne "") {
		die "${errs}Can't continue after import errors ".
			"at @{[(caller(0))[1]]} line @{[(caller(0))[2]]}.\n";
	}
}

# Logic duplicated from Params::Classify.  Duplicating it here avoids
# an extensive and potentially circular dependency graph.
sub _is_string($) {
	my($arg) = @_;
	return defined($arg) && ref(\$arg) eq "SCALAR";
}

local/lib/perl5/Test/Deep/Cmp.pm view on Meta::CPAN

  '""' => \&string,
  fallback => 1,
;

use Scalar::Util ();

sub import
{
  my $pkg = shift;

  my $callpkg = caller();
  if ($callpkg =~ /^Test::Deep::/)
  {
    no strict 'refs';

    push @{$callpkg."::ISA"}, $pkg;
  }
}

sub new
{

local/lib/perl5/Test/Deep/MM.pm view on Meta::CPAN

use strict;
use warnings;

package Test::Deep::MM 1.204;

sub import
{
  my $self = shift;

  my ($pkg) = caller();
  my $mpkg = $pkg."::Methods";
  foreach my $attr (@_)
  {
    if ($attr =~ /^[a-z]/)
    {
      no strict 'refs';
      *{$mpkg."::$attr"} = \&{$attr};
    }
    else
    {

local/lib/perl5/Test/Spec/Mocks.pm view on Meta::CPAN


our %To_Universal = map { $_ => 1 } qw(stubs expects);

#
# use Test::Spec::Mocks ();               # nothing (import never called)
# use Test::Spec::Mocks;                  # stubs,expects=>UNIVERSAL, stub,mock=>caller
# use Test::Spec::Mocks qw(stubs stub);   # stubs=>UNIVERSAL, stub=>caller
#
sub import {
  my $srcpkg = shift;
  my $callpkg = caller(0);
  my @syms = @_ ? @_ : @EXPORT;
  SYMBOL: for my $orig_sym (@syms) {
    no strict 'refs';
    # accept but ignore leading '&', we only export subs
    (my $sym = $orig_sym) =~ s{\A\&}{};
    if (not grep { $_ eq $sym } @EXPORT_OK) {
      Carp::croak("\"$orig_sym\" is not exported by the $srcpkg module");
    }
    my $destpkg = $To_Universal{$sym} ? 'UNIVERSAL' : $callpkg;
    my $src  = join("::", $srcpkg, $sym);

local/lib/perl5/Test/Spec/Mocks.pm view on Meta::CPAN

# Foo->expects("name")                  # empty return value
sub expects {
  if (@_ != 2 || ref($_[1])) {
    Carp::croak "usage: ->expects('foo')";
  }
  _install('Test::Spec::Mocks::Expectation', @_);
}

sub _install {
  my $stub_class = shift;
  my ($caller) = ((caller(1))[3] =~ /.*::(.*)/);

  my $target = shift;
  my @methods;

  # normalize name/value pairs to name/subroutine pairs
  if (@_ > 0 && @_ % 2 == 0) {
    # list of name/value pairs
    while (my ($name,$value) = splice(@_,0,2)) {
      push @methods, { name => $name, value => $value };
    }

local/lib/perl5/Test/Spec/Mocks.pm view on Meta::CPAN

    my $args = shift;
    while (my ($name,$value) = each %$args) {
      push @methods, { name => $name, value => $value };
    }
  }
  elsif (@_ == 1 && !ref($_[0])) {
    # name only
    push @methods, { name => shift };
  }
  else {
    Carp::croak "usage: $caller('foo'), $caller(foo=>'bar') or $caller({foo=>'bar'})";
  }

  my $context = Test::Spec->current_context
    || Carp::croak "Test::Spec::Mocks only works in conjunction with Test::Spec";
  my $retval; # for chaining. last wins.

  for my $method (@methods) {
    my $stub = $stub_class->new({ target => $target, method => $method->{name} });
    $stub->returns($method->{value}) if exists $method->{value};
    $context->on_enter(sub { $stub->setup });

local/lib/perl5/Try/Tiny.pm view on Meta::CPAN

      . ') - perhaps a missing semi-colon before or'
      );
    }
  }

  # FIXME consider using local $SIG{__DIE__} to accumulate all errors. It's
  # not perfect, but we could provide a list of additional errors for
  # $catch->();

  # name the blocks if we have Sub::Name installed
  _subname(caller().'::try {...} ' => $try)
    if _HAS_SUBNAME;

  # set up scope guards to invoke the finally blocks at the end.
  # this should really be a function scope lexical variable instead of
  # file scope + local but that causes issues with perls < 5.20 due to
  # perl rt#119311
  local $_finally_guards{guards} = [
    map Try::Tiny::ScopeGuard->_new($_),
    @finally
  ];

local/lib/perl5/Try/Tiny.pm view on Meta::CPAN

    # no failure, $@ is back to what it was, everything is fine
    return $wantarray ? @ret : $ret[0];
  }
}

sub catch (&;@) {
  my ( $block, @rest ) = @_;

  croak 'Useless bare catch()' unless wantarray;

  _subname(caller().'::catch {...} ' => $block)
    if _HAS_SUBNAME;
  return (
    bless(\$block, 'Try::Tiny::Catch'),
    @rest,
  );
}

sub finally (&;@) {
  my ( $block, @rest ) = @_;

  croak 'Useless bare finally()' unless wantarray;

  _subname(caller().'::finally {...} ' => $block)
    if _HAS_SUBNAME;
  return (
    bless(\$block, 'Try::Tiny::Finally'),
    @rest,
  );
}

{
  package # hide from PAUSE
    Try::Tiny::ScopeGuard;

local/lib/perl5/x86_64-linux-gnu-thread-multi/Compress/Raw/Lzma.pm view on Meta::CPAN

use constant OFF_FIXED      => 3 ;
use constant OFF_FIRST_ONLY => 4 ;
use constant OFF_STICKY     => 5 ;



sub ParseParameters
{
    my $level = shift || 0 ;

    my $sub = (caller($level + 1))[3] ;
    #local $Carp::CarpLevel = 1 ;
    my $p = new Compress::Raw::Lzma::Parameters() ;
    $p->parse(@_)
        or croak "$sub: $p->{Error}" ;

    return $p;
}


sub Compress::Raw::Lzma::Parameters::new

local/lib/perl5/x86_64-linux-gnu-thread-multi/Compress/Raw/Lzma.pm view on Meta::CPAN

            'PresetDict' => [1, 1, Parse_string(), undef],
            'Lc'    => [1, 1, Parse_unsigned(), LZMA_LC_DEFAULT()],
            'Lp'    => [1, 1, Parse_unsigned(), LZMA_LP_DEFAULT()],
            'Pb'    => [1, 1, Parse_unsigned(), LZMA_PB_DEFAULT()],
            'Mode'  => [1, 1, Parse_unsigned(), LZMA_MODE_NORMAL()],
            'Nice'  => [1, 1, Parse_unsigned(), 64],
            'Mf'    => [1, 1, Parse_unsigned(), LZMA_MF_BT4()],
            'Depth' => [1, 1, Parse_unsigned(), 0],
        }, @_) ;

    my $pkg = (caller(1))[3] ;

    my $DictSize = $got->value('DictSize');
    die "Dictsize $DictSize not in range 4KiB - 1536Mib"
        if $DictSize < 1024 * 4 ||
           $DictSize > 1024 * 1024 * 1536 ;

    my $Lc = $got->value('Lc');
    die "Lc $Lc not in range 0-4"
        if $Lc < 0 || $Lc > 4;

local/lib/perl5/x86_64-linux-gnu-thread-multi/Compress/Raw/Lzma.pm view on Meta::CPAN

        if defined $obj;

    $obj;
}

sub Lzma::Filter::Lzma::mkPreset
{
    my $type = shift;

    my $preset = shift;
    my $pkg = (caller(1))[3] ;

    my $obj = Lzma::Filter::Lzma::_mkPreset($type, $preset);

    bless $obj, $pkg
        if defined $obj;

    $obj;
}

@Lzma::Filter::Lzma1::ISA = qw(Lzma::Filter::Lzma);

local/lib/perl5/x86_64-linux-gnu-thread-multi/Compress/Raw/Lzma.pm view on Meta::CPAN

@Lzma::Filter::BCJ::ISA = qw(Lzma::Filter);

sub Lzma::Filter::BCJ::mk
{
    my $type = shift;
    my $got = Compress::Raw::Lzma::ParseParameters(0,
            {
                'Offset' => [1, 1, Parse_unsigned(), 0],
            }, @_) ;

    my $pkg = (caller(1))[3] ;
    my $obj = Lzma::Filter::BCJ::_mk($type, $got->value('Offset')) ;
    bless $obj, $pkg
        if defined $obj;

    $obj;
}

@Lzma::Filter::X86::ISA = qw(Lzma::Filter::BCJ);

sub Lzma::Filter::X86

( run in 0.383 second using v1.01-cache-2.11-cpan-cc502c75498 )