Commit 2ea6850411c010e2c9a3a5e82aa5161586e80d5b - libdbix-class-inflatecolumn-ip-perl

[svn-inject] Installing original source of libdbix-class-inflatecolumn-ip-perl (0.02001) Jonathan Yu 13 years ago

28 changed file(s) with 2751 addition(s) and 0 deletion(s). Raw diff Collapse all Expand all

+12

-0

Changes less more

	0	Revision history for DBIx::Class::InflateColumn::IP
	1
	2	0.02001 Sun Jun 17 20:27:34 2007
	3	- Initial version of format autodetection, based solely on column type.
	4
	5	0.02000 Thu May 24 11:28:40 2007
	6	- First release uploaded to CPAN.
	7	- Added configuration options for format and class.
	8
	9	0.01 Wed May 23 14:53:10 2007
	10	- First version, released on an unsuspecting world.
	11

+28

-0

MANIFEST less more

	0	Changes
	1	inc/Module/AutoInstall.pm
	2	inc/Module/Install.pm
	3	inc/Module/Install/AutoInstall.pm
	4	inc/Module/Install/Base.pm
	5	inc/Module/Install/Can.pm
	6	inc/Module/Install/Fetch.pm
	7	inc/Module/Install/Include.pm
	8	inc/Module/Install/Makefile.pm
	9	inc/Module/Install/Metadata.pm
	10	inc/Module/Install/Win32.pm
	11	inc/Module/Install/WriteAll.pm
	12	lib/DBIx/Class/InflateColumn/IP.pm
	13	Makefile.PL
	14	MANIFEST
	15	META.yml # Will be created by "make dist"
	16	README
	17	t/00-load.t
	18	t/01-ip.t
	19	t/boilerplate.t
	20	t/lib/DBICTest.pm
	21	t/lib/DBICTest/Schema.pm
	22	t/lib/DBICTest/Schema/Host.pm
	23	t/lib/DBICTest/Schema/Network.pm
	24	t/lib/sqlite.sql
	25	t/pod-coverage.t
	26	t/pod.t
	27	t/style-notabs.t

+20

-0

