Commit c438b2cb52a4e19a07b0c6212fe50279de5c69fb - libmousex-strictconstructor-perl

Imported Upstream version 0.02 Damyan Ivanov 12 years ago

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

-0

Changes less more

	0	Revision history for Perl extension MouseX::StrictConstructor.
	1
	2	0.02 Tue Jul 6 20:37:11 2010
	3	- Use the public API
	4
	5	0.01 Tue Jul 6 18:30:04 2010
	6	- original version; created by h2xs 1.23 with options
	7	-AXn MouseX::StrictConstructor
	8

+24

-0

MANIFEST less more

	0	Changes
	1	inc/Module/Install.pm
	2	inc/Module/Install/AuthorTests.pm
	3	inc/Module/Install/Base.pm
	4	inc/Module/Install/Can.pm
	5	inc/Module/Install/Fetch.pm
	6	inc/Module/Install/Makefile.pm
	7	inc/Module/Install/Metadata.pm
	8	inc/Module/Install/Repository.pm
	9	inc/Module/Install/Win32.pm
	10	inc/Module/Install/WriteAll.pm
	11	lib/MouseX/StrictConstructor.pm
	12	Makefile.PL
	13	MANIFEST This list of files
	14	MANIFEST.SKIP
	15	META.yml
	16	README
	17	t/000_load.t
	18	t/001_basic.t
	19	xt/01_podspell.t
	20	xt/02_pod.t
	21	xt/03_pod-coverage.t
	22	xt/04_synopsis.t
	23	xt/05_vars.t

+59

-0

MANIFEST.SKIP less more

	0
	1	#!start included /usr/local/lib/perl5/5.10.0/ExtUtils/MANIFEST.SKIP
	2	# Avoid version control files.
	3	\bRCS\b
	4	\bCVS\b
	5	\bSCCS\b
	6	,v$
	7	\B\.svn\b
	8	\B\.git\b
	9	\B\.gitignore\b
	10	\b_darcs\b
	11
	12	# Avoid Makemaker generated and utility files.
	13	\bMANIFEST\.bak
	14	\bMakefile$
	15	\bblib/
	16	\bMakeMaker-\d
	17	\bpm_to_blib\.ts$
	18	\bpm_to_blib$
	19	\bblibdirs\.ts$ # 6.18 through 6.25 generated this
	20
	21	# Avoid Module::Build generated and utility files.
	22	\bBuild$
	23	\b_build/
	24
	25	# Avoid temp and backup files.
	26	~$
	27	\.old$
	28	\#$
	29	\b\.#
	30	\.bak$
	31
	32	# Avoid Devel::Cover files.
	33	\bcover_db\b
	34	#!end included /usr/local/lib/perl5/5.10.0/ExtUtils/MANIFEST.SKIP
	35
	36
	37	# skip dot files
	38	^\.
	39
	40	# skip author's files
	41	\bauthor\b
	42
	43	# skip object files
	44	Xslate\.c$
	45	\.o(?:bj)?$
	46	\.bs$
	47	\.def$
	48
	49	\.out$
	50
	51	# skip devel-cover stuff
	52	cover_db/
	53
	54	# skip nytprof stuff
	55	nytprof/
	56	\.out$
	57
	58	MYMETA\.yml$

+29

-0

META.yml less more

	0	---
	1	abstract: 'Make your object constructors blow up on unknown attributes '
	2	author:
	3	- 'Fuji, Goro (gfx) <gfuji(at)cpan.org>'
	4	build_requires:
	5	ExtUtils::MakeMaker: 6.42
	6	Test::More: 0.88
	7	configure_requires:
	8	ExtUtils::MakeMaker: 6.42
	9	distribution_type: module
	10	generated_by: 'Module::Install version 1.00'
	11	license: perl
	12	meta-spec:
	13	url: http://module-build.sourceforge.net/META-spec-v1.4.html
	14	version: 1.4
	15	module_name: MouseX::StrictConstructor
	16	name: MouseX-StrictConstructor
	17	no_index:
	18	directory:
	19	- inc
	20	- t
	21	- xt
	22	requires:
	23	Mouse: 0.62
	24	perl: 5.6.2
	25	resources:
	26	license: http://dev.perl.org/licenses/
	27	repository: git://github.com/gfx/p5-MouseX-StrictConstructor.git
	28	version: 0.02

+14

-0

Makefile.PL less more

	0	use inc::Module::Install;
	1
	2	all_from 'lib/MouseX/StrictConstructor.pm';
	3
	4	requires 'Mouse' => '0.62';
	5
	6	test_requires 'Test::More' => 0.88; # done_testing()
	7
	8	tests_recursive;
	9	author_tests 'xt';
	10
	11	auto_set_repository() if -d '.git';
	12
	13	WriteAll(check_nmake => 1);

+36

-0

README less more

	0	This is Perl module MouseX::StrictConstructor.
	1
	2	NAME
	3
	4	MouseX::StrictConstructor - Makes your constructors strict
	5
	6	INSTALLATION
	7
	8	MouseX::StrictConstructor installation is straightforward. If your CPAN shell is set up,
	9	you should just be able to do
	10
	11	$ cpan MouseX::StrictConstructor
	12
	13	Download it, unpack it, then build it as per the usual:
	14
	15	$ perl Makefile.PL
	16	$ make && make test
	17
	18	Then install it:
	19
	20	$ make install
	21
	22	DOCUMENTATION
	23
	24	MouseX::StrictConstructor documentation is available as in POD. So you can do:
	25
	26	$ perldoc MouseX::StrictConstructor
	27
	28	to read the documentation online with your favorite pager.
	29
	30	LICENSE AND COPYRIGHT
	31
	32	Copyright (c) 2010, Fuji, Goro (gfx). All rights reserved.
	33
	34	This library is free software; you can redistribute it and/or modify
	35	it under the same terms as Perl itself.

+59

-0

inc/Module/Install/AuthorTests.pm less more

	0	#line 1
	1	package Module::Install::AuthorTests;
	2
	3	use 5.005;
	4	use strict;
	5	use Module::Install::Base;
	6	use Carp ();
	7
	8	#line 16
	9
	10	use vars qw{$VERSION $ISCORE @ISA};
	11	BEGIN {
	12	$VERSION = '0.002';
	13	$ISCORE = 1;
	14	@ISA = qw{Module::Install::Base};
	15	}
	16
	17	#line 42
	18
	19	sub author_tests {
	20	my ($self, @dirs) = @_;
	21	_add_author_tests($self, \@dirs, 0);
	22	}
	23
	24	#line 56
	25
	26	sub recursive_author_tests {
	27	my ($self, @dirs) = @_;
	28	_add_author_tests($self, \@dirs, 1);
	29	}
	30
	31	sub _wanted {
	32	my $href = shift;
	33	sub { /\.t$/ and -f $_ and $href->{$File::Find::dir} = 1 }
	34	}
	35
	36	sub _add_author_tests {
	37	my ($self, $dirs, $recurse) = @_;
	38	return unless $Module::Install::AUTHOR;
	39
	40	my @tests = $self->tests ? (split / /, $self->tests) : 't/*.t';
	41
	42	# XXX: pick a default, later -- rjbs, 2008-02-24
	43	my @dirs = @$dirs ? @$dirs : Carp::confess "no dirs given to author_tests";
	44	@dirs = grep { -d } @dirs;
	45
	46	if ($recurse) {
	47	require File::Find;
	48	my %test_dir;
	49	File::Find::find(_wanted(\%test_dir), @dirs);
	50	$self->tests( join ' ', @tests, map { "$_/*.t" } sort keys %test_dir );
	51	} else {
	52	$self->tests( join ' ', @tests, map { "$_/*.t" } sort @dirs );
	53	}
	54	}
	55
	56	#line 107
	57
	58	1;

+83

-0

inc/Module/Install/Base.pm less more

	0	#line 1
	1	package Module::Install::Base;
	2
	3	use strict 'vars';
	4	use vars qw{$VERSION};
	5	BEGIN {
	6	$VERSION = '1.00';
	7	}
	8
	9	# Suspend handler for "redefined" warnings
	10	BEGIN {
	11	my $w = $SIG{__WARN__};
	12	$SIG{__WARN__} = sub { $w };
	13	}
	14
	15	#line 42
	16
	17	sub new {
	18	my $class = shift;
	19	unless ( defined &{"${class}::call"} ) {
	20	*{"${class}::call"} = sub { shift->_top->call(@_) };
	21	}
	22	unless ( defined &{"${class}::load"} ) {
	23	*{"${class}::load"} = sub { shift->_top->load(@_) };
	24	}
	25	bless { @_ }, $class;
	26	}
	27
	28	#line 61
	29
	30	sub AUTOLOAD {
	31	local $@;
	32	my $func = eval { shift->_top->autoload } or return;
	33	goto &$func;
	34	}
	35
	36	#line 75
	37
	38	sub _top {
	39	$_[0]->{_top};
	40	}
	41
	42	#line 90
	43
	44	sub admin {
	45	$_[0]->_top->{admin}
	46	or
	47	Module::Install::Base::FakeAdmin->new;
	48	}
	49
	50	#line 106
	51
	52	sub is_admin {
	53	! $_[0]->admin->isa('Module::Install::Base::FakeAdmin');
	54	}
	55
	56	sub DESTROY {}
	57
	58	package Module::Install::Base::FakeAdmin;
	59
	60	use vars qw{$VERSION};
	61	BEGIN {
	62	$VERSION = $Module::Install::Base::VERSION;
	63	}
	64
	65	my $fake;
	66
	67	sub new {
	68	$fake \|\|= bless(\@_, $_[0]);
	69	}
	70
	71	sub AUTOLOAD {}
	72
	73	sub DESTROY {}
	74
	75	# Restore warning handler
	76	BEGIN {
	77	$SIG{__WARN__} = $SIG{__WARN__}->();
	78	}
	79
	80	1;
	81
	82	#line 159

