Commit 618e9e4befb8f77eed0f95dd1e52b43984efb416 - libjifty-dbi-perl

[svn-upgrade] Integrating new upstream version, libjifty-dbi-perl (0.59) Yves Agostini 14 years ago

20 changed file(s) with 565 addition(s) and 253 deletion(s). Raw diff Collapse all Expand all

+11

-0

Changes less more

0	0	Revision history for Perl extension Jifty::DBI.
	1
	2	0.59 Wed Nov 18 20:12:57 EST 2009
	3	- Features:
	4	* Support a special value of "all" in set_page_info
	5
	6	- Fixes:
	7	* Make "default is ''" propagate correctly to ALTER and CREATE TABLE
	8	statements
	9
	10	- Installation:
	11	* Our Module::Install was hilariously out of date
1	12
2	13	0.58 Tue Jul 14 03:21:21 EST 2009
3	14	- Possible incompatibilities:

-2

META.yml less more

1	1	author: ~
2	2	build_requires:
3	3	DBD::SQLite: 1.14
	4	ExtUtils::MakeMaker: 6.42
4	5	Test::More: 0.52
5	6	Test::Warn: 0.1
	7	configure_requires:
	8	ExtUtils::MakeMaker: 6.42
6	9	distribution_type: module
7		generated_by: 'Module::Install version 0.79'
	10	generated_by: 'Module::Install version 0.91'
8	11	license: perl
9	12	meta-spec:
10	13	url: http://module-build.sourceforge.net/META-spec-v1.4.html

40	43	version: 0
41	44	resources:
42	45	license: http://dev.perl.org/licenses/
43		version: 0.53
	46	version: 0.59

+22

-22

SIGNATURE less more

14	14	Hash: SHA1
15	15
16	16	SHA1 f29ac6543498d1b0e81f387b7284a039f83e7d29 .gitignore
17		SHA1 64906601c4115e5507dd41021127384db33a1e62 Changes
	17	SHA1 81b8e2df34131211193bf3b935b5a036dc051ec4 Changes
18	18	SHA1 006b044e48cc925d04f620f317a907d459b2d128 MANIFEST
19		SHA1 d3897bc376b40669acb9171adfd51f321d184fd8 META.yml
	19	SHA1 2f7ef1c4bb35edf899145b1c291924200fcac09f META.yml
20	20	SHA1 48bd6ca8a37ec79b7cae91028d7e9489ad33a03b Makefile.PL
21	21	SHA1 ae8407c841f230c353f683bd5c257815aed9b9f0 README
22	22	SHA1 82d6ac3f6def48558d09f8b6e3b53ed4194d8c81 ROADMAP

29	29	SHA1 584c0f6cdebcbf760dfca8413c94783586120214 ex/Example/Model/Address.pm
30	30	SHA1 7cea1a5289f79c2a87837924a83feb583f6e8890 ex/Example/Model/Employee.pm
31	31	SHA1 a9d62e4f5b43b2f78066172a4771238ee7df6339 ex/create_tables.pl
32		SHA1 603bb9de29fb8cba7f13409c546750972eff645d inc/Module/AutoInstall.pm
33		SHA1 ae018c4565c1277089ca8f1b28f888d95430cb7f inc/Module/Install.pm
34		SHA1 0a6f29536bedea3bb94744a7d43ffe39da7e4819 inc/Module/Install/AutoInstall.pm
35		SHA1 4552acdfca8b78f8015d8449e1325616259095f5 inc/Module/Install/Base.pm
36		SHA1 7fb663fff161fb45882b52edd62857bf15359658 inc/Module/Install/Can.pm
37		SHA1 8b1d3db746faa6faf2d967a48d3812ec1f44b4c6 inc/Module/Install/Fetch.pm
38		SHA1 d7ce736cdd05d5156d379ef39cca93beeeeba828 inc/Module/Install/Include.pm
39		SHA1 9f6beaa2f4749ceb5dd0c9b0c647d0f3289c7b46 inc/Module/Install/Makefile.pm
40		SHA1 7ad1da4fff7a1e7a634c9d734111c8292be08884 inc/Module/Install/Metadata.pm
41		SHA1 e9aa83f3e8b16ccfce544a90a57b63b70a497759 inc/Module/Install/Win32.pm
42		SHA1 ade2ac0b0246d4d8e28fa46942e53f6925abda46 inc/Module/Install/WriteAll.pm
43		SHA1 dd7c0df4e3dd9ff7112ff0ea2fbe501b8d786246 lib/Jifty/DBI.pm
44		SHA1 79cb88cd57d1194370a6a5beab9dcd2baf5eb7b3 lib/Jifty/DBI/Collection.pm
	32	SHA1 e5fb92ac217988bfc7a6af739b0459627020a27e inc/Module/AutoInstall.pm
	33	SHA1 fd5f3c4f0418efee3b9b16cf8c3902e8374909df inc/Module/Install.pm
	34	SHA1 5c529e96420d964b192f011b121283a4916f7331 inc/Module/Install/AutoInstall.pm
	35	SHA1 7cd7c349afdf3f012e475507b1017bdfa796bfbd inc/Module/Install/Base.pm
	36	SHA1 ba186541bbf6439111f01fc70769cf24d22869bf inc/Module/Install/Can.pm
	37	SHA1 aaa50eca0d7751db7a4d953fac9bc72c6294e238 inc/Module/Install/Fetch.pm
	38	SHA1 219da5a95c290312a81477b226f005997d97dcfd inc/Module/Install/Include.pm
	39	SHA1 3e83972921d54198d1246f7278f08664006cd65d inc/Module/Install/Makefile.pm
	40	SHA1 12bf1867955480d47d5171a9e9c6a96fabe0b58f inc/Module/Install/Metadata.pm
	41	SHA1 f7ee667e878bd2faf22ee9358a7b5a2cc8e91ba4 inc/Module/Install/Win32.pm
	42	SHA1 8ed29d6cf217e0977469575d788599cbfb53a5ca inc/Module/Install/WriteAll.pm
	43	SHA1 2d4ea93c0b624bc5939d882d9c7f0d897fdc63b1 lib/Jifty/DBI.pm
	44	SHA1 09c42f022a1b2ca5dab645fe9fe6e50ea1fa82b4 lib/Jifty/DBI/Collection.pm
45	45	SHA1 639ef9c81f03fb084b312a5f9a6f6a3ff63b36b7 lib/Jifty/DBI/Collection/Union.pm
46	46	SHA1 bcba77fd2bacf0475aea1de97f57365c8de92ca6 lib/Jifty/DBI/Collection/Unique.pm
47	47	SHA1 6d59ec1286f3ed887494753d01ed1f4760fd0a9b lib/Jifty/DBI/Column.pm

