Commit d6734351af0af6a53ace3f46902d2463272ca1b7 - libobject-destroyer-perl

[svn-upgrade] new version libobject-destroyer-perl (2.01) Ansgar Burchardt 13 years ago

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

+17

-13

Changes less more

0	0	Revision history for Perl extension Object::Destroyer
1	1
	2	2.01 Thu 24 Mar 2011
	3	- Updating to Module::Install::DSL 1.00
	4	- Bump perl version to 5.006 to keep the minimum version test happy
	5
2	6	2.00 Wed Dec 6 2006
3		- Added support for missing void context for wrapper
4		- Removed obligatory requirement for Scalar::Util
5		- Added new method - dismiss - to cancel the Destroyer
6
	7	- Added support for missing void context for wrapper
	8	- Removed obligatory requirement for Scalar::Util
	9	- Added new method - dismiss - to cancel the Destroyer
	10
7	11	1.99 Tue Oct 17 2006
8		- Complete overhaul by Igor Gariev to expand its functionality
9		- Added support for explicit clean-up method name
10		- Added support for clean-up code by code reference
11		- Added support for AUTOLOAD'ed methods of wrapped objects
	12	- Complete overhaul by Igor Gariev to expand its functionality
	13	- Added support for explicit clean-up method name
	14	- Added support for clean-up code by code reference
	15	- Added support for AUTOLOAD'ed methods of wrapped objects
12	16
13	17	1.02 Fri 6 Oct 2006
14		- Moving to new SVN repository
15		- Cleaning up tests
16		- Updating to Module::Install 0.64
17		- Moving to production version
	18	- Moving to new SVN repository
	19	- Cleaning up tests
	20	- Updating to Module::Install 0.64
	21	- Moving to production version
18	22
19	23	0.1 Sun Jan 11 2004
20		- original version
	24	- original version

-1

MANIFEST less more

1	1	inc/Module/Install.pm
2	2	inc/Module/Install/Base.pm
3	3	inc/Module/Install/Can.pm
	4	inc/Module/Install/DSL.pm
4	5	inc/Module/Install/Fetch.pm
5	6	inc/Module/Install/Makefile.pm
6	7	inc/Module/Install/Metadata.pm

17	18	t/03_destroy.t
18	19	t/04_wrapper.t
19	20	t/05_dismiss.t
20		t/99_author.t
	21	xt/meta.t
	22	xt/pmv.t
	23	xt/pod.t

+22

-10

META.yml less more

0		abstract: Make objects with circular references DESTROY normally
1		author: Adam Kennedy <adamk@cpan.org> and Igor Gariev <gariev@hotmail.com>
2		build_requires:
	0	---
	1	abstract: 'Make objects with circular references DESTROY normally'
	2	author:
	3	- 'Adam Kennedy <adamk@cpan.org>'
	4	build_requires:
	5	ExtUtils::MakeMaker: 6.42
3	6	Test::More: 0.42
	7	configure_requires:
	8	ExtUtils::MakeMaker: 6.42
4	9	distribution_type: module
5		generated_by: Module::Install version 0.64
	10	generated_by: 'Module::Install version 1.00'
6	11	license: perl
	12	meta-spec:
	13	url: http://module-build.sourceforge.net/META-spec-v1.4.html
	14	version: 1.4
7	15	name: Object-Destroyer
8		no_index:
9		directory:
	16	no_index:
	17	directory:
10	18	- inc
11	19	- t
12		requires:
13		Carp: 0
14		perl: 5.005
15		version: 2.00
	20	- xt
	21	requires:
	22	perl: 5.6.0
	23	resources:
	24	ChangeLog: http://fisheye2.atlassian.com/changelog/cpan/trunk/Object-Destroyer
	25	license: http://dev.perl.org/licenses/
	26	repository: http://svn.ali.as/cpan/trunk/Object-Destroyer
	27	version: 2.01

-9

Makefile.PL less more

0		use strict;
1		use inc::Module::Install;
	0	use inc::Module::Install::DSL 1.00;
2	1
3		name 'Object-Destroyer';
4		all_from 'lib/Object/Destroyer.pm';
5		requires 'Carp' => 0;
6		build_requires 'Test::More' => '0.42';
7
8		WriteAll();
9
	2	name Object-Destroyer
	3	all_from lib/Object/Destroyer.pm
	4	test_requires Test::More 0.42

+29

-27

README less more

3	3
4	4	SYNOPSIS
5	5	use Object::Destroyer;
6
7		## Use a standalone destroyer to release something
	6
	7	## Use a standalone destroyer to release something
8	8	## when it falls out of scope
9	9	BLOCK:
10	10	{

29	29	my $Mess = Big::Custy::Mess->new;
30	30	print $Mess->hello;
31	31	}
32
33		package Big::Crusty::Mess;
	32
	33	package Big::Crusty::Mess;
34	34	sub new {
35	35	my $self = bless {}, shift;
36	36	$self->populate;

73	73	# Parse in a large nested document
74	74	my $filename = shift;
75	75	my $document = My::XML::Tree->open($filename);
76
77		# Create the Object::Destroyer to clean it up as needed
	76
	77	# Create the Object::Destroyer to clean it up as needed
78	78	my $sentry = Object::Destroyer->new( $document, 'release' );
79
80		# Continue with the Document as normal
	79
	80	# Continue with the Document as normal
81	81	if ($document->author == $me) {
82	82	# Normally this would have leaked the document
83	83	return new Error("You already own the Document");
84	84	}
85
86		$document->change_author($me);
	85
	86	$document->change_author($me);
87	87	$document->save;
88	88
89	89	# We don't have to $Document->DESTROY here

118	118	##
119	119
120	120	... code with return, next or last ...
121
122		}
	121
	122	}
123	123
124	124	Use as a Transparent Wrapper
125	125	For situations where a class is always going to produce circular

