view release on metacpan or search on metacpan
MakeMethods/Template/Universal.pm view on Meta::CPAN
'_ATTR_REQUIRED_{}' =>
'(_ATTR_{*} or Carp::croak("No * parameter defined for _ATTR_{name}"))',
'_ATTR_DEFAULT_{}' =>
sub { my @a = split(' ',$_[0],2); "(_ATTR_{$a[0]} || $a[1])" },
_ACCESS_PRIVATE_ => '( ( (caller)[0] eq _ATTR_{target_class} ) or croak "Attempted access to private method _ATTR_{name}")',
_ACCESS_PROTECTED_ => '( UNIVERSAL::isa((caller)[0], _ATTR_{target_class}) or croak "Attempted access to protected method _ATTR_{name}" )',
'_CALL_METHODS_FROM_HASH_' => q{
# Accept key-value attr list, or reference to unblessed hash of attrs
my @args = (scalar @_ == 1 and ref($_[0]) eq 'HASH') ? %{$_[0]} : @_;
while ( scalar @args ) { local $_ = shift(@args); $self->$_( shift(@args) ) }
view release on metacpan or search on metacpan
lib/Class/Multimethods.pm view on Meta::CPAN
# THIS IS INTERPOSED BETWEEN THE CALLING PACKAGE AND Exporter TO SUPPORT THE
# use Class:Multimethods @methodnames SYNTAX
sub import
{
my $package = (caller)[0];
install_dispatch($package,pop @_) while $#_;
Class::Multimethods->export_to_level(1);
}
lib/Class/Multimethods.pm view on Meta::CPAN
# AND THE TYPE NAMES SUPPLIED. CAN ALSO BE USED WITH JUST THE MULTIMETHOD
# NAME IN ORDER TO INSTALL A SUITABLE DISPATCH SUB INTO THE CALLING PACKAGE
sub multimethod
{
my $package = (caller)[0];
my $name = shift;
install_dispatch($package,$name);
if (@_) # NOT JUST INSTALLING A DISPATCH SUB...
{
view release on metacpan or search on metacpan
t/lib/Test/Simple.pm view on Meta::CPAN
_print *TESTOUT, $msg;
#'#
unless( $test ) {
my($pack, $file, $line) = (caller)[0,1,2];
if( $pack eq 'Test::More' ) {
($file, $line) = (caller(1))[1,2];
}
_print *TESTERR, "# Failed test ($file at line $line)\n";
}
view release on metacpan or search on metacpan
# configuring Log::Agent
logconfig(-level=>$ENV{POBJECT_DEBUG} || 0);
sub import {
my $class = shift;
my $caller_pkg = (caller)[0];
unless ( @_ ) {
no strict 'refs';
*{ "$caller_pkg\::pobject" } = \&{ "$class\::pobject" };
return 1
view release on metacpan or search on metacpan
lib/Class/Persist/Proxy.pm view on Meta::CPAN
}
sub AUTOLOAD {
my $self = shift;
$self = $self->load() or return; # die "Can't find in DB from ".(caller)[0]." line ".(caller)[2];
my $meth = substr($AUTOLOAD, rindex($AUTOLOAD, ':') + 1);
my $can = $self->can($meth) or EO::Error::Method::NotFound->throw(text => "Method $meth unknownin class ".ref($self));
$can->($self, @_);
}
view release on metacpan or search on metacpan
lib/Class/Property.pm view on Meta::CPAN
return $package;
};
push @EXPORT, 'property';
sub property{ return $make_property->( (caller)[0], @_);}
push @EXPORT, 'rw_property';
sub rw_property{ return $make_property->( (caller)[0], map{$_ => {'set' => undef, 'get' => undef }} @_);}
push @EXPORT, 'ro_property';
sub ro_property{ return $make_property->( (caller)[0], map{$_ => {'get' => undef }} @_);}
push @EXPORT, 'wo_property';
sub wo_property{ return $make_property->( (caller)[0], map{$_ => {'set' => undef }} @_);}
__END__
=head1 NAME
Class::Property - Perl implementation of class properties.
view release on metacpan or search on metacpan
lib/Class/Scaffold/Util.pm view on Meta::CPAN
}
sub const ($@) {
my $name = shift;
my %args = @_;
my ($pkg, $filename, $line) = (caller)[ 0 .. 2 ];
no strict 'refs';
my $every_hash_name = "${name}_HASH";
$::PTAGS && $::PTAGS->add_tag($every_hash_name, $filename, $line);
*{"${pkg}::${every_hash_name}"} = sub { %args };
$::PTAGS && $::PTAGS->add_tag($name, $filename, $line);
view release on metacpan or search on metacpan
lib/Class/StrongSingleton.pm view on Meta::CPAN
## protected initializer
sub _init_StrongSingleton {
# do not let us be called by anything which
# is not derived from Class::StrongSingleton
(UNIVERSAL::isa((caller)[0], 'Class::StrongSingleton'))
|| die "Illegal Operation : _init_StrongSingleton can only be called by a subclass of Class::StrongSingleton";
my ($self) = @_;
(ref($self))
|| die "Illegal Operation : _init_StrongSingleton can only be called as an instance method";
# get the class name
view release on metacpan or search on metacpan
lib/Tie/InsideOut.pm view on Meta::CPAN
my $self = \$scalar;
bless $self, $class;
my $id = $self->_get_id;
{
my $caller = shift || (caller)[0];
no strict 'refs';
$NameSpaces{$id} = $caller;
}
$self->CLEAR;
view release on metacpan or search on metacpan
lib/Class/Variable.pm view on Meta::CPAN
push @EXPORT, 'public';
sub public($;)
{
my @names = @_;
my $package = (caller)[0];
foreach my $name (@names)
{
no strict 'refs';
*{$package.'::'.$name } = get_public_variable($package, $name);
}
lib/Class/Variable.pm view on Meta::CPAN
push @EXPORT, 'protected';
sub protected($;)
{
my @names = @_;
my $package = (caller)[0];
foreach my $name (@names)
{
no strict 'refs';
*{$package.'::'.$name } = get_protected_variable($package, $name);
}
lib/Class/Variable.pm view on Meta::CPAN
push @EXPORT, 'private';
sub private($;)
{
my @names = @_;
my $package = (caller)[0];
foreach my $name (@names)
{
no strict 'refs';
*{$package.'::'.$name } = get_private_variable($package, $name);
}
view release on metacpan or search on metacpan
lib/Classic/Perl.pm view on Meta::CPAN
sub import{
shift;
for(@_) {
die
"$_ is not a feature Classic::Perl knows about at "
. join(" line ", (caller)[1,2]) . ".\n"
unless exists$features{$_};
next if $] < 5.0089999;
$_ eq '$*' and &_enable_multiline;
next if $] < 5.0109999;
$_ eq 'split' and $^H{Classic_Perl__split} = 1;
lib/Classic/Perl.pm view on Meta::CPAN
sub unimport {
shift;
for(@_) {
die
"$_ is not a feature Classic::Perl knows about at "
. join(" line ", (caller)[1,2]) . ".\n"
unless exists $features{$_};
delete $^H{"Classic_Perl__$_"};
}
return if @_;
# if($^H{'Classic_Perl__$['}) {
view release on metacpan or search on metacpan
ClearPrompt.pm view on Meta::CPAN
local $!; # don't mess up errno in the caller's world.
# Play back responses from the StashFile if it exists and other conditions
# are satisfied. It seems that CC sets the series id to all zeroes
# after an error condition (??) so we avoid that case explicitly.
my $lineno = (caller)[2];
my $subtext = "from $prog:$lineno";
if ($TriggerSeries && $ENV{CLEARCASE_SERIES_ID} &&
$ENV{CLEARCASE_SERIES_ID} !~ /^[0:.]+$/) {
(my $sid = $ENV{CLEARCASE_SERIES_ID}) =~ s%:+%-%g;
$StashFile = tempname($prog, "CLEARCASE_SERIES_ID=$sid");
ClearPrompt.pm view on Meta::CPAN
# This is a pseudo warn() func which is called via the $SIG{__WARN__} hook.
sub cpwarn {
my @msg = @_;
# always show line numbers if this dbg flag set
if ($ENV{CLEARCASE_CLEARPROMPT_SHOW_LINENO}) {
my($file, $line) = (caller)[1,2];
chomp $msg[-1];
push(@msg, " at $file line $line.\n");
}
_automail('WARN', "Warning from $prog", @msg);
if ($ENV{ATRIA_FORCE_GUI} && $Dialogs{WARN}) {
ClearPrompt.pm view on Meta::CPAN
# A pseudo die() which can be made to override the caller's builtin.
sub die {
my @msg = @_;
# always show line numbers if this dbg flag set
if ($ENV{CLEARCASE_CLEARPROMPT_SHOW_LINENO}) {
my($file, $line) = (caller)[1,2];
chomp $msg[-1];
push(@msg, " at $file line $line.\n");
}
_automail('DIE', "Error from $prog", @msg);
if ($ENV{ATRIA_FORCE_GUI} && $Dialogs{DIE}) {
view release on metacpan or search on metacpan
lib/Combinator.pm view on Meta::CPAN
$cir_begin_pat = $opt{cir_begin};
$nex_begin_pat = $opt{nex_begin};
$cir_par_pat = $opt{cir_par};
$com_pat = qr/($begin_pat((?:(?-2)|(?!$begin_pat).)*?)$end_pat)/s;
$token_pat = qr/$com_pat|(?!$begin_pat)./s;
$line_shift = (caller)[2];
}
sub att_sub {
my($att1, $att2, $cb) = @_;
sub {
view release on metacpan or search on metacpan
lib/Comment/Block.pm view on Meta::CPAN
sub import {
my ($type) = @_;
my (%context) = (
_inBlock => 0,
_filename => (caller)[1],
_line_no => 0,
_last_begin => 0,
);
filter_add(bless \%context);
}
view release on metacpan or search on metacpan
lib/Config/Abstraction.pm view on Meta::CPAN
return undef;
}
sub _load_config
{
if(!UNIVERSAL::isa((caller)[0], __PACKAGE__)) {
Carp::croak('Illegal Operation: This method can only be called by a subclass');
}
my $self = shift;
my %merged;
view release on metacpan or search on metacpan
# take a look at it for me
sub import_names {
my ($self, $namespace) = @_;
unless ( defined $namespace ) {
$namespace = (caller)[0];
}
if ( $namespace eq 'Config::Simple') {
croak "You cannot import into 'Config::Simple' package";
}
my %vars = $self->vars();
map { $arg->{$_} = $cfg->param($_) } $cfg->param();
return $cfg;
}
# following is the original version of our import_from():
unless ( defined $arg ) {
$arg = (caller)[0];
}
my $cfg = $class->new($file) or return;
$cfg->import_names($arg);
return $cfg;
}
view release on metacpan or search on metacpan
=cut
sub define_accessors {
my ($self, $package, @names) = @_;
@names = $self->directives() unless @names;
$package = (caller)[0] unless defined $package;
my $name;
foreach $name (@names) {
$self->_define_accessor($name, $package);
}
@names;
}
sub _define_accessor {
my ($self, $name, $package) = @_;
$package = (caller)[0] unless defined $package;
no strict 'refs';
*{ $package . "::" . $name } = $self->_make_accessor($name);
return $name;
}
view release on metacpan or search on metacpan
t/10-basics.t view on Meta::CPAN
use Const::Fast;
sub throws_readonly(&@) {
my ($sub, $desc) = @_;
my ($file, $line) = (caller)[1,2];
my $error = qr/\AModification of a read-only value attempted at \Q$file\E line $line\.\Z/;
local $Test::Builder::Level = $Test::Builder::Level + 1;
like(exception { $sub->() }, $error, $desc);
}
sub throws_reassign(&@) {
my ($sub, $desc) = @_;
my ($file, $line) = (caller)[1,2];
my $error = qr/\AAttempt to reassign a readonly \w+ at \Q$file\E line $line\.?\Z/;
local $Test::Builder::Level = $Test::Builder::Level + 1;
like(exception { $sub->() }, $error, $desc);
}
view release on metacpan or search on metacpan
t/fail_with.t view on Meta::CPAN
eval_nok { my $x = Other::fail_auto_message(); $x.'a' } 'good' => 'Exception thrown in str context';
sub set_up_2 {
package Other;
my $LINE = (caller)[2];
local $SIG{__WARN__} = sub {
my $message = shift;
::is $message,
'FAIL handler for package Other redefined at '.__FILE__
." line $LINE\n"
t/fail_with.t view on Meta::CPAN
my @results = Other::fail_auto_message();
ok @results == 0 => 'Returned empty list in list context';
sub set_up_3 {
package Other;
my $LINE = (caller)[2];
local $SIG{__WARN__} = sub {
my $message = shift;
::is $message,
'FAIL handler for package Other redefined at '.__FILE__
." line $LINE\n"
view release on metacpan or search on metacpan
lib/Convert/GeekCode.pm view on Meta::CPAN
return;
}
sub locate {
my $path = (caller)[0];
my $file = $_[0];
$path =~ s|::|/|g;
$path =~ s|\w+\$||;
view release on metacpan or search on metacpan
my $selection = (ref($choice) eq 'CODE')
? $choice->()
: $choice;
return $selection if defined $selection;
}
die "couldn't randomize: " . join(", ", @_) . "at " . (caller)[2];
}
sub syl_count
{
my $count = 0;
view release on metacpan or search on metacpan
##### code
my $host = &Sys::Hostname::hostname;
($host = "\L$host") =~ s/\s+//g;
&$user_info((caller)[1]); # defaults
sub import {
my ($alm) = ((caller)[1] =~ m|.+/auto/(.+)/.+\.al$|);
my $level=0;
my $i;
my $ptr;
while (1) {
($level, @_) = &$seek_caller($level);
my $expire = 0;
if ( exists $parms{EXP} ) { # if the EXPiration is present
($expire = &date2time($parms{EXP})) ||
die "invalid expiration date $user license";
}
@_ = split('/',(caller)[1]); # last element
if ( $_[$#_] =~ /\.pm$/ ) {
@_ = split(/\./,$_[$#_]); # remove extension
}
my $key = $_[$#_-1];
@_ = split(',',$ptr->{private});
foreach $i (0..$#_) {
$_[$i] = join('/',split('::',$_[$i]));
}
}
my $match = (caller)[1];
if (grep($match =~ /$_\.pm$/,@_)) {
$ptr->{$key} = $parms{KEY} or die "missing private key $user";
} else {
$ptr->{$key} = $parms{PKEY} or die "missing public key $user";
}
view release on metacpan or search on metacpan
lib/Ecyrillic.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/DB/Evented.pm view on Meta::CPAN
for my $method_name ( qw(selectrow_hashref selectcol_arrayref selectall_hashref selectall_arrayref) ) {
no strict 'refs';
*{$method_name} = sub {
my $self = shift;
my ($sql, $key_field, $attr, @args) = (shift, ($method_name eq 'selectall_hashref' ? (shift) : (undef)), shift, @_);
$self->_add_to_queue($sql, $attr, $key_field, @args, $method_name, (caller)[1,2]);
};
}
# TODO: Investigate if this is the bet way to handle this.
# The child processes are technically held by AnyEvent::DBI
view release on metacpan or search on metacpan
t/80proxy.t view on Meta::CPAN
$result;
}
sub Test ($;$) {
my($ok, $msg) = @_;
$msg = ($msg) ? " ($msg)" : "";
my $line = (caller)[2];
++$numTest;
($ok) ? print "ok $numTest at line $line\n" : print "not ok $numTest\n";
warn "# failed test $numTest at line ".(caller)[2]."$msg\n" unless $ok;
++$failed_tests unless $ok;
return $ok;
}
}
view release on metacpan or search on metacpan
lib/DBIx/Class/Helper/ResultSet/IgnoreWantarray.pm view on Meta::CPAN
use parent 'DBIx::Class::ResultSet';
sub search :DBIC_method_is_indirect_sugar{
$_[0]->throw_exception ('->search is *not* a mutator, calling it in void context makes no sense')
if !defined wantarray && (caller)[0] !~ /^\QDBIx::Class::/;
shift->search_rs(@_);
}
1;
view release on metacpan or search on metacpan
lib/DBIx/Class/Schema/Loader.pm view on Meta::CPAN
sub import {
my $self = shift;
return if !@_;
my $cpkg = (caller)[0];
foreach my $opt (@_) {
if($opt =~ m{^dump_to_dir:(.*)$}) {
$self->dump_to_dir($1)
}
view release on metacpan or search on metacpan
lib/DBIx/Class/ResultSet.pm view on Meta::CPAN
# turn may be called in void context due to some braindead
# overload or whatever else the user decided to be clever
# at this particular day. Thus limit the exception to
# external code calls only
$self->throw_exception ('->search is *not* a mutator, calling it in void context makes no sense')
if (caller)[0] !~ /^\QDBIx::Class::/;
return ();
}
}
view release on metacpan or search on metacpan
ProcedureCall.pm view on Meta::CPAN
}
sub import {
my $class = shift;
my $caller = (caller)[0];
no strict 'refs';
foreach (@_) {
my ($name, @attr) = split ':';
my @err = grep { not exists $__known_attributes{lc $_} } @attr;
view release on metacpan or search on metacpan
lib/DBIx/Simple.pm view on Meta::CPAN
return shift->{dbh}->last_insert_id(@_);
}
sub disconnect {
my ($self) = @_;
$self->_die(sprintf($err_cause, "$self->disconnect", (caller)[1, 2]));
return 1;
}
sub DESTROY {
my ($self) = @_;
$self->_die(sprintf($err_cause, "$self->DESTROY", (caller)[1, 2]));
}
### public methods wrapping SQL::Abstract
for my $method (qw/select insert update delete/) {
lib/DBIx/Simple.pm view on Meta::CPAN
sub finish {
$_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject';
my ($self) = @_;
$self->_die(
sprintf($err_cause, "$self->finish", (caller)[1, 2])
);
}
sub DESTROY {
return if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject';
my ($self) = @_;
$self->_die(
sprintf($err_cause, "$self->DESTROY", (caller)[1, 2])
);
}
1;