58	58	SHA1 67ffe7188a1f529d7594f4fa3803bcbe15ba6485 lib/Jifty/DBI/Filter/YAML.pm
59	59	SHA1 9a6fd17e677321904436fefec4d434e17a4685b1 lib/Jifty/DBI/Filter/base64.pm
60	60	SHA1 deb33fa7b35f3542aac3e2d7fb4b5d3070dc3917 lib/Jifty/DBI/Filter/utf8.pm
61		SHA1 64d39ed536e8cb5465b0e1aa0f40f7bb9ae5e47a lib/Jifty/DBI/Handle.pm
	61	SHA1 99a22e6954200e1bf3901cf963b88c2a830e460f lib/Jifty/DBI/Handle.pm
62	62	SHA1 bcc7c456e1c4d0dddd5564f03c8bb03a6c7e261f lib/Jifty/DBI/Handle/Informix.pm
63	63	SHA1 338116a45f8eb6bfca5e76e8d3be78fb61fffe81 lib/Jifty/DBI/Handle/ODBC.pm
64	64	SHA1 960fd0b63f3de11924c5d47a3c0c6d1db105ed5b lib/Jifty/DBI/Handle/Oracle.pm

68	68	SHA1 cf80896a175702a157770f64ae469430678c3357 lib/Jifty/DBI/Handle/mysql.pm
69	69	SHA1 f2cc4fcce79c9a88a023d4e6bd96c2089eef1ced lib/Jifty/DBI/Handle/mysqlPP.pm
70	70	SHA1 45d653e3a223599b50850010826bd835b80368d7 lib/Jifty/DBI/HasFilters.pm
71		SHA1 fc176a04f20301b698a390a014eda349d139d94f lib/Jifty/DBI/Record.pm
72		SHA1 3853ce268985b129f2175251fb369d9689837f39 lib/Jifty/DBI/Record/Cachable.pm
	71	SHA1 24de085d41bfa49b1a6588311e675cff0615c8f0 lib/Jifty/DBI/Record.pm
	72	SHA1 663978b31373520d1e2deec87e957d1dbfd1347c lib/Jifty/DBI/Record/Cachable.pm
73	73	SHA1 1aac77960c508d3b2e5188e15825ad5b04391d76 lib/Jifty/DBI/Record/Memcached.pm
74	74	SHA1 53834b3315a509ba33a8647681f472d3ae7b0557 lib/Jifty/DBI/Record/Plugin.pm
75	75	SHA1 13b7e19a9ce99323f0ad41ce36422acb46ff07f9 lib/Jifty/DBI/Schema.pm
76		SHA1 a4d1a953ea4a29fe169b1c4c043ffff15b24c077 lib/Jifty/DBI/SchemaGenerator.pm
	76	SHA1 30684592748a10ac2d775ea95a858e8699d46688 lib/Jifty/DBI/SchemaGenerator.pm
77	77	SHA1 32834b7c4cf5a8d131382fccc8db341be8768291 t/00.load.t
78	78	SHA1 9aa7fed2b2409faa4c71d2a45db210721f47403e t/01-version_checks.t
79	79	SHA1 13c9fe3eeec0d000a7c86ea2474e30186cbc37e2 t/01basics.t

117	117	-----BEGIN PGP SIGNATURE-----
118	118	Version: GnuPG v1.4.7 (Darwin)
119	119
120		iD8DBQFKXDOCsxfQtHhyRPoRAst4AJ99hkuLonvmHzyX1MeoUiuuZkTIQQCdF9Cd
121		uX0sd4zMEnoWm3En9My0mLw=
122		=tpG0
	120	iD8DBQFLBJv7sxfQtHhyRPoRAog4AKCIv7JYxk/gyfUsKD1I6AwLS1tSfwCfeY18
	121	jZQ6G3H6abFEj8XNr5+p6TQ=
	122	=ao3T
123	123	-----END PGP SIGNATURE-----

+72

-35

inc/Module/AutoInstall.pm less more

17	17
18	18	# various lexical flags
19	19	my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $HasCPANPLUS );
20		my ( $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly );
	20	my (
	21	$Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps
	22	);
21	23	my ( $PostambleActions, $PostambleUsed );
22	24
23	25	# See if it's a testing or non-interactive session

71	73	}
72	74	elsif ( $arg =~ /^--test(?:only)?$/ ) {
73	75	$TestOnly = 1;
	76	}
	77	elsif ( $arg =~ /^--all(?:deps)?$/ ) {
	78	$AllDeps = 1;
74	79	}
75	80	}
76	81	}

114	119	)[0]
115	120	);
116	121
	122	# We want to know if we're under CPAN early to avoid prompting, but
	123	# if we aren't going to try and install anything anyway then skip the
	124	# check entirely since we don't want to have to load (and configure)
	125	# an old CPAN just for a cosmetic message
	126
	127	$UnderCPAN = _check_lock(1) unless $SkipInstall;
	128
117	129	while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) {
118	130	my ( @required, @tests, @skiptests );
119	131	my $default = 1;

162	174	}
163	175
164	176	# XXX: check for conflicts and uninstalls(!) them.
165		if (
166		defined( my $cur = _version_check( _load($mod), $arg \|\|= 0 ) ) )
	177	my $cur = _load($mod);
	178	if (_version_cmp ($cur, $arg) >= 0)
167	179	{
168	180	print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n";
169	181	push @Existing, $mod => $arg;
170	182	$DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
171	183	}
172	184	else {
173		print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n";
	185	if (not defined $cur) # indeed missing
	186	{
	187	print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n";
	188	}
	189	else
	190	{
	191	# no need to check $arg as _version_cmp ($cur, undef) would satisfy >= above
	192	print "too old. ($cur < $arg)\n";
	193	}
	194
174	195	push @required, $mod => $arg;
175	196	}
176	197	}

183	204	!$SkipInstall
184	205	and (
185	206	$CheckOnly
	207	or ($mandatory and $UnderCPAN)
	208	or $AllDeps
186	209	or _prompt(
187	210	qq{==> Auto-install the }
188	211	. ( @required / 2 )

213	236	}
214	237	}
215	238
216		$UnderCPAN = _check_lock(); # check for $UnderCPAN
217
218	239	if ( @Missing and not( $CheckOnly or $UnderCPAN ) ) {
219	240	require Config;
220	241	print

233	254	*{'main::WriteMakefile'} = \&Write if caller(0) eq 'main';
234	255	}
235	256
	257	sub _running_under {
	258	my $thing = shift;
	259	print <<"END_MESSAGE";
	260	*** Since we're running under ${thing}, I'll just let it take care
	261	of the dependency's installation later.
	262	END_MESSAGE
	263	return 1;
	264	}
	265