130	130	Take the following example class
131	131
132	132	package My::Tree;
133
134		use strict;
	133
	134	use strict;
135	135	use Object::Destroyer;
136
137		sub new {
	136
	137	sub new {
138	138	my $self = bless {}, shift;
139	139	$self->init; ## assume that circular references are made
140	140

142	142	my $wrapper = Object::Destroyer->new( $self, 'release' );
143	143	return $wrapper;
144	144	}
145
146		sub release {
	145
	146	sub release {
147	147	my $self = shift;
148	148	foreach (values %$self) {
149	149	$_->DESTROY if ref $_ eq 'My::Tree::Node';

156	156	sub process_file {
157	157	# Create a new tree
158	158	my $tree = My::Tree->new( source => shift );
159
160		# Process the Tree
	159
	160	# Process the Tree
161	161	if ($tree->comments) {
162	162	$tree->remove_comments or return;
163	163	}
164	164	else {
165	165	return 1; # Nothing to do
166	166	}
167
168		my $filename = $tree->param('target') or return;
	167
	168	my $filename = $tree->param('target') or return;
169	169	$tree->write($filename) or return;
170
171		return 1;
	170
	171	return 1;
172	172	}
173	173
174	174	We were able to work with the data, and at no point did we know that we

199	199	my $sentry = Object::Destroyer->new( $object );
200	200	my $sentry = Object::Destroyer->new( $object, 'method_name' );
201	201	my $sentry = Object::Destroyer->new( $code_reference );
202
	202
203	203	The "new" constructor takes as arguments either a single blessed
204	204	object with an optional name of the method to be called, or a
205	205	refernce to code to be executed. If the method name is not

242	242	Kennedy.
243	243
244	244	AUTHORS
245		Adam Kennedy <adamk@cpan.org> and Igor Gariev <gariev@hotmail.com>
	245	Adam Kennedy <adamk@cpan.org>
	246
	247	Igor Gariev <gariev@hotmail.com>
246	248
247	249	COPYRIGHT
248		Copyright 2004 - 2006 Adam Kennedy.
	250	Copyright 2004 - 2011 Adam Kennedy.
249	251
250	252	This program is free software; you can redistribute it and/or modify it
251	253	under the same terms as Perl itself.

+39

-26

inc/Module/Install/Base.pm less more

0	0	#line 1
1	1	package Module::Install::Base;
2	2
3		$VERSION = '0.64';
	3	use strict 'vars';
	4	use vars qw{$VERSION};
	5	BEGIN {
	6	$VERSION = '1.00';
	7	}
4	8
5	9	# Suspend handler for "redefined" warnings
6	10	BEGIN {

8	12	$SIG{__WARN__} = sub { $w };
9	13	}
10	14
11		### This is the ONLY module that shouldn't have strict on
12		# use strict;
13
14		#line 41
	15	#line 42
15	16
16	17	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 );
	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	26	}
27	27
28	28	#line 61
29	29
30	30	sub AUTOLOAD {
31		my $self = shift;
32		local $@;
33		my $autoload = eval { $self->_top->autoload } or return;
34		goto &$autoload;
	31	local $@;
	32	my $func = eval { shift->_top->autoload } or return;
	33	goto &$func;
35	34	}
36	35
37		#line 76
	36	#line 75
38	37
39		sub _top { $_[0]->{_top} }
	38	sub _top {
	39	$_[0]->{_top};
	40	}
40	41
41		#line 89
	42	#line 90
42	43
43	44	sub admin {
44		$_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new;
	45	$_[0]->_top->{admin}
	46	or
	47	Module::Install::Base::FakeAdmin->new;
45	48	}
46	49
	50	#line 106
	51
47	52	sub is_admin {
48		$_[0]->admin->VERSION;
	53	! $_[0]->admin->isa('Module::Install::Base::FakeAdmin');
49	54	}
50	55
51	56	sub DESTROY {}
52	57
53	58	package Module::Install::Base::FakeAdmin;
54	59
55		my $Fake;
56		sub new { $Fake \|\|= bless(\@_, $_[0]) }
	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	}
57	70
58	71	sub AUTOLOAD {}
59	72

66	79
67	80	1;
68	81
69		#line 138
	82	#line 159

-10

inc/Module/Install/Can.pm less more

1	1	package Module::Install::Can;
2	2
3	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 ();
	4	use Config ();
	5	use File::Spec ();
	6	use ExtUtils::MakeMaker ();
	7	use Module::Install::Base ();
10	8
11		use vars qw{$VERSION $ISCORE @ISA};
	9	use vars qw{$VERSION @ISA $ISCORE};
12	10	BEGIN {
13		$VERSION = '0.64';
	11	$VERSION = '1.00';
	12	@ISA = 'Module::Install::Base';
14	13	$ISCORE = 1;
15		@ISA = qw{Module::Install::Base};
16	14	}
17	15
18	16	# check if we can load some module

38	36	return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd));
39	37
40	38	for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') {
	39	next if $dir eq '';
41	40	my $abs = File::Spec->catfile($dir, $_[1]);
42	41	return $abs if (-x $abs or $abs = MM->maybe_command($abs));
43	42	}

78	77
79	78	__END__
80	79
81		#line 157
	80	#line 156

+94

-0

