view release on metacpan or search on metacpan
lib/Filter/Template.pm view on Meta::CPAN
# Outer closure to define a unique scope.
{
my $template_name = '';
my ($template_line, $enum_index);
my ($package_name, $file_name, $line_number) = (caller)[0,1,2];
my $const_regexp_dirty = 0;
my $state = STATE_PLAIN;
# The following block processes inheritance requests for
# templates/constants and enums. added by sungo 09/2001
view release on metacpan or search on metacpan
lib/Filter/signatures.pm view on Meta::CPAN
# Make sure we return undef as the last statement of our initialization
# See t/07*
push @defaults, "();" if @args;
$res = sprintf 'sub %s { my (%s)=@_;%s%s', $name, join(",", @args), join( "" , @defaults), "\n" x $padding;
# die sprintf("Too many arguments for subroutine at %s line %d.\n", (caller)[1, 2]) unless @_ <= 2
# die sprintf("Too few arguments for subroutine at %s line %d.\n", (caller)[1, 2]) unless @_ >= 2
} else {
$res = sprintf 'sub %s { @_==0 or warn "Subroutine %s called with parameters.";();', $name, $name;
};
return $res
view release on metacpan or search on metacpan
Call/Call.pm view on Meta::CPAN
# Did we get a code reference?
my $coderef = (ref $obj eq 'CODE');
# If the parameter isn't already a reference, make it one.
if (!$coderef and (!ref($obj) or ref($obj) =~ /^ARRAY|HASH$/)) {
$obj = bless (\$obj, (caller)[0]);
}
# finish off the installation of the filter in C.
Filter::Util::Call::real_import($obj, (caller)[0], $coderef) ;
}
XSLoader::load('Filter::Util::Call');
1;
view release on metacpan or search on metacpan
t/lib/Test/Util.pm view on Meta::CPAN
$file =~ s@/$@/index.html@;
# figure out which bank test is calling us and use that to find the files
if ( !$context ) {
( $context ) = (caller)[1];
$context =~ s@t/(.*)\.t$@$1@;
$context =~ s@\.pm$@@;
}
$file =~ s@^\w+?://[^/]+@@;
t/lib/Test/Util.pm view on Meta::CPAN
}
}
sub setup {
my ( $MODULE_UNDER_TEST ) = (caller)[1] =~ m@/?(\w+)\.t$@;
eval "use Test::MockBank::$MODULE_UNDER_TEST\n";
$MODULE_UNDER_TEST;
}
view release on metacpan or search on metacpan
inc/Class/MOP/Class.pm view on Meta::CPAN
sub make_immutable {
my ( $self, @args ) = @_;
return unless $self->is_mutable;
my ($file, $line) = (caller)[1..2];
$self->_initialize_immutable(
file => $file,
line => $line,
$self->_immutable_options(@args),
view release on metacpan or search on metacpan
devel/cb-to-fq.pl view on Meta::CPAN
};
sub quotes_from_cbrss {
my ($fq, $quotes, $str, %option) = @_;
my $source = $option{'source'} || (caller)[0];
my $symbol_list = $option{'symbol_list'};
foreach my $symbol (@$symbol_list) {
$quotes->{$symbol,'method'} = $option{'method'};
$quotes->{$symbol,'source'} = $source;
$quotes->{$symbol,'success'} = 0;
view release on metacpan or search on metacpan
t/lineno-torture.t view on Meta::CPAN
}
fun test_loc($marker) {
my $expected = actual_location_of_line_with $marker;
defined $expected or die "$marker: something done fucked up";
my $got = (caller)[2];
is $got, $expected, "location of '$marker'";
}
sub {
test_loc 'LT torture begin.';
view release on metacpan or search on metacpan
lib/Function/Runner.pm view on Meta::CPAN
# Clear the LOG
$LOG = [];
my $fn_map = {}; # initial function map
my $defn = $_[1]; # user-provided function definition
my $pkg = (caller)[0]; # calling package
_die("missing defn or pkg") unless defined $defn && defined $pkg;
# See: https://perldoc.perl.org/perlmod#Symbol-Tables
my $tab = eval '\%'.$pkg.'::'; # symbol table of calling package
peek 3, ['Symbol Table: ','\%'.$pkg.'::',"has ref: \"".ref($tab).'"'];
view release on metacpan or search on metacpan
lib/Future.pm view on Meta::CPAN
{
my $self = shift;
my ( $exception, @more ) = @_;
if( !ref $exception and $exception !~ m/\n$/ ) {
$exception .= sprintf " at %s line %d\n", (caller)[1,2];
}
$self->fail( $exception, @more );
}
view release on metacpan or search on metacpan
lib/Egbk.pm view on Meta::CPAN
elsif (defined $_[1]) {
return $_[1] . '::' . $name;
}
else {
return (caller)[0] . '::' . $name;
}
}
sub qualify_to_ref ($;$) {
if (defined $_[1]) {
no strict qw(refs);
return \*{ qualify $_[0], $_[1] };
}
else {
no strict qw(refs);
return \*{ qualify $_[0], (caller)[0] };
}
}
}
# P.714 29.2.39. flock
view release on metacpan or search on metacpan
nytprof/Exporter-Heavy-pm-11-line.html view on Meta::CPAN
<tr><td class="h"><a name="227"></a>227</td><td></td><td></td><td></td><td></td><td class="s"> my $pkg = ref $self || $self;</td></tr>
<tr><td class="h"><a name="228"></a>228</td><td></td><td></td><td></td><td></td><td class="s"> return ${pkg}->VERSION($wanted);</td></tr>
<tr><td class="h"><a name="229"></a>229</td><td></td><td></td><td></td><td></td><td class="s">}</td></tr>
<tr><td class="h"><a name="230"></a>230</td><td></td><td></td><td></td><td></td><td class="s"></td></tr>
<tr><td class="h"><a name="231"></a>231</td><td></td><td></td><td></td><td></td><td class="s">sub heavy_export_tags {</td></tr>
<tr><td class="h"><a name="232"></a>232</td><td></td><td></td><td></td><td></td><td class="s"> _push_tags((caller)[0], "EXPORT", \@_);</td></tr>
<tr><td class="h"><a name="233"></a>233</td><td></td><td></td><td></td><td></td><td class="s">}</td></tr>
<tr><td class="h"><a name="234"></a>234</td><td></td><td></td><td></td><td></td><td class="s"></td></tr>
<tr><td class="h"><a name="235"></a>235</td><td></td><td></td><td></td><td></td><td class="s">sub heavy_export_ok_tags {</td></tr>
<tr><td class="h"><a name="236"></a>236</td><td></td><td></td><td></td><td></td><td class="s"> _push_tags((caller)[0], "EXPORT_OK", \@_);</td></tr>
<tr><td class="h"><a name="237"></a>237</td><td></td><td></td><td></td><td></td><td class="s">}</td></tr>
<tr><td class="h"><a name="238"></a>238</td><td></td><td></td><td></td><td></td><td class="s"></td></tr>
<tr><td class="h"><a name="239"></a>239</td><td class="c3">1</td><td class="c0"><span title="Avg 5µs">5µs</span></td><td></td><td></td><td class="s">1;</td></tr>
<tr><td class="s"><a name=""></a> </td><td></td><td></td><td></td><td></td><td class="s"></td></tr>
<tr><td class="h"><a name="Exporter__Heavy__CORE_match"></a></td><td></td><td></td><td></td><td></td><td class="s"><div class="calls"><div class="calls_in"># spent 1µs within Exporter::Heavy::CORE:match which was called 2 times, avg 650ns/call:
view release on metacpan or search on metacpan
lib/Gearman/WorkerSpawner.pm view on Meta::CPAN
$_ ne 'kids' # so DESTROY doesn't kill them
}
keys %$self
}, __PACKAGE__;
$params{source} = (caller)[1] if $params{caller_source};
# first command is startup parameters
$cmd = _serialize({
spawner => $storable_self,
class => $class,
view release on metacpan or search on metacpan
lib/Geo/Calc.pm view on Meta::CPAN
}
sub _precision {
my ( $self, $number, $precision ) = @_;
die "Error: Private method called" unless (caller)[0]->isa( ref($self) );
my $mbf = Math::BigFloat->new( $number );
$mbf->precision( $precision );
return $mbf->bstr() + 0;
lib/Geo/Calc.pm view on Meta::CPAN
sub _ib_precision {
my ( $self, $brng, $precision, $mul ) = @_;
$mul ||= 1;
die "Error: Private method called" unless (caller)[0]->isa( ref($self) );
my $mbf = Math::BigFloat->new( POSIX::fmod( $mul * ( Math::Trig::rad2deg( $brng ) ) + 360, 360 ) );
$mbf->precision( $precision );
return $mbf->bstr() + 0;
}
sub _fb_precision {
my ( $self, $brng, $precision ) = @_;
die "Error: Private method called" unless (caller)[0]->isa( ref($self) );
my $mbf = Math::BigFloat->new( POSIX::fmod( ( Math::Trig::rad2deg( $brng ) ) + 180, 360 ) );
$mbf->precision( $precision );
return $mbf->bstr() + 0;
view release on metacpan or search on metacpan
lib/Getopt/App.pm view on Meta::CPAN
}
sub extract_usage {
my %pod2usage;
$pod2usage{'-sections'} = shift;
$pod2usage{'-input'} = shift || (caller)[1];
$pod2usage{'-verbose'} = 99 if $pod2usage{'-sections'};
require Pod::Usage;
open my $USAGE, '>', \my $usage;
Pod::Usage::pod2usage(-exitval => 'noexit', -output => $USAGE, %pod2usage);
view release on metacpan or search on metacpan
local($pdt_reg_exp6) = '^\s*required_file_list\s*$';
local($full_help) = 0;
local($usage_help) = 0;
local($file_list) = 'optional_file_list';
local($error) = 0;
local($pkg) = (caller)[0];
local($value, $rt, $type, $required, @P_PARAMETER, %P_INFO, %P_ALIAS,
@P_REQUIRED, %P_VALID_VALUES, %P_ENV, %P_SET);
local($option, $default_value, $list, $parameter, $alias, @keys,
$found, $length, %P_EVALUATE, %P_DEFAULT_VALUE);
local(@local_pdt);
my($prompt, $I, %cmds) = @_;
$noReadLine = 1 if not evap_isatty( $I );
my($proc, $args, %long, %alias, $name, $long, $alias);
my $pkg = (caller)[0];
my $inp = ref($I) ? $I : "${pkg}::${I}";
$evap_embed = 1; # enable embedding
$shell = (defined $ENV{'SHELL'} and $ENV{'SHELL'} ne '') ?
$ENV{'SHELL'} : '/bin/sh';
view release on metacpan or search on metacpan
lib/Getopt/Long/More.pm view on Meta::CPAN
# copied verbatim from Getopt::Long, with a bit of modification (add my)
sub GetOptionsFromString(@) {
my ($string) = shift;
require Text::ParseWords;
my $args = [ Text::ParseWords::shellwords($string) ];
local $Getopt::Long::caller ||= (caller)[0];
my $ret = GetOptionsFromArray($args, @_);
return ( $ret, $args ) if wantarray;
if ( @$args ) {
$ret = 0;
warn("GetOptionsFromString: Excess data \"@$args\" in string \"$string\"\n");
lib/Getopt/Long/More.pm view on Meta::CPAN
sub GetOptionsFromArray {
require Getopt::Long;
my $ary = shift;
local $Getopt::Long::caller ||= (caller)[0]; # grab and set this asap.
my @go_opts_spec;
if ( ref($_[0]) ) {
require Scalar::Util;
view release on metacpan or search on metacpan
lib/Getopt/Long.pm view on Meta::CPAN
sub GetOptionsFromString(@) {
my ($string) = shift;
require Text::ParseWords;
my $args = [ Text::ParseWords::shellwords($string) ];
$caller ||= (caller)[0]; # current context
my $ret = GetOptionsFromArray($args, @_);
return ( $ret, $args ) if wantarray;
if ( @$args ) {
$ret = 0;
warn("GetOptionsFromString: Excess data \"@$args\" in string \"$string\"\n");
lib/Getopt/Long.pm view on Meta::CPAN
sub GetOptionsFromArray(@) {
my ($argv, @optionlist) = @_; # local copy of the option descriptions
my $argend = '--'; # option list terminator
my %opctl = (); # table of option specs
my $pkg = $caller || (caller)[0]; # current context
# Needed if linkage is omitted.
my @ret = (); # accum for non-options
my %linkage; # linkage
my $userlinkage; # user supplied HASH
my $opt; # current option
view release on metacpan or search on metacpan
lib/Getopt/Mixed/Help.pm view on Meta::CPAN
my $max_length = 0;
my $env_prefix = undef;
my $use_multiple = 0;
my $multiple = undef;
my %multiple_options = ();
my $package = (caller)[0];
# preparation loop (module parameters):
while (@_ > 0)
{
my $option = shift;
view release on metacpan or search on metacpan
lib/Getopt/Mixed.pm view on Meta::CPAN
# nextOption yourself; getOptions doesn't support it:
$order = $PERMUTE if $order == $RETURN_IN_ORDER;
my ($option,$value,$package);
$package = (caller)[0];
while (($option, $value) = nextOption()) {
$option =~ s/\W/_/g; # Make a legal Perl identifier
$value = 1 unless defined $value;
my $code = "\$" . $package . "::opt_$option = \$value;";
view release on metacpan or search on metacpan
Glade/Two/Generate.pm view on Meta::CPAN
} else {
# We have no value and no default to use so bail out here
$Glade_Perl->diag_print (1, "error No value in supplied ".
"%s and NO default was supplied in ".
"%s called from %s line %s",
"$proto->{'widget'}{'name'}\->{'$key'}", $me, (caller)[0], (caller)[2]);
return undef;
}
}
# We must have some sort of value to use by now
unless ($request) {
view release on metacpan or search on metacpan
Glade/PerlUI.pm view on Meta::CPAN
} else {
# We have no value and no default to use so bail out here
$Glade_Perl->diag_print (1, "error No value in supplied ".
"%s and NO default was supplied in ".
"%s called from %s line %s",
"$proto->{'name'}\->{'$key'}", $me, (caller)[0], (caller)[2] );
return undef;
}
} else {
# We have a value to use
# $Glade_Perl->diag_print (8, "$indent- Value supplied in ".
view release on metacpan or search on metacpan
lib/Grammar/Marpa.pm view on Meta::CPAN
my $ebnf = ref($_[0]) eq 'HASH' ? undef : shift(@_);
my $pkg;
my %args;
if (ref ($_[-1]) eq 'HASH') {
%args = %{pop(@_)};
$pkg = shift(@_) // (caller)[0];
}
elsif (@_ % 2) {
$pkg = shift;
%args = @_;
}
else {
$pkg = (caller)[0];
%args = @_;
}
my %Gargs;
$Gargs{ bless_package } = delete $args{ bless_package } if $args{ bless_package };
$Gargs{ trace_file_handle } = $args{ trace_file_handle } if $args{ trace_file_handle };
view release on metacpan or search on metacpan
lib/Egreek.pm view on Meta::CPAN
elsif (defined $_[1]) {
return $_[1] . '::' . $name;
}
else {
return (caller)[0] . '::' . $name;
}
}
sub qualify_to_ref ($;$) {
if (defined $_[1]) {
no strict qw(refs);
return \*{ qualify $_[0], $_[1] };
}
else {
no strict qw(refs);
return \*{ qualify $_[0], (caller)[0] };
}
}
}
# P.714 29.2.39. flock
view release on metacpan or search on metacpan
lib/HTML/DOM/EventTarget.pm view on Meta::CPAN
sub AUTOLOAD {
my($pack,$meth) = our $AUTOLOAD =~ /(.*)::(.*)/s;
$meth =~ /^on([a-z]+)\z/
or die "Can't locate object method \"$meth\" via package "
. qq'"$pack" at '.join' line ',(caller)[1,2]
,. "\n";
shift->event_handler($1, @_);
}
sub DESTROY{}
view release on metacpan or search on metacpan
lib/HTML/YaTmpl.pm view on Meta::CPAN
if( exists $ENV{HTML_TMPL_SEARCH_PATH} ) {
my $sep=$Config{path_sep} || ':';
$I->path=[split $sep, $ENV{HTML_TMPL_SEARCH_PATH}];
}
}
$I->package=(caller)[0];
$I->errors=[];
foreach my $m (@CLASS_MEMBERS) {
$I->$m=$o{$m} if( exists $o{$m} );
}
view release on metacpan or search on metacpan
t/lib/Test/HT.pm view on Meta::CPAN
($identifier, $arg) = ref $_[0] ? (undef, shift) : (shift, shift || {});
my $comment = (defined $_[0] and ! ref $_[0])
? shift(@_)
: sprintf("ht_test at %s, line %s", (caller)[1, 2]);
my $extra = (! defined $_[0]) ? {}
: (! reftype $_[0]) ? confess("bogus extra value")
: (reftype $_[0] eq 'CODE') ? { assert => $_[0] }
: (reftype $_[0] eq 'HASH') ? $_[0]
view release on metacpan or search on metacpan
HashObject.pm view on Meta::CPAN
}
}
elsif (!defined $self->method_keys && $key eq 'keys') {
$self->method_keys($value);
}
elsif ( $self->object->isa( (caller)[0] ) ) {
return $self->{storage}->{$key} = $value;
}
elsif (grep /^$key$/, @{$self->method_keys}) {
$self->object->$key($value);
}
HashObject.pm view on Meta::CPAN
}
sub FETCH {
my $self = shift;
my $key = shift;
if ( $self->object->isa((caller)[0]) ) {
return $self->{storage}->{$key};
}
elsif (grep /^$key$/, @{$self->method_keys}) {
return $self->object->$key;
}
HashObject.pm view on Meta::CPAN
}
}
sub FIRSTKEY {
my $self = shift;
if ( $self->object->isa((caller)[0]) ) {
return (keys %{$self->{storage}})[0];
}
else {
# we have to do this for data dumps...
return (@{$self->defined_public_keys})[0];
HashObject.pm view on Meta::CPAN
my $self = shift;
my $last_method = shift;
my @keys;
if ( $self->object->isa((caller)[0]) ) {
@keys = keys %{$self->{storage}};
}
else {
@keys = @{$self->defined_public_keys};
}
HashObject.pm view on Meta::CPAN
sub EXISTS {
my $self = shift;
my $key = shift;
if ( $self->object->isa((caller)[0]) ) {
return exists $self->{storage}->{$key};
}
else {
return (grep /^$key$/, @{$self->defined_public_keys});
}
HashObject.pm view on Meta::CPAN
sub DELETE {
my $self = shift;
my $key = shift;
if ( $self->object->isa((caller)[0]) ) {
return delete $self->{storage}->{$key};
}
else {
warn "Cannot delete methods. Please set the values instead.";
}
}
# override this method if you have some default for clearing the method hash values...
sub CLEAR {
my $self = shift;
if ( $self->object->isa((caller)[0]) ) {
$self->{storage} = {};
}
else {
warn "Cannot clear tied method calls";
}
}
sub SCALAR {
my $self = shift;
if ( $self->object->isa((caller)[0]) ) {
return scalar keys %{$self->{storage}};
}
else {
return scalar @{$self->defined_public_keys};
}
view release on metacpan or search on metacpan
lib/Hyper/Developer/Server.pm view on Meta::CPAN
my $arg_ref = shift;
my $config = delete $arg_ref->{$PACKAGE};
my $self = HTTP::Server::Simple::new($class, %{$arg_ref});
$self->{$PACKAGE} = {
base_path => dirname((caller)[1]) . '/../../',
refresh => Module::Refresh->new(),
%{$config}
};
return $self;
view release on metacpan or search on metacpan
t/010examples-lzma.t view on Meta::CPAN
$aok &= is $stdout, $expected, " expected content is ok"
if defined $expected ;
if (! $aok) {
diag "Command line: $cmd";
my ($file, $line) = (caller)[1,2];
diag "Test called from $file, line $line";
}
1 while unlink $stderr;
}
view release on metacpan or search on metacpan
lib/IO/Compress/Base.pm view on Meta::CPAN
sub _def
{
my $obj = shift ;
my $class= (caller)[0] ;
my $name = (caller(1))[3] ;
$obj->croakError("$name: expected at least 1 parameters\n")
unless @_ >= 1 ;