236	266	# Check to see if we are currently running under CPAN.pm and/or CPANPLUS;
237	267	# if we are, then we simply let it taking care of our dependencies
238	268	sub _check_lock {
239		return unless @Missing;
	269	return unless @Missing or @_;
	270
	271	my $cpan_env = $ENV{PERL5_CPAN_IS_RUNNING};
240	272
241	273	if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) {
242		print <<'END_MESSAGE';
243
244		*** Since we're running under CPANPLUS, I'll just let it take care
245		of the dependency's installation later.
246		END_MESSAGE
247		return 1;
248		}
249
250		_load_cpan();
	274	return _running_under($cpan_env ? 'CPAN' : 'CPANPLUS');
	275	}
	276
	277	require CPAN;
	278
	279	if ($CPAN::VERSION > '1.89') {
	280	if ($cpan_env) {
	281	return _running_under('CPAN');
	282	}
	283	return; # CPAN.pm new enough, don't need to check further
	284	}
	285
	286	# last ditch attempt, this -will- configure CPAN, very sorry
	287
	288	_load_cpan(1); # force initialize even though it's already loaded
251	289
252	290	# Find the CPAN lock-file
253	291	my $lock = MM->catfile( $CPAN::Config->{cpan_home}, ".lock" );

283	321	while ( my ( $pkg, $ver ) = splice( @_, 0, 2 ) ) {
284	322
285	323	# grep out those already installed
286		if ( defined( _version_check( _load($pkg), $ver ) ) ) {
	324	if ( _version_cmp( _load($pkg), $ver ) >= 0 ) {
287	325	push @installed, $pkg;
288	326	}
289	327	else {

312	350	@modules = @newmod;
313	351	}
314	352
315		if ( _has_cpanplus() ) {
	353	if ( _has_cpanplus() and not $ENV{PERL_AUTOINSTALL_PREFER_CPAN} ) {
316	354	_install_cpanplus( \@modules, \@config );
317	355	} else {
318	356	_install_cpan( \@modules, \@config );

322	360
323	361	# see if we have successfully installed them
324	362	while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
325		if ( defined( _version_check( _load($pkg), $ver ) ) ) {
	363	if ( _version_cmp( _load($pkg), $ver ) >= 0 ) {
326	364	push @installed, $pkg;
327	365	}
328	366	elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) {

377	415	my $success;
378	416	my $obj = $modtree->{$pkg};
379	417
380		if ( $obj and defined( _version_check( $obj->{version}, $ver ) ) ) {
	418	if ( $obj and _version_cmp( $obj->{version}, $ver ) >= 0 ) {
381	419	my $pathname = $pkg;
382	420	$pathname =~ s/::/\\W/;
383	421

470	508	my $obj = CPAN::Shell->expand( Module => $pkg );
471	509	my $success = 0;
472	510
473		if ( $obj and defined( _version_check( $obj->cpan_version, $ver ) ) ) {
	511	if ( $obj and _version_cmp( $obj->cpan_version, $ver ) >= 0 ) {
474	512	my $pathname = $pkg;
475	513	$pathname =~ s/::/\\W/;
476	514

534	572	my $ver = shift;
535	573
536	574	return
537		if defined( _version_check( _load($class), $ver ) ); # no need to upgrade
	575	if _version_cmp( _load($class), $ver ) >= 0; # no need to upgrade
538	576
539	577	if (
540	578	_prompt( "==> A newer version of $class ($ver) is required. Install?",

631	669
632	670	# Load CPAN.pm and it's configuration
633	671	sub _load_cpan {
634		return if $CPAN::VERSION;
	672	return if $CPAN::VERSION and $CPAN::Config and not @_;
635	673	require CPAN;
636	674	if ( $CPAN::HandleConfig::VERSION ) {
637	675	# Newer versions of CPAN have a HandleConfig module

643	681	}
644	682
645	683	# compare two versions, either use Sort::Versions or plain comparison
646		sub _version_check {
	684	# return values same as <=>
	685	sub _version_cmp {
647	686	my ( $cur, $min ) = @_;
648		return unless defined $cur;
	687	return -1 unless defined $cur; # if 0 keep comparing
	688	return 1 unless $min;
649	689
650	690	$cur =~ s/\s+$//;
651	691

656	696	) {
657	697
658	698	# use version.pm if it is installed.
659		return (
660		( version->new($cur) >= version->new($min) ) ? $cur : undef );
	699	return version->new($cur) <=> version->new($min);
661	700	}
662	701	elsif ( $Sort::Versions::VERSION or defined( _load('Sort::Versions') ) )
663	702	{
664	703
665	704	# use Sort::Versions as the sorting algorithm for a.b.c versions
666		return ( ( Sort::Versions::versioncmp( $cur, $min ) != -1 )
667		? $cur
668		: undef );
	705	return Sort::Versions::versioncmp( $cur, $min );
669	706	}
670	707
671	708	warn "Cannot reliably compare non-decimal formatted versions.\n"

674	711
675	712	# plain comparison
676	713	local $^W = 0; # shuts off 'not numeric' bugs
677		return ( $cur >= $min ? $cur : undef );
	714	return $cur <=> $min;
678	715	}
679	716
680	717	# nothing; this usage is deprecated.

705	742	if $Config;
706	743
707	744	$PostambleActions = (
708		$missing
	745	($missing and not $UnderCPAN)
709	746	? "\$(PERL) $0 --config=$config --installdeps=$missing"
710	747	: "\$(NOECHO) \$(NOOP)"
711	748	);

745	782	sub postamble {
746	783	$PostambleUsed = 1;
747	784
748		return << ".";
	785	return <<"END_MAKE";
749	786
750	787	config :: installdeps
751	788	\t\$(NOECHO) \$(NOOP)

756	793	installdeps ::
757	794	\t$PostambleActions
758	795
759		.
	796	END_MAKE
760	797
761	798	}
762	799

764	801
765	802	__END__
766	803
767		#line 1003
	804	#line 1056

-4

inc/Module/Install/AutoInstall.pm less more

1	1	package Module::Install::AutoInstall;
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.79';
	8	$VERSION = '0.91';
	9	@ISA = 'Module::Install::Base';
9	10	$ISCORE = 1;
10		@ISA = qw{Module::Install::Base};
11	11	}
12	12
13	13	sub AutoInstall { $_[0] }

+33

-27

inc/Module/Install/Base.pm less more

0	0	#line 1
1	1	package Module::Install::Base;
2	2
3		$VERSION = '0.79';
	3	use strict 'vars';
	4	use vars qw{$VERSION};
	5	BEGIN {
	6	$VERSION = '0.91';
	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
47		#line 101
	50	#line 106
48	51
49	52	sub is_admin {
50		$_[0]->admin->VERSION;
	53	$_[0]->admin->VERSION;
51	54	}
52	55
53	56	sub DESTROY {}
54	57
55	58	package Module::Install::Base::FakeAdmin;
56	59
57		my $Fake;
58		sub new { $Fake \|\|= bless(\@_, $_[0]) }
	60	my $fake;
	61
	62	sub new {
	63	$fake \|\|= bless(\@_, $_[0]);
	64	}
59	65
60	66	sub AUTOLOAD {}
61	67

68	74
69	75	1;
70	76
71		#line 146
	77	#line 154

-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.79';
	11	$VERSION = '0.91';
	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

79	77
80	78	__END__
81	79
82		#line 158
	80	#line 156

-4

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.79';
	8	$VERSION = '0.91';
	9	@ISA = 'Module::Install::Base';
9	10	$ISCORE = 1;
10		@ISA = qw{Module::Install::Base};
11	11	}
12	12
13	13	sub get_file {

-4

inc/Module/Install/Include.pm less more

1	1	package Module::Install::Include;
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.79';
	8	$VERSION = '0.91';
	9	@ISA = 'Module::Install::Base';
9	10	$ISCORE = 1;
10		@ISA = qw{Module::Install::Base};
11	11	}
12	12
13	13	sub include {

+33

-18

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
	7	use vars qw{$VERSION @ISA $ISCORE};
8	8	BEGIN {
9		$VERSION = '0.79';
	9	$VERSION = '0.91';
	10	@ISA = 'Module::Install::Base';
10	11	$ISCORE = 1;
11		@ISA = qw{Module::Install::Base};
12	12	}
13	13
14	14	sub Makefile { $_[0] }

113	113	my $self = shift;
114	114	die "&Makefile->write() takes no arguments\n" if @_;
115	115
116		# Make sure we have a new enough
	116	# Check the current Perl version
	117	my $perl_version = $self->perl_version;
	118	if ( $perl_version ) {
	119	eval "use $perl_version; 1"
	120	or die "ERROR: perl: Version $] is installed, "
	121	. "but we need version >= $perl_version";
	122	}
	123
	124	# Make sure we have a new enough MakeMaker
117	125	require ExtUtils::MakeMaker;
118	126
119		# MakeMaker can complain about module versions that include
120		# an underscore, even though its own version may contain one!
121		# Hence the funny regexp to get rid of it. See RT #35800
122		# for details.
123
124		$self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ );
125
126		# Generate the
	127	if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) {
	128	# MakeMaker can complain about module versions that include
	129	# an underscore, even though its own version may contain one!
	130	# Hence the funny regexp to get rid of it. See RT #35800
	131	# for details.
	132	$self->build_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ );
	133	$self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ );
	134	} else {
	135	# Allow legacy-compatibility with 5.005 by depending on the
	136	# most recent EU:MM that supported 5.005.
	137	$self->build_requires( 'ExtUtils::MakeMaker' => 6.42 );
	138	$self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 );
	139	}
	140
	141	# Generate the MakeMaker params
127	142	my $args = $self->makemaker_args;
128	143	$args->{DISTNAME} = $self->name;
129	144	$args->{NAME} = $self->module_name \|\| $self->name;

132	147	if ( $self->tests ) {
133	148	$args->{test} = { TESTS => $self->tests };
134	149	}
135		if ($] >= 5.005) {
	150	if ( $] >= 5.005 ) {
136	151	$args->{ABSTRACT} = $self->abstract;
137	152	$args->{AUTHOR} = $self->author;
138	153	}

146	161	delete $args->{SIGN};
147	162	}
148	163
149		# merge both kinds of requires into prereq_pm
	164	# Merge both kinds of requires into prereq_pm
150	165	my $prereq = ($args->{PREREQ_PM} \|\|= {});
151	166	%$prereq = ( %$prereq,
152	167	map { @$_ }

249	264
250	265	__END__
251	266
252		#line 379
	267	#line 394

+190

-76

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.79';
	8	$VERSION = '0.91';
	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	18	name

36	40	repository
37	41	};
38	42
	43	my @array_keys = qw{
	44	keywords
	45	};
	46
39	47	sub Meta { shift }
	48	sub Meta_BooleanKeys { @boolean_keys }
40	49	sub Meta_ScalarKeys { @scalar_keys }
41	50	sub Meta_TupleKeys { @tuple_keys }
42	51	sub Meta_ResourceKeys { @resource_keys }
	52	sub Meta_ArrayKeys { @array_keys }
	53
	54	foreach my $key ( @boolean_keys ) {
	55	*$key = sub {
	56	my $self = shift;
	57	if ( defined wantarray and not @_ ) {
	58	return $self->{values}->{$key};
	59	}
	60	$self->{values}->{$key} = ( @_ ? $_[0] : 1 );
	61	return $self;
	62	};
	63	}
43	64
44	65	foreach my $key ( @scalar_keys ) {
45	66	*$key = sub {
46	67	my $self = shift;
47		return $self->{values}{$key} if defined wantarray and !@_;
48		$self->{values}{$key} = shift;
	68	return $self->{values}->{$key} if defined wantarray and !@_;
	69	$self->{values}->{$key} = shift;
	70	return $self;
	71	};
	72	}
	73
	74	foreach my $key ( @array_keys ) {
	75	*$key = sub {
	76	my $self = shift;
	77	return $self->{values}->{$key} if defined wantarray and !@_;
	78	$self->{values}->{$key} \|\|= [];
	79	push @{$self->{values}->{$key}}, @_;
49	80	return $self;
50	81	};
51	82	}

54	85	*$key = sub {
55	86	my $self = shift;
56	87	unless ( @_ ) {
57		return () unless $self->{values}{resources};
	88	return () unless $self->{values}->{resources};
58	89	return map { $_->[1] }
59	90	grep { $_->[0] eq $key }
60		@{ $self->{values}{resources} };
61		}
62		return $self->{values}{resources}{$key} unless @_;
	91	@{ $self->{values}->{resources} };
	92	}
	93	return $self->{values}->{resources}->{$key} unless @_;
63	94	my $uri = shift or die(
64	95	"Did not provide a value to $key()"
65	96	);

68	99	};
69	100	}
70	101
71		foreach my $key ( grep {$_ ne "resources"} @tuple_keys) {
	102	foreach my $key ( grep { $_ ne "resources" } @tuple_keys) {
72	103	*$key = sub {
73	104	my $self = shift;
74		return $self->{values}{$key} unless @_;
	105	return $self->{values}->{$key} unless @_;
75	106	my @added;
76	107	while ( @_ ) {
77	108	my $module = shift or last;
78	109	my $version = shift \|\| 0;
79	110	push @added, [ $module, $version ];
80	111	}
81		push @{ $self->{values}{$key} }, @added;
	112	push @{ $self->{values}->{$key} }, @added;
82	113	return map {@$_} @added;
83	114	};
84	115	}

99	130	if ( $name eq lc $name and ! $lc_resource{$name} ) {
100	131	die("Unsupported reserved lowercase resource '$name'");
101	132	}
102		$self->{values}{resources} \|\|= [];
103		push @{ $self->{values}{resources} }, [ $name, $value ];
104		}
105		$self->{values}{resources};
	133	$self->{values}->{resources} \|\|= [];
	134	push @{ $self->{values}->{resources} }, [ $name, $value ];
	135	}
	136	$self->{values}->{resources};
106	137	}
107	138
108	139	# Aliases for build_requires that will have alternative
109	140	# meanings in some future version of META.yml.
110		sub test_requires { shift->build_requires(@_) }
111		sub install_requires { shift->build_requires(@_) }
	141	sub test_requires { shift->build_requires(@_) }
	142	sub install_requires { shift->build_requires(@_) }
112	143
113	144	# Aliases for installdirs options
114		sub install_as_core { $_[0]->installdirs('perl') }
115		sub install_as_cpan { $_[0]->installdirs('site') }
116		sub install_as_site { $_[0]->installdirs('site') }
117		sub install_as_vendor { $_[0]->installdirs('vendor') }
118
119		sub sign {
120		my $self = shift;
121		return $self->{values}{sign} if defined wantarray and ! @_;
122		$self->{values}{sign} = ( @_ ? $_[0] : 1 );
123		return $self;
124		}
	145	sub install_as_core { $_[0]->installdirs('perl') }
	146	sub install_as_cpan { $_[0]->installdirs('site') }
	147	sub install_as_site { $_[0]->installdirs('site') }
	148	sub install_as_vendor { $_[0]->installdirs('vendor') }
125	149
126	150	sub dynamic_config {
127	151	my $self = shift;

129	153	warn "You MUST provide an explicit true/false value to dynamic_config\n";
130	154	return $self;
131	155	}
132		$self->{values}{dynamic_config} = $_[0] ? 1 : 0;
	156	$self->{values}->{dynamic_config} = $_[0] ? 1 : 0;
133	157	return 1;
134	158	}
135	159
136	160	sub perl_version {
137	161	my $self = shift;
138		return $self->{values}{perl_version} unless @_;
	162	return $self->{values}->{perl_version} unless @_;
139	163	my $version = shift or die(
140	164	"Did not provide a value to perl_version()"
141	165	);

148	172	die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n";
149	173	}
150	174
151		$self->{values}{perl_version} = $version;
152		}
	175	$self->{values}->{perl_version} = $version;
	176	}
	177
	178	#Stolen from M::B
	179	my %license_urls = (
	180	perl => 'http://dev.perl.org/licenses/',
	181	apache => 'http://apache.org/licenses/LICENSE-2.0',
	182	artistic => 'http://opensource.org/licenses/artistic-license.php',
	183	artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php',
	184	lgpl => 'http://opensource.org/licenses/lgpl-license.php',
	185	lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php',
	186	lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html',
	187	bsd => 'http://opensource.org/licenses/bsd-license.php',
	188	gpl => 'http://opensource.org/licenses/gpl-license.php',
	189	gpl2 => 'http://opensource.org/licenses/gpl-2.0.php',
	190	gpl3 => 'http://opensource.org/licenses/gpl-3.0.html',
	191	mit => 'http://opensource.org/licenses/mit-license.php',
	192	mozilla => 'http://opensource.org/licenses/mozilla1.1.php',
	193	open_source => undef,
	194	unrestricted => undef,
	195	restrictive => undef,
	196	unknown => undef,
	197	);
