view release on metacpan or search on metacpan
lib/Apache/Voodoo.pm view on Meta::CPAN
# Database Interaction
################################################################################
# deprecated, dbi uses exceptions now.
sub db_error {
my @caller = caller(1);
my $query = $DBI::lasth->{'Statement'};
$query = join("\n", map { $_ =~ s/^\s*//; $_} split(/\n/,$query));
my $errstr = "\n";
view release on metacpan or search on metacpan
return undef
};
my $_enabled_error_handler = sub {
my ($self, $value) = @_;
my @caller = caller();
$caller[0] =~ s/.+://;
$caller[2] =~ s/.+://;
my $id = "($caller[0]:$caller[2])";
$value = join(':', $id, $value);
$_dbl->log_event($value) if ($_dbl);
my $_fatal_error_handler = sub {
my ($self, $value) = @_;
die "_raise_exception called without object. Always call _raise_exception as a method, not a subroutine."
unless UNIVERSAL::isa($self, 'Apache::Wyrd');
my @caller = caller();
$caller[0] =~ s/.+://;
$caller[2] =~ s/.+://;
my $processing = undef;
$processing = $self->dbl->self_path if ($_dbl);
$processing ||= "{COULD NOT PROCESS PATH TO PERL OBJECT}";#assume self_path could be erroneously null
#set always returns the value it is set to (no reason, may be useful for catching
#errors down the road).
return $newval;
} elsif (ref($self) && &UNIVERSAL::can($self, '_raise_exception')) {
$self->_error("Dead because of \$self->" . $AUTOLOAD . " being called. You probably need to define this function/attribute or import it from somewhere else.");
return $self->_raise_exception("Undefined variable was accessed in AUTOLOAD: $AUTOLOAD at " . join(':', caller()));
}
}
die ("Dead because an undefined subroutine in a non-method call was executed: " . $AUTOLOAD . "() at " . join(':', caller()) . ". You probably need to correct/define this subroutine or import it from somewhere else. This error was reported by Wyrd...
}
=pod
Note: methods are described I<(format: (returned value/s) C<methodname>
view release on metacpan or search on metacpan
lib/Apache/XPointer.pm view on Meta::CPAN
sub _nometh {
my $pkg = shift;
my $apache = shift;
my $caller = (caller(1))[3];
$caller =~ s/.*:://;
$apache->log()->error(sprintf("package %s does not define a '%s' method",
$pkg,$caller));
return 0;
view release on metacpan or search on metacpan
inc/Module/AutoInstall.pm view on Meta::CPAN
chdir $cwd;
# import to main::
no strict 'refs';
*{'main::WriteMakefile'} = \&Write if caller(0) eq 'main';
}
# Check to see if we are currently running under CPAN.pm and/or CPANPLUS;
# if we are, then we simply let it taking care of our dependencies
sub _check_lock {
view release on metacpan or search on metacpan
lib/Apache2/API.pm view on Meta::CPAN
use warnings;
sub import
{
my( $this, @arguments ) = @_ ;
my $class = CORE::caller();
# my $code = qq{package ${class}; use Apache2::Const -compile => qw( @arguments );};
# print( "Evaluating -> $code\n" );
# eval( $code );
# print( "\$@ -> $@\n" );
lib/Apache2/API.pm view on Meta::CPAN
$msg->{code} ||= Apache2::Const::HTTP_INTERNAL_SERVER_ERROR;
$self->error( $msg ) if( $msg->{message} );
CORE::delete( $msg->{skip_frames} );
# So it gets logged or displayed on terminal
my( $pack, $file, $line ) = caller;
my $sub_str = ( caller(1) )[3];
my $sub = CORE::index( $sub_str, '::' ) != -1 ? substr( $sub_str, rindex( $sub_str, '::' ) + 2 ) : $sub_str;
# Now we tweak the hash to send it to the client
$msg->{message} = CORE::delete( $msg->{public_message} ) || 'An unexpected server error has occurred';
# Give it a chance to be localised
$msg->{message} = $self->gettext( $msg->{message} );
lib/Apache2/API.pm view on Meta::CPAN
$ref->{error}->{code} = $code if( !CORE::length( $ref->{error}->{code} ) );
CORE::delete( $ref->{code} ) if( CORE::length( $ref->{code} ) );
}
my $frameOffset = 0;
my $sub = ( caller( $frameOffset + 1 ) )[3];
$frameOffset++ if( substr( $sub, rindex( $sub, '::' ) + 2 ) eq 'reply' );
my( $pack, $file, $line ) = caller( $frameOffset );
$sub = ( caller( $frameOffset + 1 ) )[3];
# Without an Access-Control-Allow-Origin field, this would trigger an erro ron the web browser
# So we make sure it is there if not set already
unless( $self->response->headers->get( 'Access-Control-Allow-Origin' ) )
{
$self->response->headers->set( 'Access-Control-Allow-Origin' => '*' );
lib/Apache2/API.pm view on Meta::CPAN
sub warn
{
my $self = shift( @_ );
my $txt = join( '', map( ref( $_ ) eq 'CODE' ? $_->() : $_, @_ ) );
my( $pkg, $file, $line, @otherInfo ) = caller;
my $sub = ( caller( 1 ) )[3];
my $sub2 = substr( $sub, rindex( $sub, '::' ) + 2 );
my $trace = $self->_get_stack_trace();
my $frame = $trace->next_frame;
my $frame2 = $trace->next_frame;
my $r = $self->apache_request;
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
#####################################################################
# Utility Functions
sub _caller {
my $depth = 0;
my $call = caller($depth);
while ( $call eq __PACKAGE__ ) {
$depth++;
$call = caller($depth);
}
return $call;
}
sub _read {
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
#####################################################################
# Common Utility Functions
sub _caller {
my $depth = 0;
my $call = caller($depth);
while ( $call eq __PACKAGE__ ) {
$depth++;
$call = caller($depth);
}
return $call;
}
# Done in evals to avoid confusing Perl::MinimumVersion
view release on metacpan or search on metacpan
lib/Apache2/AuthCAS.pm view on Meta::CPAN
$logLevel = $LOG_ERROR if (!$logLevel);
if ($self->casConfig("LogLevel") >= $logLevel)
{
my $sub = (caller(1))[3];
$sub =~ /(\w+)$/;
$self->{'request'}->log->alert("CAS($$): $1: $msg");
}
}
view release on metacpan or search on metacpan
inc/Module/AutoInstall.pm view on Meta::CPAN
chdir $cwd;
# import to main::
no strict 'refs';
*{'main::WriteMakefile'} = \&Write if caller(0) eq 'main';
}
# Check to see if we are currently running under CPAN.pm and/or CPANPLUS;
# if we are, then we simply let it taking care of our dependencies
sub _check_lock {
view release on metacpan or search on metacpan
lib/Apache2/AuthCookieDBI.pm view on Meta::CPAN
sub _dbi_connect {
my ( $class, $r, $config_hash ) = @_;
Carp::confess('Failed to pass Apache request object') if not $r;
my ( $pkg, $file, $line, $sub ) = caller(1);
my $info_message = "${class}\t_dbi_connect called in $sub at line $line";
$class->logger( $r, Apache2::Const::LOG_INFO, $info_message, undef,
LOG_TYPE_SYSTEM, $r->uri );
my %c = $config_hash ? %$config_hash : $class->_dbi_config_vars($r);
lib/Apache2/AuthCookieDBI.pm view on Meta::CPAN
Apache2::Const::LOG_ALERT => 'alert',
Apache2::Const::LOG_EMERG => 'emerg',
);
my $log_method = $apache_log_method_for_level{$log_level};
if ( !$log_method ) {
my ( $pkg, $file, $line, $sub ) = caller(1);
$r->log_error(
"Unknown log_level '$log_level' passed to logger() from $sub at line $line in $file "
);
$log_method = 'log_error';
}
view release on metacpan or search on metacpan
inc/Module/AutoInstall.pm view on Meta::CPAN
chdir $cwd;
# import to main::
no strict 'refs';
*{'main::WriteMakefile'} = \&Write if caller(0) eq 'main';
return (@Existing, @Missing);
}
sub _running_under {
view release on metacpan or search on metacpan
t/lib/Apache2/Controller/Test/OpenIDServer.pm view on Meta::CPAN
# try overriding signal handlers
$HTTP::Server::Simple::SIG{ALRM} = sub {
my @args = @_;
# warn "# received timeout alarm, temminating $$\n";
# warn "# args are (".join(',',@args).")\n";
# warn "# (caller is ".caller().")\n";
# die "# terminating on alarm\n";
exit(0);
};
$HTTP::Server::Simple::SIG{INT} = sub {
t/lib/Apache2/Controller/Test/OpenIDServer.pm view on Meta::CPAN
# we overload run so we can set the appropriate alarm to die
sub run {
my ($self, @args) = @_;
# warn "# setting alarm in pid $$ for 45 seconds...\n";
# warn "# caller is ".caller()."\n";
alarm(45);
# warn "# calling super run\n";
return $self->HTTP::Server::Simple::run(@args);
}
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
#####################################################################
# Utility Functions
sub _caller {
my $depth = 0;
my $call = caller($depth);
while ( $call eq __PACKAGE__ ) {
$depth++;
$call = caller($depth);
}
return $call;
}
sub _read {
view release on metacpan or search on metacpan
lib/Apache2/FileHash.pm view on Meta::CPAN
{
my ($r, $filename) = @_;
my (undef, undef, $suffix) = &File::Basename::fileparse($filename, qr/\.(.*?)$/);
my ($package) = (caller(0))[0];
$package =~ s#^.*:##;
my $orig_filename = $filename;
$filename =~ s/$suffix$//;
view release on metacpan or search on metacpan
inc/Module/AutoInstall.pm view on Meta::CPAN
chdir $cwd;
# import to main::
no strict 'refs';
*{'main::WriteMakefile'} = \&Write if caller(0) eq 'main';
return (@Existing, @Missing);
}
sub _running_under {
view release on metacpan or search on metacpan
inc/Module/AutoInstall.pm view on Meta::CPAN
chdir $cwd;
# import to main::
no strict 'refs';
*{'main::WriteMakefile'} = \&Write if caller(0) eq 'main';
return (@Existing, @Missing);
}
sub _running_under {
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
#####################################################################
# Utility Functions
sub _caller {
my $depth = 0;
my $call = caller($depth);
while ( $call eq __PACKAGE__ ) {
$depth++;
$call = caller($depth);
}
return $call;
}
sub _read {
view release on metacpan or search on metacpan
lib/Apache2/ErrorReport.pm view on Meta::CPAN
# Special handing for derived Error.pm classes
$stacktrace = $E->stacktrace;
} else {
# $stacktrace = "$E\n";
# my $i = 0;
# while (my ($package, $filename, $line, $subr) = caller($i)){
# $stacktrace .= "stack $i: $package $subr line $line\n";
# $i++;
# }
$stacktrace = Carp::longmess($E);
}
view release on metacpan or search on metacpan
lib/Apache2/Expression.pm view on Meta::CPAN
my $data = shift( @_ );
return( '' ) if( !length( $data ) );
my $opts = $self->_get_args_as_hash( @_ );
pos( $data ) = 0;
my $prefix = $self->legacy ? 'Legacy' : $self->trunk ? 'Trunk' : '';
my @callinfo = caller(0);
$opts->{top} = 0;
$opts->{top} = 1 if( $callinfo[0] ne ref( $self ) || ( $callinfo[0] eq ref( $self ) && substr( (caller(1))[3], rindex( (caller(1))[3], ':' ) + 1 ) ne 'parse' ) );
# This is used to avoid looping when an expression drills down its substring by calling parse again
my $skip = {};
if( ref( $opts->{skip} ) eq 'ARRAY' &&
scalar( @{$opts->{skip}} ) )
{
view release on metacpan or search on metacpan
lib/Apache2/TieBucketBrigade.pm view on Meta::CPAN
sub {
if (@_ == 1) {
#ignore selecting filehandle
my $sh = shift;
unless (ref($sh)) {
my $caller = caller();
$sh = \*{$caller .'::'. $sh};
}
return CORE::select();
}
elsif (@_ == 4) {
view release on metacpan or search on metacpan
inc/Module/AutoInstall.pm view on Meta::CPAN
chdir $cwd;
# import to main::
no strict 'refs';
*{'main::WriteMakefile'} = \&Write if caller(0) eq 'main';
return (@Existing, @Missing);
}
sub _running_under {
view release on metacpan or search on metacpan
lib/Apache2_4/AuthCookieMultiDBI.pm view on Meta::CPAN
sub _dbi_connect {
my ($self, $r) = @_;
Carp::confess('Failed to pass Apache request object') if not $r;
my ( $pkg, $file, $line, $sub ) = caller(1);
my $info_message = "${self} -> _dbi_connect called in $sub at line $line";
$r->server->log_error( $info_message );
my %c = $self->_dbi_config_vars($r);
view release on metacpan or search on metacpan
script/_acme-cpanauthors view on Meta::CPAN
#}
#
#sub get_logger {
# my ($package, %per_target_conf) = @_;
#
# my $caller = caller(0);
# $per_target_conf{category} = $caller
# if !defined($per_target_conf{category});
# my $obj = []; $obj =~ $re_addr;
# my $pkg = "Log::ger::Obj$1"; bless $obj, $pkg;
# add_target(object => $obj, \%per_target_conf);
script/_acme-cpanauthors view on Meta::CPAN
#}
#
#sub import {
# my ($package, %per_target_conf) = @_;
#
# my $caller = caller(0);
# $package->_import_to($caller, %per_target_conf);
#}
#
#1;
## ABSTRACT: A lightweight, flexible logging framework
script/_acme-cpanauthors view on Meta::CPAN
# %args = %{shift()};
# } else {
# %args = (name => shift, conf => {@_});
# }
#
# my $caller = caller(0);
# $args{target} = 'package';
# $args{target_arg} = $caller;
#
# set($pkg, \%args);
#}
script/_acme-cpanauthors view on Meta::CPAN
#our $_i; # temporary variable
#sub err {
# require Scalar::Util;
#
# # get information about caller
# my @caller = CORE::caller(1);
# if (!@caller) {
# # probably called from command-line (-e)
# @caller = ("main", "-e", 1, "program");
# }
#
script/_acme-cpanauthors view on Meta::CPAN
# $stack_trace = [];
# $_i = 1;
# while (1) {
# {
# package DB;
# @_c = CORE::caller($_i);
# if (@_c) {
# $_c[4] = [@DB::args];
# }
# }
# last unless @_c;
script/_acme-cpanauthors view on Meta::CPAN
# my @r;
# my $i = 0;
# my $j = -1;
# while ($i <= $n+1) { # +1 for this sub itself
# $j++;
# @r = CORE::caller($j);
# last unless @r;
# if ($r[0] eq $pkg && $r[1] =~ /^\(eval /) {
# next;
# }
# $i++;
script/_acme-cpanauthors view on Meta::CPAN
# if ($args{base_name}) {
# my ($pkg, $leaf);
# if ($args{base_name} =~ /(.+)::(.+)/) {
# ($pkg, $leaf) = ($1, $2);
# } else {
# $pkg = CORE::caller();
# $leaf = $args{base_name};
# }
# no strict 'refs';
# $base_code = \&{"$pkg\::$leaf"};
# $base_meta = ${"$pkg\::SPEC"}{$leaf};
script/_acme-cpanauthors view on Meta::CPAN
# if ($args{output_name}) {
# my ($pkg, $leaf);
# if ($args{output_name} =~ /(.+)::(.+)/) {
# ($pkg, $leaf) = ($1, $2);
# } else {
# $pkg = CORE::caller();
# $leaf = $args{output_name};
# }
# no strict 'refs';
# no warnings 'redefine';
# *{"$pkg\::$leaf"} = $output_code if $args{install_sub} // 1;
script/_acme-cpanauthors view on Meta::CPAN
# result_naked => 1,
#};
#sub gen_curried_sub {
# my ($base_name, $set_args, $output_name) = @_;
#
# my $caller = CORE::caller();
#
# my ($base_pkg, $base_leaf);
# if ($base_name =~ /(.+)::(.+)/) {
# ($base_pkg, $base_leaf) = ($1, $2);
# } else {
script/_acme-cpanauthors view on Meta::CPAN
#
#This document describes version 0.470 of Perinci::Sub::Util (from Perl distribution Perinci-Sub-Util), released on 2020-10-20.
#
#=head1 SYNOPSIS
#
#Example for err() and caller():
#
# use Perinci::Sub::Util qw(err caller);
#
# sub foo {
# my %args = @_;
# my $res;
#
# my $caller = caller();
#
# $res = bar(...);
# return err($err, 500, "Can't foo") if $res->[0] != 200;
#
# [200, "OK"];
script/_acme-cpanauthors view on Meta::CPAN
#that contains extra information.
#
#Return value: (hash)
#
#
#=head2 caller([ $n ])
#
#Just like Perl's builtin caller(), except that this one will ignore wrapper code
#in the call stack. You should use this if your code is potentially wrapped. See
#L<Perinci::Sub::Wrapper> for more details.
#
#=head2 err(...) => ARRAY
#
script/_acme-cpanauthors view on Meta::CPAN
# }
#}
#
#sub func_args_by_tag {
# my ($func_name, $args, $tag) = @_;
# my $meta = _find_meta([caller(1)], $func_name)
# or die "Can't find Rinci function metadata for $func_name";
# args_by_tag($meta, $args, $tag);
#}
#
#sub func_argnames_by_tag {
# my ($func_name, $tag) = @_;
# my $meta = _find_meta([caller(1)], $func_name)
# or die "Can't find Rinci function metadata for $func_name";
# argnames_by_tag($meta, $tag);
#}
#
#sub call_with_its_args {
script/_acme-cpanauthors view on Meta::CPAN
# defined &{$func_name}
# or die "Function $func_name not defined";
# $func = \&{$func_name};
# $meta = ${"$1::SPEC"}{$2};
# } else {
# my @caller = caller(1);
# my $fullname = "$caller[0]::$func_name";
# defined &{$fullname}
# or die "Function $fullname not defined";
# $func = \&{$fullname};
# $meta = ${"$caller[0]::SPEC"}{$func_name};
view release on metacpan or search on metacpan
inc/ExtUtils/AutoInstall.pm view on Meta::CPAN
chdir $cwd;
# import to main::
no strict 'refs';
*{'main::WriteMakefile'} = \&Write if caller(0) eq 'main';
}
# CPAN.pm is non-reentrant, so check if we're under it and have no CPANPLUS
sub _check_lock {
return unless @Missing;
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
#####################################################################
# Common Utility Functions
sub _caller {
my $depth = 0;
my $call = caller($depth);
while ( $call eq __PACKAGE__ ) {
$depth++;
$call = caller($depth);
}
return $call;
}
# Done in evals to avoid confusing Perl::MinimumVersion
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
#####################################################################
# Common Utility Functions
sub _caller {
my $depth = 0;
my $call = caller($depth);
while ( $call eq __PACKAGE__ ) {
$depth++;
$call = caller($depth);
}
return $call;
}
sub _read {
view release on metacpan or search on metacpan
inc/Module/AutoInstall.pm view on Meta::CPAN
chdir $cwd;
# import to main::
no strict 'refs';
*{'main::WriteMakefile'} = \&Write if caller(0) eq 'main';
return (@Existing, @Missing);
}
sub _running_under {
view release on metacpan or search on metacpan
my(
%options, %option_name, %commands, @aliases, @installables,
%plugin_loaded, @plugins,
);
run(@ARGV) unless caller(); # Don't run anything if loaded via 'require'
sub run {
App::BCVI->base_init();
App::BCVI->load_plugins();
if(!defined $key or !length $key) {
die "Can't register option without 'name'";
}
my($package, $filename, $line) = caller();
$opt->{provider} = "$package at $filename line $line";
my $taken = $options{$key};
if($taken && !$opt->{force_override}) {
warn "option '--$key' already registered by $taken->{provider}\n";
}
die "Can't register command without 'name'";
}
$cmd->{dispatch_to} ||= "execute_$key";
my($package, $filename, $line) = caller();
$cmd->{provider} = "$package at $filename line $line";
warn "option '$key' already registered by $commands{$key}->{provider}\n"
if $commands{$key} && !$cmd->{force_override};
$commands{$key} = $cmd;
}
}
sub register_installable {
my $class = shift;
my($package, $filename, $line) = caller();
push @installables, $filename;
}
sub shell_aliases {
sub hook_client_class {
my($class) = @_;
my($calling_class, $calling_file) = caller();
my $client_class = $class->client_class();
$class->map_class(client => $calling_class);
no strict 'refs';
unshift @{"${calling_class}::ISA"}, $client_class;
sub hook_server_class {
my($class) = @_;
my($calling_class, $calling_file) = caller();
my $server_class = $class->server_class();
$class->map_class(server => $calling_class);
no strict 'refs';
unshift @{"${calling_class}::ISA"}, $server_class;
view release on metacpan or search on metacpan
ccstack = top_si->si_cxstack;
cxix = DPPP_dopoptosub_at(ccstack, top_si->si_cxix);
}
if (cxix < 0)
return NULL;
/* caller() should not report the automatic calls to &DB::sub */
if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
level++;
if (!level--)
break;
if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
const I32 dbcxix = DPPP_dopoptosub_at(ccstack, cxix - 1);
/* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
field below is defined for any cx. */
/* caller() should not report the automatic calls to &DB::sub */
if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
cx = &ccstack[dbcxix];
}
return cx;
view release on metacpan or search on metacpan
inc/Module/AutoInstall.pm view on Meta::CPAN
chdir $cwd;
# import to main::
no strict 'refs';
*{'main::WriteMakefile'} = \&Write if caller(0) eq 'main';
return (@Existing, @Missing);
}
sub _running_under {