+81

-0

inc/Module/Install/Can.pm less more

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

+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 @ISA $ISCORE};
	7	BEGIN {
	8	$VERSION = '1.00';
	9	@ISA = 'Module::Install::Base';
	10	$ISCORE = 1;
	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;

+415

-0

inc/Module/Install/Makefile.pm less more

	0	#line 1
	1	package Module::Install::Makefile;
	2
	3	use strict 'vars';
	4	use ExtUtils::MakeMaker ();
	5	use Module::Install::Base ();
	6	use Fcntl qw/:flock :seek/;
	7
	8	use vars qw{$VERSION @ISA $ISCORE};
	9	BEGIN {
	10	$VERSION = '1.00';
	11	@ISA = 'Module::Install::Base';
	12	$ISCORE = 1;
	13	}
	14
	15	sub Makefile { $_[0] }
	16
	17	my %seen = ();
	18
	19	sub prompt {
	20	shift;
	21
	22	# Infinite loop protection
	23	my @c = caller();
	24	if ( ++$seen{"$c[1]\|$c[2]\|$_[0]"} > 3 ) {
	25	die "Caught an potential prompt infinite loop ($c[1]\|$c[2]\|$_[0])";
	26	}
	27
	28	# In automated testing or non-interactive session, always use defaults
	29	if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) {
	30	local $ENV{PERL_MM_USE_DEFAULT} = 1;
	31	goto &ExtUtils::MakeMaker::prompt;
	32	} else {
	33	goto &ExtUtils::MakeMaker::prompt;
	34	}
	35	}
	36
	37	# Store a cleaned up version of the MakeMaker version,
	38	# since we need to behave differently in a variety of
	39	# ways based on the MM version.
	40	my $makemaker = eval $ExtUtils::MakeMaker::VERSION;
	41
	42	# If we are passed a param, do a "newer than" comparison.
	43	# Otherwise, just return the MakeMaker version.
	44	sub makemaker {
	45	( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0
	46	}
	47
	48	# Ripped from ExtUtils::MakeMaker 6.56, and slightly modified
	49	# as we only need to know here whether the attribute is an array
	50	# or a hash or something else (which may or may not be appendable).
	51	my %makemaker_argtype = (
	52	C => 'ARRAY',
	53	CONFIG => 'ARRAY',
	54	# CONFIGURE => 'CODE', # ignore
	55	DIR => 'ARRAY',
	56	DL_FUNCS => 'HASH',
	57	DL_VARS => 'ARRAY',
	58	EXCLUDE_EXT => 'ARRAY',
	59	EXE_FILES => 'ARRAY',
	60	FUNCLIST => 'ARRAY',
	61	H => 'ARRAY',
	62	IMPORTS => 'HASH',
	63	INCLUDE_EXT => 'ARRAY',
	64	LIBS => 'ARRAY', # ignore ''
	65	MAN1PODS => 'HASH',
	66	MAN3PODS => 'HASH',
	67	META_ADD => 'HASH',
	68	META_MERGE => 'HASH',
	69	PL_FILES => 'HASH',
	70	PM => 'HASH',
	71	PMLIBDIRS => 'ARRAY',
	72	PMLIBPARENTDIRS => 'ARRAY',
	73	PREREQ_PM => 'HASH',
	74	CONFIGURE_REQUIRES => 'HASH',
	75	SKIP => 'ARRAY',
	76	TYPEMAPS => 'ARRAY',
	77	XS => 'HASH',
	78	# VERSION => ['version',''], # ignore
	79	# _KEEP_AFTER_FLUSH => '',
	80
	81	clean => 'HASH',
	82	depend => 'HASH',
	83	dist => 'HASH',
	84	dynamic_lib=> 'HASH',
	85	linkext => 'HASH',
	86	macro => 'HASH',
	87	postamble => 'HASH',
	88	realclean => 'HASH',
	89	test => 'HASH',
	90	tool_autosplit => 'HASH',
	91
	92	# special cases where you can use makemaker_append
	93	CCFLAGS => 'APPENDABLE',
	94	DEFINE => 'APPENDABLE',
	95	INC => 'APPENDABLE',
	96	LDDLFLAGS => 'APPENDABLE',
	97	LDFROM => 'APPENDABLE',
	98	);
	99
	100	sub makemaker_args {
	101	my ($self, %new_args) = @_;
	102	my $args = ( $self->{makemaker_args} \|\|= {} );
	103	foreach my $key (keys %new_args) {
	104	if ($makemaker_argtype{$key}) {
	105	if ($makemaker_argtype{$key} eq 'ARRAY') {
	106	$args->{$key} = [] unless defined $args->{$key};
	107	unless (ref $args->{$key} eq 'ARRAY') {
	108	$args->{$key} = [$args->{$key}]
	109	}
	110	push @{$args->{$key}},
	111	ref $new_args{$key} eq 'ARRAY'
	112	? @{$new_args{$key}}
	113	: $new_args{$key};
	114	}
	115	elsif ($makemaker_argtype{$key} eq 'HASH') {
	116	$args->{$key} = {} unless defined $args->{$key};
	117	foreach my $skey (keys %{ $new_args{$key} }) {
	118	$args->{$key}{$skey} = $new_args{$key}{$skey};
	119	}
	120	}
	121	elsif ($makemaker_argtype{$key} eq 'APPENDABLE') {
	122	$self->makemaker_append($key => $new_args{$key});
	123	}
	124	}
	125	else {
	126	if (defined $args->{$key}) {
	127	warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n};
	128	}
	129	$args->{$key} = $new_args{$key};
	130	}
	131	}
	132	return $args;
	133	}
	134
	135	# For mm args that take multiple space-seperated args,
	136	# append an argument to the current list.
	137	sub makemaker_append {
	138	my $self = shift;
	139	my $name = shift;
	140	my $args = $self->makemaker_args;
	141	$args->{$name} = defined $args->{$name}
	142	? join( ' ', $args->{$name}, @_ )
	143	: join( ' ', @_ );
	144	}
	145
	146	sub build_subdirs {
	147	my $self = shift;
	148	my $subdirs = $self->makemaker_args->{DIR} \|\|= [];
	149	for my $subdir (@_) {
	150	push @$subdirs, $subdir;
	151	}
	152	}
	153
	154	sub clean_files {
	155	my $self = shift;
	156	my $clean = $self->makemaker_args->{clean} \|\|= {};
	157	%$clean = (
	158	%$clean,
	159	FILES => join ' ', grep { length $_ } ($clean->{FILES} \|\| (), @_),
	160	);
	161	}
	162
	163	sub realclean_files {
	164	my $self = shift;
	165	my $realclean = $self->makemaker_args->{realclean} \|\|= {};
	166	%$realclean = (
	167	%$realclean,
	168	FILES => join ' ', grep { length $_ } ($realclean->{FILES} \|\| (), @_),
	169	);
	170	}
	171
	172	sub libs {
	173	my $self = shift;
	174	my $libs = ref $_[0] ? shift : [ shift ];
	175	$self->makemaker_args( LIBS => $libs );
	176	}
	177
	178	sub inc {
	179	my $self = shift;
	180	$self->makemaker_args( INC => shift );
	181	}
	182
	183	sub _wanted_t {
	184	}
	185
	186	sub tests_recursive {
	187	my $self = shift;
	188	my $dir = shift \|\| 't';
	189	unless ( -d $dir ) {
	190	die "tests_recursive dir '$dir' does not exist";
	191	}
	192	my %tests = map { $_ => 1 } split / /, ($self->tests \|\| '');
	193	require File::Find;
	194	File::Find::find(
	195	sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 },
	196	$dir
	197	);
	198	$self->tests( join ' ', sort keys %tests );
	199	}
	200
	201	sub write {
	202	my $self = shift;
	203	die "&Makefile->write() takes no arguments\n" if @_;
	204
	205	# Check the current Perl version
	206	my $perl_version = $self->perl_version;
	207	if ( $perl_version ) {
	208	eval "use $perl_version; 1"
	209	or die "ERROR: perl: Version $] is installed, "
	210	. "but we need version >= $perl_version";
	211	}
	212
	213	# Make sure we have a new enough MakeMaker
	214	require ExtUtils::MakeMaker;
	215
	216	if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) {
	217	# MakeMaker can complain about module versions that include
	218	# an underscore, even though its own version may contain one!
	219	# Hence the funny regexp to get rid of it. See RT #35800
	220	# for details.
	221	my $v = $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/;
	222	$self->build_requires( 'ExtUtils::MakeMaker' => $v );
	223	$self->configure_requires( 'ExtUtils::MakeMaker' => $v );
	224	} else {
	225	# Allow legacy-compatibility with 5.005 by depending on the
	226	# most recent EU:MM that supported 5.005.
	227	$self->build_requires( 'ExtUtils::MakeMaker' => 6.42 );
	228	$self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 );
	229	}
	230
	231	# Generate the MakeMaker params
	232	my $args = $self->makemaker_args;
	233	$args->{DISTNAME} = $self->name;
	234	$args->{NAME} = $self->module_name \|\| $self->name;
	235	$args->{NAME} =~ s/-/::/g;
	236	$args->{VERSION} = $self->version or die <<'EOT';
	237	ERROR: Can't determine distribution version. Please specify it
	238	explicitly via 'version' in Makefile.PL, or set a valid $VERSION
	239	in a module, and provide its file path via 'version_from' (or
	240	'all_from' if you prefer) in Makefile.PL.
	241	EOT
	242
	243	$DB::single = 1;
	244	if ( $self->tests ) {
	245	my @tests = split ' ', $self->tests;
	246	my %seen;
	247	$args->{test} = {
	248	TESTS => (join ' ', grep {!$seen{$_}++} @tests),
	249	};
	250	} elsif ( $Module::Install::ExtraTests::use_extratests ) {
	251	# Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness.
	252	# So, just ignore our xt tests here.
	253	} elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) {
	254	$args->{test} = {
	255	TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ),
	256	};
	257	}
	258	if ( $] >= 5.005 ) {
	259	$args->{ABSTRACT} = $self->abstract;
	260	$args->{AUTHOR} = join ', ', @{$self->author \|\| []};
	261	}
	262	if ( $self->makemaker(6.10) ) {
	263	$args->{NO_META} = 1;
	264	#$args->{NO_MYMETA} = 1;
	265	}
	266	if ( $self->makemaker(6.17) and $self->sign ) {
	267	$args->{SIGN} = 1;
	268	}
	269	unless ( $self->is_admin ) {
	270	delete $args->{SIGN};
	271	}
	272	if ( $self->makemaker(6.31) and $self->license ) {
	273	$args->{LICENSE} = $self->license;
	274	}
	275
	276	my $prereq = ($args->{PREREQ_PM} \|\|= {});
	277	%$prereq = ( %$prereq,
	278	map { @$_ } # flatten [module => version]
	279	map { @$_ }
	280	grep $_,
	281	($self->requires)
	282	);
	283
	284	# Remove any reference to perl, PREREQ_PM doesn't support it
	285	delete $args->{PREREQ_PM}->{perl};
	286
	287	# Merge both kinds of requires into BUILD_REQUIRES
	288	my $build_prereq = ($args->{BUILD_REQUIRES} \|\|= {});
	289	%$build_prereq = ( %$build_prereq,
	290	map { @$_ } # flatten [module => version]
	291	map { @$_ }
	292	grep $_,
	293	($self->configure_requires, $self->build_requires)
	294	);
	295
	296	# Remove any reference to perl, BUILD_REQUIRES doesn't support it
	297	delete $args->{BUILD_REQUIRES}->{perl};
	298
	299	# Delete bundled dists from prereq_pm, add it to Makefile DIR
	300	my $subdirs = ($args->{DIR} \|\| []);
	301	if ($self->bundles) {
	302	my %processed;
	303	foreach my $bundle (@{ $self->bundles }) {
	304	my ($mod_name, $dist_dir) = @$bundle;
	305	delete $prereq->{$mod_name};
	306	$dist_dir = File::Basename::basename($dist_dir); # dir for building this module
	307	if (not exists $processed{$dist_dir}) {
	308	if (-d $dist_dir) {
	309	# List as sub-directory to be processed by make
	310	push @$subdirs, $dist_dir;
	311	}
	312	# Else do nothing: the module is already present on the system
	313	$processed{$dist_dir} = undef;
	314	}
	315	}
	316	}
	317
	318	unless ( $self->makemaker('6.55_03') ) {
	319	%$prereq = (%$prereq,%$build_prereq);
	320	delete $args->{BUILD_REQUIRES};
	321	}
	322
	323	if ( my $perl_version = $self->perl_version ) {
	324	eval "use $perl_version; 1"
	325	or die "ERROR: perl: Version $] is installed, "
	326	. "but we need version >= $perl_version";
	327
	328	if ( $self->makemaker(6.48) ) {
	329	$args->{MIN_PERL_VERSION} = $perl_version;
	330	}
	331	}
	332
	333	if ($self->installdirs) {
	334	warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS};
	335	$args->{INSTALLDIRS} = $self->installdirs;
	336	}
	337
	338	my %args = map {
	339	( $_ => $args->{$_} ) } grep {defined($args->{$_} )
	340	} keys %$args;
	341
	342	my $user_preop = delete $args{dist}->{PREOP};
	343	if ( my $preop = $self->admin->preop($user_preop) ) {
	344	foreach my $key ( keys %$preop ) {
	345	$args{dist}->{$key} = $preop->{$key};
	346	}
	347	}
	348
	349	my $mm = ExtUtils::MakeMaker::WriteMakefile(%args);
	350	$self->fix_up_makefile($mm->{FIRST_MAKEFILE} \|\| 'Makefile');
	351	}
	352
	353	sub fix_up_makefile {
	354	my $self = shift;
	355	my $makefile_name = shift;
	356	my $top_class = ref($self->_top) \|\| '';
	357	my $top_version = $self->_top->VERSION \|\| '';
	358
	359	my $preamble = $self->preamble
	360	? "# Preamble by $top_class $top_version\n"
	361	. $self->preamble
	362	: '';
	363	my $postamble = "# Postamble by $top_class $top_version\n"
	364	. ($self->postamble \|\| '');
	365
	366	local *MAKEFILE;
	367	open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
	368	eval { flock MAKEFILE, LOCK_EX };
	369	my $makefile = do { local $/; <MAKEFILE> };
	370
	371	$makefile =~ s/\b(test_harness$\$\(TEST_VERBOSE$, )/$1'inc', /;
	372	$makefile =~ s/( -I\$$INST_ARCHLIB$)/ -Iinc$1/g;
	373	$makefile =~ s/( "-I\$$INST_LIB$")/ "-Iinc"$1/g;
	374	$makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m;
	375	$makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m;
	376
	377	# Module::Install will never be used to build the Core Perl
	378	# Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks
	379	# PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist
	380	$makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m;
	381	#$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m;
	382
	383	# Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well.
	384	$makefile =~ s/(\"?)-I\$$PERL_LIB$\1//g;
	385
	386	# XXX - This is currently unused; not sure if it breaks other MM-users
	387	# $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg;
	388
	389	seek MAKEFILE, 0, SEEK_SET;
	390	truncate MAKEFILE, 0;
	391	print MAKEFILE "$preamble$makefile$postamble" or die $!;
	392	close MAKEFILE or die $!;
	393
	394	1;
	395	}
	396
	397	sub preamble {
	398	my ($self, $text) = @_;
	399	$self->{preamble} = $text . $self->{preamble} if defined $text;
	400	$self->{preamble};
	401	}
	402
	403	sub postamble {
	404	my ($self, $text) = @_;
	405	$self->{postamble} \|\|= $self->admin->postamble;
	406	$self->{postamble} .= $text if defined $text;
	407	$self->{postamble}
	408	}
	409
	410	1;
	411
	412	__END__
	413
	414	#line 541

+715

-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 @ISA $ISCORE};
	7	BEGIN {
	8	$VERSION = '1.00';
	9	@ISA = 'Module::Install::Base';
	10	$ISCORE = 1;
	11	}
	12
	13	my @boolean_keys = qw{
	14	sign
	15	};
	16
	17	my @scalar_keys = qw{
	18	name
	19	module_name
	20	abstract
	21	version
	22	distribution_type
	23	tests
	24	installdirs
	25	};
	26
	27	my @tuple_keys = qw{
	28	configure_requires
	29	build_requires
	30	requires
	31	recommends
	32	bundles
	33	resources
	34	};
	35
	36	my @resource_keys = qw{
	37	homepage
	38	bugtracker
	39	repository
	40	};
	41
	42	my @array_keys = qw{
	43	keywords
	44	author
	45	};
	46
	47	*authors = \&author;
	48
	49	sub Meta { shift }
	50	sub Meta_BooleanKeys { @boolean_keys }
	51	sub Meta_ScalarKeys { @scalar_keys }
	52	sub Meta_TupleKeys { @tuple_keys }
	53	sub Meta_ResourceKeys { @resource_keys }
	54	sub Meta_ArrayKeys { @array_keys }
	55
	56	foreach my $key ( @boolean_keys ) {
	57	*$key = sub {
	58	my $self = shift;
	59	if ( defined wantarray and not @_ ) {
	60	return $self->{values}->{$key};
	61	}
	62	$self->{values}->{$key} = ( @_ ? $_[0] : 1 );
	63	return $self;
	64	};
	65	}
	66
	67	foreach my $key ( @scalar_keys ) {
	68	*$key = sub {
	69	my $self = shift;
	70	return $self->{values}->{$key} if defined wantarray and !@_;
	71	$self->{values}->{$key} = shift;
	72	return $self;
	73	};
	74	}
	75
	76	foreach my $key ( @array_keys ) {
	77	*$key = sub {
	78	my $self = shift;
	79	return $self->{values}->{$key} if defined wantarray and !@_;
	80	$self->{values}->{$key} \|\|= [];
	81	push @{$self->{values}->{$key}}, @_;
	82	return $self;
	83	};
	84	}
	85
	86	foreach my $key ( @resource_keys ) {
	87	*$key = sub {
	88	my $self = shift;
	89	unless ( @_ ) {
	90	return () unless $self->{values}->{resources};
	91	return map { $_->[1] }
	92	grep { $_->[0] eq $key }
	93	@{ $self->{values}->{resources} };
	94	}
	95	return $self->{values}->{resources}->{$key} unless @_;
	96	my $uri = shift or die(
	97	"Did not provide a value to $key()"
	98	);
	99	$self->resources( $key => $uri );
	100	return 1;
	101	};
	102	}
	103
	104	foreach my $key ( grep { $_ ne "resources" } @tuple_keys) {
	105	*$key = sub {
	106	my $self = shift;
	107	return $self->{values}->{$key} unless @_;
	108	my @added;
	109	while ( @_ ) {
	110	my $module = shift or last;
	111	my $version = shift \|\| 0;
	112	push @added, [ $module, $version ];
	113	}
	114	push @{ $self->{values}->{$key} }, @added;
	115	return map {@$_} @added;
	116	};
	117	}
	118
	119	# Resource handling
	120	my %lc_resource = map { $_ => 1 } qw{
	121	homepage
	122	license
	123	bugtracker
	124	repository
	125	};
	126
	127	sub resources {
	128	my $self = shift;
	129	while ( @_ ) {
	130	my $name = shift or last;
	131	my $value = shift or next;
	132	if ( $name eq lc $name and ! $lc_resource{$name} ) {
	133	die("Unsupported reserved lowercase resource '$name'");
	134	}
	135	$self->{values}->{resources} \|\|= [];
	136	push @{ $self->{values}->{resources} }, [ $name, $value ];
	137	}
	138	$self->{values}->{resources};
	139	}
	140
	141	# Aliases for build_requires that will have alternative
	142	# meanings in some future version of META.yml.
	143	sub test_requires { shift->build_requires(@_) }
	144	sub install_requires { shift->build_requires(@_) }
	145
	146	# Aliases for installdirs options
	147	sub install_as_core { $_[0]->installdirs('perl') }
	148	sub install_as_cpan { $_[0]->installdirs('site') }
	149	sub install_as_site { $_[0]->installdirs('site') }
	150	sub install_as_vendor { $_[0]->installdirs('vendor') }
	151
	152	sub dynamic_config {
	153	my $self = shift;
	154	unless ( @_ ) {
	155	warn "You MUST provide an explicit true/false value to dynamic_config\n";
	156	return $self;
	157	}
	158	$self->{values}->{dynamic_config} = $_[0] ? 1 : 0;
	159	return 1;
	160	}
	161
	162	sub perl_version {
	163	my $self = shift;
	164	return $self->{values}->{perl_version} unless @_;
	165	my $version = shift or die(
	166	"Did not provide a value to perl_version()"
	167	);
	168
	169	# Normalize the version
	170	$version = $self->_perl_version($version);
	171
	172	# We don't support the reall old versions
	173	unless ( $version >= 5.005 ) {
	174	die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n";
	175	}
	176
	177	$self->{values}->{perl_version} = $version;
	178	}
	179
	180	sub all_from {
	181	my ( $self, $file ) = @_;
	182
	183	unless ( defined($file) ) {
	184	my $name = $self->name or die(
	185	"all_from called with no args without setting name() first"
	186	);
	187	$file = join('/', 'lib', split(/-/, $name)) . '.pm';
	188	$file =~ s{.*/}{} unless -e $file;
	189	unless ( -e $file ) {
	190	die("all_from cannot find $file from $name");
	191	}
	192	}
	193	unless ( -f $file ) {
	194	die("The path '$file' does not exist, or is not a file");
	195	}
	196
	197	$self->{values}{all_from} = $file;
	198
	199	# Some methods pull from POD instead of code.
	200	# If there is a matching .pod, use that instead
	201	my $pod = $file;
	202	$pod =~ s/\.pm$/.pod/i;
	203	$pod = $file unless -e $pod;
	204
	205	# Pull the different values
	206	$self->name_from($file) unless $self->name;
	207	$self->version_from($file) unless $self->version;
	208	$self->perl_version_from($file) unless $self->perl_version;
	209	$self->author_from($pod) unless @{$self->author \|\| []};
	210	$self->license_from($pod) unless $self->license;
	211	$self->abstract_from($pod) unless $self->abstract;
	212
	213	return 1;
	214	}
	215
	216	sub provides {
	217	my $self = shift;
	218	my $provides = ( $self->{values}->{provides} \|\|= {} );
	219	%$provides = (%$provides, @_) if @_;
	220	return $provides;
	221	}
	222
	223	sub auto_provides {
	224	my $self = shift;
	225	return $self unless $self->is_admin;
	226	unless (-e 'MANIFEST') {
	227	warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
	228	return $self;
	229	}
	230	# Avoid spurious warnings as we are not checking manifest here.
	231	local $SIG{__WARN__} = sub {1};
	232	require ExtUtils::Manifest;
	233	local *ExtUtils::Manifest::manicheck = sub { return };
	234
	235	require Module::Build;
	236	my $build = Module::Build->new(
	237	dist_name => $self->name,
	238	dist_version => $self->version,
	239	license => $self->license,
	240	);
	241	$self->provides( %{ $build->find_dist_packages \|\| {} } );
	242	}
	243
	244	sub feature {
	245	my $self = shift;
	246	my $name = shift;
	247	my $features = ( $self->{values}->{features} \|\|= [] );
	248	my $mods;
	249
	250	if ( @_ == 1 and ref( $_[0] ) ) {
	251	# The user used ->feature like ->features by passing in the second
	252	# argument as a reference. Accomodate for that.
	253	$mods = $_[0];
	254	} else {
	255	$mods = \@_;
	256	}
	257
	258	my $count = 0;
	259	push @$features, (
	260	$name => [
	261	map {
	262	ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_
	263	} @$mods
	264	]
	265	);
	266
	267	return @$features;
	268	}
	269
	270	sub features {
	271	my $self = shift;
	272	while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
	273	$self->feature( $name, @$mods );
	274	}
	275	return $self->{values}->{features}
	276	? @{ $self->{values}->{features} }
	277	: ();
	278	}
	279
	280	sub no_index {
	281	my $self = shift;
	282	my $type = shift;
	283	push @{ $self->{values}->{no_index}->{$type} }, @_ if $type;
	284	return $self->{values}->{no_index};
	285	}
	286
	287	sub read {
	288	my $self = shift;
	289	$self->include_deps( 'YAML::Tiny', 0 );
	290
	291	require YAML::Tiny;
	292	my $data = YAML::Tiny::LoadFile('META.yml');
	293
	294	# Call methods explicitly in case user has already set some values.
	295	while ( my ( $key, $value ) = each %$data ) {
	296	next unless $self->can($key);
	297	if ( ref $value eq 'HASH' ) {
	298	while ( my ( $module, $version ) = each %$value ) {
	299	$self->can($key)->($self, $module => $version );
	300	}
	301	} else {
	302	$self->can($key)->($self, $value);
	303	}
	304	}
	305	return $self;
	306	}
	307
	308	sub write {
	309	my $self = shift;
	310	return $self unless $self->is_admin;
	311	$self->admin->write_meta;
	312	return $self;
	313	}
	314
	315	sub version_from {
	316	require ExtUtils::MM_Unix;
	317	my ( $self, $file ) = @_;
	318	$self->version( ExtUtils::MM_Unix->parse_version($file) );
	319
	320	# for version integrity check
	321	$self->makemaker_args( VERSION_FROM => $file );
	322	}
	323
	324	sub abstract_from {
	325	require ExtUtils::MM_Unix;
	326	my ( $self, $file ) = @_;
	327	$self->abstract(
	328	bless(
	329	{ DISTNAME => $self->name },
	330	'ExtUtils::MM_Unix'
	331	)->parse_abstract($file)
	332	);
	333	}
	334
	335	# Add both distribution and module name
	336	sub name_from {
	337	my ($self, $file) = @_;
	338	if (
	339	Module::Install::_read($file) =~ m/
	340	^ \s*
	341	package \s*
	342	([\w:]+)
	343	\s* ;
	344	/ixms
	345	) {
	346	my ($name, $module_name) = ($1, $1);
	347	$name =~ s{::}{-}g;
	348	$self->name($name);
	349	unless ( $self->module_name ) {
	350	$self->module_name($module_name);
	351	}
	352	} else {
	353	die("Cannot determine name from $file\n");
	354	}
	355	}
	356
	357	sub _extract_perl_version {
	358	if (
	359	$_[0] =~ m/
	360	^\s*
	361	(?:use\|require) \s*
	362	v?
	363	([\d_\.]+)
	364	\s* ;
	365	/ixms
	366	) {
	367	my $perl_version = $1;
	368	$perl_version =~ s{_}{}g;
	369	return $perl_version;
	370	} else {
	371	return;
	372	}
	373	}
	374
	375	sub perl_version_from {
	376	my $self = shift;
	377	my $perl_version=_extract_perl_version(Module::Install::_read($_[0]));
	378	if ($perl_version) {
	379	$self->perl_version($perl_version);
	380	} else {
	381	warn "Cannot determine perl version info from $_[0]\n";
	382	return;
	383	}
	384	}
	385
	386	sub author_from {
	387	my $self = shift;
	388	my $content = Module::Install::_read($_[0]);
	389	if ($content =~ m/
	390	=head \d \s+ (?:authors?)\b \s*
	391	([^\n]*)
	392	\|
	393	=head \d \s+ (?:licen[cs]e\|licensing\|copyright\|legal)\b \s*
	394	.? copyright .? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
	395	([^\n]*)
	396	/ixms) {
	397	my $author = $1 \|\| $2;
	398
	399	# XXX: ugly but should work anyway...
	400	if (eval "require Pod::Escapes; 1") {
	401	# Pod::Escapes has a mapping table.
	402	# It's in core of perl >= 5.9.3, and should be installed
	403	# as one of the Pod::Simple's prereqs, which is a prereq
	404	# of Pod::Text 3.x (see also below).
	405	$author =~ s{ E<( (\d+) \| ([A-Za-z]+) )> }
	406	{
	407	defined $2
	408	? chr($2)
	409	: defined $Pod::Escapes::Name2character_number{$1}
	410	? chr($Pod::Escapes::Name2character_number{$1})
	411	: do {
	412	warn "Unknown escape: E<$1>";
	413	"E<$1>";
	414	};
	415	}gex;
	416	}
	417	elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) {
	418	# Pod::Text < 3.0 has yet another mapping table,
	419	# though the table name of 2.x and 1.x are different.
	420	# (1.x is in core of Perl < 5.6, 2.x is in core of
	421	# Perl < 5.9.3)
	422	my $mapping = ($Pod::Text::VERSION < 2)
	423	? \%Pod::Text::HTML_Escapes
	424	: \%Pod::Text::ESCAPES;
	425	$author =~ s{ E<( (\d+) \| ([A-Za-z]+) )> }
	426	{
	427	defined $2
	428	? chr($2)
	429	: defined $mapping->{$1}
	430	? $mapping->{$1}
	431	: do {
	432	warn "Unknown escape: E<$1>";
	433	"E<$1>";
	434	};
	435	}gex;
	436	}
	437	else {
	438	$author =~ s{E<lt>}{<}g;
	439	$author =~ s{E<gt>}{>}g;
	440	}
	441	$self->author($author);
	442	} else {
	443	warn "Cannot determine author info from $_[0]\n";
	444	}
	445	}
	446
	447	#Stolen from M::B
	448	my %license_urls = (
	449	perl => 'http://dev.perl.org/licenses/',
	450	apache => 'http://apache.org/licenses/LICENSE-2.0',
	451	apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1',
	452	artistic => 'http://opensource.org/licenses/artistic-license.php',
	453	artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php',
	454	lgpl => 'http://opensource.org/licenses/lgpl-license.php',
	455	lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php',
	456	lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html',
	457	bsd => 'http://opensource.org/licenses/bsd-license.php',
	458	gpl => 'http://opensource.org/licenses/gpl-license.php',
	459	gpl2 => 'http://opensource.org/licenses/gpl-2.0.php',
	460	gpl3 => 'http://opensource.org/licenses/gpl-3.0.html',
	461	mit => 'http://opensource.org/licenses/mit-license.php',
	462	mozilla => 'http://opensource.org/licenses/mozilla1.1.php',
	463	open_source => undef,
	464	unrestricted => undef,
	465	restrictive => undef,
	466	unknown => undef,
	467	);
	468
	469	sub license {
	470	my $self = shift;
	471	return $self->{values}->{license} unless @_;
	472	my $license = shift or die(
	473	'Did not provide a value to license()'
	474	);
	475	$license = __extract_license($license) \|\| lc $license;
	476	$self->{values}->{license} = $license;
	477
	478	# Automatically fill in license URLs
	479	if ( $license_urls{$license} ) {
	480	$self->resources( license => $license_urls{$license} );
	481	}
	482
	483	return 1;
	484	}
	485
	486	sub _extract_license {
	487	my $pod = shift;
	488	my $matched;
	489	return __extract_license(
	490	($matched) = $pod =~ m/
	491	(=head \d \s+ L(?i:ICEN[CS]E\|ICENSING)\b.*?)
	492	(=head \d.\|=cut.\|)\z
	493	/xms
	494	) \|\| __extract_license(
	495	($matched) = $pod =~ m/
	496	(=head \d \s+ (?:C(?i:OPYRIGHTS?)\|L(?i:EGAL))\b.*?)
	497	(=head \d.\|=cut.\|)\z
	498	/xms
	499	);
	500	}
	501
	502	sub __extract_license {
	503	my $license_text = shift or return;
	504	my @phrases = (
	505	'(?:under )?the same (?:terms\|license) as (?:perl\|the perl (?:\d )?programming language)' => 'perl', 1,
	506	'(?:under )?the terms of (?:perl\|the perl programming language) itself' => 'perl', 1,
	507	'Artistic and GPL' => 'perl', 1,
	508	'GNU general public license' => 'gpl', 1,
	509	'GNU public license' => 'gpl', 1,
	510	'GNU lesser general public license' => 'lgpl', 1,
	511	'GNU lesser public license' => 'lgpl', 1,
	512	'GNU library general public license' => 'lgpl', 1,
	513	'GNU library public license' => 'lgpl', 1,
	514	'GNU Free Documentation license' => 'unrestricted', 1,
	515	'GNU Affero General Public License' => 'open_source', 1,
	516	'(?:Free)?BSD license' => 'bsd', 1,
	517	'Artistic license' => 'artistic', 1,
	518	'Apache (?:Software )?license' => 'apache', 1,
	519	'GPL' => 'gpl', 1,
	520	'LGPL' => 'lgpl', 1,
	521	'BSD' => 'bsd', 1,
	522	'Artistic' => 'artistic', 1,
	523	'MIT' => 'mit', 1,
	524	'Mozilla Public License' => 'mozilla', 1,
	525	'Q Public License' => 'open_source', 1,
	526	'OpenSSL License' => 'unrestricted', 1,
	527	'SSLeay License' => 'unrestricted', 1,
	528	'zlib License' => 'open_source', 1,
	529	'proprietary' => 'proprietary', 0,
	530	);
	531	while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
	532	$pattern =~ s#\s+#\\s+#gs;
	533	if ( $license_text =~ /\b$pattern\b/i ) {
	534	return $license;
	535	}
	536	}
	537	return '';
	538	}
	539
	540	sub license_from {
	541	my $self = shift;
	542	if (my $license=_extract_license(Module::Install::_read($_[0]))) {
	543	$self->license($license);
	544	} else {
	545	warn "Cannot determine license info from $_[0]\n";
	546	return 'unknown';
	547	}
	548	}
	549
	550	sub _extract_bugtracker {
	551	my @links = $_[0] =~ m#L<(
	552	\Qhttp://rt.cpan.org/\E[^>]+\|
	553	\Qhttp://github.com/\E[\w_]+/[\w_]+/issues\|
	554	\Qhttp://code.google.com/p/\E[\w_\-]+/issues/list
	555	)>#gx;
	556	my %links;
	557	@links{@links}=();
	558	@links=keys %links;
	559	return @links;
	560	}
	561
	562	sub bugtracker_from {
	563	my $self = shift;
	564	my $content = Module::Install::_read($_[0]);
	565	my @links = _extract_bugtracker($content);
	566	unless ( @links ) {
	567	warn "Cannot determine bugtracker info from $_[0]\n";
	568	return 0;
	569	}
	570	if ( @links > 1 ) {
	571	warn "Found more than one bugtracker link in $_[0]\n";
	572	return 0;
	573	}
	574
	575	# Set the bugtracker
	576	bugtracker( $links[0] );
	577	return 1;
	578	}
	579
	580	sub requires_from {
	581	my $self = shift;
	582	my $content = Module::Install::_readperl($_[0]);
	583	my @requires = $content =~ m/^use\s+([^\W\d]\w(?:::\w+))\s+([\d\.]+)/mg;
	584	while ( @requires ) {
	585	my $module = shift @requires;
	586	my $version = shift @requires;
	587	$self->requires( $module => $version );
	588	}
	589	}
	590
	591	sub test_requires_from {
	592	my $self = shift;
	593	my $content = Module::Install::_readperl($_[0]);
	594	my @requires = $content =~ m/^use\s+([^\W\d]\w(?:::\w+))\s+([\d\.]+)/mg;
	595	while ( @requires ) {
	596	my $module = shift @requires;
	597	my $version = shift @requires;
	598	$self->test_requires( $module => $version );
	599	}
	600	}
	601
	602	# Convert triple-part versions (eg, 5.6.1 or 5.8.9) to
	603	# numbers (eg, 5.006001 or 5.008009).
	604	# Also, convert double-part versions (eg, 5.8)
	605	sub _perl_version {
	606	my $v = $_[-1];
	607	$v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e;
	608	$v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0\|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 \|\| 0)/e;
	609	$v =~ s/(\.\d\d\d)000$/$1/;
	610	$v =~ s/_.+$//;
	611	if ( ref($v) ) {
	612	# Numify
	613	$v = $v + 0;
	614	}
	615	return $v;
	616	}
	617
	618	sub add_metadata {
	619	my $self = shift;
	620	my %hash = @_;
	621	for my $key (keys %hash) {
	622	warn "add_metadata: $key is not prefixed with 'x_'.\n" .
	623	"Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/;
	624	$self->{values}->{$key} = $hash{$key};
	625	}
	626	}
	627
	628
	629	######################################################################
	630	# MYMETA Support
	631
	632	sub WriteMyMeta {
	633	die "WriteMyMeta has been deprecated";
	634	}
	635
	636	sub write_mymeta_yaml {
	637	my $self = shift;
	638
	639	# We need YAML::Tiny to write the MYMETA.yml file
	640	unless ( eval { require YAML::Tiny; 1; } ) {
	641	return 1;
	642	}
	643
	644	# Generate the data
	645	my $meta = $self->_write_mymeta_data or return 1;
	646
	647	# Save as the MYMETA.yml file
	648	print "Writing MYMETA.yml\n";
	649	YAML::Tiny::DumpFile('MYMETA.yml', $meta);
	650	}
	651
	652	sub write_mymeta_json {
	653	my $self = shift;
	654
	655	# We need JSON to write the MYMETA.json file
	656	unless ( eval { require JSON; 1; } ) {
	657	return 1;
	658	}
	659
	660	# Generate the data
	661	my $meta = $self->_write_mymeta_data or return 1;
	662
	663	# Save as the MYMETA.yml file
	664	print "Writing MYMETA.json\n";
	665	Module::Install::_write(
	666	'MYMETA.json',
	667	JSON->new->pretty(1)->canonical->encode($meta),
	668	);
	669	}
	670
	671	sub _write_mymeta_data {
	672	my $self = shift;
	673
	674	# If there's no existing META.yml there is nothing we can do
	675	return undef unless -f 'META.yml';
	676
	677	# We need Parse::CPAN::Meta to load the file
	678	unless ( eval { require Parse::CPAN::Meta; 1; } ) {
	679	return undef;
	680	}
	681
	682	# Merge the perl version into the dependencies
	683	my $val = $self->Meta->{values};
	684	my $perl = delete $val->{perl_version};
	685	if ( $perl ) {
	686	$val->{requires} \|\|= [];
	687	my $requires = $val->{requires};
	688
	689	# Canonize to three-dot version after Perl 5.6
	690	if ( $perl >= 5.006 ) {
	691	$perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2\|\|0), int($3\|\|0))}e
	692	}
	693	unshift @$requires, [ perl => $perl ];
	694	}
	695
	696	# Load the advisory META.yml file
	697	my @yaml = Parse::CPAN::Meta::LoadFile('META.yml');
	698	my $meta = $yaml[0];
	699
	700	# Overwrite the non-configure dependency hashs
	701	delete $meta->{requires};
	702	delete $meta->{build_requires};
	703	delete $meta->{recommends};
	704	if ( exists $val->{requires} ) {
	705	$meta->{requires} = { map { @$_ } @{ $val->{requires} } };
	706	}
	707	if ( exists $val->{build_requires} ) {
	708	$meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } };
	709	}
	710
	711	return $meta;
	712	}
	713
	714	1;