153	198
154	199	sub license {
155	200	my $self = shift;
156		return $self->{values}{license} unless @_;
	201	return $self->{values}->{license} unless @_;
157	202	my $license = shift or die(
158	203	'Did not provide a value to license()'
159	204	);
160		$self->{values}{license} = $license;
	205	$self->{values}->{license} = $license;
161	206
162	207	# Automatically fill in license URLs
163		if ( $license eq 'perl' ) {
164		$self->resources( license => 'http://dev.perl.org/licenses/' );
	208	if ( $license_urls{$license} ) {
	209	$self->resources( license => $license_urls{$license} );
165	210	}
166	211
167	212	return 1;

203	248
204	249	sub provides {
205	250	my $self = shift;
206		my $provides = ( $self->{values}{provides} \|\|= {} );
	251	my $provides = ( $self->{values}->{provides} \|\|= {} );
207	252	%$provides = (%$provides, @_) if @_;
208	253	return $provides;
209	254	}

232	277	sub feature {
233	278	my $self = shift;
234	279	my $name = shift;
235		my $features = ( $self->{values}{features} \|\|= [] );
	280	my $features = ( $self->{values}->{features} \|\|= [] );
236	281	my $mods;
237	282
238	283	if ( @_ == 1 and ref( $_[0] ) ) {

260	305	while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
261	306	$self->feature( $name, @$mods );
262	307	}
263		return $self->{values}{features}
264		? @{ $self->{values}{features} }
	308	return $self->{values}->{features}
	309	? @{ $self->{values}->{features} }
265	310	: ();
266	311	}
267	312
268	313	sub no_index {
269	314	my $self = shift;
270	315	my $type = shift;
271		push @{ $self->{values}{no_index}{$type} }, @_ if $type;
272		return $self->{values}{no_index};
	316	push @{ $self->{values}->{no_index}->{$type} }, @_ if $type;
	317	return $self->{values}->{no_index};
273	318	}
274	319
275	320	sub read {

393	438	/ixms ) {
394	439	my $license_text = $1;
395	440	my @phrases = (
396		'under the same (?:terms\|license) as perl itself' => 'perl', 1,
397		'GNU general public license' => 'gpl', 1,
398		'GNU public license' => 'gpl', 1,
399		'GNU lesser general public license' => 'lgpl', 1,
400		'GNU lesser public license' => 'lgpl', 1,
401		'GNU library general public license' => 'lgpl', 1,
402		'GNU library public license' => 'lgpl', 1,
403		'BSD license' => 'bsd', 1,
404		'Artistic license' => 'artistic', 1,
405		'GPL' => 'gpl', 1,
406		'LGPL' => 'lgpl', 1,
407		'BSD' => 'bsd', 1,
408		'Artistic' => 'artistic', 1,
409		'MIT' => 'mit', 1,
410		'proprietary' => 'proprietary', 0,
	441	'under the same (?:terms\|license) as (?:perl\|the perl programming language) itself' => 'perl', 1,
	442	'GNU general public license' => 'gpl', 1,
	443	'GNU public license' => 'gpl', 1,
	444	'GNU lesser general public license' => 'lgpl', 1,
	445	'GNU lesser public license' => 'lgpl', 1,
	446	'GNU library general public license' => 'lgpl', 1,
	447	'GNU library public license' => 'lgpl', 1,
	448	'BSD license' => 'bsd', 1,
	449	'Artistic license' => 'artistic', 1,
	450	'GPL' => 'gpl', 1,
	451	'LGPL' => 'lgpl', 1,
	452	'BSD' => 'bsd', 1,
	453	'Artistic' => 'artistic', 1,
	454	'MIT' => 'mit', 1,
	455	'proprietary' => 'proprietary', 0,
411	456	);
412	457	while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
413	458	$pattern =~ s{\s+}{\\s+}g;

422	467	return 'unknown';
423	468	}
424	469
	470	sub _extract_bugtracker {
	471	my @links = $_[0] =~ m#L<(\Qhttp://rt.cpan.org/\E[^>]+)>#g;
	472	my %links;
	473	@links{@links}=();
	474	@links=keys %links;
	475	return @links;
	476	}
	477
425	478	sub bugtracker_from {
426	479	my $self = shift;
427	480	my $content = Module::Install::_read($_[0]);
428		my @links = $content =~ m/L\<(http\:\/\/rt\.cpan\.org\/[^>]+)\>/g;
	481	my @links = _extract_bugtracker($content);
429	482	unless ( @links ) {
430	483	warn "Cannot determine bugtracker info from $_[0]\n";
431	484	return 0;

438	491	# Set the bugtracker
439	492	bugtracker( $links[0] );
440	493	return 1;
	494	}
	495
	496	sub requires_from {
	497	my $self = shift;
	498	my $content = Module::Install::_readperl($_[0]);
	499	my @requires = $content =~ m/^use\s+([^\W\d]\w(?:::\w+))\s+([\d\.]+)/mg;
	500	while ( @requires ) {
	501	my $module = shift @requires;
	502	my $version = shift @requires;
	503	$self->requires( $module => $version );
	504	}
	505	}
	506
	507	sub test_requires_from {
	508	my $self = shift;
	509	my $content = Module::Install::_readperl($_[0]);
	510	my @requires = $content =~ m/^use\s+([^\W\d]\w(?:::\w+))\s+([\d\.]+)/mg;
	511	while ( @requires ) {
	512	my $module = shift @requires;
	513	my $version = shift @requires;
	514	$self->test_requires( $module => $version );
	515	}
441	516	}
442	517
443	518	# Convert triple-part versions (eg, 5.6.1 or 5.8.9) to

445	520	# Also, convert double-part versions (eg, 5.8)
446	521	sub _perl_version {
447	522	my $v = $_[-1];
448		$v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e;
	523	$v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e;
449	524	$v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0\|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 \|\| 0)/e;
450	525	$v =~ s/(\.\d\d\d)000$/$1/;
451	526	$v =~ s/_.+$//;
452	527	if ( ref($v) ) {
453		$v = $v + 0; # Numify
	528	# Numify
	529	$v = $v + 0;
454	530	}
455	531	return $v;
456	532	}

460	536
461	537
462	538	######################################################################
463		# MYMETA.yml Support
	539	# MYMETA Support
464	540
465	541	sub WriteMyMeta {
466		$_[0]->write_mymeta;
467		}
468
469		sub write_mymeta {
470		my $self = shift;
471
	542	die "WriteMyMeta has been deprecated";
	543	}
	544
	545	sub write_mymeta_yaml {
	546	my $self = shift;
	547
	548	# We need YAML::Tiny to write the MYMETA.yml file
	549	unless ( eval { require YAML::Tiny; 1; } ) {
	550	return 1;
	551	}
	552
	553	# Generate the data
	554	my $meta = $self->_write_mymeta_data or return 1;
	555
	556	# Save as the MYMETA.yml file
	557	print "Writing MYMETA.yml\n";
	558	YAML::Tiny::DumpFile('MYMETA.yml', $meta);
	559	}
	560
	561	sub write_mymeta_json {
	562	my $self = shift;
	563
	564	# We need JSON to write the MYMETA.json file
	565	unless ( eval { require JSON; 1; } ) {
	566	return 1;
	567	}
	568
	569	# Generate the data
	570	my $meta = $self->_write_mymeta_data or return 1;
	571
	572	# Save as the MYMETA.yml file
	573	print "Writing MYMETA.json\n";
	574	Module::Install::_write(
	575	'MYMETA.json',
	576	JSON->new->pretty(1)->canonical->encode($meta),
	577	);
	578	}
	579
	580	sub _write_mymeta_data {
	581	my $self = shift;
	582
472	583	# If there's no existing META.yml there is nothing we can do
473		return unless -f 'META.yml';
	584	return undef unless -f 'META.yml';
	585
	586	# We need Parse::CPAN::Meta to load the file
	587	unless ( eval { require Parse::CPAN::Meta; 1; } ) {
	588	return undef;
	589	}
474	590
475	591	# Merge the perl version into the dependencies
476	592	my $val = $self->Meta->{values};

487	603	}
488	604
489	605	# Load the advisory META.yml file
490		require YAML::Tiny;
491		my @yaml = YAML::Tiny::LoadFile('META.yml');
	606	my @yaml = Parse::CPAN::Meta::LoadFile('META.yml');
492	607	my $meta = $yaml[0];
493	608
494	609	# Overwrite the non-configure dependency hashs

502	617	$meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } };
503	618	}
504	619
505		# Save as the MYMETA.yml file
506		YAML::Tiny::DumpFile('MYMETA.yml', $meta);
	620	return $meta;