inc/Module/Install/DSL.pm less more

	0	#line 1
	1	package Module::Install::DSL;
	2
	3	use strict;
	4	use vars qw{$VERSION $ISCORE};
	5	BEGIN {
	6	$VERSION = '1.00';
	7	$ISCORE = 1;
	8	inc::Module::Install::DSL::VERSION = VERSION;
	9	@inc::Module::Install::DSL::ISA = __PACKAGE__;
	10	}
	11
	12	sub import {
	13	# Read in the rest of the Makefile.PL
	14	open 0 or die "Couldn't open $0: $!";
	15	my $dsl;
	16	SCOPE: {
	17	local $/ = undef;
	18	$dsl = join "", <0>;
	19	}
	20
	21	# Change inc::Module::Install::DSL to the regular one.
	22	# Remove anything before the use inc::... line.
	23	$dsl =~ s/.?^\suse\s+(?:inc::)?Module::Install::DSL(\b[^;]);\s\n//sm;
	24
	25	# Load inc::Module::Install as we would in a regular Makefile.Pl
	26	SCOPE: {
	27	package main;
	28	require inc::Module::Install;
	29	inc::Module::Install->import;
	30	}
	31
	32	# Add the ::DSL plugin to the list of packages in /inc
	33	my $admin = $Module::Install::MAIN->{admin};
	34	if ( $admin ) {
	35	my $from = $INC{"$admin->{path}/DSL.pm"};
	36	my $to = "$admin->{base}/$admin->{prefix}/$admin->{path}/DSL.pm";
	37	$admin->copy( $from => $to );
	38	}
	39
	40	# Convert the basic syntax to code
	41	my $code = "INIT {\n"
	42	. "package main;\n\n"
	43	. dsl2code($dsl)
	44	. "\n\nWriteAll();\n"
	45	. "}\n";
	46
	47	# Execute the script
	48	eval $code;
	49	print STDERR "Failed to execute the generated code...\n$@" if $@;
	50
	51	exit(0);
	52	}
	53
	54	sub dsl2code {
	55	my $dsl = shift;
	56
	57	# Split into lines and strip blanks
	58	my @lines = grep { /\S/ } split /[\012\015]+/, $dsl;
	59
	60	# Each line represents one command
	61	my @code = ();
	62	foreach my $line ( @lines ) {
	63	# Split the lines into tokens
	64	my @tokens = split /\s+/, $line;
	65
	66	# The first word is the command
	67	my $command = shift @tokens;
	68	my @params = ();
	69	my @suffix = ();
	70	while ( @tokens ) {
	71	my $token = shift @tokens;
	72	if ( $token eq 'if' or $token eq 'unless' ) {
	73	# This is the beginning of a suffix
	74	push @suffix, $token;
	75	push @suffix, @tokens;
	76	last;
	77	} else {
	78	# Convert to a string
	79	$token =~ s/([\\\'])/\\$1/g;
	80	push @params, "'$token'";
	81	}
	82	};
	83
	84	# Merge to create the final line of code
	85	@tokens = ( $command, @params ? join( ', ', @params ) : (), @suffix );
	86	push @code, join( ' ', @tokens ) . ";\n";
	87	}
	88
	89	# Join into the complete code block
	90	return join( '', @code );
	91	}
	92
	93	1;

-6

inc/Module/Install/Fetch.pm less more

1	1	package Module::Install::Fetch;
2	2
3	3	use strict;
4		use Module::Install::Base;
	4	use Module::Install::Base ();
5	5
6		use vars qw{$VERSION $ISCORE @ISA};
	6	use vars qw{$VERSION @ISA $ISCORE};
7	7	BEGIN {
8		$VERSION = '0.64';
	8	$VERSION = '1.00';
	9	@ISA = 'Module::Install::Base';
9	10	$ISCORE = 1;
10		@ISA = qw{Module::Install::Base};
11	11	}
12	12
13	13	sub get_file {
14	14	my ($self, %args) = @_;
15		my ($scheme, $host, $path, $file) =
	15	my ($scheme, $host, $path, $file) =
16	16	$args{url} =~ m\|^(\w+)://([^/]+)(.+)/(.+)\| or return;
17	17
18	18	if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) {
19	19	$args{url} = $args{ftp_url}
20	20	or (warn("LWP support unavailable!\n"), return);
21		($scheme, $host, $path, $file) =
	21	($scheme, $host, $path, $file) =
22	22	$args{url} =~ m\|^(\w+)://([^/]+)(.+)/(.+)\| or return;
23	23	}
24	24

+370

-163

inc/Module/Install/Makefile.pm less more

1	1	package Module::Install::Makefile;
2	2
3	3	use strict 'vars';
4		use Module::Install::Base;
5		use ExtUtils::MakeMaker ();
6
7		use vars qw{$VERSION $ISCORE @ISA};
	4	use ExtUtils::MakeMaker ();
	5	use Module::Install::Base ();
	6	use Fcntl qw/:flock :seek/;
	7
	8	use vars qw{$VERSION @ISA $ISCORE};
8	9	BEGIN {
9		$VERSION = '0.64';
	10	$VERSION = '1.00';
	11	@ISA = 'Module::Install::Base';
10	12	$ISCORE = 1;
11		@ISA = qw{Module::Install::Base};
12	13	}
13	14
14	15	sub Makefile { $_[0] }

16	17	my %seen = ();
17	18
18	19	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		}
	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	);
35	99
36	100	sub makemaker_args {
37		my $self = shift;
38		my $args = ($self->{makemaker_args} \|\|= {});
39		%$args = ( %$args, @_ ) if @_;
40		$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;
41	133	}
42	134
43	135	# For mm args that take multiple space-seperated args,
44	136	# append an argument to the current list.
45	137	sub makemaker_append {
46		my $self = shift;
47		my $name = shift;
48		my $args = $self->makemaker_args;
49		$args->{name} = defined $args->{$name}
50		? join( ' ', $args->{name}, @_ )
51		: join( ' ', @_ );
	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( ' ', @_ );
52	144	}
53	145
54	146	sub build_subdirs {
55		my $self = shift;
56		my $subdirs = $self->makemaker_args->{DIR} \|\|= [];
57		for my $subdir (@_) {
58		push @$subdirs, $subdir;
59		}
	147	my $self = shift;
	148	my $subdirs = $self->makemaker_args->{DIR} \|\|= [];
	149	for my $subdir (@_) {
	150	push @$subdirs, $subdir;
	151	}
60	152	}
61	153
62	154	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}, @_),
	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