META.yml less more

	0	---
	1	abstract: Auto-create NetAddr::IP objects from columns.
	2	author: "Dagfinn Ilmari Manns\xE5ker, C<< <ilmari at ilmari.org> >>"
	3	distribution_type: module
	4	generated_by: Module::Install version 0.67
	5	license: perl
	6	meta-spec:
	7	url: http://module-build.sourceforge.net/META-spec-v1.3.html
	8	version: 1.3
	9	name: DBIx-Class-InflateColumn-IP
	10	no_index:
	11	directory:
	12	- inc
	13	- t
	14	requires:
	15	DBIx::Class: 0.07005
	16	NetAddr::IP: 0
	17	perl: 5.6.1
	18	tests: t/*.t
	19	version: 0.02001

+21

-0

Makefile.PL less more

	0	use strict;
	1	use warnings;
	2	use inc::Module::Install 0.65;
	3
	4	name 'DBIx-Class-InflateColumn-IP';
	5	license 'perl';
	6	perl_version '5.006001';
	7	all_from 'lib/DBIx/Class/InflateColumn/IP.pm';
	8
	9	requires 'DBIx::Class' => 0.07005;
	10	requires 'NetAddr::IP';
	11
	12	tests 't/*.t';
	13	clean_files 'DBIx-Class-InflateColumn-IP-* t/var README';
	14
	15	eval {
	16	system 'pod2text lib/DBIx/Class/InflateColumn/IP.pm > README';
	17	};
	18
	19	auto_install;
	20	WriteAll;

+101

-0

README less more

	0	NAME
	1	DBIx::Class::InflateColumn::IP - Auto-create NetAddr::IP objects from
	2	columns.
	3
	4	SYNOPSIS
	5	Load this component and declare columns as IP addresses with the
	6	appropriate format.
	7
	8	package Host;
	9	__PACKAGE__->load_components(qw/InflateColumn::IP Core/);
	10	__PACKAGE__->add_columns(
	11	ip_address => {
	12	data_type => 'integer',
	13	is_nullable => 0,
	14	is_ip => 1,
	15	ip_format => 'numeric',
	16	}
	17	);
	18
	19	package Network;
	20	__PACKAGE__->load_components(qw/InflateColumn::IP Core/);
	21	__PACKAGE__->add_columns(
	22	address => {
	23	data_type => 'varchar',
	24	size => 18
	25	is_nullable => 0,
	26	is_ip => 1,
	27	ip_format => 'cidr',
	28	}
	29	);
	30
	31	Then you can treat the specified column as a NetAddr::IP object.
	32
	33	print 'IP address: ', $host->ip_address->addr;
	34	print 'Address type: ', $host->ip_address->iptype;
	35
	36	DBIx::Class::InflateColumn::IP supports a limited amount of
	37	auto-detection of the format based on the column type. If the type
	38	begins with "int", it's assumed to be numeric, while "inet" and "cidr"
	39	(as used by e.g. PostgreSQL) are assumed to be "cidr" format.
	40
	41	METHODS
	42	ip_class
	43	Arguments: $class
	44
	45	Gets/sets the address class that the columns should be inflated into.
	46	The default class is NetAddr::IP.
	47
	48	ip_format
	49	Arguments: $format
	50
	51	Gets/sets the name of the method used to deflate the address for the
	52	database. This must return a value suitable for "$ip_class-"new(); The
	53	default format is "addr", which returns the address in dotted-quad
	54	notation. See "Methods" in NetAddr::IP for suitable values.
	55
	56	register_column
	57	Chains with "register_column" in DBIx::Class::Row, and sets up IP
	58	address columns appropriately. This would not normally be called
	59	directly by end users.
	60
	61	AUTHOR
	62	Dagfinn Ilmari Mannsåker, "<ilmari at ilmari.org>"
	63
	64	BUGS
	65	Please report any bugs or feature requests to
	66	"bug-dbix-class-inflatecolumn-ip at rt.cpan.org", or through the web
	67	interface at
	68	<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=DBIx-Class-InflateColumn
	69	-IP>. I will be notified, and then you'll automatically be notified of
	70	progress on your bug as I make changes.
	71
	72	SUPPORT
	73	You can find documentation for this module with the perldoc command.
	74
	75	perldoc DBIx::Class::InflateColumn::IP
	76
	77	You can also look for information at:
	78
	79	* AnnoCPAN: Annotated CPAN documentation
	80	<http://annocpan.org/dist/DBIx-Class-InflateColumn-IP>
	81
	82	* CPAN Ratings
	83	<http://cpanratings.perl.org/d/DBIx-Class-InflateColumn-IP>
	84
	85	* RT: CPAN's request tracker
	86	<http://rt.cpan.org/NoAuth/Bugs.html?Dist=DBIx-Class-InflateColumn-I
	87	P>
	88
	89	* Search CPAN
	90	<http://search.cpan.org/dist/DBIx-Class-InflateColumn-IP>
	91
	92	SEE ALSO
	93	DBIx::Class, NetAddr::IP
	94
	95	COPYRIGHT & LICENSE
	96	Copyright 2007 Dagfinn Ilmari Mannsåker, all rights reserved.
	97
	98	This program is free software; you can redistribute it and/or modify it
	99	under the same terms as Perl itself.
	100

+768

-0

inc/Module/AutoInstall.pm less more

	0	#line 1
	1	package Module::AutoInstall;
	2
	3	use strict;
	4	use Cwd ();
	5	use ExtUtils::MakeMaker ();
	6
	7	use vars qw{$VERSION};
	8	BEGIN {
	9	$VERSION = '1.03';
	10	}
	11
	12	# special map on pre-defined feature sets
	13	my %FeatureMap = (
	14	'' => 'Core Features', # XXX: deprecated
	15	'-core' => 'Core Features',
	16	);
	17
	18	# various lexical flags
	19	my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $HasCPANPLUS );
	20	my ( $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly );
	21	my ( $PostambleActions, $PostambleUsed );
	22
	23	# See if it's a testing or non-interactive session
	24	_accept_default( $ENV{AUTOMATED_TESTING} or ! -t STDIN );
	25	_init();
	26
	27	sub _accept_default {
	28	$AcceptDefault = shift;
	29	}
	30
	31	sub missing_modules {
	32	return @Missing;
	33	}
	34
	35	sub do_install {
	36	__PACKAGE__->install(
	37	[
	38	$Config
	39	? ( UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} )
	40	: ()
	41	],
	42	@Missing,
	43	);
	44	}
	45
	46	# initialize various flags, and/or perform install
	47	sub _init {
	48	foreach my $arg (
	49	@ARGV,
	50	split(
	51	/[\s\t]+/,
	52	$ENV{PERL_AUTOINSTALL} \|\| $ENV{PERL_EXTUTILS_AUTOINSTALL} \|\| ''
	53	)
	54	)
	55	{
	56	if ( $arg =~ /^--config=(.*)$/ ) {
	57	$Config = [ split( ',', $1 ) ];
	58	}
	59	elsif ( $arg =~ /^--installdeps=(.*)$/ ) {
	60	__PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) );
	61	exit 0;
	62	}
	63	elsif ( $arg =~ /^--default(?:deps)?$/ ) {
	64	$AcceptDefault = 1;
	65	}
	66	elsif ( $arg =~ /^--check(?:deps)?$/ ) {
	67	$CheckOnly = 1;
	68	}
	69	elsif ( $arg =~ /^--skip(?:deps)?$/ ) {
	70	$SkipInstall = 1;
	71	}
	72	elsif ( $arg =~ /^--test(?:only)?$/ ) {
	73	$TestOnly = 1;
	74	}
	75	}
	76	}
	77
	78	# overrides MakeMaker's prompt() to automatically accept the default choice
	79	sub _prompt {
	80	goto &ExtUtils::MakeMaker::prompt unless $AcceptDefault;
	81
	82	my ( $prompt, $default ) = @_;
	83	my $y = ( $default =~ /^[Yy]/ );
	84
	85	print $prompt, ' [', ( $y ? 'Y' : 'y' ), '/', ( $y ? 'n' : 'N' ), '] ';
	86	print "$default\n";
	87	return $default;
	88	}
	89
	90	# the workhorse
	91	sub import {
	92	my $class = shift;
	93	my @args = @_ or return;
	94	my $core_all;
	95
	96	print "*** $class version " . $class->VERSION . "\n";
	97	print "*** Checking for Perl dependencies...\n";
	98
	99	my $cwd = Cwd::cwd();
	100
	101	$Config = [];
	102
	103	my $maxlen = length(
	104	(
	105	sort { length($b) <=> length($a) }
	106	grep { /^[^\-]/ }
	107	map {
	108	ref($_)
	109	? ( ( ref($_) eq 'HASH' ) ? keys(%$_) : @{$_} )
	110	: ''
	111	}
	112	map { +{@args}->{$_} }
	113	grep { /^[^\-]/ or /^-core$/i } keys %{ +{@args} }
	114	)[0]
	115	);
	116
	117	while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) {
	118	my ( @required, @tests, @skiptests );
	119	my $default = 1;
	120	my $conflict = 0;
	121
	122	if ( $feature =~ m/^-(\w+)$/ ) {
	123	my $option = lc($1);
	124
	125	# check for a newer version of myself
	126	_update_to( $modules, @_ ) and return if $option eq 'version';
	127
	128	# sets CPAN configuration options
	129	$Config = $modules if $option eq 'config';
	130
	131	# promote every features to core status
	132	$core_all = ( $modules =~ /^all$/i ) and next
	133	if $option eq 'core';
	134
	135	next unless $option eq 'core';
	136	}
	137
	138	print "[" . ( $FeatureMap{ lc($feature) } \|\| $feature ) . "]\n";
	139
	140	$modules = [ %{$modules} ] if UNIVERSAL::isa( $modules, 'HASH' );
	141
	142	unshift @$modules, -default => &{ shift(@$modules) }
	143	if ( ref( $modules->[0] ) eq 'CODE' ); # XXX: bugward combatability
	144
	145	while ( my ( $mod, $arg ) = splice( @$modules, 0, 2 ) ) {
	146	if ( $mod =~ m/^-(\w+)$/ ) {
	147	my $option = lc($1);
	148
	149	$default = $arg if ( $option eq 'default' );
	150	$conflict = $arg if ( $option eq 'conflict' );
	151	@tests = @{$arg} if ( $option eq 'tests' );
	152	@skiptests = @{$arg} if ( $option eq 'skiptests' );
	153
	154	next;
	155	}
	156
	157	printf( "- %-${maxlen}s ...", $mod );
	158
	159	if ( $arg and $arg =~ /^\D/ ) {
	160	unshift @$modules, $arg;
	161	$arg = 0;
	162	}
	163
	164	# XXX: check for conflicts and uninstalls(!) them.
	165	if (
	166	defined( my $cur = _version_check( _load($mod), $arg \|\|= 0 ) ) )
	167	{
	168	print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n";
	169	push @Existing, $mod => $arg;
	170	$DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
	171	}
	172	else {
	173	print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n";
	174	push @required, $mod => $arg;
	175	}
	176	}
	177
	178	next unless @required;
	179
	180	my $mandatory = ( $feature eq '-core' or $core_all );
	181
	182	if (
	183	!$SkipInstall
	184	and (
	185	$CheckOnly
	186	or _prompt(
	187	qq{==> Auto-install the }
	188	. ( @required / 2 )
	189	. ( $mandatory ? ' mandatory' : ' optional' )
	190	. qq{ module(s) from CPAN?},
	191	$default ? 'y' : 'n',
	192	) =~ /^[Yy]/
	193	)
	194	)
	195	{
	196	push( @Missing, @required );
	197	$DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
	198	}
	199
	200	elsif ( !$SkipInstall
	201	and $default
	202	and $mandatory
	203	and
	204	_prompt( qq{==> The module(s) are mandatory! Really skip?}, 'n', )
	205	=~ /^[Nn]/ )
	206	{
	207	push( @Missing, @required );
	208	$DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
	209	}
	210
	211	else {
	212	$DisabledTests{$_} = 1 for map { glob($_) } @tests;
	213	}
	214	}
	215
	216	$UnderCPAN = _check_lock(); # check for $UnderCPAN
	217
	218	if ( @Missing and not( $CheckOnly or $UnderCPAN ) ) {
	219	require Config;
	220	print
	221	"*** Dependencies will be installed the next time you type '$Config::Config{make}'.\n";
	222
	223	# make an educated guess of whether we'll need root permission.
	224	print " (You may need to do that as the 'root' user.)\n"
	225	if eval '$>';
	226	}
	227	print "*** $class configuration finished.\n";
	228
	229	chdir $cwd;
	230
	231	# import to main::
	232	no strict 'refs';
	233	*{'main::WriteMakefile'} = \&Write if caller(0) eq 'main';
	234	}
	235
	236	# Check to see if we are currently running under CPAN.pm and/or CPANPLUS;
	237	# if we are, then we simply let it taking care of our dependencies
	238	sub _check_lock {
	239	return unless @Missing;
	240
	241	if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) {
	242	print <<'END_MESSAGE';
	243
	244	*** Since we're running under CPANPLUS, I'll just let it take care
	245	of the dependency's installation later.
	246	END_MESSAGE
	247	return 1;
	248	}
	249
	250	_load_cpan();
	251
	252	# Find the CPAN lock-file
	253	my $lock = MM->catfile( $CPAN::Config->{cpan_home}, ".lock" );
	254	return unless -f $lock;
	255
	256	# Check the lock
	257	local *LOCK;
	258	return unless open(LOCK, $lock);
	259
	260	if (
	261	( $^O eq 'MSWin32' ? _under_cpan() : <LOCK> == getppid() )
	262	and ( $CPAN::Config->{prerequisites_policy} \|\| '' ) ne 'ignore'
	263	) {
	264	print <<'END_MESSAGE';
	265
	266	*** Since we're running under CPAN, I'll just let it take care
	267	of the dependency's installation later.
	268	END_MESSAGE
	269	return 1;
	270	}
	271
	272	close LOCK;
	273	return;
	274	}
	275
	276	sub install {
	277	my $class = shift;
	278
	279	my $i; # used below to strip leading '-' from config keys
	280	my @config = ( map { s/^-// if ++$i; $_ } @{ +shift } );
	281
	282	my ( @modules, @installed );
	283	while ( my ( $pkg, $ver ) = splice( @_, 0, 2 ) ) {
	284
	285	# grep out those already installed
	286	if ( defined( _version_check( _load($pkg), $ver ) ) ) {
	287	push @installed, $pkg;
	288	}
	289	else {
	290	push @modules, $pkg, $ver;
	291	}
	292	}
	293
	294	return @installed unless @modules; # nothing to do
	295	return @installed if _check_lock(); # defer to the CPAN shell
	296
	297	print "*** Installing dependencies...\n";
	298
	299	return unless _connected_to('cpan.org');
	300
	301	my %args = @config;
	302	my %failed;
	303	local *FAILED;
	304	if ( $args{do_once} and open( FAILED, '.#autoinstall.failed' ) ) {
	305	while (<FAILED>) { chomp; $failed{$_}++ }
	306	close FAILED;
	307
	308	my @newmod;
	309	while ( my ( $k, $v ) = splice( @modules, 0, 2 ) ) {
	310	push @newmod, ( $k => $v ) unless $failed{$k};
	311	}
	312	@modules = @newmod;
	313	}
	314
	315	if ( _has_cpanplus() ) {
	316	_install_cpanplus( \@modules, \@config );
	317	} else {
	318	_install_cpan( \@modules, \@config );
	319	}
	320
	321	print "*** $class installation finished.\n";
	322
	323	# see if we have successfully installed them
	324	while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
	325	if ( defined( _version_check( _load($pkg), $ver ) ) ) {
	326	push @installed, $pkg;
	327	}
	328	elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) {
	329	print FAILED "$pkg\n";
	330	}
	331	}
	332
	333	close FAILED if $args{do_once};
	334
	335	return @installed;
	336	}
	337
	338	sub _install_cpanplus {
	339	my @modules = @{ +shift };
	340	my @config = _cpanplus_config( @{ +shift } );
	341	my $installed = 0;
	342
	343	require CPANPLUS::Backend;
	344	my $cp = CPANPLUS::Backend->new;
	345	my $conf = $cp->configure_object;
	346
	347	return unless $conf->can('conf') # 0.05x+ with "sudo" support
	348	or _can_write($conf->_get_build('base')); # 0.04x
	349
	350	# if we're root, set UNINST=1 to avoid trouble unless user asked for it.
	351	my $makeflags = $conf->get_conf('makeflags') \|\| '';
	352	if ( UNIVERSAL::isa( $makeflags, 'HASH' ) ) {
	353	# 0.03+ uses a hashref here
	354	$makeflags->{UNINST} = 1 unless exists $makeflags->{UNINST};
	355
	356	} else {
	357	# 0.02 and below uses a scalar
	358	$makeflags = join( ' ', split( ' ', $makeflags ), 'UNINST=1' )
	359	if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } );
	360
	361	}
	362	$conf->set_conf( makeflags => $makeflags );
	363	$conf->set_conf( prereqs => 1 );
	364
	365
	366
	367	while ( my ( $key, $val ) = splice( @config, 0, 2 ) ) {
	368	$conf->set_conf( $key, $val );
	369	}
	370
	371	my $modtree = $cp->module_tree;
	372	while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
	373	print "*** Installing $pkg...\n";
	374
	375	MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall;
	376
	377	my $success;
	378	my $obj = $modtree->{$pkg};
	379
	380	if ( $obj and defined( _version_check( $obj->{version}, $ver ) ) ) {
	381	my $pathname = $pkg;
	382	$pathname =~ s/::/\\W/;
	383
	384	foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) {
	385	delete $INC{$inc};
	386	}
	387
	388	my $rv = $cp->install( modules => [ $obj->{module} ] );
	389
	390	if ( $rv and ( $rv->{ $obj->{module} } or $rv->{ok} ) ) {
	391	print "*** $pkg successfully installed.\n";
	392	$success = 1;
	393	} else {
	394	print "*** $pkg installation cancelled.\n";
	395	$success = 0;
	396	}
	397
	398	$installed += $success;
	399	} else {
	400	print << ".";
	401	*** Could not find a version $ver or above for $pkg; skipping.
	402	.
	403	}
	404
	405	MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall;
	406	}
	407
	408	return $installed;
	409	}
	410
	411	sub _cpanplus_config {
	412	my @config = ();
	413	while ( @_ ) {
	414	my ($key, $value) = (shift(), shift());
	415	if ( $key eq 'prerequisites_policy' ) {
	416	if ( $value eq 'follow' ) {
	417	$value = CPANPLUS::Internals::Constants::PREREQ_INSTALL();
	418	} elsif ( $value eq 'ask' ) {
	419	$value = CPANPLUS::Internals::Constants::PREREQ_ASK();
	420	} elsif ( $value eq 'ignore' ) {
	421	$value = CPANPLUS::Internals::Constants::PREREQ_IGNORE();
	422	} else {
	423	die "*** Cannot convert option $key = '$value' to CPANPLUS version.\n";
	424	}
	425	} else {
	426	die "*** Cannot convert option $key to CPANPLUS version.\n";
	427	}
	428	}
	429	return @config;
	430	}
	431
	432	sub _install_cpan {
	433	my @modules = @{ +shift };
	434	my @config = @{ +shift };
	435	my $installed = 0;
	436	my %args;
	437
	438	_load_cpan();
	439	require Config;
	440
	441	if (CPAN->VERSION < 1.80) {
	442	# no "sudo" support, probe for writableness
	443	return unless _can_write( MM->catfile( $CPAN::Config->{cpan_home}, 'sources' ) )
	444	and _can_write( $Config::Config{sitelib} );
	445	}
	446
	447	# if we're root, set UNINST=1 to avoid trouble unless user asked for it.
	448	my $makeflags = $CPAN::Config->{make_install_arg} \|\| '';
	449	$CPAN::Config->{make_install_arg} =
	450	join( ' ', split( ' ', $makeflags ), 'UNINST=1' )
	451	if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } );
	452
	453	# don't show start-up info
	454	$CPAN::Config->{inhibit_startup_message} = 1;
	455
	456	# set additional options
	457	while ( my ( $opt, $arg ) = splice( @config, 0, 2 ) ) {
	458	( $args{$opt} = $arg, next )
	459	if $opt =~ /^force$/; # pseudo-option
	460	$CPAN::Config->{$opt} = $arg;
	461	}
	462
	463	local $CPAN::Config->{prerequisites_policy} = 'follow';
	464
	465	while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
	466	MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall;
	467
	468	print "*** Installing $pkg...\n";
	469
	470	my $obj = CPAN::Shell->expand( Module => $pkg );
	471	my $success = 0;
	472
	473	if ( $obj and defined( _version_check( $obj->cpan_version, $ver ) ) ) {
	474	my $pathname = $pkg;
	475	$pathname =~ s/::/\\W/;
	476
	477	foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) {
	478	delete $INC{$inc};
	479	}
	480
	481	my $rv = $args{force} ? CPAN::Shell->force( install => $pkg )
	482	: CPAN::Shell->install($pkg);
	483	$rv \|\|= eval {
	484	$CPAN::META->instance( 'CPAN::Distribution', $obj->cpan_file, )
	485	->{install}
	486	if $CPAN::META;
	487	};
	488
	489	if ( $rv eq 'YES' ) {
	490	print "*** $pkg successfully installed.\n";
	491	$success = 1;
	492	}
	493	else {
	494	print "*** $pkg installation failed.\n";
	495	$success = 0;
	496	}
	497
	498	$installed += $success;
	499	}
	500	else {
	501	print << ".";
	502	*** Could not find a version $ver or above for $pkg; skipping.
	503	.
	504	}
	505
	506	MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall;
	507	}
	508
	509	return $installed;
	510	}
	511
	512	sub _has_cpanplus {
	513	return (
	514	$HasCPANPLUS = (
	515	$INC{'CPANPLUS/Config.pm'}
	516	or _load('CPANPLUS::Shell::Default')
	517	)
	518	);
	519	}
	520
	521	# make guesses on whether we're under the CPAN installation directory
	522	sub _under_cpan {
	523	require Cwd;
	524	require File::Spec;
	525
	526	my $cwd = File::Spec->canonpath( Cwd::cwd() );
	527	my $cpan = File::Spec->canonpath( $CPAN::Config->{cpan_home} );
	528
	529	return ( index( $cwd, $cpan ) > -1 );
	530	}
	531
	532	sub _update_to {
	533	my $class = __PACKAGE__;
	534	my $ver = shift;
	535
	536	return
	537	if defined( _version_check( _load($class), $ver ) ); # no need to upgrade
	538
	539	if (
	540	_prompt( "==> A newer version of $class ($ver) is required. Install?",
	541	'y' ) =~ /^[Nn]/
	542	)
	543	{
	544	die "*** Please install $class $ver manually.\n";
	545	}
	546
	547	print << ".";
	548	*** Trying to fetch it from CPAN...
	549	.
	550
	551	# install ourselves
	552	_load($class) and return $class->import(@_)
	553	if $class->install( [], $class, $ver );
	554
	555	print << '.'; exit 1;
	556
	557	*** Cannot bootstrap myself. :-( Installation terminated.
	558	.
	559	}
	560
	561	# check if we're connected to some host, using inet_aton
	562	sub _connected_to {
	563	my $site = shift;
	564
	565	return (
	566	( _load('Socket') and Socket::inet_aton($site) ) or _prompt(
	567	qq(
	568	*** Your host cannot resolve the domain name '$site', which
	569	probably means the Internet connections are unavailable.
	570	==> Should we try to install the required module(s) anyway?), 'n'
	571	) =~ /^[Yy]/
	572	);
	573	}
	574
	575	# check if a directory is writable; may create it on demand
	576	sub _can_write {
	577	my $path = shift;
	578	mkdir( $path, 0755 ) unless -e $path;
	579
	580	return 1 if -w $path;
	581
	582	print << ".";
	583	*** You are not allowed to write to the directory '$path';
	584	the installation may fail due to insufficient permissions.
	585	.
	586
	587	if (
	588	eval '$>' and lc(`sudo -V`) =~ /version/ and _prompt(
	589	qq(
	590	==> Should we try to re-execute the autoinstall process with 'sudo'?),
	591	((-t STDIN) ? 'y' : 'n')
	592	) =~ /^[Yy]/
	593	)
	594	{
	595
	596	# try to bootstrap ourselves from sudo
	597	print << ".";
	598	*** Trying to re-execute the autoinstall process with 'sudo'...
	599	.
	600	my $missing = join( ',', @Missing );
	601	my $config = join( ',',
	602	UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} )
	603	if $Config;
	604
	605	return
	606	unless system( 'sudo', $^X, $0, "--config=$config",
	607	"--installdeps=$missing" );
	608
	609	print << ".";
	610	*** The 'sudo' command exited with error! Resuming...
	611	.
	612	}
	613
	614	return _prompt(
	615	qq(
	616	==> Should we try to install the required module(s) anyway?), 'n'
	617	) =~ /^[Yy]/;
	618	}
	619
	620	# load a module and return the version it reports
	621	sub _load {
	622	my $mod = pop; # class/instance doesn't matter
	623	my $file = $mod;
	624
	625	$file =~ s\|::\|/\|g;
	626	$file .= '.pm';
	627
	628	local $@;
	629	return eval { require $file; $mod->VERSION } \|\| ( $@ ? undef: 0 );
	630	}
	631
	632	# Load CPAN.pm and it's configuration
	633	sub _load_cpan {
	634	return if $CPAN::VERSION;
	635	require CPAN;
	636	if ( $CPAN::HandleConfig::VERSION ) {
	637	# Newer versions of CPAN have a HandleConfig module
	638	CPAN::HandleConfig->load;
	639	} else {
	640	# Older versions had the load method in Config directly
	641	CPAN::Config->load;
	642	}
	643	}
	644
	645	# compare two versions, either use Sort::Versions or plain comparison
	646	sub _version_check {
	647	my ( $cur, $min ) = @_;
	648	return unless defined $cur;
	649
	650	$cur =~ s/\s+$//;
	651
	652	# check for version numbers that are not in decimal format
	653	if ( ref($cur) or ref($min) or $cur =~ /v\|\..\./ or $min =~ /v\|\..\./ ) {
	654	if ( ( $version::VERSION or defined( _load('version') )) and
	655	version->can('new')
	656	) {
	657
	658	# use version.pm if it is installed.
	659	return (
	660	( version->new($cur) >= version->new($min) ) ? $cur : undef );
	661	}
	662	elsif ( $Sort::Versions::VERSION or defined( _load('Sort::Versions') ) )
	663	{
	664
	665	# use Sort::Versions as the sorting algorithm for a.b.c versions
	666	return ( ( Sort::Versions::versioncmp( $cur, $min ) != -1 )
	667	? $cur
	668	: undef );
	669	}
	670
	671	warn "Cannot reliably compare non-decimal formatted versions.\n"
	672	. "Please install version.pm or Sort::Versions.\n";
	673	}
	674
	675	# plain comparison
	676	local $^W = 0; # shuts off 'not numeric' bugs
	677	return ( $cur >= $min ? $cur : undef );
	678	}
	679
	680	# nothing; this usage is deprecated.
	681	sub main::PREREQ_PM { return {}; }
	682
	683	sub _make_args {
	684	my %args = @_;
	685
	686	$args{PREREQ_PM} = { %{ $args{PREREQ_PM} \|\| {} }, @Existing, @Missing }
	687	if $UnderCPAN or $TestOnly;
	688
	689	if ( $args{EXE_FILES} and -e 'MANIFEST' ) {
	690	require ExtUtils::Manifest;
	691	my $manifest = ExtUtils::Manifest::maniread('MANIFEST');
	692
	693	$args{EXE_FILES} =
	694	[ grep { exists $manifest->{$_} } @{ $args{EXE_FILES} } ];
	695	}
	696
	697	$args{test}{TESTS} \|\|= 't/*.t';
	698	$args{test}{TESTS} = join( ' ',
	699	grep { !exists( $DisabledTests{$_} ) }
	700	map { glob($_) } split( /\s+/, $args{test}{TESTS} ) );
	701
	702	my $missing = join( ',', @Missing );
	703	my $config =
	704	join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} )
	705	if $Config;
	706
	707	$PostambleActions = (
	708	$missing
	709	? "\$(PERL) $0 --config=$config --installdeps=$missing"
	710	: "\$(NOECHO) \$(NOOP)"
	711	);
	712
	713	return %args;
	714	}
	715
	716	# a wrapper to ExtUtils::MakeMaker::WriteMakefile
	717	sub Write {
	718	require Carp;
	719	Carp::croak "WriteMakefile: Need even number of args" if @_ % 2;
	720
	721	if ($CheckOnly) {
	722	print << ".";
	723	*** Makefile not written in check-only mode.
	724	.
	725	return;
	726	}
	727
	728	my %args = _make_args(@_);
	729
	730	no strict 'refs';
	731
	732	$PostambleUsed = 0;
	733	local *MY::postamble = \&postamble unless defined &MY::postamble;
	734	ExtUtils::MakeMaker::WriteMakefile(%args);
	735
	736	print << "." unless $PostambleUsed;
	737	*** WARNING: Makefile written with customized MY::postamble() without
	738	including contents from Module::AutoInstall::postamble() --
	739	auto installation features disabled. Please contact the author.
	740	.
	741
	742	return 1;
	743	}
	744
	745	sub postamble {
	746	$PostambleUsed = 1;
	747
	748	return << ".";
	749
	750	config :: installdeps
	751	\t\$(NOECHO) \$(NOOP)
	752
	753	checkdeps ::
	754	\t\$(PERL) $0 --checkdeps
	755
	756	installdeps ::
	757	\t$PostambleActions
	758
	759	.
	760
	761	}
	762
	763	1;
	764
	765	__END__
	766
	767	#line 1003

+61

-0

inc/Module/Install/AutoInstall.pm less more

	0	#line 1
	1	package Module::Install::AutoInstall;
	2
	3	use strict;
	4	use Module::Install::Base;
	5
	6	use vars qw{$VERSION $ISCORE @ISA};
	7	BEGIN {
	8	$VERSION = '0.67';
	9	$ISCORE = 1;
	10	@ISA = qw{Module::Install::Base};
	11	}
	12
	13	sub AutoInstall { $_[0] }
	14
	15	sub run {
	16	my $self = shift;
	17	$self->auto_install_now(@_);
	18	}
	19
	20	sub write {
	21	my $self = shift;
	22	$self->auto_install(@_);
	23	}
	24
	25	sub auto_install {
	26	my $self = shift;
	27	return if $self->{done}++;
	28
	29	# Flatten array of arrays into a single array
	30	my @core = map @$_, map @$_, grep ref,
	31	$self->build_requires, $self->requires;
	32
	33	my @config = @_;
	34
	35	# We'll need Module::AutoInstall
	36	$self->include('Module::AutoInstall');
	37	require Module::AutoInstall;
	38
	39	Module::AutoInstall->import(
	40	(@config ? (-config => \@config) : ()),
	41	(@core ? (-core => \@core) : ()),
	42	$self->features,
	43	);
	44
	45	$self->makemaker_args( Module::AutoInstall::_make_args() );
	46
	47	my $class = ref($self);
	48	$self->postamble(
	49	"# --- $class section:\n" .
	50	Module::AutoInstall::postamble()
	51	);
	52	}
	53
	54	sub auto_install_now {
	55	my $self = shift;
	56	$self->auto_install(@_);
	57	Module::AutoInstall::do_install();
	58	}
	59
	60	1;

+70

-0

inc/Module/Install/Base.pm less more

	0	#line 1
	1	package Module::Install::Base;
	2
	3	$VERSION = '0.67';
	4
	5	# Suspend handler for "redefined" warnings
	6	BEGIN {
	7	my $w = $SIG{__WARN__};
	8	$SIG{__WARN__} = sub { $w };
	9	}
	10
	11	### This is the ONLY module that shouldn't have strict on
	12	# use strict;
	13
	14	#line 41
	15
	16	sub new {
	17	my ($class, %args) = @_;
	18
	19	foreach my $method ( qw(call load) ) {
	20	*{"$class\::$method"} = sub {
	21	shift()->_top->$method(@_);
	22	} unless defined &{"$class\::$method"};
	23	}
	24
	25	bless( \%args, $class );
	26	}
	27
	28	#line 61
	29
	30	sub AUTOLOAD {
	31	my $self = shift;
	32	local $@;
	33	my $autoload = eval { $self->_top->autoload } or return;
	34	goto &$autoload;
	35	}
	36
	37	#line 76
	38
	39	sub _top { $_[0]->{_top} }
	40
	41	#line 89
	42
	43	sub admin {
	44	$_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new;
	45	}
	46
	47	sub is_admin {
	48	$_[0]->admin->VERSION;
	49	}
	50
	51	sub DESTROY {}
	52
	53	package Module::Install::Base::FakeAdmin;
	54
	55	my $Fake;
	56	sub new { $Fake \|\|= bless(\@_, $_[0]) }
	57
	58	sub AUTOLOAD {}
	59
	60	sub DESTROY {}
	61
	62	# Restore warning handler
	63	BEGIN {
	64	$SIG{__WARN__} = $SIG{__WARN__}->();
	65	}
	66
	67	1;
	68
	69	#line 138

+82

-0

inc/Module/Install/Can.pm less more

	0	#line 1
	1	package Module::Install::Can;
	2
	3	use strict;
	4	use Module::Install::Base;
	5	use Config ();
	6	### This adds a 5.005 Perl version dependency.
	7	### This is a bug and will be fixed.
	8	use File::Spec ();
	9	use ExtUtils::MakeMaker ();
	10
	11	use vars qw{$VERSION $ISCORE @ISA};
	12	BEGIN {
	13	$VERSION = '0.67';
	14	$ISCORE = 1;
	15	@ISA = qw{Module::Install::Base};
	16	}
	17
	18	# check if we can load some module
	19	### Upgrade this to not have to load the module if possible
	20	sub can_use {
	21	my ($self, $mod, $ver) = @_;
	22	$mod =~ s{::\|\\}{/}g;
	23	$mod .= '.pm' unless $mod =~ /\.pm$/i;
	24
	25	my $pkg = $mod;
	26	$pkg =~ s{/}{::}g;
	27	$pkg =~ s{\.pm$}{}i;
	28
	29	local $@;
	30	eval { require $mod; $pkg->VERSION($ver \|\| 0); 1 };
	31	}
	32
	33	# check if we can run some command
	34	sub can_run {
	35	my ($self, $cmd) = @_;
	36
	37	my $_cmd = $cmd;
	38	return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd));
	39
	40	for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') {
	41	my $abs = File::Spec->catfile($dir, $_[1]);
	42	return $abs if (-x $abs or $abs = MM->maybe_command($abs));
	43	}
	44
	45	return;
	46	}
	47
	48	# can we locate a (the) C compiler
	49	sub can_cc {
	50	my $self = shift;
	51	my @chunks = split(/ /, $Config::Config{cc}) or return;
	52
	53	# $Config{cc} may contain args; try to find out the program part
	54	while (@chunks) {
	55	return $self->can_run("@chunks") \|\| (pop(@chunks), next);
	56	}
	57
	58	return;
	59	}
	60
	61	# Fix Cygwin bug on maybe_command();
	62	if ( $^O eq 'cygwin' ) {
	63	require ExtUtils::MM_Cygwin;
	64	require ExtUtils::MM_Win32;
	65	if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) {
	66	*ExtUtils::MM_Cygwin::maybe_command = sub {
	67	my ($self, $file) = @_;
	68	if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) {
	69	ExtUtils::MM_Win32->maybe_command($file);
	70	} else {
	71	ExtUtils::MM_Unix->maybe_command($file);
	72	}
	73	}
	74	}
	75	}
	76
	77	1;
	78
	79	__END__
	80
	81	#line 157

+93

-0

inc/Module/Install/Fetch.pm less more

	0	#line 1
	1	package Module::Install::Fetch;
	2
	3	use strict;
	4	use Module::Install::Base;
	5
	6	use vars qw{$VERSION $ISCORE @ISA};
	7	BEGIN {
	8	$VERSION = '0.67';
	9	$ISCORE = 1;
	10	@ISA = qw{Module::Install::Base};
	11	}
	12
	13	sub get_file {
	14	my ($self, %args) = @_;
	15	my ($scheme, $host, $path, $file) =
	16	$args{url} =~ m\|^(\w+)://([^/]+)(.+)/(.+)\| or return;
	17
	18	if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) {
	19	$args{url} = $args{ftp_url}
	20	or (warn("LWP support unavailable!\n"), return);
	21	($scheme, $host, $path, $file) =
	22	$args{url} =~ m\|^(\w+)://([^/]+)(.+)/(.+)\| or return;
	23	}
	24
	25	$\|++;
	26	print "Fetching '$file' from $host... ";
	27
	28	unless (eval { require Socket; Socket::inet_aton($host) }) {
	29	warn "'$host' resolve failed!\n";
	30	return;
	31	}
	32
	33	return unless $scheme eq 'ftp' or $scheme eq 'http';
	34
	35	require Cwd;
	36	my $dir = Cwd::getcwd();
	37	chdir $args{local_dir} or return if exists $args{local_dir};
	38
	39	if (eval { require LWP::Simple; 1 }) {
	40	LWP::Simple::mirror($args{url}, $file);
	41	}
	42	elsif (eval { require Net::FTP; 1 }) { eval {
	43	# use Net::FTP to get past firewall
	44	my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600);
	45	$ftp->login("anonymous", 'anonymous@example.com');
	46	$ftp->cwd($path);
	47	$ftp->binary;
	48	$ftp->get($file) or (warn("$!\n"), return);
	49	$ftp->quit;
	50	} }
	51	elsif (my $ftp = $self->can_run('ftp')) { eval {
	52	# no Net::FTP, fallback to ftp.exe
	53	require FileHandle;
	54	my $fh = FileHandle->new;
	55
	56	local $SIG{CHLD} = 'IGNORE';
	57	unless ($fh->open("\|$ftp -n")) {
	58	warn "Couldn't open ftp: $!\n";
	59	chdir $dir; return;
	60	}
	61
	62	my @dialog = split(/\n/, <<"END_FTP");
	63	open $host
	64	user anonymous anonymous\@example.com
	65	cd $path
	66	binary
	67	get $file $file
	68	quit
	69	END_FTP
	70	foreach (@dialog) { $fh->print("$_\n") }
	71	$fh->close;
	72	} }
	73	else {
	74	warn "No working 'ftp' program available!\n";
	75	chdir $dir; return;
	76	}
	77
	78	unless (-f $file) {
	79	warn "Fetching failed: $@\n";
	80	chdir $dir; return;
	81	}
	82
	83	return if exists $args{size} and -s $file != $args{size};
	84	system($args{run}) if exists $args{run};
	85	unlink($file) if $args{remove};
	86
	87	print(((!exists $args{check_for} or -e $args{check_for})
	88	? "done!" : "failed! ($!)"), "\n");
	89	chdir $dir; return !$?;
	90	}
	91
	92	1;

+34

-0

inc/Module/Install/Include.pm less more

	0	#line 1
	1	package Module::Install::Include;
	2
	3	use strict;
	4	use Module::Install::Base;
	5
	6	use vars qw{$VERSION $ISCORE @ISA};
	7	BEGIN {
	8	$VERSION = '0.67';
	9	$ISCORE = 1;
	10	@ISA = qw{Module::Install::Base};
	11	}
	12
	13	sub include {
	14	shift()->admin->include(@_);
	15	}
	16
	17	sub include_deps {
	18	shift()->admin->include_deps(@_);
	19	}
	20
	21	sub auto_include {
	22	shift()->admin->auto_include(@_);
	23	}
	24
	25	sub auto_include_deps {
	26	shift()->admin->auto_include_deps(@_);
	27	}
	28
	29	sub auto_include_dependent_dists {
	30	shift()->admin->auto_include_dependent_dists(@_);
	31	}
	32
	33	1;

+237

-0

inc/Module/Install/Makefile.pm less more

	0	#line 1
	1	package Module::Install::Makefile;
	2
	3	use strict 'vars';
	4	use Module::Install::Base;
	5	use ExtUtils::MakeMaker ();
	6
	7	use vars qw{$VERSION $ISCORE @ISA};
	8	BEGIN {
	9	$VERSION = '0.67';
	10	$ISCORE = 1;
	11	@ISA = qw{Module::Install::Base};
	12	}
	13
	14	sub Makefile { $_[0] }
	15
	16	my %seen = ();
	17
	18	sub prompt {
	19	shift;
	20
	21	# Infinite loop protection
	22	my @c = caller();
	23	if ( ++$seen{"$c[1]\|$c[2]\|$_[0]"} > 3 ) {
	24	die "Caught an potential prompt infinite loop ($c[1]\|$c[2]\|$_[0])";
	25	}
	26
	27	# In automated testing, always use defaults
	28	if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) {
	29	local $ENV{PERL_MM_USE_DEFAULT} = 1;
	30	goto &ExtUtils::MakeMaker::prompt;
	31	} else {
	32	goto &ExtUtils::MakeMaker::prompt;
	33	}
	34	}
	35
	36	sub makemaker_args {
	37	my $self = shift;
	38	my $args = ($self->{makemaker_args} \|\|= {});
	39	%$args = ( %$args, @_ ) if @_;
	40	$args;
	41	}
	42
	43	# For mm args that take multiple space-seperated args,
	44	# append an argument to the current list.
	45	sub makemaker_append {
	46	my $self = sShift;
	47	my $name = shift;
	48	my $args = $self->makemaker_args;
	49	$args->{name} = defined $args->{$name}
	50	? join( ' ', $args->{name}, @_ )
	51	: join( ' ', @_ );
	52	}
	53
	54	sub build_subdirs {
	55	my $self = shift;
	56	my $subdirs = $self->makemaker_args->{DIR} \|\|= [];
	57	for my $subdir (@_) {
	58	push @$subdirs, $subdir;
	59	}
	60	}
	61
	62	sub clean_files {
	63	my $self = shift;
	64	my $clean = $self->makemaker_args->{clean} \|\|= {};
	65	%$clean = (
	66	%$clean,
	67	FILES => join(' ', grep length, $clean->{FILES}, @_),
	68	);
	69	}
	70
	71	sub realclean_files {
	72	my $self = shift;
	73	my $realclean = $self->makemaker_args->{realclean} \|\|= {};
	74	%$realclean = (
	75	%$realclean,
	76	FILES => join(' ', grep length, $realclean->{FILES}, @_),
	77	);
	78	}
	79
	80	sub libs {
	81	my $self = shift;
	82	my $libs = ref $_[0] ? shift : [ shift ];
	83	$self->makemaker_args( LIBS => $libs );
	84	}
	85
	86	sub inc {
	87	my $self = shift;
	88	$self->makemaker_args( INC => shift );
	89	}
	90
	91	my %test_dir = ();
	92
	93	sub _wanted_t {
	94	/\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1;
	95	}
	96
	97	sub tests_recursive {
	98	my $self = shift;
	99	if ( $self->tests ) {
	100	die "tests_recursive will not work if tests are already defined";
	101	}
	102	my $dir = shift \|\| 't';
	103	unless ( -d $dir ) {
	104	die "tests_recursive dir '$dir' does not exist";
	105	}
	106	require File::Find;
	107	%test_dir = ();
	108	File::Find::find( \&_wanted_t, $dir );
	109	$self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir );
	110	}
	111
	112	sub write {
	113	my $self = shift;
	114	die "&Makefile->write() takes no arguments\n" if @_;
	115
	116	my $args = $self->makemaker_args;
	117	$args->{DISTNAME} = $self->name;
	118	$args->{NAME} = $self->module_name \|\| $self->name \|\| $self->determine_NAME($args);
	119	$args->{VERSION} = $self->version \|\| $self->determine_VERSION($args);
	120	$args->{NAME} =~ s/-/::/g;
	121	if ( $self->tests ) {
	122	$args->{test} = { TESTS => $self->tests };
	123	}
	124	if ($] >= 5.005) {
	125	$args->{ABSTRACT} = $self->abstract;
	126	$args->{AUTHOR} = $self->author;
	127	}
	128	if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) {
	129	$args->{NO_META} = 1;
	130	}
	131	if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) {
	132	$args->{SIGN} = 1;
	133	}
	134	unless ( $self->is_admin ) {
	135	delete $args->{SIGN};
	136	}
	137
	138	# merge both kinds of requires into prereq_pm
	139	my $prereq = ($args->{PREREQ_PM} \|\|= {});
	140	%$prereq = ( %$prereq,
	141	map { @$_ }
	142	map { @$_ }
	143	grep $_,
	144	($self->build_requires, $self->requires)
	145	);
	146
	147	# merge both kinds of requires into prereq_pm
	148	my $subdirs = ($args->{DIR} \|\|= []);
	149	if ($self->bundles) {
	150	foreach my $bundle (@{ $self->bundles }) {
	151	my ($file, $dir) = @$bundle;
	152	push @$subdirs, $dir if -d $dir;
	153	delete $prereq->{$file};
	154	}
	155	}
	156
	157	if ( my $perl_version = $self->perl_version ) {
	158	eval "use $perl_version; 1"
	159	or die "ERROR: perl: Version $] is installed, "
	160	. "but we need version >= $perl_version";
	161	}
	162
	163	$args->{INSTALLDIRS} = $self->installdirs;
	164
	165	my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args;
	166
	167	my $user_preop = delete $args{dist}->{PREOP};
	168	if (my $preop = $self->admin->preop($user_preop)) {
	169	$args{dist} = $preop;
	170	}
	171
	172	my $mm = ExtUtils::MakeMaker::WriteMakefile(%args);
	173	$self->fix_up_makefile($mm->{FIRST_MAKEFILE} \|\| 'Makefile');
	174	}
	175
	176	sub fix_up_makefile {
	177	my $self = shift;
	178	my $makefile_name = shift;
	179	my $top_class = ref($self->_top) \|\| '';
	180	my $top_version = $self->_top->VERSION \|\| '';
	181
	182	my $preamble = $self->preamble
	183	? "# Preamble by $top_class $top_version\n"
	184	. $self->preamble
	185	: '';
	186	my $postamble = "# Postamble by $top_class $top_version\n"
	187	. ($self->postamble \|\| '');
	188
	189	local *MAKEFILE;
	190	open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
	191	my $makefile = do { local $/; <MAKEFILE> };
	192	close MAKEFILE or die $!;
	193
	194	$makefile =~ s/\b(test_harness$\$\(TEST_VERBOSE$, )/$1'inc', /;
	195	$makefile =~ s/( -I\$$INST_ARCHLIB$)/ -Iinc$1/g;
	196	$makefile =~ s/( "-I\$$INST_LIB$")/ "-Iinc"$1/g;
	197	$makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m;
	198	$makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m;
	199
	200	# Module::Install will never be used to build the Core Perl
	201	# Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks
	202	# PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist
	203	$makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m;
	204	#$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m;
	205
	206	# Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well.
	207	$makefile =~ s/("?)-I\$$PERL_LIB$\1//g;
	208
	209	# XXX - This is currently unused; not sure if it breaks other MM-users
	210	# $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg;
	211
	212	open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
	213	print MAKEFILE "$preamble$makefile$postamble" or die $!;
	214	close MAKEFILE or die $!;
	215
	216	1;
	217	}
	218
	219	sub preamble {
	220	my ($self, $text) = @_;
	221	$self->{preamble} = $text . $self->{preamble} if defined $text;
	222	$self->{preamble};
	223	}
	224
	225	sub postamble {
	226	my ($self, $text) = @_;
	227	$self->{postamble} \|\|= $self->admin->postamble;
	228	$self->{postamble} .= $text if defined $text;
	229	$self->{postamble}
	230	}
	231
	232	1;
	233
	234	__END__
	235
	236	#line 363

+336

-0

inc/Module/Install/Metadata.pm less more

	0	#line 1
	1	package Module::Install::Metadata;
	2
	3	use strict 'vars';
	4	use Module::Install::Base;
	5
	6	use vars qw{$VERSION $ISCORE @ISA};
	7	BEGIN {
	8	$VERSION = '0.67';
	9	$ISCORE = 1;
	10	@ISA = qw{Module::Install::Base};
	11	}
	12
	13	my @scalar_keys = qw{
	14	name module_name abstract author version license
	15	distribution_type perl_version tests installdirs
	16	};
	17
	18	my @tuple_keys = qw{
	19	build_requires requires recommends bundles
	20	};
	21
	22	sub Meta { shift }
	23	sub Meta_ScalarKeys { @scalar_keys }
	24	sub Meta_TupleKeys { @tuple_keys }
	25
	26	foreach my $key (@scalar_keys) {
	27	*$key = sub {
	28	my $self = shift;
	29	return $self->{values}{$key} if defined wantarray and !@_;
	30	$self->{values}{$key} = shift;
	31	return $self;
	32	};
	33	}
	34
	35	foreach my $key (@tuple_keys) {
	36	*$key = sub {
	37	my $self = shift;
	38	return $self->{values}{$key} unless @_;
	39
	40	my @rv;
	41	while (@_) {
	42	my $module = shift or last;
	43	my $version = shift \|\| 0;
	44	if ( $module eq 'perl' ) {
	45	$version =~ s{^(\d+)\.(\d+)\.(\d+)}
	46	{$1 + $2/1_000 + $3/1_000_000}e;
	47	$self->perl_version($version);
	48	next;
	49	}
	50	my $rv = [ $module, $version ];
	51	push @rv, $rv;
	52	}
	53	push @{ $self->{values}{$key} }, @rv;
	54	@rv;
	55	};
	56	}
	57
	58	# configure_requires is currently a null-op
	59	sub configure_requires { 1 }
	60
	61	# Aliases for build_requires that will have alternative
	62	# meanings in some future version of META.yml.
	63	sub test_requires { shift->build_requires(@_) }
	64	sub install_requires { shift->build_requires(@_) }
	65
	66	# Aliases for installdirs options
	67	sub install_as_core { $_[0]->installdirs('perl') }
	68	sub install_as_cpan { $_[0]->installdirs('site') }
	69	sub install_as_site { $_[0]->installdirs('site') }
	70	sub install_as_vendor { $_[0]->installdirs('vendor') }
	71
	72	sub sign {
	73	my $self = shift;
	74	return $self->{'values'}{'sign'} if defined wantarray and ! @_;
	75	$self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 );
	76	return $self;
	77	}
	78
	79	sub dynamic_config {
	80	my $self = shift;
	81	unless ( @_ ) {
	82	warn "You MUST provide an explicit true/false value to dynamic_config, skipping\n";
	83	return $self;
	84	}
	85	$self->{'values'}{'dynamic_config'} = $_[0] ? 1 : 0;
	86	return $self;
	87	}
	88
	89	sub all_from {
	90	my ( $self, $file ) = @_;
	91
	92	unless ( defined($file) ) {
	93	my $name = $self->name
	94	or die "all_from called with no args without setting name() first";
	95	$file = join('/', 'lib', split(/-/, $name)) . '.pm';
	96	$file =~ s{.*/}{} unless -e $file;
	97	die "all_from: cannot find $file from $name" unless -e $file;
	98	}
	99
	100	$self->version_from($file) unless $self->version;
	101	$self->perl_version_from($file) unless $self->perl_version;
	102
	103	# The remaining probes read from POD sections; if the file
	104	# has an accompanying .pod, use that instead
	105	my $pod = $file;
	106	if ( $pod =~ s/\.pm$/.pod/i and -e $pod ) {
	107	$file = $pod;
	108	}
	109
	110	$self->author_from($file) unless $self->author;
	111	$self->license_from($file) unless $self->license;
	112	$self->abstract_from($file) unless $self->abstract;
	113	}
	114
	115	sub provides {
	116	my $self = shift;
	117	my $provides = ( $self->{values}{provides} \|\|= {} );
	118	%$provides = (%$provides, @_) if @_;
	119	return $provides;
	120	}
	121
	122	sub auto_provides {
	123	my $self = shift;
	124	return $self unless $self->is_admin;
	125
	126	unless (-e 'MANIFEST') {
	127	warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
	128	return $self;
	129	}
	130
	131	# Avoid spurious warnings as we are not checking manifest here.
	132
	133	local $SIG{__WARN__} = sub {1};
	134	require ExtUtils::Manifest;
	135	local *ExtUtils::Manifest::manicheck = sub { return };
	136
	137	require Module::Build;
	138	my $build = Module::Build->new(
	139	dist_name => $self->name,
	140	dist_version => $self->version,
	141	license => $self->license,
	142	);
	143	$self->provides(%{ $build->find_dist_packages \|\| {} });
	144	}
	145
	146	sub feature {
	147	my $self = shift;
	148	my $name = shift;
	149	my $features = ( $self->{values}{features} \|\|= [] );
	150
	151	my $mods;
	152
	153	if ( @_ == 1 and ref( $_[0] ) ) {
	154	# The user used ->feature like ->features by passing in the second
	155	# argument as a reference. Accomodate for that.
	156	$mods = $_[0];
	157	} else {
	158	$mods = \@_;
	159	}
	160
	161	my $count = 0;
	162	push @$features, (
	163	$name => [
	164	map {
	165	ref($_) ? ( ref($_) eq 'HASH' ) ? %$_
	166	: @$_
	167	: $_
	168	} @$mods
	169	]
	170	);
	171
	172	return @$features;
	173	}
	174
	175	sub features {
	176	my $self = shift;
	177	while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
	178	$self->feature( $name, @$mods );
	179	}
	180	return $self->{values}->{features}
	181	? @{ $self->{values}->{features} }
	182	: ();
	183	}
	184
	185	sub no_index {
	186	my $self = shift;
	187	my $type = shift;
	188	push @{ $self->{values}{no_index}{$type} }, @_ if $type;
	189	return $self->{values}{no_index};
	190	}
	191
	192	sub read {
	193	my $self = shift;
	194	$self->include_deps( 'YAML', 0 );
	195
	196	require YAML;
	197	my $data = YAML::LoadFile('META.yml');
	198
	199	# Call methods explicitly in case user has already set some values.
	200	while ( my ( $key, $value ) = each %$data ) {
	201	next unless $self->can($key);
	202	if ( ref $value eq 'HASH' ) {
	203	while ( my ( $module, $version ) = each %$value ) {
	204	$self->can($key)->($self, $module => $version );
	205	}
	206	}
	207	else {
	208	$self->can($key)->($self, $value);
	209	}
	210	}
	211	return $self;
	212	}
	213
	214	sub write {
	215	my $self = shift;
	216	return $self unless $self->is_admin;
	217	$self->admin->write_meta;
	218	return $self;
	219	}
	220
	221	sub version_from {
	222	my ( $self, $file ) = @_;
	223	require ExtUtils::MM_Unix;
	224	$self->version( ExtUtils::MM_Unix->parse_version($file) );
	225	}
	226
	227	sub abstract_from {
	228	my ( $self, $file ) = @_;
	229	require ExtUtils::MM_Unix;
	230	$self->abstract(
	231	bless(
	232	{ DISTNAME => $self->name },
	233	'ExtUtils::MM_Unix'
	234	)->parse_abstract($file)
	235	);
	236	}
	237
	238	sub _slurp {
	239	my ( $self, $file ) = @_;
	240
	241	local *FH;
	242	open FH, "< $file" or die "Cannot open $file.pod: $!";
	243	do { local $/; <FH> };
	244	}
	245
	246	sub perl_version_from {
	247	my ( $self, $file ) = @_;
	248
	249	if (
	250	$self->_slurp($file) =~ m/
	251	^
	252	use \s*
	253	v?
	254	([\d_\.]+)
	255	\s* ;
	256	/ixms
	257	)
	258	{
	259	my $v = $1;
	260	$v =~ s{_}{}g;
	261	$self->perl_version($1);
	262	}
	263	else {
	264	warn "Cannot determine perl version info from $file\n";
	265	return;
	266	}
	267	}
	268
	269	sub author_from {
	270	my ( $self, $file ) = @_;
	271	my $content = $self->_slurp($file);
	272	if ($content =~ m/
	273	=head \d \s+ (?:authors?)\b \s*
	274	([^\n]*)
	275	\|
	276	=head \d \s+ (?:licen[cs]e\|licensing\|copyright\|legal)\b \s*
	277	.? copyright .? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
	278	([^\n]*)
	279	/ixms) {
	280	my $author = $1 \|\| $2;
	281	$author =~ s{E<lt>}{<}g;
	282	$author =~ s{E<gt>}{>}g;
	283	$self->author($author);
	284	}
	285	else {
	286	warn "Cannot determine author info from $file\n";
	287	}
	288	}
	289
	290	sub license_from {
	291	my ( $self, $file ) = @_;
	292
	293	if (
	294	$self->_slurp($file) =~ m/
	295	(
	296	=head \d \s+
	297	(?:licen[cs]e\|licensing\|copyright\|legal)\b
	298	.*?
	299	)
	300	(=head\\d.\|=cut.\|)
	301	\z
	302	/ixms
	303	)
	304	{
	305	my $license_text = $1;
	306	my @phrases = (
	307	'under the same (?:terms\|license) as perl itself' => 'perl', 1,
	308	'GNU public license' => 'gpl', 1,
	309	'GNU lesser public license' => 'gpl', 1,
	310	'BSD license' => 'bsd', 1,
	311	'Artistic license' => 'artistic', 1,
	312	'GPL' => 'gpl', 1,
	313	'LGPL' => 'lgpl', 1,
	314	'BSD' => 'bsd', 1,
	315	'Artistic' => 'artistic', 1,
	316	'MIT' => 'mit', 1,
	317	'proprietary' => 'proprietary', 0,
	318	);
	319	while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
	320	$pattern =~ s{\s+}{\\s+}g;
	321	if ( $license_text =~ /\b$pattern\b/i ) {
	322	if ( $osi and $license_text =~ /All rights reserved/i ) {
	323	warn "LEGAL WARNING: 'All rights reserved' may invalidate Open Source licenses. Consider removing it.";
	324	}
	325	$self->license($license);
	326	return 1;
	327	}
	328	}
	329	}
	330
	331	warn "Cannot determine license info from $file\n";
	332	return 'unknown';
	333	}
	334
	335	1;

