view release on metacpan or search on metacpan
lib/Class/DbC.pm view on Meta::CPAN
extends => { type => SCALAR, optional => 1 },
clone_with => { type => CODEREF, optional => 1 },
constructor_name => { type => SCALAR, default => 'new' },
});
my $caller_pkg = (caller)[0];
$Spec_for{ $caller_pkg } = \%arg;
_handle_extentions($caller_pkg, $arg{extends});
_add_governor($caller_pkg);
}
view release on metacpan or search on metacpan
lib/Class/Easy.pm view on Meta::CPAN
? (keys %{$sub_by_type->{method}}, keys %{$sub_by_type->{runtime}})
: $sub_by_type;
}
sub list_all_subs_for {
my $module = shift || (caller)[0];
my $filter = shift || '';
$module = ref $module
if ref $module;
view release on metacpan or search on metacpan
## private
sub WriteStack {
my $self = shift;
my( $key, $name, $s ) = @_;
my $fh = (caller)[0] . "::$name";
my $i = @$s;
my( $type, @v, $v );
my( $junk, $word, $ident, $stuff );
my @roots = ();
my @keep = ();
view release on metacpan or search on metacpan
lib/Class/Implant.pm view on Meta::CPAN
use Class::Inspector;
our $VERSION = '0.01';
sub import {
*{(caller)[0] . "::implant"} = \&implant;
}
sub implant (@) {
my $option = ( ref($_[-1]) eq "HASH" ? pop(@_) : undef );
my @class = @_;
view release on metacpan or search on metacpan
lib/Class/LazyLoad.pm view on Meta::CPAN
{
my @todo;
sub import
{
shift;
return if (caller)[0] eq 'Class::LazyLoad::Functions';
unless ( @_ ) {
push @todo, [ (caller)[0], 'new' ];
return;
}
foreach ( @_ ) {
if (ref($_) eq 'ARRAY') {
lib/Class/LazyLoad.pm view on Meta::CPAN
'${}' => sub { _build($_[0]); $_[0] },
'%{}' => sub { _build($_[0]); $_[0] },
'&{}' => sub { _build($_[0]); $_[0] },
'@{}' => sub {
# C::LL does array access, so make sure it's not us before building.
return $_[0] if (caller)[0] eq __PACKAGE__;
_build($_[0]); $_[0]
},
nomethod => sub {
my $realclass = $_[0][1];
if ($_[3] eq '""') {
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
hax/make_argcheck_ops.c.inc view on Meta::CPAN
#define make_croak_op(message) S_make_croak_op(aTHX_ message)
static OP *S_make_croak_op(pTHX_ SV *message)
{
#if HAVE_PERL_VERSION(5, 22, 0)
sv_catpvs(message, " at %s line %d.\n");
/* die sprintf($message, (caller)[1,2]) */
return op_convert_list(OP_DIE, 0,
op_convert_list(OP_SPRINTF, 0,
op_append_list(OP_LIST,
newSVOP(OP_CONST, 0, message),
newSLICEOP(0,
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
sub ntest ($$$) {
my $ret = 1;
if ($_[1] != $_[2]) {
printf "#$_[0]: expecting $_[1]\n";
printf "#$_[0]: got $_[2]\n";
printf "#line %d %s\n",(caller)[2,1];
print "not ";
$ret = 0;
}
print "ok $_[0]\n";
$ret;
sub stest ($$$) {
my $ret = 1;
unless (defined $_[2] && $_[1] eq $_[2]) {
printf "#$_[0]: expecting %s\n", $_[1] =~ /[^\.\d\w]/ ? "hex:".unpack("H*",$_[1]) : $_[1];
printf "#$_[0]: got %s\n", defined($_[2]) ? $_[2] =~ /[^\.\d\w]/ ? "hex:".unpack("H*",$_[2]) : $_[2] : 'undef';
printf "#line %d %s\n",(caller)[2,1];
print "not ";
$ret = 0;
}
print "ok $_[0]\n";
$ret;
}
sub btest ($$) {
unless ($_[1]) {
printf "#line %d %s\n",(caller)[2,1];
print "not ";
}
print "ok $_[0]\n";
$_[1]
}
my $ok = $expect eq $got;
unless ($ok) {
printf "#$_[0]: expecting %s\n", $expect;
printf "#$_[0]: got %s\n", $got;
printf "#line %d %s\n",(caller)[2,1];
print "not ";
}
print "ok $_[0]\n";
$ok;
}
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
eg/chat2new.pl view on Meta::CPAN
# returns undef if can't find a pty.
# Modify "/dev/pty" to "/dev/pts" for Dell Unix v2.2 (aka SVR4.04). Joe Doupnik.
sub _getpty { ## private
local($_PTY,$_TTY) = @_;
$_PTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
$_TTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
local($pty, $tty, $kind);
if( -e "/dev/pts000" ){ ## mods by Joe Doupnik Dec 1992
$kind = "pts"; ## SVR4 Streams
} else {
$kind = "pty"; ## BSD Clist stuff
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";
}