68	197	);
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 );
	198	$self->tests( join ' ', sort keys %tests );
89	199	}
90	200
91	201	sub write {
92		my $self = shift;
93		die "&Makefile->write() takes no arguments\n" if @_;
94
95		my $args = $self->makemaker_args;
96		$args->{DISTNAME} = $self->name;
97		$args->{NAME} = $self->module_name \|\| $self->name \|\| $self->determine_NAME($args);
98		$args->{VERSION} = $self->version \|\| $self->determine_VERSION($args);
99		$args->{NAME} =~ s/-/::/g;
100		if ( $self->tests ) {
101		$args->{test} = { TESTS => $self->tests };
102		}
103		if ($] >= 5.005) {
104		$args->{ABSTRACT} = $self->abstract;
105		$args->{AUTHOR} = $self->author;
106		}
107		if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) {
108		$args->{NO_META} = 1;
109		}
110		if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) {
111		$args->{SIGN} = 1;
112		}
113		unless ( $self->is_admin ) {
114		delete $args->{SIGN};
115		}
116
117		# merge both kinds of requires into prereq_pm
118		my $prereq = ($args->{PREREQ_PM} \|\|= {});
119		%$prereq = ( %$prereq, map { @$_ } map { @$_ } grep $_,
120		($self->build_requires, $self->requires) );
121
122		# merge both kinds of requires into prereq_pm
123		my $subdirs = ($args->{DIR} \|\|= []);
124		if ($self->bundles) {
125		foreach my $bundle (@{ $self->bundles }) {
126		my ($file, $dir) = @$bundle;
127		push @$subdirs, $dir if -d $dir;
128		delete $prereq->{$file};
129		}
130		}
131
132		if ( my $perl_version = $self->perl_version ) {
133		eval "use $perl_version; 1"
134		or die "ERROR: perl: Version $] is installed, "
135		. "but we need version >= $perl_version";
136		}
137
138		my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args;
139		if ($self->admin->preop) {
140		$args{dist} = $self->admin->preop;
141		}
142
143		my $mm = ExtUtils::MakeMaker::WriteMakefile(%args);
144		$self->fix_up_makefile($mm->{FIRST_MAKEFILE} \|\| 'Makefile');
	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');
145	351	}
146	352
147	353	sub fix_up_makefile {
148		my $self = shift;
149		my $makefile_name = shift;
150		my $top_class = ref($self->_top) \|\| '';
151		my $top_version = $self->_top->VERSION \|\| '';
152
153		my $preamble = $self->preamble
154		? "# Preamble by $top_class $top_version\n"
155		. $self->preamble
156		: '';
157		my $postamble = "# Postamble by $top_class $top_version\n"
158		. ($self->postamble \|\| '');
159
160		local *MAKEFILE;
161		open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
162		my $makefile = do { local $/; <MAKEFILE> };
163		close MAKEFILE or die $!;
164
165		$makefile =~ s/\b(test_harness$\$\(TEST_VERBOSE$, )/$1'inc', /;
166		$makefile =~ s/( -I\$$INST_ARCHLIB$)/ -Iinc$1/g;
167		$makefile =~ s/( "-I\$$INST_LIB$")/ "-Iinc"$1/g;
168		$makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m;
169		$makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m;
170
171		# Module::Install will never be used to build the Core Perl
172		# Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks
173		# PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist
174		$makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m;
175		#$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m;
176
177		# Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well.
178		$makefile =~ s/("?)-I\$$PERL_LIB$\1//g;
179
180		# XXX - This is currently unused; not sure if it breaks other MM-users
181		# $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg;
182
183		open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
184		print MAKEFILE "$preamble$makefile$postamble" or die $!;
185		close MAKEFILE or die $!;
186
187		1;
	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;
188	395	}
189	396
190	397	sub preamble {
191		my ($self, $text) = @_;
192		$self->{preamble} = $text . $self->{preamble} if defined $text;
193		$self->{preamble};
	398	my ($self, $text) = @_;
	399	$self->{preamble} = $text . $self->{preamble} if defined $text;
	400	$self->{preamble};
194	401	}
195	402
196	403	sub postamble {
197		my ($self, $text) = @_;
198		$self->{postamble} \|\|= $self->admin->postamble;
199		$self->{postamble} .= $text if defined $text;
200		$self->{postamble}
	404	my ($self, $text) = @_;
	405	$self->{postamble} \|\|= $self->admin->postamble;
	406	$self->{postamble} .= $text if defined $text;
	407	$self->{postamble}
201	408	}
202	409
203	410	1;
204	411
205	412	__END__
206	413
207		#line 334
	414	#line 541

+697

-297

inc/Module/Install/Metadata.pm less more

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

-8

inc/Module/Install/Win32.pm less more

1	1	package Module::Install::Win32;
2	2
3	3	use strict;
4		use Module::Install::Base;
	4	use Module::Install::Base ();
5	5
6		use vars qw{$VERSION $ISCORE @ISA};
	6	use vars qw{$VERSION @ISA $ISCORE};
7	7	BEGIN {
8		$VERSION = '0.64';
	8	$VERSION = '1.00';
	9	@ISA = 'Module::Install::Base';
9	10	$ISCORE = 1;
10		@ISA = qw{Module::Install::Base};
11	11	}
12	12
13	13	# determine if the user needs nmake, and download it if needed

15	15	my $self = shift;
16	16	$self->load('can_run');
17	17	$self->load('get_file');
18
	18
19	19	require Config;
20	20	return unless (
21	21	$^O eq 'MSWin32' and

37	37	remove => 1,
38	38	);
39	39
40		if (!$rv) {
41		die <<'END_MESSAGE';
	40	die <<'END_MESSAGE' unless $rv;
42	41
43	42	-------------------------------------------------------------------------------
44	43

58	57
59	58	-------------------------------------------------------------------------------
60	59	END_MESSAGE
61		}
	60
62	61	}
63	62
64	63	1;

+48

-28

inc/Module/Install/WriteAll.pm less more

1	1	package Module::Install::WriteAll;
2	2
3	3	use strict;
4		use Module::Install::Base;
	4	use Module::Install::Base ();
5	5
6		use vars qw{$VERSION $ISCORE @ISA};
	6	use vars qw{$VERSION @ISA $ISCORE};
7	7	BEGIN {
8		$VERSION = '0.64';
	8	$VERSION = '1.00';
	9	@ISA = qw{Module::Install::Base};
9	10	$ISCORE = 1;
10		@ISA = qw{Module::Install::Base};
11	11	}
12	12
13	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		);
	14	my $self = shift;
	15	my %args = (
	16	meta => 1,
	17	sign => 0,
	18	inline => 0,
	19	check_nmake => 1,
	20	@_,
	21	);