+88

-0

inc/Module/Install/Repository.pm less more

	0	#line 1
	1	package Module::Install::Repository;
	2
	3	use strict;
	4	use 5.005;
	5	use vars qw($VERSION);
	6	$VERSION = '0.06';
	7
	8	use base qw(Module::Install::Base);
	9
	10	sub _execute {
	11	my ($command) = @_;
	12	`$command`;
	13	}
	14
	15	sub auto_set_repository {
	16	my $self = shift;
	17
	18	return unless $Module::Install::AUTHOR;
	19
	20	my $repo = _find_repo(\&_execute);
	21	if ($repo) {
	22	$self->repository($repo);
	23	} else {
	24	warn "Cannot determine repository URL\n";
	25	}
	26	}
	27
	28	sub _find_repo {
	29	my ($execute) = @_;
	30
	31	if (-e ".git") {
	32	# TODO support remote besides 'origin'?
	33	if ($execute->('git remote show -n origin') =~ /URL: (.*)$/m) {
	34	# XXX Make it public clone URL, but this only works with github
	35	my $git_url = $1;
	36	$git_url =~ s![\w\-]+\@([^:]+):!git://$1/!;
	37	return $git_url;
	38	} elsif ($execute->('git svn info') =~ /URL: (.*)$/m) {
	39	return $1;
	40	}
	41	} elsif (-e ".svn") {
	42	if (`svn info` =~ /URL: (.*)$/m) {
	43	return $1;
	44	}
	45	} elsif (-e "_darcs") {
	46	# defaultrepo is better, but that is more likely to be ssh, not http
	47	if (my $query_repo = `darcs query repo`) {
	48	if ($query_repo =~ m!Default Remote: (http://.+)!) {
	49	return $1;
	50	}
	51	}
	52
	53	open my $handle, '<', '_darcs/prefs/repos' or return;
	54	while (<$handle>) {
	55	chomp;
	56	return $_ if m!^http://!;
	57	}
	58	} elsif (-e ".hg") {
	59	if ($execute->('hg paths') =~ /default = (.*)$/m) {
	60	my $mercurial_url = $1;
	61	$mercurial_url =~ s!^ssh://hg\@(bitbucket\.org/)!https://$1!;
	62	return $mercurial_url;
	63	}
	64	} elsif (-e "$ENV{HOME}/.svk") {
	65	# Is there an explicit way to check if it's an svk checkout?
	66	my $svk_info = `svk info` or return;
	67	SVK_INFO: {
	68	if ($svk_info =~ /Mirrored From: (.*), Rev\./) {
	69	return $1;
	70	}
	71
	72	if ($svk_info =~ m!Merged From: (/mirror/.*), Rev\.!) {
	73	$svk_info = `svk info /$1` or return;
	74	redo SVK_INFO;
	75	}
	76	}
	77
	78	return;
	79	}
	80	}
	81
	82	1;
	83	__END__
	84
	85	=encoding utf-8
	86
	87	#line 128

+64

-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 @ISA $ISCORE};
	7	BEGIN {
	8	$VERSION = '1.00';
	9	@ISA = 'Module::Install::Base';
	10	$ISCORE = 1;
	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	die <<'END_MESSAGE' unless $rv;
	41
	42	-------------------------------------------------------------------------------
	43
	44	Since you are using Microsoft Windows, you will need the 'nmake' utility
	45	before installation. It's available at:
	46
	47	http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe
	48	or
	49	ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe
	50
	51	Please download the file manually, save it to a directory in %PATH% (e.g.
	52	C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to
	53	that directory, and run "Nmake15.exe" from there; that will create the
	54	'nmake.exe' file needed by this module.
	55
	56	You may then resume the installation process described in README.
	57
	58	-------------------------------------------------------------------------------
	59	END_MESSAGE
	60
	61	}
	62
	63	1;

+63

-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 @ISA $ISCORE};
	7	BEGIN {
	8	$VERSION = '1.00';
	9	@ISA = qw{Module::Install::Base};
	10	$ISCORE = 1;
	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->admin->WriteAll(%args) if $self->is_admin;
	25
	26	$self->check_nmake if $args{check_nmake};
	27	unless ( $self->makemaker_args->{PL_FILES} ) {
	28	# XXX: This still may be a bit over-defensive...
	29	unless ($self->makemaker(6.25)) {
	30	$self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL';
	31	}
	32	}
	33
	34	# Until ExtUtils::MakeMaker support MYMETA.yml, make sure
	35	# we clean it up properly ourself.
	36	$self->realclean_files('MYMETA.yml');
	37
	38	if ( $args{inline} ) {
	39	$self->Inline->write;
	40	} else {
	41	$self->Makefile->write;
	42	}
	43
	44	# The Makefile write process adds a couple of dependencies,
	45	# so write the META.yml files after the Makefile.
	46	if ( $args{meta} ) {
	47	$self->Meta->write;
	48	}
	49
	50	# Experimental support for MYMETA
	51	if ( $ENV{X_MYMETA} ) {
	52	if ( $ENV{X_MYMETA} eq 'JSON' ) {
	53	$self->Meta->write_mymeta_json;
	54	} else {
	55	$self->Meta->write_mymeta_yaml;
	56	}
	57	}
	58
	59	return 1;
	60	}
	61
	62	1;

