view release on metacpan or search on metacpan
lib/OWL/Config.pm view on Meta::CPAN
# imports names into the caller's namespace as global variables;
# adapted from the same method in Config::Simple
sub import_names {
shift;
my $namespace = @_ ? shift : (caller)[0];
return if $namespace eq 'OWL::Config';
no strict 'refs';
no warnings; # avoid "Useless use of a variable..."
while ( my ($key, $value) = each %Config ) {
view release on metacpan or search on metacpan
t/lib/Helper.pm view on Meta::CPAN
# Note: if you want your query parameters or uri fragment to be normalized, set them afterwards
# body_content can be a reference; the Content-Type header is used to determine the encoding format:
# see _generate_body
sub request ($method, $uri_string, $headers = [], $body_content = undef) {
die '$TYPE is not set at ', join(' line ', (caller)[1,2]), ".\n" if not defined $TYPE;
die 'Wide character in body content at ', join(' line ', (caller)[1,2]), ".\n"
if not ref $body_content and length $body_content and $body_content =~ /[^\x00-\xff]/;
($headers, $body_content) = _generate_body($headers, $body_content) if ref $body_content;
my $req;
t/lib/Helper.pm view on Meta::CPAN
# add missing Content-Length, etc
$req->fix_headers;
}
else {
die '$TYPE '.$TYPE.' not supported at ', join(' line ', (caller)[1,2]), ".\n";
}
return $req;
}
# body_content can be a reference; the Content-Type header is used to determine the encoding format:
# see _generate_body
sub response ($code, $headers = [], $body_content = undef) {
die '$TYPE is not set at ', join(' line ', (caller)[1,2]), ".\n" if not defined $TYPE;
die 'Wide character in body content at ', join(' line ', (caller)[1,2]), ".\n"
if not ref $body_content and length $body_content and $body_content =~ /[^\x00-\xff]/;
($headers, $body_content) = _generate_body($headers, $body_content) if ref $body_content;
my $res;
t/lib/Helper.pm view on Meta::CPAN
headers => $headers,
defined $body_content ? (content => $body_content) : (),
);
}
else {
die '$TYPE '.$TYPE.' not supported at ', join(' line ', (caller)[1,2]), ".\n";
}
if ($TYPE eq 'lwp' or $TYPE eq 'plack' or $TYPE eq 'catalyst' or $TYPE eq 'dancer2') {
$res->headers->header('Content-Length' => length $body_content)
if defined $body_content
t/lib/Helper.pm view on Meta::CPAN
return $res;
}
sub uri ($uri_string, @path_parts) {
die '$TYPE is not set at ', join(' line ', (caller)[1,2]), ".\n" if not defined $TYPE;
my $uri;
if (elem($TYPE, [qw(lwp plack catalyst dancer2)])) {
test_needs('URI');
$uri = URI->new($uri_string);
t/lib/Helper.pm view on Meta::CPAN
elsif ($TYPE eq 'mojo') {
$uri = Mojo::URL->new($uri_string);
$uri->path->parts(\@path_parts) if @path_parts;
}
else {
die '$TYPE '.$TYPE.' not supported at ', join(' line ', (caller)[1,2]), ".\n";
}
return $uri;
}
# sets query parameters on the request
sub query_params ($request, $pairs) {
die '$TYPE is not set at ', join(' line ', (caller)[1,2]), ".\n" if not defined $TYPE;
my $uri;
if ($TYPE eq 'lwp') {
$request->uri->query_form($pairs);
}
t/lib/Helper.pm view on Meta::CPAN
$request->env->{REQUEST_URI} .= '?' . $request->env->{QUERY_STRING};
$request->uri->query($request->env->{QUERY_STRING}) if $TYPE eq 'catalyst';
# $request->_clear_parameters if $TYPE eq 'catalyst'; # might need this later
}
else {
die '$TYPE '.$TYPE.' not supported at ', join(' line ', (caller)[1,2]), ".\n";
}
return $uri;
}
sub remove_header ($message, $header_name) {
die '$TYPE is not set at ', join(' line ', (caller)[1,2]), ".\n" if not defined $TYPE;
if ($TYPE eq 'lwp') {
$message->headers->remove_header($header_name);
}
elsif ($TYPE eq 'mojo') {
t/lib/Helper.pm view on Meta::CPAN
elsif (elem($TYPE, [qw(plack catalyst dancer2)])) {
$message->headers->remove_header($header_name);
delete $message->env->{uc $header_name =~ s/-/_/r} if $message->can('env');
}
else {
die '$TYPE '.$TYPE.' not supported at ', join(' line ', (caller)[1,2]), ".\n";
}
}
sub _generate_body ($headers, $body_content) {
my (undef, $content_type) = pairgrep { $a eq 'Content-Type' } @$headers;
t/lib/Helper.pm view on Meta::CPAN
return map +(
($_->headers->content_type//'') =~ m{^multipart/(?:[\w-]+); boundary=(.+)\z},
), $content->parts->@*;
}
die 'unrecognized type ', ref $message, ' at ', join(' line ', (caller)[1,2]), ".\n";
}
# prints the method and URI of the request, or the response code and message of the response,
# or the method and URI of the two-element hash
sub to_str (@args) {
t/lib/Helper.pm view on Meta::CPAN
}
elsif ($message->isa('Plack::Response') or $message->isa('Catalyst::Response')) {
return $message->status.' '.HTTP::Status::status_message($message->status);
}
die 'unrecognized type ', ref $message, ' at ', join(' line ', (caller)[1,2]), ".\n";
}
# create a Result object out of the document errors; suitable for stringifying
# as the OpenAPI::Modern constructor might do.
sub document_result ($document) {
view release on metacpan or search on metacpan
OpenPlugin/Application.pm view on Meta::CPAN
# CGI.pm. Otherwise, it just passes the request onto OpenPlugin.
sub param {
my $self = shift;
my @params = @_;
if( (caller)[0] eq "CGI::Application" ) {
return $self->SUPER::param->get_incoming( @params );
}
else {
return $self->SUPER::param( @params );
}
OpenPlugin/Application.pm view on Meta::CPAN
# CGI.pm. Otherwise, it just passes the request onto OpenPlugin.
sub header {
my $self = shift;
my @params = @_;
if( (caller)[0] eq "CGI::Application" ) {
return $self->SUPER::httpheader->send_outgoing( @params );
}
else {
return $self->SUPER::httpheader( @params );
}
view release on metacpan or search on metacpan
t/lib/Line/Storage.pm view on Meta::CPAN
my %lines;
sub remember_line {
my ($name) = @_;
die "$name already taken" if $lines{$name};
$lines{$name} = (caller)[2];
return;
}
sub recall_line {
my ($name) = @_;
view release on metacpan or search on metacpan
lib/OurNet/BBS/Utils.pm view on Meta::CPAN
sub locate {
my ($file, $path) = @_;
unless ($path) {
$path = (caller)[0];
$path =~ s|::\w+$||;
}
$path =~ s|::|/|g;
view release on metacpan or search on metacpan
sub ops($) { my $p = shift; my $c = ref $p || $p;
bless $p = {};
use Carp qw(croak);
my $caller = (caller)[0];
my $args = $_[0];
croak "ops takes a hash to pass arguments" unless HASH $args;
foreach (sort keys %$args) {
if (defined $_dflts{$_}) { $p->{$_} = $args->{$_} }
else {
view release on metacpan or search on metacpan
t/data/lib/Myfile.pm view on Meta::CPAN
use strict;
use warnings;
use Cwd;
sub from_caller { Cwd::realpath(_from_caller()) }
sub _from_caller { (caller)[1] }
sub from_file { Cwd::realpath(__FILE__) }
1;
view release on metacpan or search on metacpan
PApp/XML.pm view on Meta::CPAN
my $self = shift;
my $dom = shift;
my $temp = bless {
attr => {@_},
}, PApp::XML::Template::;
my $package = (caller)[0];
$temp->{code} = $temp->_dom2sub($dom, $self, $package);
delete $temp->{attr}{special};
view release on metacpan or search on metacpan
lib/PDF/Boxer/Role/SizePosition.pm view on Meta::CPAN
sub move{
my ($self, $x, $y) = @_;
return if
($self->margin_left && $self->margin_left == $x)
&& ($self->margin_top && $self->margin_top == $y);
warn $self->name." move $x, $y from ".join('-',(caller)[0,2])."\n" if $self->debug && $self->name;
$self->adjust({ margin_left => $x, margin_top => $y });
}
sub set_width{
my ($self, $arg) = @_;
return if $self->width && $self->width == $arg;
warn $self->name." set width $arg from ".join('-',(caller)[0,2])."\n" if $self->debug && $self->name;
$self->adjust({ width => $arg });
}
sub set_margin_width{
my ($self, $arg) = @_;
return if $self->margin_width && $self->margin_width == $arg;
warn $self->name." set margin_width $arg from ".join('-',(caller)[0,2])."\n" if $self->debug && $self->name;
$self->adjust({ margin_width => $arg });
}
sub set_height{
my ($self, $arg) = @_;
return if $self->height && $self->height == $arg;
warn $self->name." set height $arg from ".join('-',(caller)[0,2])."\n" if $self->debug && $self->name;
$self->adjust({ height => $arg });
}
sub set_margin_height{
my ($self, $arg) = @_;
return if $self->margin_height && $self->margin_height == $arg;
warn $self->name." set margin_height $arg from ".join('-',(caller)[0,2])."\n" if $self->debug && $self->name;
$self->adjust({ margin_height => $arg });
}
sub set_size{
my ($self, $x, $y) = @_;
return if
($self->width && $self->width == $x)
&& ($self->height && $self->height == $y);
warn $self->name." size $x, $y from ".join('-',(caller)[0,2])."\n" if $self->debug && $self->name;
$self->adjust({ width => $x, height => $y });
}
sub set_margin_size{
my ($self, $x, $y) = @_;
return if $self->margin_width == $x && $self->margin_height == $y;
warn $self->name." size $x, $y from ".join('-',(caller)[0,2])."\n" if $self->debug && $self->name;
$self->adjust({ margin_width => $x, margin_height => $y });
}
sub child_height_set{};
sub child_width_set{};
view release on metacpan or search on metacpan
lib/PDL/Demos.pm view on Meta::CPAN
defined($PERLDL::TERM) ? $PERLDL::TERM->readline($prompt) : ( print $prompt, <> );
}
sub act($) {
local $SIG{__DIE__} = \&Carp::confess;
actnw($_[0], (caller)[0]);
my $prompt = "---- (press enter)";
defined($PERLDL::TERM) ? $PERLDL::TERM->readline($prompt) : ( print $prompt, <> );
}
sub _eval_pkg {
lib/PDL/Demos.pm view on Meta::CPAN
local $SIG{__DIE__} = \&Carp::confess;
my ($script, $pack) = @_;
print "---- Code:";
print $script;
print "---- Output:\n";
_eval_pkg($script, $pack // (caller)[0]);
print "----\n";
print "----\nOOPS!!! Something went wrong, please make a bug report!: $@\n----\n" if $@;
}
my ($searched, @found);
view release on metacpan or search on metacpan
Basic/SourceFilter/FilterUtilCall.pm view on Meta::CPAN
# and one to an import file.
# --CED 5-Nov-2007
#
sub import {
my ($class) = @_;
($file,$offset) = (caller)[1,2]; # for error reporting
$offset++;
## Parse class name into a regexp suitable for filtration
my $terminator = terminator_regexp($class);
view release on metacpan or search on metacpan
Demos/Screen.pm view on Meta::CPAN
my $script = $_[0];
$script =~ s/^(\s*)output/$1print/mg;
print "---- Code:";
print $script;
print "---- Output:\n";
my $pack = (caller)[0];
# eval "package $pack; use PDLA; $_[0]";
eval "package $pack; use PDLA; $_[0]";
print "----\nOOPS!!! Something went wrong, please make a bug report!: $@\n----\n" if $@;
my $prompt = "---- (press enter)";
defined($PERLDL::TERM) ? $PERLDL::TERM->readline($prompt) : ( print $prompt, <> );
Demos/Screen.pm view on Meta::CPAN
my $script = $_[0];
$script =~ s/^(\s*)output/$1print/mg;
print "---- Code:";
print $script;
print "---- Output:\n";
my $pack = (caller)[0];
# eval "package $pack; use PDLA; $_[0]";
eval "package $pack; use PDLA; $_[0]";
print "----\n";
print "----\nOOPS!!! Something went wrong, please make a bug report!: $@\n----\n" if $@;
}
view release on metacpan or search on metacpan
Basic/SourceFilter/FilterUtilCall.pm view on Meta::CPAN
# and one to an import file.
# --CED 5-Nov-2007
#
sub import {
my ($class) = @_;
($file,$offset) = (caller)[1,2]; # for error reporting
$offset++;
## Parse class name into a regexp suitable for filtration
my $terminator = terminator_regexp($class);
view release on metacpan or search on metacpan
PGP/Pipe.pm view on Meta::CPAN
$args =~ s/%p/$self->{PGPPATH}/g;
$args =~ s/%r/$self->{PGPPATH}\/$self->{Keyring}/g; # PGP::Keyring
$args =~ s/%k/0x$self->{Keyid}/g; # PGP::Key
# Put the file descriptors in the callers package
$fin = (caller)[0] . "::$in";
$fout = (caller)[0] . "::$out";
$ferr = (caller)[0] . "::$err";
Debug ("PGP::Exec=$self->{PGPexec} $baseopts $args");
# just to make sure that PGPPATH is exported!
$ENV{PGPPATH} = $self->{PGPPATH};
view release on metacpan or search on metacpan
}
# Sends the headers waiting in %PLP::Script::header
sub sendheaders () {
local $\; # reset print behaviour if triggered by say()
$PLP::sentheaders ||= [ caller 1 ? (caller 1)[1, 2] : (caller)[1, 2] ];
print STDOUT "Content-Type: text/plain\n\n" if $PLP::DEBUG & 2;
while (my ($header, $values) = each %PLP::Script::header) {
print STDOUT "$header: $_\n" for split /\n/, $values;
}
print STDOUT "\n";
view release on metacpan or search on metacpan
lib/PMLTQ/Command.pm view on Meta::CPAN
sub extract_usage {
my $self = shift;
open my $handle, '>', \my $output;
pod2usage( -exitval => 'NOEXIT', -input => (caller)[1], -output => $handle );
$output =~ s/\n$//;
return $output;
}
view release on metacpan or search on metacpan
lib/POE/Component/Client/TCPMulti.pm view on Meta::CPAN
sub connect {
my %Options = @_[1..$#_];
$Options{Heap} ||= {};
printf STDERR "!!! -> connect method called from %s:%d\n",
(caller)[1,2] if DEBUG;
my $server = POE::Wheel::SocketFactory->new
( RemoteAddress => $Options{RemoteAddress},
RemotePort => $Options{RemotePort},
lib/POE/Component/Client/TCPMulti.pm view on Meta::CPAN
my $id = $server->ID;
printf TRACE "->connect(count %d, id %d, host (%s:%d) %s:%d);\n",
scalar keys %heap, $id, @Options{qw( RemoteAddress RemotePort )},
(caller)[1,2] if TRACE_CONNECT;
$heap{$id} = bless {
%{ $Options{Heap} },
-ID => $server->ID,
-ADDR => $Options{RemoteAddress},
view release on metacpan or search on metacpan
lib/POE/Component/Lightspeed/Hack/Kernel.pm view on Meta::CPAN
} else {
# Enqueue the event for "now", which simulates FIFO in our
# time-ordered queue.
$self->_data_ev_enqueue(
$session, ${ $self->[ KR_ACTIVE_SESSION ] }, $event_name, ET_POST, \@etc,
(caller)[1,2], ${ $self->[ KR_ACTIVE_EVENT ] }, time(),
);
}
# All done!
return 1;
lib/POE/Component/Lightspeed/Hack/Kernel.pm view on Meta::CPAN
# What should we return?
if (wantarray) {
my @return_value = (
($session == ${ $self->[ KR_ACTIVE_SESSION ] })
? $session->_invoke_state(
$session, $event_name, \@etc, (caller)[1,2],
${ $self->[ KR_ACTIVE_EVENT ] }
)
: $self->_dispatch_event(
$session, ${ $self->[ KR_ACTIVE_SESSION ] },
$event_name, ET_CALL, \@etc,
(caller)[1,2], ${ $self->[ KR_ACTIVE_EVENT ] }, time(), -__LINE__
)
);
$! = 0;
return @return_value;
lib/POE/Component/Lightspeed/Hack/Kernel.pm view on Meta::CPAN
if (defined wantarray) {
my $return_value = (
$session == ${ $self->[ KR_ACTIVE_SESSION ] }
? $session->_invoke_state(
$session, $event_name, \@etc, (caller)[1,2],
${ $self->[ KR_ACTIVE_EVENT ] }
)
: $self->_dispatch_event(
$session, ${ $self->[ KR_ACTIVE_SESSION ] },
$event_name, ET_CALL, \@etc,
(caller)[1,2], ${ $self->[ KR_ACTIVE_EVENT ] }, time(), -__LINE__
)
);
$! = 0;
return $return_value;
}
if ($session == ${ $self->[ KR_ACTIVE_SESSION ] }) {
$session->_invoke_state(
$session, $event_name, \@etc, (caller)[1,2],
${ $self->[ KR_ACTIVE_EVENT ] }
);
}
else {
$self->_dispatch_event(
$session, ${ $self->[ KR_ACTIVE_SESSION ] },
$event_name, ET_CALL, \@etc,
(caller)[1,2], ${ $self->[ KR_ACTIVE_EVENT ] }, time(), -__LINE__
);
}
$! = 0;
return;
view release on metacpan or search on metacpan
lib/POE/Kernel.pm view on Meta::CPAN
}
$self->_data_ev_enqueue(
$session, $kr_active_session,
EN_SIGNAL, ET_SIGNAL, [ $signal, @etc ],
(caller)[1,2], $kr_active_event
);
return 1;
}
# Public interface for flagging signals as handled. This will replace
lib/POE/Kernel.pm view on Meta::CPAN
# But not if the active event is ET_START, since that would generate
# a CHILD_LOSE without a CHILD_CREATE.
$self->_dispatch_event(
$old_parent, $self,
EN_CHILD, ET_CHILD, [ CHILD_LOSE, $kr_active_session, undef ],
(caller)[1,2], undef, monotime(), -__LINE__
)
unless $kr_active_event_type & ET_START;
# Tell the new parent (kernel) that it's gaining a child.
# (Actually it doesn't care, so we don't do that here, but this is
lib/POE/Kernel.pm view on Meta::CPAN
# Tell the current session that its parentage is changing.
$self->_dispatch_event(
$kr_active_session, $self,
EN_PARENT, ET_PARENT, [ $old_parent, $self ],
(caller)[1,2], undef, monotime(), -__LINE__
);
$self->_data_ses_move_child($kr_active_session->ID, $self->ID);
# Success!
lib/POE/Kernel.pm view on Meta::CPAN
# Tell the current session that the child is departing.
$self->_dispatch_event(
$kr_active_session, $self,
EN_CHILD, ET_CHILD, [ CHILD_LOSE, $child_session, undef ],
(caller)[1,2], undef, monotime(), -__LINE__
);
# Tell the new parent (kernel) that it's gaining a child.
# (Actually it doesn't care, so we don't do that here, but this is
# where the code would go if it ever does in the future.)
# Tell the child session that its parentage is changing.
$self->_dispatch_event(
$child_session, $self,
EN_PARENT, ET_PARENT, [ $kr_active_session, $self ],
(caller)[1,2], undef, monotime(), -__LINE__
);
$self->_data_ses_move_child($child_session->ID, $self->ID);
# Success!
lib/POE/Kernel.pm view on Meta::CPAN
# Enqueue the event for "now", which simulates FIFO in our
# time-ordered queue.
$self->_data_ev_enqueue(
$session, $kr_active_session, $event_name, ET_POST, \@etc,
(caller)[1,2], $kr_active_event
);
return 1;
}
#------------------------------------------------------------------------------
lib/POE/Kernel.pm view on Meta::CPAN
) if exists $poes_own_events{$event_name};
};
$self->_data_ev_enqueue(
$kr_active_session, $kr_active_session, $event_name, ET_POST, \@etc,
(caller)[1,2], $kr_active_event
);
undef;
}
lib/POE/Kernel.pm view on Meta::CPAN
if (wantarray) {
my @return_value = (
($session == $kr_active_session)
? $session->_invoke_state(
$session, $event_name, \@etc, (caller)[1,2],
$kr_active_event
)
: $self->_dispatch_event(
$session, $kr_active_session,
$event_name, ET_CALL, \@etc,
(caller)[1,2], $kr_active_event, monotime(), -__LINE__
)
);
$kr_exception and $self->_rethrow_kr_exception();
lib/POE/Kernel.pm view on Meta::CPAN
if (defined wantarray) {
my $return_value = (
$session == $kr_active_session
? $session->_invoke_state(
$session, $event_name, \@etc, (caller)[1,2],
$kr_active_event
)
: $self->_dispatch_event(
$session, $kr_active_session,
$event_name, ET_CALL, \@etc,
(caller)[1,2], $kr_active_event, monotime(), -__LINE__
)
);
$kr_exception and $self->_rethrow_kr_exception();
lib/POE/Kernel.pm view on Meta::CPAN
return $return_value;
}
if ($session == $kr_active_session) {
$session->_invoke_state(
$session, $event_name, \@etc, (caller)[1,2],
$kr_active_event
);
}
else {
$self->_dispatch_event(
$session, $kr_active_session,
$event_name, ET_CALL, \@etc,
(caller)[1,2], $kr_active_event, monotime(), -__LINE__
);
}
$kr_exception and $self->_rethrow_kr_exception();
lib/POE/Kernel.pm view on Meta::CPAN
# directly is faster than calling alarm_set to enqueue it.
if (defined $time) {
$self->_data_ev_enqueue
( $kr_active_session, $kr_active_session,
$event_name, ET_ALARM, [ @etc ],
(caller)[1,2], $kr_active_event, $time,
);
}
else {
# The event queue has become empty? Stop the time watcher.
$self->loop_pause_time_watcher() unless $kr_queue->get_item_count();
lib/POE/Kernel.pm view on Meta::CPAN
}
$self->_data_ev_enqueue
( $kr_active_session, $kr_active_session,
$event_name, ET_ALARM, [ @etc ],
(caller)[1,2], $kr_active_event, $time,
);
return 0;
}
lib/POE/Kernel.pm view on Meta::CPAN
# Add the new alarm if it includes a time. Calling _data_ev_enqueue
# directly is faster than calling alarm_set to enqueue it.
$self->_data_ev_enqueue
( $kr_active_session, $kr_active_session,
$event_name, ET_ALARM, [ @etc ],
(caller)[1,2], $kr_active_event, undef, $delay, $pri+$delay
);
}
else {
$self->alarm($event_name);
}
lib/POE/Kernel.pm view on Meta::CPAN
}
$self->_data_ev_enqueue
( $kr_active_session, $kr_active_session,
$event_name, ET_ALARM, [ @etc ],
(caller)[1,2], $kr_active_event, undef, $delay, $pri+$delay
);
return 0;
}
lib/POE/Kernel.pm view on Meta::CPAN
) if exists $poes_own_events{$event_name};
}
return $self->_data_ev_enqueue
( $kr_active_session, $kr_active_session, $event_name, ET_ALARM, [ @etc ],
(caller)[1,2], $kr_active_event, $time,
);
}
# Remove an alarm by its ID. TODO Now that alarms and events have
# been recombined, this will remove an event by its ID. However,
lib/POE/Kernel.pm view on Meta::CPAN
return;
}
return $self->_data_ev_enqueue
( $kr_active_session, $kr_active_session, $event_name, ET_ALARM, [ @etc ],
(caller)[1,2], $kr_active_event, $t, $seconds, $pri+$seconds
);
}
# Move a delay to a new offset from time(). As with alarm_adjust(),
# this is optimized internally for this sort of activity.
view release on metacpan or search on metacpan
lib/Params/Clean.pm view on Meta::CPAN
{
my $me=shift; # our package name
my @opts, my $i; push @opts, [$_[$i++]=>$_[$i++]] while $i<@_; # pair up the options (we would use a hash, but we want to preserve order, and anyway we could have the same key repeated)
my %EXPORT=map {$_=>$_} @KEYWORDS; # keywords to be exported (normally all @KEYWORDS) in convenient hash format
my $keys=join "|", @KEYWORDS; # for regex to test for any of our keywords
my $caller=(caller)[0]; # caller's package
# Set up warning/fatal/ignoral categories
$Warn{$caller}={%{$Warn{undef}}}; # start by setting up default warning levels
for (grep $opts[$_][0]=~/^(warn|die|fatal|ignore)$/, 0..$#opts) # grep through the key-halves of each opt for exception-levels
view release on metacpan or search on metacpan
my $warn;
$SIG{__WARN__} = sub {$warn = shift};
sub t_error {
my($args, $expected_message) = @_;
my $test_name = "[line ".((caller)[2])."]";
(my $expected_error = $expected_message) =~ s/XXX/Error/;
(my $expected_warning = $expected_message) =~ s/XXX/Warning/;
eval { error(@$args) };
view release on metacpan or search on metacpan
lib/Path/This.pm view on Meta::CPAN
use File::Basename ();
use Sub::Util ();
our $VERSION = '0.005';
sub THISFILE () { Cwd::abs_path((caller)[1]) }
sub THISDIR () {
my $file = (caller)[1];
return -e $file ? File::Basename::dirname(Cwd::abs_path $file) : Cwd::getcwd;
}
sub import {
my $class = shift;
view release on metacpan or search on metacpan
t/scan/utf8.t view on Meta::CPAN
delete $p->{__P_seen} if exists $p->{__P_seen};
$_[0] };
my $v = $_[0];
my $rv = ref $v;
$dflts = $p->get_dflts((caller)[0]);
my ($depth, $noquote) = (sw(depth), sw(noquote));
if (HASH eq $rv) {
my $params = $v; $v = shift; $rv = ref $v;
$depth = $params->{depth} if exists $params->{depth};
}
t/scan/utf8.t view on Meta::CPAN
sub import {
my ($modname, @args) = @_;
if (@args) {
my @others;
my $caller = (caller)[0];
if (exists $mod_dflts{$caller}) {
$dflts = $mod_dflts{$caller};
} else {
$dflts = undef; # indicate no customization to dflts
}
t/scan/utf8.t view on Meta::CPAN
sub ops($) {
my $p = shift; my $c=ref $p || $p;
bless $p = {}, $c unless ref $p;
my $args = $_[0];
my $ldflts = $p->get_dflts((caller)[0]);
%{$p->{dflts}} = %$dflts unless ref $p->{dflts};
die "ops takes a hash to pass arguments" unless HASH $args;
$ldflts = $p->{dflts};
foreach (sort keys %$args) {
if (exists $ldflts->{$_}) { $ldflts->{$_} = $args->{$_} }
view release on metacpan or search on metacpan
lib/Perl/Tidy/Formatter.pm view on Meta::CPAN
}
}
}
}
# enter a list slice, such as '(caller)[1,2]'
my $Kn = $self->K_next_code($Kc);
if ( $Kn && $rLL->[$Kn]->[_TOKEN_] eq '[' ) {
my $seqno_next = $rLL->[$Kn]->[_TYPE_SEQUENCE_];
if ( $seqno_next
&& $self->[_ris_list_by_seqno_]->{$seqno_next} )
view release on metacpan or search on metacpan
t/corpus-stack/mb/lib/mb.pm view on Meta::CPAN
$INC{$file} = $prefix_file_oo;
# run as Perl script
# must use CORE::do to use <DATA>, because CORE::eval cannot do it
# moreover "goto &CORE::do" doesn't work
return CORE::eval sprintf(<<'END', (caller)[0,2,1]);
package %s;
#line %s "%s"
CORE::do "$prefix_file_oo";
END
}
t/corpus-stack/mb/lib/mb.pm view on Meta::CPAN
# eval STRING for MBCS encoding
sub mb::eval (;$) {
local $_ = @_ ? $_[0] : $_;
# run as Perl script in caller package
return CORE::eval sprintf(<<'END', (caller)[0,2,1], mb::parse());
package %s;
#line %s "%s"
%s
END
}
t/corpus-stack/mb/lib/mb.pm view on Meta::CPAN
$INC{$_} = $prefix_file_oo;
# run as Perl script
# must use CORE::do to use <DATA>, because CORE::eval cannot do it.
local $@;
my $result = CORE::eval sprintf(<<'END', (caller)[0,2,1]);
package %s;
#line %s "%s"
CORE::do "$prefix_file_oo";
END
view release on metacpan or search on metacpan
lib/Perl6/Binding.pm view on Meta::CPAN
##==============================================================================
## import - install the filter
##==============================================================================
sub import {
my $caller = (caller)[1];
unless ($INSTALLED{$caller}) {
shift;
filter_add({ @_ });
$INSTALLED{$caller} = 1;
}
lib/Perl6/Binding.pm view on Meta::CPAN
##==============================================================================
## unimport - uninstall the filter
##==============================================================================
sub unimport {
my $caller = (caller)[1];
if ($INSTALLED{$caller}) {
filter_del();
delete $INSTALLED{$caller};
}
}
view release on metacpan or search on metacpan
lib/Perl6/Builtins.pm view on Meta::CPAN
with each of the values for these keys being the equivalent item from
the list returned by C<caller> in list context. This is useful because
it means that, instead of:
$subname = (caller)[3];
you can write the much more readable:
$subname = caller->{sub};
view release on metacpan or search on metacpan
perl5/Pugs-Compiler-Perl6/old/v6.pm view on Meta::CPAN
# invokes the Perl6-to-Perl5 compiler and creates a .pmc file
use strict;
use warnings;
my $filename = (caller)[1];
my $pmc = $filename;
$pmc =~ s/\.(pl|pm|t)$/\.pmc/;
die "this is not a .pl, .t or .pm file"
unless $pmc =~ /\.pmc/;
# test file dates
view release on metacpan or search on metacpan
lib/PerlIO/via/SeqIO.pm view on Meta::CPAN
if ($file or $mode !~ /:via\(SeqIO(?:::[a-zA-Z_]+)?\)/) {
#passthru
# if !defined $file, parse $mode according to presence of &...
if ($fh) {
if ( $fh =~ /^[A-Z]+$/ ) {
$fh = *{(caller)[0]."::$fh"};
}
}
if ($file) {
if ( $file =~ /^[A-Z]+$/) {
$file = *{(caller)[0]."::$file"};
}
return CORE::open($fh || $_[0],$_[1],$file);
}
else {
$_[0] ?
lib/PerlIO/via/SeqIO.pm view on Meta::CPAN
no strict qw(refs);
my $dup = gensym;
my $bareword = $1;
my $redirect = ($bareword =~ /OUT/ ? ">&" : "<&");
# get a pristine copy of DATA/STDIN/STDOUT
$fh = *{(caller)[0]."::$bareword"};
CORE::open($dup, $redirect, $fh) or croak($!);
if ($bareword =~ /OUT/) {
$| && $dup->autoflush(1);
}
# now, need to make everything output to the duplicated
lib/PerlIO/via/SeqIO.pm view on Meta::CPAN
}
else { # passthru
$DB::single=1;
($mode, $file) = $mode =~ /(\+?(?:<|>)?>?&?)(.*)/;
$file =~ /^[A-Z]+$/ and $file = *{(caller)[0]."::$file"};
$_[0] = PerlIO::Util->open($mode,$file);
}
1;
}
lib/PerlIO/via/SeqIO.pm view on Meta::CPAN
};
m/via/ && do {
return (tied $sym)->via_o; last;
};
m/^[A-Z]+$/ && do {
$sym = (caller)[0]."::$sym";
return (tied *$sym)->via_o if (tied *$sym);
return;
last;
};
}
view release on metacpan or search on metacpan
PerlQt/lib/Qt/attributes.pm view on Meta::CPAN
# Attributes override any method with the same name, so you may want
# to prefix them with _ to prevent conflicts.
#
sub import {
my $class = shift;
my $caller = (caller)[0];
for my $attribute (@_) {
exists ${ ${$caller . '::META'}{'attributes'} }{$attribute} and next;
Qt::_internal::installattribute($caller, $attribute);
${ ${$caller . '::META'}{'attributes'} }{$attribute} = 1;