507	621	}
508	622
509	623	1;

-3

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	6	use vars qw{$VERSION @ISA $ISCORE};
7	7	BEGIN {
8		$VERSION = '0.79';
9		@ISA = qw{Module::Install::Base};
	8	$VERSION = '0.91';
	9	@ISA = 'Module::Install::Base';
10	10	$ISCORE = 1;
11	11	}
12	12

+23

-3

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	6	use vars qw{$VERSION @ISA $ISCORE};
7	7	BEGIN {
8		$VERSION = '0.79';
	8	$VERSION = '0.91';;
9	9	@ISA = qw{Module::Install::Base};
10	10	$ISCORE = 1;
11	11	}

21	21	);
22	22
23	23	$self->sign(1) if $args{sign};
24		$self->Meta->write if $args{meta};
25	24	$self->admin->WriteAll(%args) if $self->is_admin;
26	25
27	26	$self->check_nmake if $args{check_nmake};

29	28	$self->makemaker_args( PL_FILES => {} );
30	29	}
31	30
	31	# Until ExtUtils::MakeMaker support MYMETA.yml, make sure
	32	# we clean it up properly ourself.
	33	$self->realclean_files('MYMETA.yml');
	34
32	35	if ( $args{inline} ) {
33	36	$self->Inline->write;
34	37	} else {
35	38	$self->Makefile->write;
36	39	}
	40
	41	# The Makefile write process adds a couple of dependencies,
	42	# so write the META.yml files after the Makefile.
	43	if ( $args{meta} ) {
	44	$self->Meta->write;
	45	}
	46
	47	# Experimental support for MYMETA
	48	if ( $ENV{X_MYMETA} ) {
	49	if ( $ENV{X_MYMETA} eq 'JSON' ) {
	50	$self->Meta->write_mymeta_json;
	51	} else {
	52	$self->Meta->write_mymeta_yaml;
	53	}
	54	}
	55
	56	return 1;