+470

-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.005;
	20	use strict 'vars';
	21	use Cwd ();
	22	use File::Find ();
	23	use File::Path ();
	24
	25	use vars qw{$VERSION $MAIN};
	26	BEGIN {
	27	# All Module::Install core packages now require synchronised versions.
	28	# This will be used to ensure we don't accidentally load old or
	29	# different versions of modules.
	30	# This is not enforced yet, but will be some time in the next few
	31	# releases once we can make sure it won't clash with custom
	32	# Module::Install extensions.
	33	$VERSION = '1.00';
	34
	35	# Storage for the pseudo-singleton
	36	$MAIN = undef;
	37
	38	inc::Module::Install::VERSION = VERSION;
	39	@inc::Module::Install::ISA = __PACKAGE__;
	40
	41	}
	42
	43	sub import {
	44	my $class = shift;
	45	my $self = $class->new(@_);
	46	my $who = $self->_caller;
	47
	48	#-------------------------------------------------------------
	49	# all of the following checks should be included in import(),
	50	# to allow "eval 'require Module::Install; 1' to test
	51	# installation of Module::Install. (RT #51267)
	52	#-------------------------------------------------------------
	53
	54	# Whether or not inc::Module::Install is actually loaded, the
	55	# $INC{inc/Module/Install.pm} is what will still get set as long as
	56	# the caller loaded module this in the documented manner.
	57	# If not set, the caller may NOT have loaded the bundled version, and thus
	58	# they may not have a MI version that works with the Makefile.PL. This would
	59	# result in false errors or unexpected behaviour. And we don't want that.
	60	my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
	61	unless ( $INC{$file} ) { die <<"END_DIE" }
	62
	63	Please invoke ${\__PACKAGE__} with:
	64
	65	use inc::${\__PACKAGE__};
	66
	67	not:
	68
	69	use ${\__PACKAGE__};
	70
	71	END_DIE
	72
	73	# This reportedly fixes a rare Win32 UTC file time issue, but
	74	# as this is a non-cross-platform XS module not in the core,
	75	# we shouldn't really depend on it. See RT #24194 for detail.
	76	# (Also, this module only supports Perl 5.6 and above).
	77	eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006;
	78
	79	# If the script that is loading Module::Install is from the future,
	80	# then make will detect this and cause it to re-run over and over
	81	# again. This is bad. Rather than taking action to touch it (which
	82	# is unreliable on some platforms and requires write permissions)
	83	# for now we should catch this and refuse to run.
	84	if ( -f $0 ) {
	85	my $s = (stat($0))[9];
	86
	87	# If the modification time is only slightly in the future,
	88	# sleep briefly to remove the problem.
	89	my $a = $s - time;
	90	if ( $a > 0 and $a < 5 ) { sleep 5 }
	91
	92	# Too far in the future, throw an error.
	93	my $t = time;
	94	if ( $s > $t ) { die <<"END_DIE" }
	95
	96	Your installer $0 has a modification time in the future ($s > $t).
	97
	98	This is known to create infinite loops in make.
	99
	100	Please correct this, then run $0 again.
	101
	102	END_DIE
	103	}
	104
	105
	106	# Build.PL was formerly supported, but no longer is due to excessive
	107	# difficulty in implementing every single feature twice.
	108	if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }
	109
	110	Module::Install no longer supports Build.PL.
	111
	112	It was impossible to maintain duel backends, and has been deprecated.
	113
	114	Please remove all Build.PL files and only use the Makefile.PL installer.
	115
	116	END_DIE
	117
	118	#-------------------------------------------------------------
	119
	120	# To save some more typing in Module::Install installers, every...
	121	# use inc::Module::Install
	122	# ...also acts as an implicit use strict.
	123	$^H \|= strict::bits(qw(refs subs vars));
	124
	125	#-------------------------------------------------------------
	126
	127	unless ( -f $self->{file} ) {
	128	foreach my $key (keys %INC) {
	129	delete $INC{$key} if $key =~ /Module\/Install/;
	130	}
	131
	132	local $^W;
	133	require "$self->{path}/$self->{dispatch}.pm";
	134	File::Path::mkpath("$self->{prefix}/$self->{author}");
	135	$self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
	136	$self->{admin}->init;
	137	@_ = ($class, _self => $self);
	138	goto &{"$self->{name}::import"};
	139	}
	140
	141	local $^W;
	142	*{"${who}::AUTOLOAD"} = $self->autoload;
	143	$self->preload;
	144
	145	# Unregister loader and worker packages so subdirs can use them again
	146	delete $INC{'inc/Module/Install.pm'};
	147	delete $INC{'Module/Install.pm'};
	148
	149	# Save to the singleton
	150	$MAIN = $self;
	151
	152	return 1;
	153	}
	154
	155	sub autoload {
	156	my $self = shift;
	157	my $who = $self->_caller;
	158	my $cwd = Cwd::cwd();
	159	my $sym = "${who}::AUTOLOAD";
	160	$sym->{$cwd} = sub {
	161	my $pwd = Cwd::cwd();
	162	if ( my $code = $sym->{$pwd} ) {
	163	# Delegate back to parent dirs
	164	goto &$code unless $cwd eq $pwd;
	165	}
	166	unless ($$sym =~ s/([^:]+)$//) {
	167	# XXX: it looks like we can't retrieve the missing function
	168	# via $$sym (usually $main::AUTOLOAD) in this case.
	169	# I'm still wondering if we should slurp Makefile.PL to
	170	# get some context or not ...
	171	my ($package, $file, $line) = caller;
	172	die <<"EOT";
	173	Unknown function is found at $file line $line.
	174	Execution of $file aborted due to runtime errors.
	175
	176	If you're a contributor to a project, you may need to install
	177	some Module::Install extensions from CPAN (or other repository).
	178	If you're a user of a module, please contact the author.
	179	EOT
	180	}
	181	my $method = $1;
	182	if ( uc($method) eq $method ) {
	183	# Do nothing
	184	return;
	185	} elsif ( $method =~ /^_/ and $self->can($method) ) {
	186	# Dispatch to the root M:I class
	187	return $self->$method(@_);
	188	}
	189
	190	# Dispatch to the appropriate plugin
	191	unshift @_, ( $self, $1 );
	192	goto &{$self->can('call')};
	193	};
	194	}
	195
	196	sub preload {
	197	my $self = shift;
	198	unless ( $self->{extensions} ) {
	199	$self->load_extensions(
	200	"$self->{prefix}/$self->{path}", $self
	201	);
	202	}
	203
	204	my @exts = @{$self->{extensions}};
	205	unless ( @exts ) {
	206	@exts = $self->{admin}->load_all_extensions;
	207	}
	208
	209	my %seen;
	210	foreach my $obj ( @exts ) {
	211	while (my ($method, $glob) = each %{ref($obj) . '::'}) {
	212	next unless $obj->can($method);
	213	next if $method =~ /^_/;
	214	next if $method eq uc($method);
	215	$seen{$method}++;
	216	}
	217	}
	218
	219	my $who = $self->_caller;
	220	foreach my $name ( sort keys %seen ) {
	221	local $^W;
	222	*{"${who}::$name"} = sub {
	223	${"${who}::AUTOLOAD"} = "${who}::$name";
	224	goto &{"${who}::AUTOLOAD"};
	225	};
	226	}
	227	}
	228
	229	sub new {
	230	my ($class, %args) = @_;
	231
	232	delete $INC{'FindBin.pm'};
	233	{
	234	# to suppress the redefine warning
	235	local $SIG{__WARN__} = sub {};
	236	require FindBin;
	237	}
	238
	239	# ignore the prefix on extension modules built from top level.
	240	my $base_path = Cwd::abs_path($FindBin::Bin);
	241	unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
	242	delete $args{prefix};
	243	}
	244	return $args{_self} if $args{_self};
	245
	246	$args{dispatch} \|\|= 'Admin';
	247	$args{prefix} \|\|= 'inc';
	248	$args{author} \|\|= ($^O eq 'VMS' ? '_author' : '.author');
	249	$args{bundle} \|\|= 'inc/BUNDLES';
	250	$args{base} \|\|= $base_path;
	251	$class =~ s/^\Q$args{prefix}\E:://;
	252	$args{name} \|\|= $class;
	253	$args{version} \|\|= $class->VERSION;
	254	unless ( $args{path} ) {
	255	$args{path} = $args{name};
	256	$args{path} =~ s!::!/!g;
	257	}
	258	$args{file} \|\|= "$args{base}/$args{prefix}/$args{path}.pm";
	259	$args{wrote} = 0;
	260
	261	bless( \%args, $class );
	262	}
	263
	264	sub call {
	265	my ($self, $method) = @_;
	266	my $obj = $self->load($method) or return;
	267	splice(@_, 0, 2, $obj);
	268	goto &{$obj->can($method)};
	269	}
	270
	271	sub load {
	272	my ($self, $method) = @_;
	273
	274	$self->load_extensions(
	275	"$self->{prefix}/$self->{path}", $self
	276	) unless $self->{extensions};
	277
	278	foreach my $obj (@{$self->{extensions}}) {
	279	return $obj if $obj->can($method);
	280	}
	281
	282	my $admin = $self->{admin} or die <<"END_DIE";
	283	The '$method' method does not exist in the '$self->{prefix}' path!
	284	Please remove the '$self->{prefix}' directory and run $0 again to load it.
	285	END_DIE
	286
	287	my $obj = $admin->load($method, 1);
	288	push @{$self->{extensions}}, $obj;
	289
	290	$obj;
	291	}
	292
	293	sub load_extensions {
	294	my ($self, $path, $top) = @_;
	295
	296	my $should_reload = 0;
	297	unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
	298	unshift @INC, $self->{prefix};
	299	$should_reload = 1;
	300	}
	301
	302	foreach my $rv ( $self->find_extensions($path) ) {
	303	my ($file, $pkg) = @{$rv};
	304	next if $self->{pathnames}{$pkg};
	305
	306	local $@;
	307	my $new = eval { local $^W; require $file; $pkg->can('new') };
	308	unless ( $new ) {
	309	warn $@ if $@;
	310	next;
	311	}
	312	$self->{pathnames}{$pkg} =
	313	$should_reload ? delete $INC{$file} : $INC{$file};
	314	push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
	315	}
	316
	317	$self->{extensions} \|\|= [];
	318	}
	319
	320	sub find_extensions {
	321	my ($self, $path) = @_;
	322
	323	my @found;
	324	File::Find::find( sub {
	325	my $file = $File::Find::name;
	326	return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
	327	my $subpath = $1;
	328	return if lc($subpath) eq lc($self->{dispatch});
	329
	330	$file = "$self->{path}/$subpath.pm";
	331	my $pkg = "$self->{name}::$subpath";
	332	$pkg =~ s!/!::!g;
	333
	334	# If we have a mixed-case package name, assume case has been preserved
	335	# correctly. Otherwise, root through the file to locate the case-preserved
	336	# version of the package name.
	337	if ( $subpath eq lc($subpath) \|\| $subpath eq uc($subpath) ) {
	338	my $content = Module::Install::_read($subpath . '.pm');
	339	my $in_pod = 0;
	340	foreach ( split //, $content ) {
	341	$in_pod = 1 if /^=\w/;
	342	$in_pod = 0 if /^=cut/;
	343	next if ($in_pod \|\| /^=cut/); # skip pod text
	344	next if /^\s*#/; # and comments
	345	if ( m/^\spackage\s+($pkg)\s;/i ) {
	346	$pkg = $1;
	347	last;
	348	}
	349	}
	350	}
	351
	352	push @found, [ $file, $pkg ];
	353	}, $path ) if -d $path;
	354
	355	@found;
	356	}
	357
	358
	359
	360
	361
	362	#####################################################################
	363	# Common Utility Functions
	364
	365	sub _caller {
	366	my $depth = 0;
	367	my $call = caller($depth);
	368	while ( $call eq __PACKAGE__ ) {
	369	$depth++;
	370	$call = caller($depth);
	371	}
	372	return $call;
	373	}
	374
	375	# Done in evals to avoid confusing Perl::MinimumVersion
	376	eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
	377	sub _read {
	378	local *FH;
	379	open( FH, '<', $_[0] ) or die "open($_[0]): $!";
	380	my $string = do { local $/; <FH> };
	381	close FH or die "close($_[0]): $!";
	382	return $string;
	383	}
	384	END_NEW
	385	sub _read {
	386	local *FH;
	387	open( FH, "< $_[0]" ) or die "open($_[0]): $!";
	388	my $string = do { local $/; <FH> };
	389	close FH or die "close($_[0]): $!";
	390	return $string;
	391	}
	392	END_OLD
	393
	394	sub _readperl {
	395	my $string = Module::Install::_read($_[0]);
	396	$string =~ s/(?:\015{1,2}\012\|\015\|\012)/\n/sg;
	397	$string =~ s/(\n)\n__(?:DATA\|END)__\b.\z/$1/s;
	398	$string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg;
	399	return $string;
	400	}
	401
	402	sub _readpod {
	403	my $string = Module::Install::_read($_[0]);
	404	$string =~ s/(?:\015{1,2}\012\|\015\|\012)/\n/sg;
	405	return $string if $_[0] =~ /\.pod\z/;
	406	$string =~ s/(^\|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+\|\z)/$1$2/sg;
	407	$string =~ s/\n=pod\b[^\n]\n+/\n\n/sg;
	408	$string =~ s/\n=cut\b[^\n]\n+/\n\n/sg;
	409	$string =~ s/^\n+//s;
	410	return $string;
	411	}
	412
	413	# Done in evals to avoid confusing Perl::MinimumVersion
	414	eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
	415	sub _write {
	416	local *FH;
	417	open( FH, '>', $_[0] ) or die "open($_[0]): $!";
	418	foreach ( 1 .. $#_ ) {
	419	print FH $_[$_] or die "print($_[0]): $!";
	420	}
	421	close FH or die "close($_[0]): $!";
	422	}
	423	END_NEW
	424	sub _write {
	425	local *FH;
	426	open( FH, "> $_[0]" ) or die "open($_[0]): $!";
	427	foreach ( 1 .. $#_ ) {
	428	print FH $_[$_] or die "print($_[0]): $!";
	429	}
	430	close FH or die "close($_[0]): $!";
	431	}
	432	END_OLD
	433
	434	# _version is for processing module versions (eg, 1.03_05) not
	435	# Perl versions (eg, 5.8.1).
	436	sub _version ($) {
	437	my $s = shift \|\| 0;
	438	my $d =()= $s =~ /(\.)/g;
	439	if ( $d >= 2 ) {
	440	# Normalise multipart versions
	441	$s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg;
	442	}
	443	$s =~ s/^(\d+)\.?//;
	444	my $l = $1 \|\| 0;
	445	my @v = map {
	446	$_ . '0' x (3 - length $_)
	447	} $s =~ /(\d{1,3})\D?/g;
	448	$l = $l . '.' . join '', @v if @v;
	449	return $l + 0;
	450	}
	451
	452	sub _cmp ($$) {
	453	_version($_[0]) <=> _version($_[1]);
	454	}
	455
	456	# Cloned from Params::Util::_CLASS
	457	sub _CLASS ($) {
	458	(
	459	defined $_[0]
	460	and
	461	! ref $_[0]
	462	and
	463	$_[0] =~ m/^[^\W\d]\w(?:::\w+)\z/s
	464	) ? $_[0] : undef;
	465	}
	466
	467	1;
	468
	469	# Copyright 2008 - 2010 Adam Kennedy.