+65

-0

inc/Module/Install/Win32.pm less more

	0	#line 1
	1	package Module::Install::Win32;
	2
	3	use strict;
	4	use Module::Install::Base;
	5
	6	use vars qw{$VERSION $ISCORE @ISA};
	7	BEGIN {
	8	$VERSION = '0.67';
	9	$ISCORE = 1;
	10	@ISA = qw{Module::Install::Base};
	11	}
	12
	13	# determine if the user needs nmake, and download it if needed
	14	sub check_nmake {
	15	my $self = shift;
	16	$self->load('can_run');
	17	$self->load('get_file');
	18
	19	require Config;
	20	return unless (
	21	$^O eq 'MSWin32' and
	22	$Config::Config{make} and
	23	$Config::Config{make} =~ /^nmake\b/i and
	24	! $self->can_run('nmake')
	25	);
	26
	27	print "The required 'nmake' executable not found, fetching it...\n";
	28
	29	require File::Basename;
	30	my $rv = $self->get_file(
	31	url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe',
	32	ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe',
	33	local_dir => File::Basename::dirname($^X),
	34	size => 51928,
	35	run => 'Nmake15.exe /o > nul',
	36	check_for => 'Nmake.exe',
	37	remove => 1,
	38	);
	39
	40	if (!$rv) {
	41	die <<'END_MESSAGE';
	42
	43	-------------------------------------------------------------------------------
	44
	45	Since you are using Microsoft Windows, you will need the 'nmake' utility
	46	before installation. It's available at:
	47
	48	http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe
	49	or
	50	ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe
	51
	52	Please download the file manually, save it to a directory in %PATH% (e.g.
	53	C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to
	54	that directory, and run "Nmake15.exe" from there; that will create the
	55	'nmake.exe' file needed by this module.
	56
	57	You may then resume the installation process described in README.
	58
	59	-------------------------------------------------------------------------------
	60	END_MESSAGE
	61	}
	62	}
	63
	64	1;

+43

-0

inc/Module/Install/WriteAll.pm less more

	0	#line 1
	1	package Module::Install::WriteAll;
	2
	3	use strict;
	4	use Module::Install::Base;
	5
	6	use vars qw{$VERSION $ISCORE @ISA};
	7	BEGIN {
	8	$VERSION = '0.67';
	9	$ISCORE = 1;
	10	@ISA = qw{Module::Install::Base};
	11	}
	12
	13	sub WriteAll {
	14	my $self = shift;
	15	my %args = (
	16	meta => 1,
	17	sign => 0,
	18	inline => 0,
	19	check_nmake => 1,
	20	@_
	21	);
	22
	23	$self->sign(1) if $args{sign};
	24	$self->Meta->write if $args{meta};
	25	$self->admin->WriteAll(%args) if $self->is_admin;
	26
	27	if ( $0 =~ /Build.PL$/i ) {
	28	$self->Build->write;
	29	} else {
	30	$self->check_nmake if $args{check_nmake};
	31	unless ( $self->makemaker_args->{'PL_FILES'} ) {
	32	$self->makemaker_args( PL_FILES => {} );
	33	}
	34	if ($args{inline}) {
	35	$self->Inline->write;
	36	} else {
	37	$self->Makefile->write;
	38	}
	39	}
	40	}
	41
	42	1;

+281

-0

inc/Module/Install.pm less more

	0	#line 1
	1	package Module::Install;
	2
	3	# For any maintainers:
	4	# The load order for Module::Install is a bit magic.
	5	# It goes something like this...
	6	#
	7	# IF ( host has Module::Install installed, creating author mode ) {
	8	# 1. Makefile.PL calls "use inc::Module::Install"
	9	# 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install
	10	# 3. The installed version of inc::Module::Install loads
	11	# 4. inc::Module::Install calls "require Module::Install"
	12	# 5. The ./inc/ version of Module::Install loads
	13	# } ELSE {
	14	# 1. Makefile.PL calls "use inc::Module::Install"
	15	# 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install
	16	# 3. The ./inc/ version of Module::Install loads
	17	# }
	18
	19	use 5.004;
	20	use strict 'vars';
	21
	22	use vars qw{$VERSION};
	23	BEGIN {
	24	# All Module::Install core packages now require synchronised versions.
	25	# This will be used to ensure we don't accidentally load old or
	26	# different versions of modules.
	27	# This is not enforced yet, but will be some time in the next few
	28	# releases once we can make sure it won't clash with custom
	29	# Module::Install extensions.
	30	$VERSION = '0.67';
	31	}
	32
	33	# Whether or not inc::Module::Install is actually loaded, the
	34	# $INC{inc/Module/Install.pm} is what will still get set as long as
	35	# the caller loaded module this in the documented manner.
	36	# If not set, the caller may NOT have loaded the bundled version, and thus
	37	# they may not have a MI version that works with the Makefile.PL. This would
	38	# result in false errors or unexpected behaviour. And we don't want that.
	39	my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
	40	unless ( $INC{$file} ) {
	41	die <<"END_DIE";
	42	Please invoke ${\__PACKAGE__} with:
	43
	44	use inc::${\__PACKAGE__};
	45
	46	not:
	47
	48	use ${\__PACKAGE__};
	49
	50	END_DIE
	51	}
	52
	53	# If the script that is loading Module::Install is from the future,
	54	# then make will detect this and cause it to re-run over and over
	55	# again. This is bad. Rather than taking action to touch it (which
	56	# is unreliable on some platforms and requires write permissions)
	57	# for now we should catch this and refuse to run.
	58	if ( -f $0 and (stat($0))[9] > time ) {
	59	die << "END_DIE";
	60	Your installer $0 has a modification time in the future.
	61
	62	This is known to create infinite loops in make.
	63
	64	Please correct this, then run $0 again.
	65
	66	END_DIE
	67	}
	68
	69	use Cwd ();
	70	use File::Find ();
	71	use File::Path ();
	72	use FindBin;
	73
	74	inc::Module::Install::VERSION = VERSION;
	75	@inc::Module::Install::ISA = __PACKAGE__;
	76
	77	sub autoload {
	78	my $self = shift;
	79	my $who = $self->_caller;
	80	my $cwd = Cwd::cwd();
	81	my $sym = "${who}::AUTOLOAD";
	82	$sym->{$cwd} = sub {
	83	my $pwd = Cwd::cwd();
	84	if ( my $code = $sym->{$pwd} ) {
	85	# delegate back to parent dirs
	86	goto &$code unless $cwd eq $pwd;
	87	}
	88	$$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
	89	unshift @_, ($self, $1);
	90	goto &{$self->can('call')} unless uc($1) eq $1;
	91	};
	92	}
	93
	94	sub import {
	95	my $class = shift;
	96	my $self = $class->new(@_);
	97	my $who = $self->_caller;
	98
	99	unless ( -f $self->{file} ) {
	100	require "$self->{path}/$self->{dispatch}.pm";
	101	File::Path::mkpath("$self->{prefix}/$self->{author}");
	102	$self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
	103	$self->{admin}->init;
	104	@_ = ($class, _self => $self);
	105	goto &{"$self->{name}::import"};
	106	}
	107
	108	*{"${who}::AUTOLOAD"} = $self->autoload;
	109	$self->preload;
	110
	111	# Unregister loader and worker packages so subdirs can use them again
	112	delete $INC{"$self->{file}"};
	113	delete $INC{"$self->{path}.pm"};
	114	}
	115
	116	sub preload {
	117	my ($self) = @_;
	118
	119	unless ( $self->{extensions} ) {
	120	$self->load_extensions(
	121	"$self->{prefix}/$self->{path}", $self
	122	);
	123	}
	124
	125	my @exts = @{$self->{extensions}};
	126	unless ( @exts ) {
	127	my $admin = $self->{admin};
	128	@exts = $admin->load_all_extensions;
	129	}
	130
	131	my %seen;
	132	foreach my $obj ( @exts ) {
	133	while (my ($method, $glob) = each %{ref($obj) . '::'}) {
	134	next unless $obj->can($method);
	135	next if $method =~ /^_/;
	136	next if $method eq uc($method);
	137	$seen{$method}++;
	138	}
	139	}
	140
	141	my $who = $self->_caller;
	142	foreach my $name ( sort keys %seen ) {
	143	*{"${who}::$name"} = sub {
	144	${"${who}::AUTOLOAD"} = "${who}::$name";
	145	goto &{"${who}::AUTOLOAD"};
	146	};
	147	}
	148	}
	149
	150	sub new {
	151	my ($class, %args) = @_;
	152
	153	# ignore the prefix on extension modules built from top level.
	154	my $base_path = Cwd::abs_path($FindBin::Bin);
	155	unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
	156	delete $args{prefix};
	157	}
	158
	159	return $args{_self} if $args{_self};
	160
	161	$args{dispatch} \|\|= 'Admin';
	162	$args{prefix} \|\|= 'inc';
	163	$args{author} \|\|= ($^O eq 'VMS' ? '_author' : '.author');
	164	$args{bundle} \|\|= 'inc/BUNDLES';
	165	$args{base} \|\|= $base_path;
	166	$class =~ s/^\Q$args{prefix}\E:://;
	167	$args{name} \|\|= $class;
	168	$args{version} \|\|= $class->VERSION;
	169	unless ( $args{path} ) {
	170	$args{path} = $args{name};
	171	$args{path} =~ s!::!/!g;
	172	}
	173	$args{file} \|\|= "$args{base}/$args{prefix}/$args{path}.pm";
	174
	175	bless( \%args, $class );
	176	}
	177
	178	sub call {
	179	my ($self, $method) = @_;
	180	my $obj = $self->load($method) or return;
	181	splice(@_, 0, 2, $obj);
	182	goto &{$obj->can($method)};
	183	}
	184
	185	sub load {
	186	my ($self, $method) = @_;
	187
	188	$self->load_extensions(
	189	"$self->{prefix}/$self->{path}", $self
	190	) unless $self->{extensions};
	191
	192	foreach my $obj (@{$self->{extensions}}) {
	193	return $obj if $obj->can($method);
	194	}
	195
	196	my $admin = $self->{admin} or die <<"END_DIE";
	197	The '$method' method does not exist in the '$self->{prefix}' path!
	198	Please remove the '$self->{prefix}' directory and run $0 again to load it.
	199	END_DIE
	200
	201	my $obj = $admin->load($method, 1);
	202	push @{$self->{extensions}}, $obj;
	203
	204	$obj;
	205	}
	206
	207	sub load_extensions {
	208	my ($self, $path, $top) = @_;
	209
	210	unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
	211	unshift @INC, $self->{prefix};
	212	}
	213
	214	foreach my $rv ( $self->find_extensions($path) ) {
	215	my ($file, $pkg) = @{$rv};
	216	next if $self->{pathnames}{$pkg};
	217
	218	local $@;
	219	my $new = eval { require $file; $pkg->can('new') };
	220	unless ( $new ) {
	221	warn $@ if $@;
	222	next;
	223	}
	224	$self->{pathnames}{$pkg} = delete $INC{$file};
	225	push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
	226	}
	227
	228	$self->{extensions} \|\|= [];
	229	}
	230
	231	sub find_extensions {
	232	my ($self, $path) = @_;
	233
	234	my @found;
	235	File::Find::find( sub {
	236	my $file = $File::Find::name;
	237	return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
	238	my $subpath = $1;
	239	return if lc($subpath) eq lc($self->{dispatch});
	240
	241	$file = "$self->{path}/$subpath.pm";
	242	my $pkg = "$self->{name}::$subpath";
	243	$pkg =~ s!/!::!g;
	244
	245	# If we have a mixed-case package name, assume case has been preserved
	246	# correctly. Otherwise, root through the file to locate the case-preserved
	247	# version of the package name.
	248	if ( $subpath eq lc($subpath) \|\| $subpath eq uc($subpath) ) {
	249	open PKGFILE, "<$subpath.pm" or die "find_extensions: Can't open $subpath.pm: $!";
	250	my $in_pod = 0;
	251	while ( <PKGFILE> ) {
	252	$in_pod = 1 if /^=\w/;
	253	$in_pod = 0 if /^=cut/;
	254	next if ($in_pod \|\| /^=cut/); # skip pod text
	255	next if /^\s*#/; # and comments
	256	if ( m/^\spackage\s+($pkg)\s;/i ) {
	257	$pkg = $1;
	258	last;
	259	}
	260	}
	261	close PKGFILE;
	262	}
	263
	264	push @found, [ $file, $pkg ];
	265	}, $path ) if -d $path;
	266
	267	@found;
	268	}
	269
	270	sub _caller {
	271	my $depth = 0;
	272	my $call = caller($depth);
	273	while ( $call eq __PACKAGE__ ) {
	274	$depth++;
	275	$call = caller($depth);
	276	}
	277	return $call;
	278	}
	279
	280	1;

