Acme-Acotie
view release on metacpan or search on metacpan
#!/usr/bin/env perl
use strict;
use warnings;
use lib 'lib';
package Acotie;
sub test1 {
print "test1\n";
}
sub test2 {
print "test2\n";
}
sub test3 {
print "test3\n";
}
use Acme::Acotie;
package main;
Acotie->test1;
Acotie->test2;
Acotie->test3;
inc/Module/Install.pm view on Meta::CPAN
local *FH;
open FH, "< $_[0]" or die "open($_[0]): $!";
my $str = do { local $/; <FH> };
close FH or die "close($_[0]): $!";
return $str;
}
sub _write {
local *FH;
open FH, "> $_[0]" or die "open($_[0]): $!";
foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!" }
close FH or die "close($_[0]): $!";
}
sub _version ($) {
my $s = shift || 0;
$s =~ s/^(\d+)\.?//;
my $l = $1 || 0;
my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g;
$l = $l . '.' . join '', @v if @v;
return $l + 0;
inc/Module/Install/Fetch.pm view on Meta::CPAN
$args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) {
$args{url} = $args{ftp_url}
or (warn("LWP support unavailable!\n"), return);
($scheme, $host, $path, $file) =
$args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
}
$|++;
print "Fetching '$file' from $host... ";
unless (eval { require Socket; Socket::inet_aton($host) }) {
warn "'$host' resolve failed!\n";
return;
}
return unless $scheme eq 'ftp' or $scheme eq 'http';
require Cwd;
my $dir = Cwd::getcwd();
inc/Module/Install/Fetch.pm view on Meta::CPAN
}
my @dialog = split(/\n/, <<"END_FTP");
open $host
user anonymous anonymous\@example.com
cd $path
binary
get $file $file
quit
END_FTP
foreach (@dialog) { $fh->print("$_\n") }
$fh->close;
} }
else {
warn "No working 'ftp' program available!\n";
chdir $dir; return;
}
unless (-f $file) {
warn "Fetching failed: $@\n";
chdir $dir; return;
}
return if exists $args{size} and -s $file != $args{size};
system($args{run}) if exists $args{run};
unlink($file) if $args{remove};
print(((!exists $args{check_for} or -e $args{check_for})
? "done!" : "failed! ($!)"), "\n");
chdir $dir; return !$?;
}
1;
inc/Module/Install/Makefile.pm view on Meta::CPAN
$makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m;
#$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m;
# Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well.
$makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g;
# XXX - This is currently unused; not sure if it breaks other MM-users
# $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg;
open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
print MAKEFILE "$preamble$makefile$postamble" or die $!;
close MAKEFILE or die $!;
1;
}
sub preamble {
my ($self, $text) = @_;
$self->{preamble} = $text . $self->{preamble} if defined $text;
$self->{preamble};
}
inc/Module/Install/Metadata.pm view on Meta::CPAN
'LGPL' => 'lgpl', 1,
'BSD' => 'bsd', 1,
'Artistic' => 'artistic', 1,
'MIT' => 'mit', 1,
'proprietary' => 'proprietary', 0,
);
while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
$pattern =~ s{\s+}{\\s+}g;
if ( $license_text =~ /\b$pattern\b/i ) {
if ( $osi and $license_text =~ /All rights reserved/i ) {
print "WARNING: 'All rights reserved' in copyright may invalidate Open Source license.\n";
}
$self->license($license);
return 1;
}
}
}
warn "Cannot determine license info from $_[0]\n";
return 'unknown';
}
inc/Module/Install/Win32.pm view on Meta::CPAN
$self->load('get_file');
require Config;
return unless (
$^O eq 'MSWin32' and
$Config::Config{make} and
$Config::Config{make} =~ /^nmake\b/i and
! $self->can_run('nmake')
);
print "The required 'nmake' executable not found, fetching it...\n";
require File::Basename;
my $rv = $self->get_file(
url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe',
ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe',
local_dir => File::Basename::dirname($^X),
size => 51928,
run => 'Nmake15.exe /o > nul',
check_for => 'Nmake.exe',
remove => 1,
inc/Spiffy.pm view on Meta::CPAN
s[^(sub\s+\w+)\s*\(\s*\)(\s+\{.*\n)]
[${1}${2}]gm;
s[^my\s+sub\s+(\w+)(\s+\{)(.*)((?s:.*?\n))\}\n]
[push @my_subs, $1; "\$$1 = sub$2my \$self = shift;$3$4\};\n"]gem;
my $preclare = '';
if (@my_subs) {
$preclare = join ',', map "\$$_", @my_subs;
$preclare = "my($preclare);";
}
$_ = "use strict;use warnings;$preclare${_};1;\n$end";
if ($filter_dump) { print; exit }
if ($filter_save) { $filter_result = $_; $_ = $filter_result; }
$done = 1;
}
);
}
sub base {
push @_, -base;
goto &import;
}
inc/Spiffy.pm view on Meta::CPAN
my $default_string =
( ref($default) eq 'ARRAY' and not @$default )
? '[]'
: (ref($default) eq 'HASH' and not keys %$default )
? '{}'
: default_as_code($default);
my $code = $code{sub_start};
if ($args->{-init}) {
my $fragment = $args->{-weak} ? $code{weak_init} : $code{init};
$code .= sprintf $fragment, $field, $args->{-init}, ($field) x 4;
}
$code .= sprintf $code{set_default}, $field, $default_string, $field
if defined $default;
$code .= sprintf $code{return_if_get}, $field;
$code .= sprintf $code{set}, $field;
$code .= sprintf $code{weaken}, $field, $field
if $args->{-weak};
$code .= sprintf $code{sub_end}, $field;
my $sub = eval $code;
die $@ if $@;
no strict 'refs';
*{"${package}::$field"} = $sub;
return $code if defined wantarray;
}
sub default_as_code {
require Data::Dumper;
inc/Spiffy.pm view on Meta::CPAN
sub WWW {
warn spiffy_dump(@_) . at_line_number;
return wantarray ? @_ : $_[0];
}
sub XXX {
die spiffy_dump(@_) . at_line_number;
}
sub YYY {
print spiffy_dump(@_) . at_line_number;
return wantarray ? @_ : $_[0];
}
sub ZZZ {
require Carp;
Carp::confess spiffy_dump(@_);
}
1;
inc/Test/Base.pm view on Meta::CPAN
? splice(@_, 0, 1)
: default_object();
return $self, @_;
}
sub blocks() {
(my ($self), @_) = find_my_self(@_);
croak "Invalid arguments passed to 'blocks'"
if @_ > 1;
croak sprintf("'%s' is invalid argument to blocks()", shift(@_))
if @_ && $_[0] !~ /^[a-zA-Z]\w*$/;
my $blocks = $self->block_list;
my $section_name = shift || '';
my @blocks = $section_name
? (grep { exists $_->{$section_name} } @$blocks)
: (@$blocks);
return scalar(@blocks) unless wantarray;
inc/Test/Base/Filter.pm view on Meta::CPAN
if ($file =~ /(.*)[\\\/]/) {
my $dir = $1;
if (not -e $dir) {
require File::Path;
File::Path::mkpath($dir)
or die "Can't create $dir";
}
}
open my $fh, ">$file"
or die "Can't open '$file' for output\n:$!";
print $fh @_;
close $fh;
return $file;
}
sub yaml {
$self->assert_scalar(@_);
require YAML;
return YAML::Load(shift);
}
sub _write_to {
my $filename = shift;
open my $script, ">$filename"
or die "Couldn't open $filename: $!\n";
print $script @_;
close $script
or die "Couldn't close $filename: $!\n";
}
__DATA__
#line 638
inc/Test/Builder.pm view on Meta::CPAN
my $self = shift;
my($max) = @_;
if( @_ ) {
$self->croak("Number of tests must be a positive integer. You gave it '$max'")
unless $max =~ /^\+?\d+$/ and $max > 0;
$self->{Expected_Tests} = $max;
$self->{Have_Plan} = 1;
$self->_print("1..$max\n") unless $self->no_header;
}
return $self->{Expected_Tests};
}
#line 279
sub no_plan {
my $self = shift;
inc/Test/Builder.pm view on Meta::CPAN
sub skip_all {
my($self, $reason) = @_;
my $out = "1..0";
$out .= " # Skip $reason" if $reason;
$out .= "\n";
$self->{Skip_All} = 1;
$self->_print($out) unless $self->no_header;
exit(0);
}
#line 339
sub exported_to {
my($self, $pack) = @_;
if( defined $pack ) {
inc/Test/Builder.pm view on Meta::CPAN
$result->{type} = 'todo';
}
else {
$result->{reason} = '';
$result->{type} = '';
}
$self->{Test_Results}[$self->{Curr_Test}-1] = $result;
$out .= "\n";
$self->_print($out);
unless( $test ) {
my $msg = $todo ? "Failed (TODO)" : "Failed";
$self->_print_diag("\n") if $ENV{HARNESS_ACTIVE};
my(undef, $file, $line) = $self->caller;
if( defined $name ) {
$self->diag(qq[ $msg test '$name'\n]);
$self->diag(qq[ at $file line $line.\n]);
}
else {
$self->diag(qq[ $msg test at $file line $line.\n]);
}
}
inc/Test/Builder.pm view on Meta::CPAN
# force numeric context
$self->_unoverload_num($val);
}
}
else {
$$val = 'undef';
}
}
local $Level = $Level + 1;
return $self->diag(sprintf <<DIAGNOSTIC, $got, $expect);
got: %s
expected: %s
DIAGNOSTIC
}
#line 600
sub isnt_eq {
my($self, $got, $dont_expect, $name) = @_;
inc/Test/Builder.pm view on Meta::CPAN
return $ok;
}
sub _cmp_diag {
my($self, $got, $type, $expect) = @_;
$got = defined $got ? "'$got'" : 'undef';
$expect = defined $expect ? "'$expect'" : 'undef';
local $Level = $Level + 1;
return $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect);
%s
%s
%s
DIAGNOSTIC
}
sub _caller_context {
my $self = shift;
inc/Test/Builder.pm view on Meta::CPAN
return $code;
}
#line 766
sub BAIL_OUT {
my($self, $reason) = @_;
$self->{Bailed_Out} = 1;
$self->_print("Bail out! $reason");
exit 255;
}
#line 779
*BAILOUT = \&BAIL_OUT;
#line 791
inc/Test/Builder.pm view on Meta::CPAN
type => 'skip',
reason => $why,
});
my $out = "ok";
$out .= " $self->{Curr_Test}" if $self->use_numbers;
$out .= " # skip";
$out .= " $why" if length $why;
$out .= "\n";
$self->_print($out);
return 1;
}
#line 833
sub todo_skip {
my($self, $why) = @_;
$why ||= '';
inc/Test/Builder.pm view on Meta::CPAN
actual_ok => 0,
name => '',
type => 'todo_skip',
reason => $why,
});
my $out = "not ok";
$out .= " $self->{Curr_Test}" if $self->use_numbers;
$out .= " # TODO & SKIP $why\n";
$self->_print($out);
return 1;
}
#line 911
sub maybe_regex {
my ($self, $regex) = @_;
inc/Test/Builder.pm view on Meta::CPAN
local $Level = $Level + 1;
$ok = $self->ok( $test, $name );
}
unless( $ok ) {
$this = defined $this ? "'$this'" : 'undef';
my $match = $cmp eq '=~' ? "doesn't match" : "matches";
local $Level = $Level + 1;
$self->diag(sprintf <<DIAGNOSTIC, $this, $match, $regex);
%s
%13s '%s'
DIAGNOSTIC
}
return $ok;
}
inc/Test/Builder.pm view on Meta::CPAN
#line 1197
sub diag {
my($self, @msgs) = @_;
return if $self->no_diag;
return unless @msgs;
# Prevent printing headers when compiling (i.e. -c)
return if $^C;
# Smash args together like print does.
# Convert undef to 'undef' so its readable.
my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
# Escape each line with a #.
$msg =~ s/^/# /gm;
# Stick a newline on the end if it needs it.
$msg .= "\n" unless $msg =~ /\n\Z/;
local $Level = $Level + 1;
$self->_print_diag($msg);
return 0;
}
#line 1234
sub _print {
my($self, @msgs) = @_;
# Prevent printing headers when only compiling. Mostly for when
# tests are deparsed with B::Deparse
return if $^C;
my $msg = join '', @msgs;
local($\, $", $,) = (undef, ' ', '');
my $fh = $self->output;
# Escape each line after the first with a # so we don't
# confuse Test::Harness.
$msg =~ s/\n(.)/\n# $1/sg;
# Stick a newline on the end if it needs it.
$msg .= "\n" unless $msg =~ /\n\Z/;
print $fh $msg;
}
#line 1268
sub _print_diag {
my $self = shift;
local($\, $", $,) = (undef, ' ', '');
my $fh = $self->todo ? $self->todo_output : $self->failure_output;
print $fh @_;
}
#line 1305
sub output {
my($self, $fh) = @_;
if( defined $fh ) {
$self->{Out_FH} = $self->_new_fh($fh);
}
inc/Test/Builder.pm view on Meta::CPAN
select $old_fh;
}
my($Testout, $Testerr);
sub _dup_stdhandles {
my $self = shift;
$self->_open_testhandles;
# Set everything to unbuffered else plain prints to STDOUT will
# come out in the wrong order from our own prints.
_autoflush($Testout);
_autoflush(\*STDOUT);
_autoflush($Testerr);
_autoflush(\*STDERR);
$self->output ($Testout);
$self->failure_output($Testerr);
$self->todo_output ($Testout);
}
inc/Test/Builder.pm view on Meta::CPAN
# doesn't puke.
if( !$self->{Have_Plan} ) {
return;
}
# Don't do an ending if we bailed out.
if( $self->{Bailed_Out} ) {
return;
}
# Figure out if we passed or failed and print helpful messages.
my $test_results = $self->{Test_Results};
if( @$test_results ) {
# The plan? We have no plan.
if( $self->{No_Plan} ) {
$self->_print("1..$self->{Curr_Test}\n") unless $self->no_header;
$self->{Expected_Tests} = $self->{Curr_Test};
}
# Auto-extended arrays and elements which aren't explicitly
# filled in with a shared reference will puke under 5.8.0
# ithreads. So we have to fill them in by hand. :(
my $empty_result = &share({});
for my $idx ( 0..$self->{Expected_Tests}-1 ) {
$test_results->[$idx] = $empty_result
unless defined $test_results->[$idx];
inc/Test/More.pm view on Meta::CPAN
my $tb = Test::More->builder;
unless( @_ == 2 or @_ == 3 ) {
my $msg = <<WARNING;
is_deeply() takes two or three args, you gave %d.
This usually means you passed an array or hash instead
of a reference to it
WARNING
chop $msg; # clip off newline so carp() will put in line/file
_carp sprintf $msg, scalar @_;
return $tb->ok(0);
}
my($got, $expected, $name) = @_;
$tb->_unoverload_str(\$expected, \$got);
my $ok;
if( !ref $got and !ref $expected ) { # neither is a reference
( run in 0.694 second using v1.01-cache-2.11-cpan-de7293f3b23 )