+61

-0

lib/MouseX/StrictConstructor.pm less more

	0	package MouseX::StrictConstructor;
	1
	2	use 5.006_002;
	3	use Mouse ();
	4	use Mouse::Exporter;
	5
	6	our $VERSION = '0.02';
	7
	8	Mouse::Exporter->setup_import_methods();
	9
	10	sub init_meta {
	11	shift;
	12	my $meta = Mouse->init_meta(@_);
	13	$meta->strict_constructor(1); # XXX: Mouse-extended feature
	14	return $meta;
	15	}
	16
	17	1;
	18	__END__
	19
	20	=head1 NAME
	21
	22	MouseX::StrictConstructor - Make your object constructors blow up on unknown attributes
	23
	24	=head1 SYNOPSIS
	25
	26	use Mouse;
	27	use MouseX::StrictConstructor;
	28
	29	=head1 DESCRIPTION
	30
	31	Simply loading this module makes your constructors "strict". If your
	32	constructor is called with an attribute argument that your class
	33	does not declare, then it dies. This is a great way to catch small typos.
	34
	35	=head1 BUGS
	36
	37	All complex software has bugs lurking in it, and this module is no
	38	exception. If you find a bug please either email me, or add the bug
	39	to cpan-RT.
	40
	41	=head1 SEE ALSO
	42
	43	L<Mouse>
	44
	45	L<Moose>
	46
	47	L<MooseX::StrictConstructor>
	48
	49	=head1 AUTHOR
	50
	51	Fuji, Goro (gfx) E<lt>gfuji(at)cpan.orgE<gt>
	52
	53	=head1 COPYRIGHT AND LICENSE
	54
	55	Copyright (c) 2010, Fuji, Goro (gfx). All rights reserved.
	56
	57	This library is free software; you can redistribute it and/or modify
	58	it under the same terms as Perl itself.
	59
	60	=cut