+177

-0

lib/DBIx/Class/InflateColumn/IP.pm less more

	0	package DBIx::Class::InflateColumn::IP;
	1
	2	use warnings;
	3	use strict;
	4
	5	our $VERSION = '0.02001';
	6
	7	use base qw/DBIx::Class/;
	8	__PACKAGE__->mk_classdata(ip_format => 'addr');
	9	__PACKAGE__->mk_classdata(ip_class => 'NetAddr::IP');
	10
	11	=head1 NAME
	12
	13	DBIx::Class::InflateColumn::IP - Auto-create NetAddr::IP objects from columns.
	14
	15	=head1 SYNOPSIS
	16
	17	Load this component and declare columns as IP addresses with the
	18	appropriate format.
	19
	20	package Host;
	21	__PACKAGE__->load_components(qw/InflateColumn::IP Core/);
	22	__PACKAGE__->add_columns(
	23	ip_address => {
	24	data_type => 'integer',
	25	is_nullable => 0,
	26	is_ip => 1,
	27	ip_format => 'numeric',
	28	}
	29	);
	30
	31	package Network;
	32	__PACKAGE__->load_components(qw/InflateColumn::IP Core/);
	33	__PACKAGE__->add_columns(
	34	address => {
	35	data_type => 'varchar',
	36	size => 18
	37	is_nullable => 0,
	38	is_ip => 1,
	39	ip_format => 'cidr',
	40	}
	41	);
	42
	43	Then you can treat the specified column as a NetAddr::IP object.
	44
	45	print 'IP address: ', $host->ip_address->addr;
	46	print 'Address type: ', $host->ip_address->iptype;
	47
	48	DBIx::Class::InflateColumn::IP supports a limited amount of
	49	auto-detection of the format based on the column type. If the type
	50	begins with C<int>, it's assumed to be numeric, while C<inet> and
	51	C<cidr> (as used by e.g. PostgreSQL) are assumed to be C<cidr> format.
	52
	53	=head1 METHODS
	54
	55	=head2 ip_class
	56
	57	=over
	58
	59	=item Arguments: $class
	60
	61	=back
	62
	63	Gets/sets the address class that the columns should be inflated into.
	64	The default class is NetAddr::IP.
	65
	66	=head2 ip_format
	67
	68	=over
	69
	70	=item Arguments: $format
	71
	72	=back
	73
	74	Gets/sets the name of the method used to deflate the address for the
	75	database. This must return a value suitable for C<$ip_class->new(); The
	76	default format is C<addr>, which returns the address in dotted-quad
	77	notation. See L<NetAddr::IP/Methods> for suitable values.
	78
	79	=head2 register_column
	80
	81	Chains with L<DBIx::Class::Row/register_column>, and sets up IP address
	82	columns appropriately. This would not normally be called directly by end
	83	users.
	84
	85	=cut
	86
	87	sub register_column {
	88	my ($self, $column, $info, @rest) = @_;
	89	$self->next::method($column, $info, @rest);
	90
	91	return unless defined $info->{'is_ip'};
	92
	93	my $ip_format = $info->{ip_format} \|\| _default_format($info->{data_type})
	94	\|\| $self->ip_format \|\| 'addr';
	95	my $ip_class = $info->{ip_class} \|\| $self->ip_class \|\| 'NetAddr::IP';
	96
	97	eval "use $ip_class";
	98	$self->throw_exception("Error loading $ip_class: $@") if $@;
	99	$self->throw_exception("Format '$ip_format' not supported by $ip_class")
	100	unless $ip_class->can($ip_format);
	101
	102	$self->inflate_column(
	103	$column => {
	104	inflate => sub { return $ip_class->new(shift); },
	105	deflate => sub { return scalar shift->$ip_format; },
	106	}
	107	);
	108	}
	109
	110	my @format_map = (
	111	{ type => qr/^int/i, format => 'numeric' },
	112	{ type => qr{^(?:inet\|cidr)$}i, format => 'cidr' },
	113	);
	114
	115	sub _default_format {
	116	my ($type) = @_;
	117
	118	for my $match (@format_map) {
	119	return $match->{format} if $type =~ $match->{type};
	120	}
	121	}
	122
	123	=head1 AUTHOR
	124
	125	Dagfinn Ilmari Mannsåker, C<< <ilmari at ilmari.org> >>
	126
	127	=head1 BUGS
	128
	129	Please report any bugs or feature requests to
	130	C<bug-dbix-class-inflatecolumn-ip at rt.cpan.org>, or through the web interface at
	131	L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=DBIx-Class-InflateColumn-IP>.
	132	I will be notified, and then you'll automatically be notified of progress on
	133	your bug as I make changes.
	134
	135	=head1 SUPPORT
	136
	137	You can find documentation for this module with the perldoc command.
	138
	139	perldoc DBIx::Class::InflateColumn::IP
	140
	141	You can also look for information at:
	142
	143	=over 4
	144
	145	=item * AnnoCPAN: Annotated CPAN documentation
	146
	147	L<http://annocpan.org/dist/DBIx-Class-InflateColumn-IP>
	148
	149	=item * CPAN Ratings
	150
	151	L<http://cpanratings.perl.org/d/DBIx-Class-InflateColumn-IP>
	152
	153	=item * RT: CPAN's request tracker
	154
	155	L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=DBIx-Class-InflateColumn-IP>
	156
	157	=item * Search CPAN
	158
	159	L<http://search.cpan.org/dist/DBIx-Class-InflateColumn-IP>
	160
	161	=back
	162
	163	=head1 SEE ALSO
	164
	165	L<DBIx::Class>, L<NetAddr::IP>
	166
	167	=head1 COPYRIGHT & LICENSE
	168
	169	Copyright 2007 Dagfinn Ilmari Mannsåker, all rights reserved.
	170
	171	This program is free software; you can redistribute it and/or modify it
	172	under the same terms as Perl itself.
	173
	174	=cut
	175
	176	1; # End of DBIx::Class::InflateColumn::IP

