• Your recent searches
Acme-Albed
10 results

 view release on metacpan or  search on metacpan

inc/Module/Install.pm  view on Meta::CPAN 

}

sub _write {
	local *FH;
	if ( $] >= 5.006 ) {
		open( FH, '>', $_[0] ) or die "open($_[0]): $!";
	} else {
		open( FH, "> $_[0]"  ) or die "open($_[0]): $!";
	}
	foreach ( 1 .. $#_ ) {
		print FH $_[$_] or die "print($_[0]): $!";
	}
	close FH or die "close($_[0]): $!";
}

# _version is for processing module versions (eg, 1.03_05) not
# Perl versions (eg, 5.8.1).
sub _version ($) {
	my $s = shift || 0;
	my $d =()= $s =~ /(\.)/g;
	if ( $d >= 2 ) {
		# Normalise multipart versions
		$s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg;
	}
	$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 

		my $version = shift @requires;
		$self->test_requires( $module => $version );
	}
}

# Convert triple-part versions (eg, 5.6.1 or 5.8.9) to
# numbers (eg, 5.006001 or 5.008009).
# Also, convert double-part versions (eg, 5.8)
sub _perl_version {
	my $v = $_[-1];
	$v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e;
	$v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e;
	$v =~ s/(\.\d\d\d)000$/$1/;
	$v =~ s/_.+$//;
	if ( ref($v) ) {
		# Numify
		$v = $v + 0;
	}
	return $v;
}

inc/Module/Install/Metadata.pm  view on Meta::CPAN 


	# We need YAML::Tiny to write the MYMETA.yml file
	unless ( eval { require YAML::Tiny; 1; } ) {
		return 1;
	}

	# Generate the data
	my $meta = $self->_write_mymeta_data or return 1;

	# Save as the MYMETA.yml file
	print "Writing MYMETA.yml\n";
	YAML::Tiny::DumpFile('MYMETA.yml', $meta);
}

sub write_mymeta_json {
	my $self = shift;

	# We need JSON to write the MYMETA.json file
	unless ( eval { require JSON; 1; } ) {
		return 1;
	}

	# Generate the data
	my $meta = $self->_write_mymeta_data or return 1;

	# Save as the MYMETA.yml file
	print "Writing MYMETA.json\n";
	Module::Install::_write(
		'MYMETA.json',
		JSON->new->pretty(1)->canonical->encode($meta),
	);
}

sub _write_mymeta_data {
	my $self = shift;

	# If there's no existing META.yml there is nothing we can do

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 639

inc/Test/Builder.pm  view on Meta::CPAN 

sub finalize {
    my $self = shift;

    return unless $self->parent;
    if( $self->{Child_Name} ) {
        $self->croak("Can't call finalize() with child ($self->{Child_Name}) active");
    }
    $self->_ending;

    # XXX This will only be necessary for TAP envelopes (we think)
    #$self->_print( $self->is_passing ? "PASS\n" : "FAIL\n" );

    my $ok = 1;
    $self->parent->{Child_Name} = undef;
    if ( $self->{Skip_All} ) {
        $self->parent->skip($self->{Skip_All});
    }
    elsif ( not @{ $self->{Test_Results} } ) {
        $self->parent->ok( 0, sprintf q[No tests run for subtest "%s"], $self->name );
    }
    else {
        $self->parent->ok( $self->is_passing, $self->name );
    }
    $? = $self->{Child_Error};
    delete $self->{Parent};

    return $self->is_passing;
}

inc/Test/Builder.pm  view on Meta::CPAN 


sub _output_plan {
    my($self, $max, $directive, $reason) = @_;

    $self->carp("The plan was already output") if $self->{Have_Output_Plan};

    my $plan = "1..$max";
    $plan .= " # $directive" if defined $directive;
    $plan .= " $reason"      if defined $reason;

    $self->_print("$plan\n");

    $self->{Have_Output_Plan} = 1;

    return;
}

#line 579

sub done_testing {
    my($self, $num_tests) = @_;

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 = $self->in_todo ? "Failed (TODO)" : "Failed";
        $self->_print_to_fh( $self->_diag_fh, "\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 


    return $code;
}

#line 1145

sub BAIL_OUT {
    my( $self, $reason ) = @_;

    $self->{Bailed_Out} = 1;
    $self->_print("Bail out!  $reason");
    exit 255;
}

#line 1158

{
    no warnings 'once';
    *BAILOUT = \&BAIL_OUT;
}

inc/Test/Builder.pm  view on Meta::CPAN 

            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 1213

sub todo_skip {
    my( $self, $why ) = @_;
    $why ||= '';

inc/Test/Builder.pm  view on Meta::CPAN 

            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 1293

sub maybe_regex {
    my( $self, $regex ) = @_;
    my $usable_regex = undef;

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;
}

# I'm not ready to publish this.  It doesn't deal with array return

inc/Test/Builder.pm  view on Meta::CPAN 


    no strict 'refs';    ## no critic
    *{ __PACKAGE__ . '::' . $method } = $code;
}

#line 1579

sub diag {
    my $self = shift;

    $self->_print_comment( $self->_diag_fh, @_ );
}

#line 1594

sub note {
    my $self = shift;

    $self->_print_comment( $self->output, @_ );
}

sub _diag_fh {
    my $self = shift;

    local $Level = $Level + 1;
    return $self->in_todo ? $self->todo_output : $self->failure_output;
}

sub _print_comment {
    my( $self, $fh, @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 the beginning, _print will take care of the rest.
    $msg =~ s/^/# /;

    local $Level = $Level + 1;
    $self->_print_to_fh( $fh, $msg );

    return 0;
}

#line 1644

sub explain {
    my $self = shift;

    return map {

inc/Test/Builder.pm  view on Meta::CPAN 

            $dumper->Indent(1)->Terse(1);
            $dumper->Sortkeys(1) if $dumper->can("Sortkeys");
            $dumper->Dump;
          }
          : $_
    } @_;
}

#line 1673

sub _print {
    my $self = shift;
    return $self->_print_to_fh( $self->output, @_ );
}

sub _print_to_fh {
    my( $self, $fh, @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, ' ', '' );

    # Escape each line after the first with a # so we don't
    # confuse Test::Harness.
    $msg =~ s{\n(?!\z)}{\n# }sg;

    # Stick a newline on the end if it needs it.
    $msg .= "\n" unless $msg =~ /\n\z/;

    return print $fh $self->_indent, $msg;
}

#line 1732

sub output {
    my( $self, $fh ) = @_;

    if( defined $fh ) {
        $self->{Out_FH} = $self->_new_fh($fh);
    }

inc/Test/Builder.pm  view on Meta::CPAN 

    return;
}

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->reset_outputs;

    return;
}

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} ) {
        $self->is_passing(0);
        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->_output_plan($self->{Curr_Test}) 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

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.381 second using v1.01-cache-2.11-cpan-de7293f3b23 )