37	57	}
38	58
39	59	1;

+87

-26

inc/Module/Install.pm less more

16	16	# 3. The ./inc/ version of Module::Install loads
17	17	# }
18	18
19		BEGIN {
20		require 5.004;
21		}
	19	use 5.005;
22	20	use strict 'vars';
23	21
24		use vars qw{$VERSION};
	22	use vars qw{$VERSION $MAIN};
25	23	BEGIN {
26	24	# All Module::Install core packages now require synchronised versions.
27	25	# This will be used to ensure we don't accidentally load old or

29	27	# This is not enforced yet, but will be some time in the next few
30	28	# releases once we can make sure it won't clash with custom
31	29	# Module::Install extensions.
32		$VERSION = '0.79';
	30	$VERSION = '0.91';
	31
	32	# Storage for the pseudo-singleton
	33	$MAIN = undef;
33	34
34	35	inc::Module::Install::VERSION = VERSION;
35	36	@inc::Module::Install::ISA = __PACKAGE__;

68	69	# again. This is bad. Rather than taking action to touch it (which
69	70	# is unreliable on some platforms and requires write permissions)
70	71	# for now we should catch this and refuse to run.
71		if ( -f $0 and (stat($0))[9] > time ) { die <<"END_DIE" }
72
73		Your installer $0 has a modification time in the future.
	72	if ( -f $0 ) {
	73	my $s = (stat($0))[9];
	74
	75	# If the modification time is only slightly in the future,
	76	# sleep briefly to remove the problem.
	77	my $a = $s - time;
	78	if ( $a > 0 and $a < 5 ) { sleep 5 }
	79
	80	# Too far in the future, throw an error.
	81	my $t = time;
	82	if ( $s > $t ) { die <<"END_DIE" }
	83
	84	Your installer $0 has a modification time in the future ($s > $t).
74	85
75	86	This is known to create infinite loops in make.
76	87
77	88	Please correct this, then run $0 again.
78	89
79	90	END_DIE
	91	}
80	92
81	93
82	94

120	132	$sym->{$cwd} = sub {
121	133	my $pwd = Cwd::cwd();
122	134	if ( my $code = $sym->{$pwd} ) {
123		# delegate back to parent dirs
	135	# Delegate back to parent dirs
124	136	goto &$code unless $cwd eq $pwd;
125	137	}
126	138	$$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
127		unless ( uc($1) eq $1 ) {
128		unshift @_, ( $self, $1 );
129		goto &{$self->can('call')};
	139	my $method = $1;
	140	if ( uc($method) eq $method ) {
	141	# Do nothing
	142	return;
	143	} elsif ( $method =~ /^_/ and $self->can($method) ) {
	144	# Dispatch to the root M:I class
	145	return $self->$method(@_);
130	146	}
	147
	148	# Dispatch to the appropriate plugin
	149	unshift @_, ( $self, $1 );
	150	goto &{$self->can('call')};
131	151	};
132	152	}
133	153

152	172	delete $INC{"$self->{file}"};
153	173	delete $INC{"$self->{path}.pm"};
154	174
	175	# Save to the singleton
	176	$MAIN = $self;
	177
155	178	return 1;
156	179	}
157	180