-0

t/00-load.t less more

	0	#!perl -T
	1
	2	use Test::More tests => 1;
	3
	4	BEGIN {
	5	use_ok( 'DBIx::Class::InflateColumn::IP' );
	6	}
	7
	8	diag( "Testing DBIx::Class::InflateColumn::IP $DBIx::Class::InflateColumn::IP::VERSION, Perl $], $^X" );

+47

-0

t/01-ip.t less more

	0	#!perl -T
	1	use lib qw(t/lib);
	2	use DBICTest;
	3	use Test::More tests => 10;
	4	use NetAddr::IP;
	5
	6	my $schema = DBICTest->init_schema();
	7
	8	my $host_rs = $schema->resultset('Host');
	9
	10	my $localhost = $host_rs->find('localhost');
	11
	12	isa_ok($localhost->address, 'NetAddr::IP', 'numeric address inflated to right class');
	13	is($localhost->address, '127.0.0.1/32', 'numeric address correctly inflated');
	14
	15	TODO: {
	16	local $TODO = "DBIx::Class doesn't support find by object yet";
	17
	18	$localhost = $host_rs->find(NetAddr::IP->new('127.0.0.1'), { key => 'address' });
	19
	20	ok($localhost, 'find by object returned a row');
	21	}
	22
	23	SKIP: {
	24	skip 'no object to check' => 1 unless $localhost;
	25
	26	is($localhost->hostname, 'localhost', 'find by object returned the right row');
	27	}
	28
	29	my $ip = NetAddr::IP->new('192.168.0.1');
	30	my $host = $host_rs->create({ hostname => 'foo', address => $ip });
	31
	32	isa_ok($host, 'DBICTest::Schema::Host', 'create with object');
	33	is($host->get_column('address'), $ip->numeric, 'numeric address correctly deflated');
	34
	35	my $net_rs = $schema->resultset('Network');
	36
	37	my $localnet = $net_rs->find('localnet');
	38
	39	isa_ok($localnet->address, 'NetAddr::IP', 'CIDR address inflated to right class');
	40	is($localnet->address, '127.0.0.0/8', 'CIDR address correctly inflated');
	41
	42	my $net_ip = NetAddr::IP->new('192.168.0.42/24');
	43	my $net = $net_rs->create({ netname => 'foo', address => $net_ip });
	44
	45	isa_ok($net, 'DBICTest::Schema::Network', 'create with object');
	46	is($net->get_column('address'), '192.168.0.42/24', 'CIDR address correctly deflated');