-0

t/000_load.t less more

	0	#!perl -w
	1	use Test::More tests => 1;
	2	BEGIN { use_ok('MouseX::StrictConstructor') };

+42

-0

t/001_basic.t less more

	0	#!perl -w
	1	use Test::More;
	2
	3	use Test::Mouse;
	4
	5	{
	6	package Foo;
	7	use Mouse;
	8	use MouseX::StrictConstructor;
	9
	10	has [qw(foo bar)] => (is => 'rw');
	11	}
	12
	13	{
	14	package Foo::Bar;
	15	use Mouse;
	16	extends 'Foo';
	17
	18	has [qw(baz)] => (is => 'rw');
	19	}
	20
	21	with_immutable sub {
	22	isa_ok(Foo->new(foo => 1, bar => 2), 'Foo');
	23
	24	eval {
	25	Foo->new(foo => 1, bar => 2, baz => 3);
	26	};
	27	like $@, qr/\b Foo \b/xms;
	28	like $@, qr/\b baz \b/xms;
	29
	30	isa_ok eval {
	31	Foo::Bar->new(foo => 1, bar => 2, baz => 3);
	32	}, 'Foo::Bar';
	33
	34	eval {
	35	Foo::Bar->new(foo => 1, bar => 2, baz => 3, qux => 4);
	36	};
	37	like $@, qr/\b Foo::Bar \b/xms;
	38	like $@, qr/\b qux \b/xms;
	39	}, qw(Foo Foo::Bar);
	40
	41	done_testing;