22	22
23		$self->sign(1) if $args{sign};
24		$self->Meta->write if $args{meta};
25		$self->admin->WriteAll(%args) if $self->is_admin;
	23	$self->sign(1) if $args{sign};
	24	$self->admin->WriteAll(%args) if $self->is_admin;
26	25
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		}
	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;
40	60	}
41	61
42	62	1;

+414

-225

inc/Module/Install.pm less more

16	16	# 3. The ./inc/ version of Module::Install loads
17	17	# }
18	18
19		use 5.004;
	19	use 5.005;
20	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.64';
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	21	use Cwd ();
70	22	use File::Find ();
71	23	use File::Path ();
72		use FindBin;
73
74		inc::Module::Install::VERSION = VERSION;
75		@inc::Module::Install::ISA = __PACKAGE__;
	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	}
76	154
77	155	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"};
	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	};
114	194	}
115	195
116	196	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		}
	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	}
148	227	}
149	228
150	229	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 );
	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 );
176	262	}
177	263
178	264	sub call {

183	269	}
184	270
185	271	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";
	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";
197	283	The '$method' method does not exist in the '$self->{prefix}' path!
198	284	Please remove the '$self->{prefix}' directory and run $0 again to load it.
199	285	END_DIE
200	286
201		my $obj = $admin->load($method, 1);
202		push @{$self->{extensions}}, $obj;
203
204		$obj;
	287	my $obj = $admin->load($method, 1);
	288	push @{$self->{extensions}}, $obj;
	289
	290	$obj;
205	291	}
206	292
207	293	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} \|\|= [];
	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} \|\|= [];
229	318	}
230	319
231	320	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		}
	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
269	364
270	365	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;
	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;
278	465	}
279	466
280	467	1;
	468
	469	# Copyright 2008 - 2010 Adam Kennedy.

+25

-39

lib/Object/Destroyer.pm less more

1	1
2	2	# See POD at end for details
3	3
4		use 5.005;
	4	use 5.006;