+48

-0

t/boilerplate.t less more

	0	#!perl -T
	1
	2	use strict;
	3	use warnings;
	4	use Test::More tests => 3;
	5
	6	sub not_in_file_ok {
	7	my ($filename, %regex) = @_;
	8	open my $fh, "<", $filename
	9	or die "couldn't open $filename for reading: $!";
	10
	11	my %violated;
	12
	13	while (my $line = <$fh>) {
	14	while (my ($desc, $regex) = each %regex) {
	15	if ($line =~ $regex) {
	16	push @{$violated{$desc}\|\|=[]}, $.;
	17	}
	18	}
	19	}
	20
	21	if (%violated) {
	22	fail("$filename contains boilerplate text");
	23	diag "$_ appears on lines @{$violated{$_}}" for keys %violated;
	24	} else {
	25	pass("$filename contains no boilerplate text");
	26	}
	27	}
	28
	29	not_in_file_ok(README =>
	30	"The README is used..." => qr/The README is used/,
	31	"'version information here'" => qr/to provide version information/,
	32	);
	33
	34	not_in_file_ok(Changes =>
	35	"placeholder date/time" => qr(Date/time)
	36	);
	37
	38	sub module_boilerplate_ok {
	39	my ($module) = @_;
	40	not_in_file_ok($module =>
	41	'the great new $MODULENAME' => qr/ - The great new /,
	42	'boilerplate description' => qr/Quick summary of what the module/,
	43	'stub function definition' => qr/function[12]/,
	44	);
	45	}
	46
	47	module_boilerplate_ok('lib/DBIx/Class/InflateColumn/IP.pm');