+60

-0

xt/01_podspell.t less more

	0	#!perl -w
	1
	2	use strict;
	3	use Test::More;
	4
	5	eval q{ use Test::Spelling; system("which", "spell") == 0 or die };
	6
	7	plan skip_all => q{Test::Spelling and spell(1) are not available.}
	8	if $@;
	9
	10	add_stopwords(map { split /[\s\:\-]/ } <DATA>);
	11	$ENV{LANG} = 'C';
	12	all_pod_files_spelling_ok('lib');
	13
	14	__DATA__
	15	Text::Xslate
	16	xslate
	17	todo
	18	str
	19	Opcode
	20	cpan
	21	render
	22	Kolon
	23	Metakolon
	24	TTerse
	25	syntaxes
	26	pre
	27	namespaces
	28	plugins
	29	html
	30	acknowledgement
	31	iff
	32	EscapedString
	33	sandboxing
	34	APIs
	35	runtime
	36	autoboxing
	37	backend
	38	TT
	39	adaptor
	40	overridable
	41	inline
	42	Toolkit's
	43	FillInForm
	44	uri
	45	CLI
	46	PSGI
	47
	48	# personal name
	49	lestrrat
	50	tokuhirom
	51	gardejo
	52	jjn
	53	Goro Fuji
	54	gfx
	55	Douglas Crockford
	56	makamaka
	57	Hannyaharamitu
	58	Maki
	59	Daisuke

