perl_mlb
view release on metacpan or search on metacpan
Exporter/Heavy.pm view on Meta::CPAN
}
}
sub heavy_require_version {
my($self, $wanted) = @_;
my $pkg = ref $self || $self;
return ${pkg}->VERSION($wanted);
}
sub heavy_export_tags {
_push_tags((caller)[0], "EXPORT", \@_);
}
sub heavy_export_ok_tags {
_push_tags((caller)[0], "EXPORT_OK", \@_);
}
1;
ExtUtils/MM.pm view on Meta::CPAN
my $class = "ExtUtils::MM_$OS";
eval "require $class" unless $INC{"ExtUtils/MM_$OS.pm"};
die $@ if $@;
unshift @ISA, $class;
sub _assert {
my $sanity = shift;
die sprintf "Assert failed at %s line %d\n", (caller)[1,2] unless $sanity;
return;
}
our($AUTOLOAD, $Debug, $VERSION);
$VERSION = 1.03;
$Debug = 0 unless defined $Debug;
sub import {
my $self = shift(@_);
my($sym, $pkg);
my $void = 0;
$pkg = (caller)[0];
foreach $sym (@_) {
if ($sym eq ":void") {
$void = 1;
}
else {
&_make_fatal($sym, $pkg, $void);
}
}
};
sub AUTOLOAD {
my $cmd = $AUTOLOAD;
$cmd =~ s/.*:://;
&_make_fatal($cmd, (caller)[0]);
goto &$AUTOLOAD;
}
sub fill_protos {
my $proto = shift;
my ($n, $isref, @out, @out1, $seen_semi) = -1;
while ($proto =~ /\S/) {
$n++;
push(@out1,[$n,@out]) if $seen_semi;
push(@out, $1 . "{\$_[$n]}"), next if $proto =~ s/^\s*\\([\@%\$\&])//;
Getopt/Long.pm view on Meta::CPAN
my $default_config = do {
Getopt::Long::Configure ()
};
sub new {
my $that = shift;
my $class = ref($that) || $that;
my %atts = @_;
# Register the callers package.
my $self = { caller_pkg => (caller)[0] };
bless ($self, $class);
# Process config attributes.
if ( defined $atts{config} ) {
my $save = Getopt::Long::Configure ($default_config, @{$atts{config}});
$self->{settings} = Getopt::Long::Configure ($save);
delete ($atts{config});
}
# Else use default config.
Getopt/Long.pm view on Meta::CPAN
# FFU.
#use constant CTL_RANGE => ;
#use constant CTL_REPEAT => ;
sub GetOptions(@) {
my @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
my $prefix = $genprefix; # current prefix
$error = '';
if ( $debug ) {
Hash/Util.pm view on Meta::CPAN
sub lock_keys (\%;@) {
my($hash, @keys) = @_;
Internals::hv_clear_placeholders %$hash;
if( @keys ) {
my %keys = map { ($_ => 1) } @keys;
my %original_keys = map { ($_ => 1) } keys %$hash;
foreach my $k (keys %original_keys) {
die sprintf "Hash has key '$k' which is not in the new key ".
"set at %s line %d\n", (caller)[1,2]
unless $keys{$k};
}
foreach my $k (@keys) {
$hash->{$k} = undef unless exists $hash->{$k};
}
Internals::SvREADONLY %$hash, 1;
foreach my $k (@keys) {
delete $hash->{$k} unless $original_keys{$k};
SelfLoader.pm view on Meta::CPAN
if ($@) {
$@ =~ s/ at .*\n//;
croak $@;
}
$@ = $save;
defined(&$AUTOLOAD) || die "SelfLoader inconsistency error";
delete $Cache{$AUTOLOAD};
goto &$AUTOLOAD
}
sub load_stubs { shift->_load_stubs((caller)[0]) }
sub _load_stubs {
# $endlines is used by Devel::SelfStubber to capture lines after __END__
my($self, $callpack, $endlines) = @_;
my $fh = \*{"${callpack}::DATA"};
my $currpack = $callpack;
my($line,$name,@lines, @stubs, $protoype);
print STDERR "SelfLoader::load_stubs($callpack)\n" if $DEBUG;
croak("$callpack doesn't contain an __DATA__ token")
$::_S_W_I_T_C_H = sub { croak "case/when statement not in switch/given block" };
my $offset;
my $fallthrough;
my ($Perl5, $Perl6) = (0,0);
sub import
{
$fallthrough = grep /\bfallthrough\b/, @_;
$offset = (caller)[2]+1;
filter_add({}) unless @_>1 && $_[1] eq 'noimport';
my $pkg = caller;
no strict 'refs';
for ( qw( on_defined on_exists ) )
{
*{"${pkg}::$_"} = \&$_;
}
*{"${pkg}::__"} = \&__ if grep /__/, @_;
$Perl6 = 1 if grep(/Perl\s*6/i, @_);
$Perl5 = 1 if grep(/Perl\s*5/i, @_) || !grep(/Perl\s*6/i, @_);
}
sub unimport
{
filter_del()
}
sub filter
{
my($self) = @_ ;
local $Switch::file = (caller)[1];
my $status = 1;
$status = filter_read(10_000);
return $status if $status<0;
$_ = filter_blocks($_,$offset);
$_ = "# line $offset\n" . $_ if $offset; undef $offset;
return $status;
}
use Text::Balanced ':ALL';
sub plan {
croak "Test::plan(%args): odd number of arguments" if @_ & 1;
croak "Test::plan(): should not be called more than once" if $planned;
local($\, $,); # guard against -l and other things that screw with
# print
_reset_globals();
_read_program( (caller)[1] );
my $max=0;
for (my $x=0; $x < @_; $x+=2) {
my ($k,$v) = @_[$x,$x+1];
if ($k =~ /^test(s)?$/) { $max = $v; }
elsif ($k eq 'todo' or
$k eq 'failok') { for (@$v) { $todo{$_}=1; }; }
elsif ($k eq 'onfail') {
ref $v eq 'CODE' or croak "Test::plan(onfail => $v): must be CODE";
$ONFAIL = $v;
os2/Filter/Util/Call.pm view on Meta::CPAN
sub filter_add($)
{
my($obj) = @_ ;
# Did we get a code reference?
my $coderef = (ref $obj eq 'CODE') ;
# If the parameter isn't already a reference, make it one.
$obj = \$obj unless ref $obj ;
$obj = bless ($obj, (caller)[0]) unless $coderef ;
# finish off the installation of the filter in C.
Filter::Util::Call::real_import($obj, (caller)[0], $coderef) ;
}
bootstrap Filter::Util::Call ;
1;
__END__
=head1 NAME
Filter::Util::Call - Perl Source Filter Utility Module
}
elsif ($_ eq 'die') {
$handler = \&handler_die;
}
elsif ($_ eq 'handler') {
@_ or croak "No argument specified after 'handler'";
$handler = shift;
unless (ref $handler or $handler eq 'IGNORE'
or $handler eq 'DEFAULT') {
require Symbol;
$handler = Symbol::qualify($handler, (caller)[0]);
}
}
elsif ($_ eq 'untrapped') {
$untrapped = 1;
}
elsif ($_ eq 'any') {
$untrapped = 0;
}
elsif ($_ =~ /^\d/) {
$VERSION >= $_ or croak "sigtrap.pm version $_ required,"
unicore/mktables view on Meta::CPAN
use warnings;
my $Tests = 0;
my $Fails = 0;
sub Expect($$$)
{
my $Expect = shift;
my $String = shift;
my $Regex = shift;
my $Line = (caller)[2];
$Tests++;
my $RegObj;
my $result = eval {
$RegObj = qr/$Regex/;
$String =~ $RegObj ? 1 : 0
};
if (not defined $result) {
print "couldn't compile /$Regex/ on $0 line $Line: $@\n";
unicore/mktables view on Meta::CPAN
$Fails++;
}
}
sub Error($)
{
my $Regex = shift;
$Tests++;
if (eval { 'x' =~ qr/$Regex/; 1 }) {
$Fails++;
my $Line = (caller)[2];
print "expected error for /$Regex/ on $0 line $Line: $@\n";
}
}
sub Finished()
{
if ($Fails == 0) {
print "All $Tests tests passed.\n";
exit(0);
} else {
( run in 0.768 second using v1.01-cache-2.11-cpan-a3c8064c92c )