+24

-0

t/lib/DBICTest/Schema/Host.pm less more

	0	package # hide from PAUSE
	1	DBICTest::Schema::Host;
	2
	3	use base qw/DBIx::Class/;
	4
	5	__PACKAGE__->load_components(qw/InflateColumn::IP Core/);
	6	__PACKAGE__->table('host');
	7
	8	__PACKAGE__->add_columns(
	9	hostname => {
	10	data_type => 'text',
	11	is_nullable => 0,
	12	},
	13	address => {
	14	data_type => 'integer',
	15	is_nullable => 0,
	16	is_ip => 1,
	17	}
	18	);
	19
	20	__PACKAGE__->set_primary_key('hostname');
	21	__PACKAGE__->add_unique_constraint(address => [ qw/address/ ]);
	22
	23	1;

+26

-0

t/lib/DBICTest/Schema/Network.pm less more

	0	package # hide from PAUSE
	1	DBICTest::Schema::Network;
	2
	3	use base qw/DBIx::Class/;
	4
	5	__PACKAGE__->load_components(qw/InflateColumn::IP Core/);
	6	__PACKAGE__->table('network');
	7
	8	__PACKAGE__->add_columns(
	9	netname => {
	10	data_type => 'text',
	11	is_nullable => 0,
	12	},
	13	address => {
	14	data_type => 'varchar',
	15	size => '18',
	16	is_nullable => 0,
	17	is_ip => 1,
	18	ip_format => 'cidr',
	19	}
	20	);
	21
	22	__PACKAGE__->set_primary_key('netname');
	23	__PACKAGE__->add_unique_constraint(address => [ qw/address/ ]);
	24
	25	1;