-0

xt/02_pod.t less more

	0	#!perl -w
	1
	2	use strict;
	3	use Test::More;
	4	eval q{use Test::Pod 1.14};
	5	plan skip_all => 'Test::Pod 1.14 required for testing PODU'
	6	if $@;
	7
	8	all_pod_files_ok();

+11

-0

xt/03_pod-coverage.t less more

	0	#!perl -w
	1
	2	use Test::More;
	3	eval q{use Test::Pod::Coverage 1.04};
	4
	5	plan skip_all => 'Test::Pod::Coverage 1.04 required for testing POD coverage'
	6	if $@;
	7
	8	all_pod_coverage_ok({
	9	also_private => [qw(unimport BUILD DEMOLISH)],
	10	});

-0

xt/04_synopsis.t less more

	0	#!perl
	1	use strict;
	2	use Test::More;
	3	eval q{use Test::Synopsis};
	4	plan skip_all => 'Test::Synopsis required for testing' if $@;
	5	local $SIG{__WARN__} = sub {
	6	warn @_ if $_[0] !~ /redefined/;
	7	};
	8	all_synopsis_ok();

+12

-0

xt/05_vars.t less more

	0	#!perl -w
	1
	2	use strict;
	3	use Test::More;
	4
	5	use Test::Requires qw(Test::Vars);
	6
	7	all_vars_ok(
	8	ignore_vars => [qw($parser $symbol)],
	9	);
	10
	11	done_testing;