165	188
166	189	my @exts = @{$self->{extensions}};
167	190	unless ( @exts ) {
168		my $admin = $self->{admin};
169		@exts = $admin->load_all_extensions;
	191	@exts = $self->{admin}->load_all_extensions;
170	192	}
171	193
172	194	my %seen;

249	271	sub load_extensions {
250	272	my ($self, $path, $top) = @_;
251	273
252		unless ( grep { !ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
	274	unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
253	275	unshift @INC, $self->{prefix};
254	276	}
255	277

313	335
314	336
315	337	#####################################################################
316		# Utility Functions
	338	# Common Utility Functions
317	339
318	340	sub _caller {
319	341	my $depth = 0;

327	349
328	350	sub _read {
329	351	local *FH;
330		open FH, "< $_[0]" or die "open($_[0]): $!";
331		my $str = do { local $/; <FH> };
	352	if ( $] >= 5.006 ) {
	353	open( FH, '<', $_[0] ) or die "open($_[0]): $!";
	354	} else {
	355	open( FH, "< $_[0]" ) or die "open($_[0]): $!";
	356	}
	357	my $string = do { local $/; <FH> };
332	358	close FH or die "close($_[0]): $!";
333		return $str;
	359	return $string;
	360	}
	361
	362	sub _readperl {
	363	my $string = Module::Install::_read($_[0]);
	364	$string =~ s/(?:\015{1,2}\012\|\015\|\012)/\n/sg;
	365	$string =~ s/(\n)\n__(?:DATA\|END)__\b.\z/$1/s;
	366	$string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg;
	367	return $string;
	368	}
	369
	370	sub _readpod {
	371	my $string = Module::Install::_read($_[0]);
	372	$string =~ s/(?:\015{1,2}\012\|\015\|\012)/\n/sg;
	373	return $string if $_[0] =~ /\.pod\z/;
	374	$string =~ s/(^\|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+\|\z)/$1$2/sg;
	375	$string =~ s/\n=pod\b[^\n]\n+/\n\n/sg;
	376	$string =~ s/\n=cut\b[^\n]\n+/\n\n/sg;
	377	$string =~ s/^\n+//s;
	378	return $string;
334	379	}
335	380
336	381	sub _write {
337	382	local *FH;
338		open FH, "> $_[0]" or die "open($_[0]): $!";
339		foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!" }
	383	if ( $] >= 5.006 ) {
	384	open( FH, '>', $_[0] ) or die "open($_[0]): $!";
	385	} else {
	386	open( FH, "> $_[0]" ) or die "open($_[0]): $!";
	387	}
	388	foreach ( 1 .. $#_ ) {
	389	print FH $_[$_] or die "print($_[0]): $!";
	390	}
340	391	close FH or die "close($_[0]): $!";
341	392	}
342	393
343	394	# _version is for processing module versions (eg, 1.03_05) not
344	395	# Perl versions (eg, 5.8.1).
345
346	396	sub _version ($) {
347	397	my $s = shift \|\| 0;
348		$s =~ s/^(\d+)\.?//;
	398	my $d =()= $s =~ /(\.)/g;
	399	if ( $d >= 2 ) {
	400	# Normalise multipart versions
	401	$s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg;
	402	}
	403	$s =~ s/^(\d+)\.?//;
349	404	my $l = $1 \|\| 0;
350		my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g;
351		$l = $l . '.' . join '', @v if @v;
	405	my @v = map {
	406	$_ . '0' x (3 - length $_)
	407	} $s =~ /(\d{1,3})\D?/g;
	408	$l = $l . '.' . join '', @v if @v;
352	409	return $l + 0;
	410	}
	411
	412	sub _cmp ($$) {
	413	_version($_[0]) <=> _version($_[1]);
353	414	}
354	415
355	416	# Cloned from Params::Util::_CLASS

359	420	and
360	421	! ref $_[0]
361	422	and
362		$_[0] =~ m/^[^\W\d]\w(?:::\w+)$/s
	423	$_[0] =~ m/^[^\W\d]\w(?:::\w+)\z/s
363	424	) ? $_[0] : undef;
364	425	}
365	426