5	5	use strict;
6	6	use Carp ();
7	7	##use Scalar::Util ();
8	8
9	9	use vars qw{$VERSION};
10	10	BEGIN {
11		$VERSION = '2.00';
12		}
13
14		if (eval {require Scalar::Util}) {
	11	$VERSION = '2.01';
	12	}
	13
	14	if ( eval { require Scalar::Util } ) {
15	15	Scalar::Util->import('blessed');
16		}
17		else{
	16	} else {
18	17	*blessed = sub {
19	18	my $ref = ref($_[0]);
20	19	return $ref

27	26	}
28	27
29	28	sub new {
30		if (ref $_[0]) {
	29	if ( ref $_[0] ) {
31	30	# This is a method called on an existing
32	31	# Destroyer, and should actually be passed through
33	32	# to the encased object via the AUTOLOAD

40	39	my $ref = shift \|\| '';
41	40	my $self = {};
42	41
43		if (ref($ref) eq 'CODE') {
	42	if ( ref($ref) eq 'CODE' ) {
44	43	##
45	44	## Object::Destroyer->new( sub {...} )
46	45	##
47	46	$self->{code} = $ref;
48		}
49		elsif (my $class = blessed($ref)) {
	47	} elsif ( my $class = blessed($ref) ) {
50	48	##
51	49	## Object::Destroyer->new( $object, 'optional_method' )
52	50	##

57	55	unless $class->can($method);
58	56	$self->{object} = $ref;
59	57	$self->{method} = $method;
60		}
61		else{
	58	} else {
62	59	##
63	60	## And what is this?
64	61	##

87	84	##
88	85	unshift @_, $object;
89	86	goto &$function;
90		}
91		elsif ($object->can("AUTOLOAD")) {
	87	} elsif ( $object->can("AUTOLOAD") ) {
92	88	##
93	89	## We can't just goto to AUTOLOAD method in unknown
94	90	## package (it may be in base class of $object).

97	93	if (wantarray) {
98	94	## List context
99	95	return $object->$method(@_);
100		}
101		elsif (defined wantarray) {
	96	} elsif ( defined wantarray ) {
102	97	## Scalar context
103	98	return scalar $object->$method(@_);
104		}
105		else {
	99	} else {
106	100	## Void context
107	101	$object->$method(@_);
108	102	}
109		}
110		else{
	103	} else {
111	104	##
112	105	## Probably this is a caller's error
113	106	##

124	117	}
125	118
126	119	sub dismiss{
127		my $self = shift;
128
129		$self->{dismissed} = 1;
	120	$_[0]->{dismissed} = 1;
130	121	}
131	122
132	123	##

136	127	sub DESTROY {
137	128	my $self = shift;
138	129
139		if ($self->{dismissed}) {
	130	if ( $self->{dismissed} ) {
140	131	## do nothing
141		}
142		elsif ( $self->{code} ) {
	132	} elsif ( $self->{code} ) {
143	133	$self->{code}->();
144		}
145		elsif ( my $object = $self->{object} ) {
	134	} elsif ( my $object = $self->{object} ) {
146	135	my $method = $self->{method};
147	136	$object->$method();
148	137	}
149
	138
150	139	%$self = ();
151	140	}
152	141

158	147	## and underlying object's class
159	148	##
160	149	sub isa {
161		my $self = shift;
	150	my $self = shift;
162	151	my $class = shift;
163	152
164	153	return $class eq __PACKAGE__ \|\|

382	371
383	372	=item new
384	373
385
386	374	my $sentry = Object::Destroyer->new( $object );
387	375	my $sentry = Object::Destroyer->new( $object, 'method_name' );
388	376	my $sentry = Object::Destroyer->new( $code_reference );
389
	377
390	378	The C<new> constructor takes as arguments either a single blessed object with
391	379	an optional name of the method to be called, or a refernce to code to be executed.
392	380	If the method name is not specified, the C<DESTROY> method is assumed.
393	381	The constructor will die if the object passed to it does not have the specified method.
394	382
395	383	=item DESTROY
396
397	384
398	385	$sentry->DESTROY;
399	386	undef $sentry;

404	391	DESTROY an object even though it is not needed. The DESTROY call will be
405	392	accepted and dealt with as it is called on the encased object.
406	393
407
408	394	=item dismiss
409
410	395
411	396	$sentry->dismiss;
412	397
413	398	If you have changed your mind and you don't want Destroyer object to do
414	399	its job, dismiss it. You may continue to use it as a wrapper, though.
415
416	400
417	401	=back
418	402

436	420
437	421	=head1 AUTHORS
438	422
439		Adam Kennedy E<lt>adamk@cpan.orgE<gt> and Igor Gariev E<lt>gariev@hotmail.comE<gt>
	423	Adam Kennedy E<lt>adamk@cpan.orgE<gt>
	424
	425	Igor Gariev E<lt>gariev@hotmail.comE<gt>
440	426
441	427	=head1 COPYRIGHT
442	428
443		Copyright 2004 - 2006 Adam Kennedy.
	429	Copyright 2004 - 2011 Adam Kennedy.
444	430
445	431	This program is free software; you can redistribute
446	432	it and/or modify it under the same terms as Perl itself.

-7

t/01_compile.t less more

0		#!/usr/bin/perl -w
	0	#!/usr/bin/perl
1	1
2	2	# Load testing for Object::Destroyer
3	3

7	7	$^W = 1;
8	8	}
9	9
10		use Test::More tests => 3;
	10	use Test::More tests => 2;
11	11
12		ok( $] >= 5.005, "Your perl is new enough" );
13		use_ok('Object::Destroyer');
14		use_ok('Object::Destroyer', 2.00);
15
16		exit(0);
	12	use_ok( 'Object::Destroyer' );
	13	use_ok( 'Object::Destroyer' => 2.01 );

+15

-12

t/02_new.t less more

0		#!/usr/bin/perl -w
	0	#!/usr/bin/perl
1	1
2	2	##
3	3	## Test for constructor of Object::Destroyer

10	10	}
11	11
12	12	use Test::More tests => 19;
13		use Object::Destroyer 2.00;
	13	use Object::Destroyer 2.01;
14	14
15	15	my $foo = Foo->new;
16		my $bar = Bar->new();
	16	my $bar = Bar->new;
17	17
18	18	##
19	19	## Object::destroyer->new($object)

23	23	ok( !eval{ Object::Destroyer->new($bar); 1; } );
24	24	like( $@, qr/Object::Destroyer requires that Bar has a DESTROY method at.*/ );
25	25
26
27	26	##
28	27	## Object::Destroyer->new($object, $method)
29	28	## $object must have method $method
30	29	##
31		ok( Object::Destroyer->new($foo, 'hello') );
32		ok( Object::Destroyer->new($foo, 'DESTROY') );
33		ok( Object::Destroyer->new($foo, 'release') );
34		ok( Object::Destroyer->new($bar, 'delete') );
	30	ok( Object::Destroyer->new($foo, 'hello') );
	31	ok( Object::Destroyer->new($foo, 'DESTROY') );
	32	ok( Object::Destroyer->new($foo, 'release') );
	33	ok( Object::Destroyer->new($bar, 'delete') );
	34
35	35	##
36	36	## Negative tests: non-existent methods, extra params to constructor
37	37	## and no method names

49	49	##
50	50	ok( Object::Destroyer->new(sub {}) );
51	51	ok( Object::Destroyer->new(\&Foo::hello) );
	52
52	53	##
53	54	## Negative tests - extra params lead to die()
54	55	##
55	56	ok( !eval{ Object::Destroyer->new(sub {}, 'extra'); 1;} );
56	57	like( $@, qr/^Extra arguments to constructor at.*/ );
57
58	58
59	59	##
60	60	## Unknown arguments to constructor leads to die

64	64
65	65
66	66
	67
	68
67	69	#####################################################################
68	70	# Test Classes
69	71
70	72	package Foo;
71	73
72		sub new{
	74	sub new {
73	75	my $self = shift;
74	76	return bless {}, ref $self \|\| $self;
75	77	}

81	83
82	84	package Bar;
83	85
84		sub new{
	86	sub new {
85	87	my $self = shift;
86	88	return bless {}, ref $self \|\| $self;
87	89	}
88	90
89		sub delete{}
	91	sub delete { }
	92
90	93	1;

+18

-23

t/03_destroy.t less more

0		#!/usr/bin/perl -w
	0	#!/usr/bin/perl
1	1
2	2	##
3	3	## Tests of main functionality of Object::Destroyer -

13	13	use Test::More tests => 31;
14	14	use Object::Destroyer;
15	15
16
17	16	##
18	17	## Make sure a Foo object behaves as expected
19	18	##
20	19	is( $Foo::destroy_counter, 0, 'Start value' );
21	20
22		{
	21	SCOPE: {
23	22	##
24	23	## This object will not be destroyed automatically
25	24	##
26	25	my $foo = Foo->new;
27	26	is( $Foo::destroy_counter, 0, 'No auto destroy of Foo objects' );
28		}
29
30		{
	27	}
	28
	29	SCOPE: {
31	30	##
32	31	## This $foo is destroyed manually
33	32	##
34	33	my $foo = Foo->new;
35	34	$foo->DESTROY;
36	35	is( $Foo::destroy_counter, 1, 'Manually called DESTROY' );
37		}
	36	}
38	37	is( $Foo::destroy_counter, 2, 'Auto called DESTROY after leaving the scope' );
39	38
40	39

46	45	## Test of default 'DESTROY' method
47	46	## It's called twice - 1st by Object::Destroyer, 2nd by Perl gc!
48	47	##
49		{
	48	SCOPE: {
50	49	my $foo = Foo->new;
51	50	my $sentry = Object::Destroyer->new($foo);
52	51	@Foo::called_method = ();

57	56	##
58	57	## Test that the specified method is called indeed
59	58	##
60		{
	59	SCOPE: {
61	60	my $foo = Foo->new;
62	61	my $sentry = Object::Destroyer->new($foo, 'release');
63	62	@Foo::called_method = ();

65	64	is( $Foo::destroy_counter, 5, 'release called by Object::Destroyer' );
66	65	is_deeply( \@Foo::called_method, ['release', 'DESTROY'] );
67	66
68		{
	67	SCOPE: {
69	68	my $foo = Foo->new;
70	69	my $sentry = Object::Destroyer->new($foo, 'delete');
71	70	@Foo::called_method = ();

78	77	## Test manual clean-up of the enclosed object
79	78	## by $sentry->DESTROY or undef($sentry)
80	79	##
81		{
	80	SCOPE: {
82	81	my $foo = Foo->new;
83	82	my $sentry = Object::Destroyer->new($foo);
84	83	is( $Foo::destroy_counter, 6, 'nothing changed' );

87	86	}
88	87	is( $Foo::destroy_counter, 8, 'Foo->DESTROY by Perl gc' );
89	88
90		{
	89	SCOPE: {
91	90	my $foo = Foo->new;
92	91	my $sentry = Object::Destroyer->new($foo, 'release');
93	92	is( $Foo::destroy_counter, 8, 'nothing changed' );

96	95	}
97	96	is( $Foo::destroy_counter, 9, 'Foo->DESTROY by Perl gc' );
98	97
99		{
	98	SCOPE: {
100	99	my $foo = Foo->new;
101	100	my $sentry = Object::Destroyer->new($foo);
102	101	is( $Foo::destroy_counter, 9, 'nothing changed' );

105	104	}
106	105	is( $Foo::destroy_counter, 11, 'Foo->DESTROY by Perl gc' );
107	106
108		{
	107	SCOPE: {
109	108	my $foo = Foo->new;
110	109	my $sentry = Object::Destroyer->new($foo, 'release');
111	110	is( $Foo::destroy_counter, 11, 'nothing changed' );

118	117	##
119	118	## Test anonymous subrotine calls
120	119	##
121		{
	120	SCOPE: {
122	121	my $test = 0;
123		{
	122	SCOPE: {
124	123	my $sentry = Object::Destroyer->new( sub{$test=1} );
125	124	is($test, 0);
126	125	}
127	126	is($test, 1);
128		for (1..10) {
	127	for ( 1 .. 10 ) {
129	128	my $sentry = Object::Destroyer->new( sub{$test++} );
130	129	}
131	130	is($test, 11);
132	131	}
133
134	132
135	133	##
136	134	## Anonymous subrotine destroys an object not capable of auto-destroy

146	144	}
147	145	is( $Bar::count, 10 );
148	146
149
150	147	##
151	148	## Test objects that use Object::Destroy in their constructors
152	149	##

159	156
160	157
161	158
	159
	160
162	161	#####################################################################
163	162	# Test Classes
164	163

169	168
170	169	sub new {
171	170	my $class = shift;
172
173	171	my $self = {};
174	172	$self->{self} = $self; ## circular reference
175	173	return bless $self, ref $class \|\| $class;

177	175
178	176	sub delete{
179	177	my $self = shift;
180
181	178	undef $self->{self};
182	179	push @called_method, 'delete';
183	180	}
184	181
185	182	sub release {
186	183	my $self = shift;
187
188	184	undef $self->{self};
189	185	push @called_method, 'release';
190	186	}
191	187
192	188	sub DESTROY {
193	189	my $self = shift;
194
195	190	$destroy_counter++;
196	191	undef $self->{self};
197	192	push @called_method, 'DESTROY';

-2

t/04_wrapper.t less more

0		#!/usr/bin/perl -w
	0	#!/usr/bin/perl
1	1
2	2	##
3	3	## Test for wrapping abilities of Object::Destroyer

10	10	}
11	11
12	12	use Test::More tests => 34;
13		use Object::Destroyer 2.00;
	13	use Object::Destroyer 2.01;
14	14
15	15	my $foo = Foo->new;
16	16	my $sentry = Object::Destroyer->new($foo, 'release');

-6

t/05_dismiss.t less more

0		#!/usr/bin/perl -w
	0	#!/usr/bin/perl
1	1
2	2	##
3	3	## Test for wrapping abilities of Object::Destroyer

10	10	}
11	11
12	12	use Test::More tests => 8;
13		use Object::Destroyer 2.00;
	13	use Object::Destroyer 2.01;
14	14
15	15
16		{
	16	SCOPE: {
17	17	my $foo = Foo->new;
18	18	}
19	19	is($Foo::destroy_counter, 0, 'Foo must not be destroyed');
20	20
21		{
	21	SCOPE: {
22	22	my $foo = Foo->new;
23	23	my $sentry = Object::Destroyer->new($foo, 'release');
24	24	is($Foo::destroy_counter, 0, 'Pre-check');

27	27	is($Foo::destroy_counter, 1, 'Foo must be destroyed');
28	28
29	29	$Foo::destroy_counter = 0;
30		{
	30	SCOPE: {
31	31	my $foo = Foo->new;
32	32	my $sentry = Object::Destroyer->new($foo, 'release');
33	33	is($Foo::destroy_counter, 0, 'Pre-check');

36	36	ok( $sentry->self_test, 'Wrapper is still ok');
37	37	}
38	38	is($Foo::destroy_counter, 0, 'Foo must not ve destroyed');
	39
	40
	41
39	42
40	43
41	44	#####################################################################

66	69	my $self = shift;
67	70	undef $self->{self};
68	71	}
69

-61

~~t/99_author.t~~ less more

0		#!/usr/bin/perl -w
1
2		use strict;
3		BEGIN {
4		$\| = 1;
5		$^W = 1;
6		}
7		use Test::More;
8
9		# Skip if doing a regular install
10		unless ( $ENV{AUTOMATED_TESTING} ) {
11		plan( skip_all => "Author tests not required for installation" );
12		}
13
14		# Can we run the POD tests?
15		eval "use Test::Pod 1.00";
16		if ( $@ ) {
17		plan( skip_all => "Test::Pod 1.00 required for testing POD" );
18		}
19
20
21
22
23
24		#####################################################################
25		# WARNING: INSANE BLACK MAGIC
26		#####################################################################
27
28		# Hack Pod::Simple::BlackBox to ignore the Test::Inline
29		# "Extended Begin" syntax.
30		# For example, "=begin has more than one word errors"
31		my $begin = \&Pod::Simple::BlackBox::_ponder_begin;
32		sub mybegin {
33		my $para = $_[1];
34		my $content = join ' ', splice @$para, 2;
35		$content =~ s/^\s+//s;
36		$content =~ s/\s+$//s;
37		my @words = split /\s+/, $content;
38		if ( $words[0] =~ /^test(?:ing)?\z/s ) {
39		foreach ( 2 .. $#$para ) {
40		$para->[$_] = '';
41		}
42		$para->[2] = $words[0];
43		}
44
45		# Continue as normal
46		push @$para, @words;
47		return &$begin(@_);
48		}
49
50		SCOPE: {
51		local $^W = 0;
52		*Pod::Simple::BlackBox::_ponder_begin = \&mybegin;
53		}
54
55		#####################################################################
56		# END BLACK MAGIC
57		#####################################################################
58
59		# Test POD
60		all_pod_files_ok();

+27

-0

xt/meta.t less more

	0	#!/usr/bin/perl
	1
	2	# Test that our META.yml file matches the current specification.
	3
	4	use strict;
	5	BEGIN {
	6	$\| = 1;
	7	$^W = 1;
	8	}
	9
	10	my $MODULE = 'Test::CPAN::Meta 0.17';
	11
	12	# Don't run tests for installs
	13	use Test::More;
	14	unless ( $ENV{AUTOMATED_TESTING} or $ENV{RELEASE_TESTING} ) {
	15	plan( skip_all => "Author tests not required for installation" );
	16	}
	17
	18	# Load the testing module
	19	eval "use $MODULE";
	20	if ( $@ ) {
	21	$ENV{RELEASE_TESTING}
	22	? die( "Failed to load required release-testing module $MODULE" )
	23	: plan( skip_all => "$MODULE not available for testing" );
	24	}
	25
	26	meta_yaml_ok();

+32

-0

xt/pmv.t less more

	0	#!/usr/bin/perl
	1
	2	# Test that our declared minimum Perl version matches our syntax
	3
	4	use strict;
	5	BEGIN {
	6	$\| = 1;
	7	$^W = 1;
	8	}
	9
	10	my @MODULES = (
	11	'Perl::MinimumVersion 1.27',
	12	'Test::MinimumVersion 0.101080',
	13	);
	14
	15	# Don't run tests for installs
	16	use Test::More;
	17	unless ( $ENV{AUTOMATED_TESTING} or $ENV{RELEASE_TESTING} ) {
	18	plan( skip_all => "Author tests not required for installation" );
	19	}
	20
	21	# Load the testing modules
	22	foreach my $MODULE ( @MODULES ) {
	23	eval "use $MODULE";
	24	if ( $@ ) {
	25	$ENV{RELEASE_TESTING}
	26	? die( "Failed to load required release-testing module $MODULE" )
	27	: plan( skip_all => "$MODULE not available for testing" );
	28	}
	29	}
	30
	31	all_minimum_version_from_metayml_ok();

+32

-0

xt/pod.t less more

	0	#!/usr/bin/perl
	1
	2	# Test that the syntax of our POD documentation is valid
	3
	4	use strict;
	5	BEGIN {
	6	$\| = 1;
	7	$^W = 1;
	8	}
	9
	10	my @MODULES = (
	11	'Pod::Simple 3.14',
	12	'Test::Pod 1.44',
	13	);
	14
	15	# Don't run tests for installs
	16	use Test::More;
	17	unless ( $ENV{AUTOMATED_TESTING} or $ENV{RELEASE_TESTING} ) {
	18	plan( skip_all => "Author tests not required for installation" );
	19	}
	20
	21	# Load the testing modules
	22	foreach my $MODULE ( @MODULES ) {
	23	eval "use $MODULE";
	24	if ( $@ ) {
	25	$ENV{RELEASE_TESTING}
	26	? die( "Failed to load required release-testing module $MODULE" )
	27	: plan( skip_all => "$MODULE not available for testing" );
	28	}
	29	}
	30
	31	all_pod_files_ok();