-0

t/lib/DBICTest/Schema.pm less more

	0	package # hide from PAUSE
	1	DBICTest::Schema;
	2
	3	use base qw/DBIx::Class::Schema/;
	4
	5	__PACKAGE__->load_classes();
	6
	7	1;

+119

-0

t/lib/DBICTest.pm less more

	0	package # hide from PAUSE
	1	DBICTest;
	2
	3	use strict;
	4	use warnings;
	5	use DBICTest::Schema;
	6
	7	=head1 NAME
	8
	9	DBICTest - Library to be used by DBIx::Class test scripts.
	10
	11	=head1 SYNOPSIS
	12
	13	use lib qw(t/lib);
	14	use DBICTest;
	15	use Test::More;
	16
	17	my $schema = DBICTest->init_schema();
	18
	19	=head1 DESCRIPTION
	20
	21	This module provides the basic utilities to write tests against
	22	DBIx::Class.
	23
	24	=head1 METHODS
	25
	26	=head2 init_schema
	27
	28	my $schema = DBICTest->init_schema(
	29	no_deploy=>1,
	30	no_populate=>1,
	31	);
	32
	33	This method removes the test SQLite database in t/var/DBIxClass.db
	34	and then creates a new, empty database.
	35
	36	This method will call deploy_schema() by default, unless the
	37	no_deploy flag is set.
	38
	39	Also, by default, this method will call populate_schema() by
	40	default, unless the no_deploy or no_populate flags are set.
	41
	42	=cut
	43
	44	sub init_schema {
	45	my $self = shift;
	46	my %args = @_;
	47	my $db_file = "t/var/DBIxClass.db";
	48
	49	unlink($db_file) if -e $db_file;
	50	unlink($db_file . "-journal") if -e $db_file . "-journal";
	51	mkdir("t/var") unless -d "t/var";
	52
	53	my $dsn = $ENV{"DBICTEST_DSN"} \|\| "dbi:SQLite:${db_file}";
	54	my $dbuser = $ENV{"DBICTEST_DBUSER"} \|\| '';
	55	my $dbpass = $ENV{"DBICTEST_DBPASS"} \|\| '';
	56
	57	my $schema = DBICTest::Schema->compose_namespace('DBICTest')
	58	->connect($dsn, $dbuser, $dbpass);
	59	$schema->storage->on_connect_do(['PRAGMA synchronous = OFF']);
	60	if ( !$args{no_deploy} ) {
	61	__PACKAGE__->deploy_schema( $schema );
	62	__PACKAGE__->populate_schema( $schema ) if( !$args{no_populate} );
	63	}
	64	return $schema;
	65	}
	66
	67	=head2 deploy_schema
	68
	69	DBICTest->deploy_schema( $schema );
	70
	71	This method does one of two things to the schema. It can either call
	72	the experimental $schema->deploy() if the DBICTEST_SQLT_DEPLOY environment
	73	variable is set, otherwise the default is to read in the t/lib/sqlite.sql
	74	file and execute the SQL within. Either way you end up with a fresh set
	75	of tables for testing.
	76
	77	=cut
	78
	79	sub deploy_schema {
	80	my $self = shift;
	81	my $schema = shift;
	82
	83	if ($ENV{"DBICTEST_SQLT_DEPLOY"}) {
	84	return $schema->deploy();
	85	} else {
	86	open IN, "t/lib/sqlite.sql";
	87	my $sql;
	88	{ local $/ = undef; $sql = <IN>; }
	89	close IN;
	90	($schema->storage->dbh->do($_) \|\| print "Error on SQL: $_\n") for split(/;\n/, $sql);
	91	}
	92	}
	93
	94	=head2 populate_schema
	95
	96	DBICTest->populate_schema( $schema );
	97
	98	After you deploy your schema you can use this method to populate
	99	the tables with test data.
	100
	101	=cut
	102
	103	sub populate_schema {
	104	my $self = shift;
	105	my $schema = shift;
	106
	107	$schema->populate('Host', [
	108	[ qw/hostname address/ ],
	109	[ 'localhost', 2130706433 ],
	110	]);
	111
	112	$schema->populate('Network', [
	113	[ qw/netname address/ ],
	114	[ qw{localnet 127.0.0.0/8} ],
	115	]);
	116	}
	117
	118	1;

-0

t/lib/sqlite.sql less more

	0	CREATE TABLE host (
	1	hostname TEXT NOT NULL PRIMARY KEY,
	2	address INTEGER NOT NULL UNIQUE
	3	);
	4
	5	CREATE TABLE network (
	6	netname TEXT NOT NULL PRIMARY KEY,
	7	address VARCHAR(18) NOT NULL UNIQUE
	8	);

-0

t/pod-coverage.t less more

	0	#!perl -T
	1
	2	use Test::More;
	3	eval "use Test::Pod::Coverage 1.04";
	4	plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@;
	5	all_pod_coverage_ok();

-0

t/pod.t less more

	0	#!perl -T
	1
	2	use Test::More;
	3	eval "use Test::Pod 1.14";
	4	plan skip_all => "Test::Pod 1.14 required for testing POD" if $@;
	5	all_pod_files_ok();

+20

-0

t/style-notabs.t less more

	0	#!perl -T
	1	use strict;
	2	use warnings;
	3
	4	use Test::More;
	5
	6	if (not $ENV{TEST_AUTHOR}) {
	7	plan skip_all => 'set TEST_AUTHOR to enable this test';
	8	}
	9	else {
	10	eval 'use Test::NoTabs 0.03';
	11	if ($@) {
	12	plan skip_all => 'Test::NoTabs 0.03 not installed';
	13	}
	14	else {
	15	plan tests => 1;
	16	}
	17	}
	18
	19	all_perl_files_ok('lib');