+36

-1

lib/Jifty/DBI/Collection.pm less more

1809	1809	C<first_row> and C<rows_per_page> so that queries return values from
1810	1810	the selected page.
1811	1811
	1812	If a C<current_page> of C<all> is passed, then paging is basically disabled
	1813	(by setting C<per_page> to the number of entries, and C<current_page> to 1)
	1814
1812	1815	=cut
1813	1816
1814	1817	sub set_page_info {

1823	1826	my $weakself = $self;
1824	1827	weaken($weakself);
1825	1828
1826		$self->pager->total_entries( lazy { $weakself->count_all } )
	1829	my $total_entries = lazy { $weakself->count_all };
	1830
	1831	if ($args{'current_page'} eq 'all') {
	1832	$args{'current_page'} = 1;
	1833	$args{'per_page'} = $total_entries;
	1834	}
	1835
	1836	$self->pager->total_entries($total_entries)
1827	1837	->entries_per_page( $args{'per_page'} )
1828	1838	->current_page( $args{'current_page'} );
1829	1839

2181	2191	);
2182	2192	}
2183	2193
	2194	=head2 each CALLBACK
	2195
	2196	Executes the callback for each item in the collection. The callback receives as
	2197	arguments each record, its zero-based index, and the collection. The return
	2198	value of C<each> is the original collection.
	2199
	2200	If the callback returns zero, the iteration ends.
	2201
	2202	=cut
	2203
	2204	sub each {
	2205	my $self = shift;
	2206	my $cb = shift;
	2207
	2208	my $idx = 0;
	2209	$self->goto_first_item;
	2210
	2211	while (my $record = $self->next) {
	2212	my $ret = $cb->($record, $idx++, $self);
	2213	last if defined($ret) && !$ret;
	2214	}
	2215
	2216	return $self;
	2217	}
	2218
2184	2219	1;
2185	2220	__END__
2186	2221

-6

lib/Jifty/DBI/Handle.pm less more

813	813	if ($force) {
814	814	$TRANSDEPTH = 0;
815	815
816		Jifty::DBI::Record->flush_cache
817		if Jifty::DBI::Record->can('flush_cache');
818
819	816	return ( $dbh->rollback );
820	817	}
821	818

829	826	$TRANSDEPTH--;
830	827	return $TRANSDEPTH;
831	828	}
832
833		Jifty::DBI::Record->flush_cache
834		if Jifty::DBI::Record->can('flush_cache');
835	829
836	830	my $rv = $dbh->rollback;
837	831	if ($rv) {

-3

lib/Jifty/DBI/Record/Cachable.pm less more

86	86
87	87	}
88	88
	89	sub _is_in_transaction {
	90	my $self = shift;
	91	$Jifty::DBI::Handle::TRANSDEPTH > 0;
	92	}
	93
89	94	=head2 load_from_hash
90	95
91	96	Overrides the implementation from L<Jifty::DBI::Record> to add caching.

103	108	( $rvalue, $msg ) = $self->SUPER::load_from_hash(@_);
104	109
105	110	## Check the return value, if its good, cache it!
106		$self->_store() if ($rvalue);
	111	$self->_store() if ($rvalue && !$self->_is_in_transaction);
107	112	return ( $rvalue, $msg );
108	113	} else { # Called as a class method;
109	114	$self = $self->SUPER::load_from_hash(@_);
110	115	## Check the return value, if its good, cache it!
111		$self->_store() if ( $self->id );
	116	$self->_store() if ( $self->id && !$self->_is_in_transaction );
112	117	return ($self);
113	118	}
114	119

143	148	## Fetch from the DB!
144	149	my ( $rvalue, $msg ) = $self->SUPER::load_by_cols(%attr);
145	150	## Check the return value, if its good, cache it!
146		if ($rvalue) {
	151	if ($rvalue && !$self->_is_in_transaction) {
147	152	## Only cache the object if its okay to do so.
148	153	$self->_store();
149	154	$self->_key_cache->set(

+20

-8

lib/Jifty/DBI/Record.pm less more

88	88	my ($flag) = @_;
89	89	if ( $class->isa(__PACKAGE__) and defined $flag and $flag eq '-base' ) {
90	90	my $descendant = (caller)[0];
91		no strict 'refs';
92		push @{ $descendant . '::ISA' }, $class;
	91	unless ( $descendant->isa($class) ) {
	92	no strict 'refs';
	93	push @{ $descendant . '::ISA' }, $class
	94	}
93	95	shift;
94	96
95	97	# run the schema callback

603	605
604	606	=head2 readable_attributes
605	607
606		Returns a list this table's readable columns
	608	Returns the list of this table's readable columns. They are first sorted so
	609	that primary keys come first, and then they are sorted in alphabetical order.
607	610
608	611	=cut
609	612
610	613	sub readable_attributes {
611	614	my $self = shift;
612		return @{
613		$self->_READABLE_COLS_CACHE() \|\| $self->_READABLE_COLS_CACHE(
614		[ sort map { $_->name } grep { $_->readable } $self->columns ]
615		)
616		};
	615
	616	my %is_primary = map { $_ => 1 } @{ $self->_primary_keys };
	617
	618	return @{ $self->_READABLE_COLS_CACHE() \|\| $self->_READABLE_COLS_CACHE([
	619	map { $_->name }
	620	sort { do {
	621	no warnings 'uninitialized';
	622	($is_primary{$b->name} <=> $is_primary{$a->name})
	623	\|\|
	624	($a->name cmp $b->name)
	625	} }
	626	grep { $_->readable }
	627	$self->columns
	628	])};
617	629	}
618	630
619	631	=head2 serialize_metadata

-0

lib/Jifty/DBI/SchemaGenerator.pm less more

286	286	column => $column,
287	287	value_ref => \$default,
288	288	);
	289	$default = \"''" if defined $default and not length $default;
289	290	$model->_handle(undef);
290	291	} else {
291	292	$default = '';

-1

lib/Jifty/DBI.pm less more

1	1	use warnings;
2	2	use strict;
3	3
4		$Jifty::DBI::VERSION = '0.58';
	4	$Jifty::DBI::VERSION = '0.59';
5	5
6	6	=head1 NAME
7	7