Commit bf246f7fe0f14373b63d1711add8dd319932a26e - libjifty-dbi-perl

+3

-2

.gitignore less more

4	4	Makefile.old
5	5	SIGNATURE
6	6	blib/
7		inc/
8	7	pm_to_blib
9
	8	.prove
	9	*.sw[po]
	10	cover_db/

+28

-0

Changes less more

0	0	Revision history for Perl extension Jifty::DBI.
	1
	2	0.64 Wed Dec 8 15:21:17 EST 2010
	3	- Installation:
	4	* Minor distribution fixes
	5
	6	0.63 Wed Dec 8 15:14:17 EST 2010
	7	- Features:
	8	* distinct_column_values method, docs and tests
	9
	10	- Fixes:
	11	* Warn about load(arg => value)
	12	* Include column_name in the value passed to reader warning
	13	* It is a rare but possible case that 0 is a valid id
	14	* Ensure encode_base64 doesn't choke on utf8
	15
	16	0.62 Thu May 20 13:58:53 EST 2010
	17	- Features:
	18	* Computed columns let you have the Jifty-DBI scaffolding but without
	19	touching the database
	20	* Column->is_boolean
	21
	22	- Fixes:
	23	* Don't attempt to store undef values in memcached
	24	* Avoid undef warnings
	25
	26	0.61 Mon Jan 4 13:04:20 EST 2010
	27	- Installation:
	28	* Minor distribution fixes
1	29
2	30	0.60 Mon Jan 4 13:02:17 EST 2010
3	31	- Features:

+5

-2

MANIFEST less more

67	67	t/02-column_constraints.t
68	68	t/02records_cachable.t
69	69	t/02records_object.t
	70	t/02searches_distinct_values.t
70	71	t/02searches_joins.t
71	72	t/03rebless.t
72	73	t/03rename_column.t

74	75	t/04memcached.t
75	76	t/05raw_value.t
76	77	t/06filter.t
	78	t/06filter_base64.t
77	79	t/06filter_boolean.t
78	80	t/06filter_datetime.t
79	81	t/06filter_duration.t

93	95	t/18triggers.t
94	96	t/19reference.t
95	97	t/20overload.t
	98	t/99-pod-coverage.t
	99	t/99-pod-spelling.t
	100	t/99-pod.t
96	101	t/case_sensitivity.t
97	102	t/metadata.t
98		t/pod-coverage.t
99		t/pod.t
100	103	t/testmodels.pl
101	104	t/utils.pl

+6

-3

META.yml less more

0	0	---
1		author: ~
2	1	build_requires:
3	2	DBD::SQLite: 1.14
4	3	ExtUtils::MakeMaker: 6.42

7	6	configure_requires:
8	7	ExtUtils::MakeMaker: 6.42
9	8	distribution_type: module
10		generated_by: 'Module::Install version 0.91'
	9	generated_by: 'Module::Install version 1.00'
11	10	license: perl
12	11	meta-spec:
13	12	url: http://module-build.sourceforge.net/META-spec-v1.4.html

19	18	- inc
20	19	- t
21	20	requires:
	21	Cache::Memcached: 0
22	22	Cache::Simple::TimedExpiry: 0.21
23	23	Class::Accessor::Fast: 0
24	24	Class::Data::Inheritable: 0

37	37	Lingua::EN::Inflect: 0
38	38	Object::Declare: 0.22
39	39	Scalar::Defer: 0.1
	40	Time::Duration: 0
	41	Time::Duration::Parse: 0.06
40	42	UNIVERSAL::require: 0.11
	43	URI: 0
41	44	YAML::Syck: 0
42	45	perl: 5.8.3
43	46	version: 0
44	47	resources:
45	48	license: http://dev.perl.org/licenses/
46		version: 0.60
	49	version: 0.64

+10

-10

README less more

6	6	This module provides an object-oriented mechanism for retrieving and
7	7	updating data in a DBI-accessible database.
8	8
9		This module is the direct descendent of DBIx::SearchBuilder. If you're
	9	This module is the direct descendant of DBIx::SearchBuilder. If you're
10	10	familiar with SearchBuilder, Jifty::DBI should be quite familiar to you.
11	11
12		What is it trying to do.
	12	Purpose
13	13	Jifty::DBI::Record abstracts the agony of writing the common and
14		generally simple SQL statements needed to serialize and de-serialize an
	14	generally simple SQL statements needed to serialize and deserialize an
15	15	object to the database. In a traditional system, you would define
16	16	various methods on your object 'create', 'read', 'update', and 'delete'
17	17	being the most common. In each method you would have a SQL statement

97	97
98	98	my $s = Simple->new( handle => $handle );
99	99
100		$s->load_by_cols(id=>1);
	100	$s->load_by_cols(id=>1);
101	101
102	102	load_by_cols
103	103	Takes a hash of column => value pairs and returns the first to

118	118	print "Foo : ", $s->foo(), "\n";
119	119	print "Bar : ", $s->bar(), "\n";
120	120
121		Thats all you have to to get the data, now to change the data!
	121	That's all you have to to get the data, now to change the data!
122	122
123	123	$s->set_bar('NewBar');
124	124
125		Pretty simple! Thats really all there is to it. Set<Field>($) returns a
	125	Pretty simple! That's really all there is to it. Set<Field>($) returns a
126	126	boolean and a string describing the problem. Lets look at an example of
127	127	what will happen if we try to set a 'Id' which we previously defined as
128	128	read only.

131	131	if (! $res) {
132	132	## Print the error!
133	133	print "$str\n";
134		}
	134	}
135	135
136	136	The output will be:
137	137

161	161
162	162	And it's gone.
163	163
164		For simple use, thats more or less all there is to it. In the future, I
165		hope to exapand this HowTo to discuss using container classes,
	164	For simple use, that's more or less all there is to it. In the future, I
	165	hope to expand this how-to to discuss using container classes,
166	166	overloading, and what ever else I think of.
167	167
168	168	LICENSE
169		Jifty::DBI is Copyright 2005-2007 Best Practical Solutions, LLC.
	169	Jifty::DBI is Copyright 2005-2010 Best Practical Solutions, LLC.
170	170	Jifty::DBI is distributed under the same terms as Perl itself.
171	171

+46

-43

SIGNATURE less more

0	0	This file contains message digests of all files listed in MANIFEST,
1		signed via the Module::Signature module, version 0.55.
	1	signed via the Module::Signature module, version 0.66.
2	2
3	3	To verify the content in this distribution, first make sure you have
4	4	Module::Signature installed, then type:

13	13	-----BEGIN PGP SIGNED MESSAGE-----
14	14	Hash: SHA1
15	15
16		SHA1 f29ac6543498d1b0e81f387b7284a039f83e7d29 .gitignore
17		SHA1 ebecbc802fdf30c483cb2c9cf0639600e1c4ef43 Changes
18		SHA1 006b044e48cc925d04f620f317a907d459b2d128 MANIFEST
19		SHA1 d836113207f525431fc0b36592d96c0178e85d70 META.yml
	16	SHA1 418a58763132c9a476627cbdce5ff01395ce84d4 .gitignore
	17	SHA1 e1c395f642330252cb46d4993d57ffea7880033d Changes
	18	SHA1 18b75d45e40e1ff66f673bab9fdaf37edf93794e MANIFEST
	19	SHA1 8f362327ea5bd6c5d365d2cb3dcf4eb226506ad6 META.yml
20	20	SHA1 48bd6ca8a37ec79b7cae91028d7e9489ad33a03b Makefile.PL
21		SHA1 ae8407c841f230c353f683bd5c257815aed9b9f0 README
	21	SHA1 e29d7b270f78a5a406921571b08290c46f2a42f6 README
22	22	SHA1 82d6ac3f6def48558d09f8b6e3b53ed4194d8c81 ROADMAP
23	23	SHA1 9d304f35438f847863969f6a069598379f5a9db2 debian/README
24	24	SHA1 00b43188583b43d0c5f953a9b4be027a1f61404b debian/changelog

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 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 889c457846ee2b8cfbe53b668170043342fcbc7b lib/Jifty/DBI.pm
44		SHA1 e406abd0327e7e14d62f46eb8f8684f5e9d86965 lib/Jifty/DBI/Collection.pm
45		SHA1 639ef9c81f03fb084b312a5f9a6f6a3ff63b36b7 lib/Jifty/DBI/Collection/Union.pm
	32	SHA1 20c73697e1713638140c719d8eaa19a275ed43a5 inc/Module/AutoInstall.pm
	33	SHA1 7305dbe2904416e28decb05396988a5d51d578be inc/Module/Install.pm
	34	SHA1 ca13d9875e1249f6e84f7070be8152c34837955e inc/Module/Install/AutoInstall.pm
	35	SHA1 129960509127732258570c122042bc48615222e1 inc/Module/Install/Base.pm
	36	SHA1 cf3356ed9a5bd2f732527ef9e7bc5ef4458c8a93 inc/Module/Install/Can.pm
	37	SHA1 bf0a3e1977effc2832d7a813a76dce3f31b437b6 inc/Module/Install/Fetch.pm
	38	SHA1 b501b0df59a5cd235cca473889f82c3d3429f39e inc/Module/Install/Include.pm
	39	SHA1 b721c93ca5bc9a6aa863b49af15f1b1de6125935 inc/Module/Install/Makefile.pm
	40	SHA1 026cc0551a0ad399d195e395b46bdf842e115192 inc/Module/Install/Metadata.pm
	41	SHA1 5457015ea5a50e93465bf2dafa29feebd547f85b inc/Module/Install/Win32.pm
	42	SHA1 051e7fa8063908befa3440508d0584a2497b97db inc/Module/Install/WriteAll.pm
	43	SHA1 906c5411b030874ae888ead4c17922fd175ad490 lib/Jifty/DBI.pm
	44	SHA1 70bccd7b0081632f79964271b08a228a26de0396 lib/Jifty/DBI/Collection.pm
	45	SHA1 503ca4cf6693580dedf8adee58267532f8467908 lib/Jifty/DBI/Collection/Union.pm
46	46	SHA1 bcba77fd2bacf0475aea1de97f57365c8de92ca6 lib/Jifty/DBI/Collection/Unique.pm
47		SHA1 47caeff7332bb22c9a38e19e15f15f4f11a1f229 lib/Jifty/DBI/Column.pm
48		SHA1 c21a985a5b799e50f2624e0fa6daee0895313825 lib/Jifty/DBI/Filter.pm
49		SHA1 e030c3ef5c723ba6dce2e3fc23afecf2a6dfe260 lib/Jifty/DBI/Filter/Boolean.pm
	47	SHA1 ac2e81ee7f24e65bcb40c86746f3e4159aeefb25 lib/Jifty/DBI/Column.pm
	48	SHA1 9f6a6435d358a79108e98e379e252139457c1e9f lib/Jifty/DBI/Filter.pm
	49	SHA1 05d100a1a9cd24c6c0285660edf3758d5f04c1c7 lib/Jifty/DBI/Filter/Boolean.pm
50	50	SHA1 d0addaa43cfa8950cb33d42a364a3c3c56a2dd59 lib/Jifty/DBI/Filter/Date.pm
51	51	SHA1 92528e882daf77aea6aff118c223f578f702f87a lib/Jifty/DBI/Filter/DateTime.pm
52	52	SHA1 561ee05d174cb1a40be59cd1ef271b6a6c458d27 lib/Jifty/DBI/Filter/Duration.pm
53	53	SHA1 79649ca3fb9f8aa9d2fdda00d6d7c7c99fe4092f lib/Jifty/DBI/Filter/SaltHash.pm
54	54	SHA1 45ff3c7d2c03136acf98b74c659e2fe8c734d929 lib/Jifty/DBI/Filter/Storable.pm
55	55	SHA1 13837e1f389b4e2e60e8b2395b327604ec7e25b6 lib/Jifty/DBI/Filter/Time.pm
56		SHA1 83b92752da73eb8a88546509b4affaf57754ea66 lib/Jifty/DBI/Filter/Truncate.pm
	56	SHA1 900abc76b7e230934571a597132e520a231f92c3 lib/Jifty/DBI/Filter/Truncate.pm
57	57	SHA1 6dcb8ad9a3b858bdb76fe62ddf1f483701e1f918 lib/Jifty/DBI/Filter/URI.pm
58	58	SHA1 67ffe7188a1f529d7594f4fa3803bcbe15ba6485 lib/Jifty/DBI/Filter/YAML.pm
59		SHA1 9a6fd17e677321904436fefec4d434e17a4685b1 lib/Jifty/DBI/Filter/base64.pm
60		SHA1 deb33fa7b35f3542aac3e2d7fb4b5d3070dc3917 lib/Jifty/DBI/Filter/utf8.pm
61		SHA1 3e42dd9a4a0106219d15ac32c377539aa50ea4c4 lib/Jifty/DBI/Handle.pm
62		SHA1 bcc7c456e1c4d0dddd5564f03c8bb03a6c7e261f lib/Jifty/DBI/Handle/Informix.pm
	59	SHA1 a0ba8e98fd032ef018bf2119adc2b2c4d1619450 lib/Jifty/DBI/Filter/base64.pm
	60	SHA1 ad030f4ec217584bedef2fe2720e4f9b1bc5af19 lib/Jifty/DBI/Filter/utf8.pm
	61	SHA1 b043cbb2d750aa1b93e25718ec563d62b3cf13b8 lib/Jifty/DBI/Handle.pm
	62	SHA1 719a11c911aac5306baa4b44f683aa76261100c7 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
65	65	SHA1 d1757e2c992ead86f70f0dfc9c659387dc9600cf lib/Jifty/DBI/Handle/Pg.pm

67	67	SHA1 bba2314c20fcc3ef71cc69090f1cd6bd515cd9b4 lib/Jifty/DBI/Handle/Sybase.pm
68	68	SHA1 cf80896a175702a157770f64ae469430678c3357 lib/Jifty/DBI/Handle/mysql.pm
69	69	SHA1 f2cc4fcce79c9a88a023d4e6bd96c2089eef1ced lib/Jifty/DBI/Handle/mysqlPP.pm
70		SHA1 45d653e3a223599b50850010826bd835b80368d7 lib/Jifty/DBI/HasFilters.pm
71		SHA1 78a2d14d076f088b66433ab3be2f45c8b0474c34 lib/Jifty/DBI/Record.pm
	70	SHA1 b7eca843dfbf0607bde08f566b2d03ba52fe82fd lib/Jifty/DBI/HasFilters.pm
	71	SHA1 1a5e2f434db00d9b31fa4153e1424c378dea0506 lib/Jifty/DBI/Record.pm
72	72	SHA1 663978b31373520d1e2deec87e957d1dbfd1347c lib/Jifty/DBI/Record/Cachable.pm
73		SHA1 1aac77960c508d3b2e5188e15825ad5b04391d76 lib/Jifty/DBI/Record/Memcached.pm
	73	SHA1 e30b1a3be2101d839a0a57e921e6f87889ef8da1 lib/Jifty/DBI/Record/Memcached.pm
74	74	SHA1 53834b3315a509ba33a8647681f472d3ae7b0557 lib/Jifty/DBI/Record/Plugin.pm
75		SHA1 13b7e19a9ce99323f0ad41ce36422acb46ff07f9 lib/Jifty/DBI/Schema.pm
76		SHA1 30684592748a10ac2d775ea95a858e8699d46688 lib/Jifty/DBI/SchemaGenerator.pm
	75	SHA1 67504194de870031d285ae4d45acf257738577f4 lib/Jifty/DBI/Schema.pm
	76	SHA1 0e347c238e62424ca029d60ac03fce75bb2af2a2 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
80		SHA1 018309dfc89440dc670cccf6138e3d4679465b47 t/01records.t
	80	SHA1 fa795e10da8ce94f1991d893e5d179e79075129e t/01records.t
81	81	SHA1 7574130aa1dc5338b6efcd0f04eca3f6dc4b2696 t/01searches.t
82	82	SHA1 df97ee4e5bcb4ef0663dcc1a8db86dc66e8d9206 t/02-column_constraints.t
83	83	SHA1 1c2bd056c575bc74caf2e59bdda8d8eb2731a3e7 t/02records_cachable.t
84	84	SHA1 33642a61fd4b5a88436a82c6dd0fef359ba74a2b t/02records_object.t
	85	SHA1 36df1d63579d2eaef4516ec3545460da046577d5 t/02searches_distinct_values.t
85	86	SHA1 ac42d8f2eea9f4856bee130b3ca557ef13940ad4 t/02searches_joins.t
86	87	SHA1 f1f330dd8b4144e3437aba1455053903306bd0bc t/03rebless.t
87	88	SHA1 4a4ed7341a37aa1ba4ecc03ad73e120a4052eac9 t/03rename_column.t

89	90	SHA1 62c42d8458d73898f47f1b72d757239747321ef5 t/04memcached.t
90	91	SHA1 4d2b42f80c2adaab70aa236a720cf57fa4b65677 t/05raw_value.t
91	92	SHA1 f0371e275879019e2abe732bbb5626d0d05049a0 t/06filter.t
	93	SHA1 38b1446e2b030261ba943dbdd03c48dfb6c3765f t/06filter_base64.t
92	94	SHA1 646947b41cfcddf80b627505940244aed2c6c5ea t/06filter_boolean.t
93	95	SHA1 8d464426f2c5b0ab5ecc5a0a0331e5f77669c2dc t/06filter_datetime.t
94	96	SHA1 172f655a7fdb4771e6e8b3aee45e93b1264a5567 t/06filter_duration.t

97	99	SHA1 f0f6ce9d48f419de6ac6154684f9065f32e30ddd t/06filter_truncate.t
98	100	SHA1 2e9777a47e3a920d063bfbf9d56375c67c5b89c5 t/06filter_utf8.t
99	101	SHA1 bb91f506a251d7b27d2fcd29c482a345318ef04f t/06filter_yaml.t
100		SHA1 64c3722f5b34feafc87113257079721c174f3f96 t/10schema.t
101		SHA1 0f4655f0a4e558ac31df7b7fdf17c9b110f934da t/11schema_records.t
	102	SHA1 46197c643a2c26d678a2a79e61f550e4589bfadc t/10schema.t
	103	SHA1 f4b0e5a9c9c22b873f12551e8b4aea7592fd94d3 t/11schema_records.t
102	104	SHA1 164ebb7144e978617c81306f5017bdcbcf41b801 t/12prefetch.t
103	105	SHA1 2389b47958bd6f92a561ca893d7bfab166ced127 t/13collection.t
104	106	SHA1 41b7fbaf031d103a4f2066f177cc3bee84ab0458 t/14handle-pg.t

108	110	SHA1 cc7d6dd9889837143074729d30030ddabcfa6b9e t/18triggers.t
109	111	SHA1 54b7727b49111162703581d13dd47dfe276fbe9a t/19reference.t
110	112	SHA1 72a16ddfc2642564023448450f3475ae5abf6d86 t/20overload.t
	113	SHA1 cf5b3950070fda63ba1b497f7d89dd6c36ae9c93 t/99-pod-coverage.t
	114	SHA1 12002f10b761d5952c5dc5143321379405283f9a t/99-pod-spelling.t
	115	SHA1 73b9826ff54a26efc2fa19edaf80d3ad961529be t/99-pod.t
111	116	SHA1 5e1158a9340410d46ffad19f381982159dccc924 t/case_sensitivity.t
112	117	SHA1 1dd9675b0a9a59fdcd300f5d92297f0ecf4f03e4 t/metadata.t
113		SHA1 59c44900b1cb957d262f96363ceff21b46e0d598 t/pod-coverage.t
114		SHA1 e9c6a5881fc60173fbc8d479c1afd2ce3b43bef1 t/pod.t
115		SHA1 62742c946808f35bcc8b2777e975c1ce068a0a71 t/testmodels.pl
	118	SHA1 97e60dd523a74a886c170eeb05b813aa551f5efe t/testmodels.pl
116	119	SHA1 653c2f961d8b4f195e5391cd261f37815068e8d5 t/utils.pl
117	120	-----BEGIN PGP SIGNATURE-----
118		Version: GnuPG v2.0.14 (GNU/Linux)
	121	Version: GnuPG v1.4.10 (Darwin)
119	122
120		iEYEARECAAYFAktCLRQACgkQMflWJZZAbqAAOwCeOxm56OcXyvFYKXRdNUHxJNHF
121		VUEAoLquqWn/1ANIGQffysa0WwKfOStP
122		=AGva
	123	iEYEARECAAYFAkz/6TgACgkQsxfQtHhyRPo1QgCfRMhwqkS8/56Xz/c4VihUk54k
	124	+JMAnRox8Eg3RIfhqpHd73M4BcyaqOFQ
	125	=Tm1r
123	126	-----END PGP SIGNATURE-----

+17

-2

inc/Module/AutoInstall.pm less more

252	252	# import to main::
253	253	no strict 'refs';
254	254	*{'main::WriteMakefile'} = \&Write if caller(0) eq 'main';
	255
	256	return (@Existing, @Missing);
255	257	}
256	258
257	259	sub _running_under {

671	673	sub _load_cpan {
672	674	return if $CPAN::VERSION and $CPAN::Config and not @_;
673	675	require CPAN;
674		if ( $CPAN::HandleConfig::VERSION ) {
	676
	677	# CPAN-1.82+ adds CPAN::Config::AUTOLOAD to redirect to
	678	# CPAN::HandleConfig->load. CPAN reports that the redirection
	679	# is deprecated in a warning printed at the user.
	680
	681	# CPAN-1.81 expects CPAN::HandleConfig->load, does not have
	682	# $CPAN::HandleConfig::VERSION but cannot handle
	683	# CPAN::Config->load
	684
	685	# Which "versions expect CPAN::Config->load?
	686
	687	if ( $CPAN::HandleConfig::VERSION
	688	\|\| CPAN::HandleConfig->can('load')
	689	) {
675	690	# Newer versions of CPAN have a HandleConfig module
676	691	CPAN::HandleConfig->load;
677	692	} else {

801	816
802	817	__END__
803	818
804		#line 1056
	819	#line 1071

+23

-2

inc/Module/Install/AutoInstall.pm less more

5	5
6	6	use vars qw{$VERSION @ISA $ISCORE};
7	7	BEGIN {
8		$VERSION = '0.91';
	8	$VERSION = '1.00';
9	9	@ISA = 'Module::Install::Base';
10	10	$ISCORE = 1;
11	11	}

36	36	$self->include('Module::AutoInstall');
37	37	require Module::AutoInstall;
38	38
39		Module::AutoInstall->import(
	39	my @features_require = Module::AutoInstall->import(
40	40	(@config ? (-config => \@config) : ()),
41	41	(@core ? (-core => \@core) : ()),
42	42	$self->features,
43	43	);
	44
	45	my %seen;
	46	my @requires = map @$_, map @$_, grep ref, $self->requires;
	47	while (my ($mod, $ver) = splice(@requires, 0, 2)) {
	48	$seen{$mod}{$ver}++;
	49	}
	50	my @build_requires = map @$_, map @$_, grep ref, $self->build_requires;
	51	while (my ($mod, $ver) = splice(@build_requires, 0, 2)) {
	52	$seen{$mod}{$ver}++;
	53	}
	54	my @configure_requires = map @$_, map @$_, grep ref, $self->configure_requires;
	55	while (my ($mod, $ver) = splice(@configure_requires, 0, 2)) {
	56	$seen{$mod}{$ver}++;
	57	}
	58
	59	my @deduped;
	60	while (my ($mod, $ver) = splice(@features_require, 0, 2)) {
	61	push @deduped, $mod => $ver unless $seen{$mod}{$ver}++;
	62	}
	63
	64	$self->requires(@deduped);
44	65
45	66	$self->makemaker_args( Module::AutoInstall::_make_args() );
46	67

+8

-3

inc/Module/Install/Base.pm less more

3	3	use strict 'vars';
4	4	use vars qw{$VERSION};
5	5	BEGIN {
6		$VERSION = '0.91';
	6	$VERSION = '1.00';
7	7	}
8	8
9	9	# Suspend handler for "redefined" warnings

50	50	#line 106
51	51
52	52	sub is_admin {
53		$_[0]->admin->VERSION;
	53	! $_[0]->admin->isa('Module::Install::Base::FakeAdmin');
54	54	}
55	55
56	56	sub DESTROY {}
57	57
58	58	package Module::Install::Base::FakeAdmin;
	59
	60	use vars qw{$VERSION};
	61	BEGIN {
	62	$VERSION = $Module::Install::Base::VERSION;
	63	}
59	64
60	65	my $fake;
61	66

74	79
75	80	1;
76	81
77		#line 154
	82	#line 159

+1

-1

inc/Module/Install/Can.pm less more

8	8
9	9	use vars qw{$VERSION @ISA $ISCORE};
10	10	BEGIN {
11		$VERSION = '0.91';
	11	$VERSION = '1.00';
12	12	@ISA = 'Module::Install::Base';
13	13	$ISCORE = 1;
14	14	}

+1

-1

inc/Module/Install/Fetch.pm less more

5	5
6	6	use vars qw{$VERSION @ISA $ISCORE};
7	7	BEGIN {
8		$VERSION = '0.91';
	8	$VERSION = '1.00';
9	9	@ISA = 'Module::Install::Base';
10	10	$ISCORE = 1;
11	11	}

+1

-1

inc/Module/Install/Include.pm less more

5	5
6	6	use vars qw{$VERSION @ISA $ISCORE};
7	7	BEGIN {
8		$VERSION = '0.91';
	8	$VERSION = '1.00';
9	9	@ISA = 'Module::Install::Base';
10	10	$ISCORE = 1;
11	11	}

+194

-47

inc/Module/Install/Makefile.pm less more

3	3	use strict 'vars';
4	4	use ExtUtils::MakeMaker ();
5	5	use Module::Install::Base ();
	6	use Fcntl qw/:flock :seek/;
6	7
7	8	use vars qw{$VERSION @ISA $ISCORE};
8	9	BEGIN {
9		$VERSION = '0.91';
	10	$VERSION = '1.00';
10	11	@ISA = 'Module::Install::Base';
11	12	$ISCORE = 1;
12	13	}

24	25	die "Caught an potential prompt infinite loop ($c[1]\|$c[2]\|$_[0])";
25	26	}
26	27
27		# In automated testing, always use defaults
28		if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) {
	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} ) {
29	30	local $ENV{PERL_MM_USE_DEFAULT} = 1;
30	31	goto &ExtUtils::MakeMaker::prompt;
31	32	} else {

33	34	}
34	35	}
35	36
	37	# Store a cleaned up version of the MakeMaker version,
	38	# since we need to behave differently in a variety of
	39	# ways based on the MM version.
	40	my $makemaker = eval $ExtUtils::MakeMaker::VERSION;
	41
	42	# If we are passed a param, do a "newer than" comparison.
	43	# Otherwise, just return the MakeMaker version.
	44	sub makemaker {
	45	( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0
	46	}
	47
	48	# Ripped from ExtUtils::MakeMaker 6.56, and slightly modified
	49	# as we only need to know here whether the attribute is an array
	50	# or a hash or something else (which may or may not be appendable).
	51	my %makemaker_argtype = (
	52	C => 'ARRAY',
	53	CONFIG => 'ARRAY',
	54	# CONFIGURE => 'CODE', # ignore
	55	DIR => 'ARRAY',
	56	DL_FUNCS => 'HASH',
	57	DL_VARS => 'ARRAY',
	58	EXCLUDE_EXT => 'ARRAY',
	59	EXE_FILES => 'ARRAY',
	60	FUNCLIST => 'ARRAY',
	61	H => 'ARRAY',
	62	IMPORTS => 'HASH',
	63	INCLUDE_EXT => 'ARRAY',
	64	LIBS => 'ARRAY', # ignore ''
	65	MAN1PODS => 'HASH',
	66	MAN3PODS => 'HASH',
	67	META_ADD => 'HASH',
	68	META_MERGE => 'HASH',
	69	PL_FILES => 'HASH',
	70	PM => 'HASH',
	71	PMLIBDIRS => 'ARRAY',
	72	PMLIBPARENTDIRS => 'ARRAY',
	73	PREREQ_PM => 'HASH',
	74	CONFIGURE_REQUIRES => 'HASH',
	75	SKIP => 'ARRAY',
	76	TYPEMAPS => 'ARRAY',
	77	XS => 'HASH',
	78	# VERSION => ['version',''], # ignore
	79	# _KEEP_AFTER_FLUSH => '',
	80
	81	clean => 'HASH',
	82	depend => 'HASH',
	83	dist => 'HASH',
	84	dynamic_lib=> 'HASH',
	85	linkext => 'HASH',
	86	macro => 'HASH',
	87	postamble => 'HASH',
	88	realclean => 'HASH',
	89	test => 'HASH',
	90	tool_autosplit => 'HASH',
	91
	92	# special cases where you can use makemaker_append
	93	CCFLAGS => 'APPENDABLE',
	94	DEFINE => 'APPENDABLE',
	95	INC => 'APPENDABLE',
	96	LDDLFLAGS => 'APPENDABLE',
	97	LDFROM => 'APPENDABLE',
	98	);
	99
36	100	sub makemaker_args {
37		my $self = shift;
	101	my ($self, %new_args) = @_;
38	102	my $args = ( $self->{makemaker_args} \|\|= {} );
39		%$args = ( %$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	}
40	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 = sShift;
	138	my $self = shift;
47	139	my $name = shift;
48	140	my $args = $self->makemaker_args;
49		$args->{name} = defined $args->{$name}
50		? join( ' ', $args->{name}, @_ )
	141	$args->{$name} = defined $args->{$name}
	142	? join( ' ', $args->{$name}, @_ )
51	143	: join( ' ', @_ );
52	144	}
53	145

88	180	$self->makemaker_args( INC => shift );
89	181	}
90	182
91		my %test_dir = ();
92
93	183	sub _wanted_t {
94		/\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1;
95	184	}
96	185
97	186	sub tests_recursive {
98	187	my $self = shift;
99		if ( $self->tests ) {
100		die "tests_recursive will not work if tests are already defined";
101		}
102	188	my $dir = shift \|\| 't';
103	189	unless ( -d $dir ) {
104	190	die "tests_recursive dir '$dir' does not exist";
105	191	}
106		%test_dir = ();
	192	my %tests = map { $_ => 1 } split / /, ($self->tests \|\| '');
107	193	require File::Find;
108		File::Find::find( \&_wanted_t, $dir );
109		$self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir );
	194	File::Find::find(
	195	sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 },
	196	$dir
	197	);
	198	$self->tests( join ' ', sort keys %tests );
110	199	}
111	200
112	201	sub write {

129	218	# an underscore, even though its own version may contain one!
130	219	# Hence the funny regexp to get rid of it. See RT #35800
131	220	# for details.
132		$self->build_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ );
133		$self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ );
	221	my $v = $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/;
	222	$self->build_requires( 'ExtUtils::MakeMaker' => $v );
	223	$self->configure_requires( 'ExtUtils::MakeMaker' => $v );
134	224	} else {
135	225	# Allow legacy-compatibility with 5.005 by depending on the
136	226	# most recent EU:MM that supported 5.005.
137		$self->build_requires( 'ExtUtils::MakeMaker' => 6.42 );
	227	$self->build_requires( 'ExtUtils::MakeMaker' => 6.42 );
138	228	$self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 );
139	229	}
140	230

142	232	my $args = $self->makemaker_args;
143	233	$args->{DISTNAME} = $self->name;
144	234	$args->{NAME} = $self->module_name \|\| $self->name;
145		$args->{VERSION} = $self->version;
146	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;
147	244	if ( $self->tests ) {
148		$args->{test} = { TESTS => $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	};
149	257	}
150	258	if ( $] >= 5.005 ) {
151	259	$args->{ABSTRACT} = $self->abstract;
152		$args->{AUTHOR} = $self->author;
153		}
154		if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) {
155		$args->{NO_META} = 1;
156		}
157		if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) {
	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 ) {
158	267	$args->{SIGN} = 1;
159	268	}
160	269	unless ( $self->is_admin ) {
161	270	delete $args->{SIGN};
162	271	}
163
164		# Merge both kinds of requires into prereq_pm
	272	if ( $self->makemaker(6.31) and $self->license ) {
	273	$args->{LICENSE} = $self->license;
	274	}
	275
165	276	my $prereq = ($args->{PREREQ_PM} \|\|= {});
166	277	%$prereq = ( %$prereq,
167		map { @$_ }
	278	map { @$_ } # flatten [module => version]
168	279	map { @$_ }
169	280	grep $_,
170		($self->configure_requires, $self->build_requires, $self->requires)
	281	($self->requires)
171	282	);
172	283
173	284	# Remove any reference to perl, PREREQ_PM doesn't support it
174	285	delete $args->{PREREQ_PM}->{perl};
175	286
176		# merge both kinds of requires into prereq_pm
177		my $subdirs = ($args->{DIR} \|\|= []);
	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} \|\| []);
178	301	if ($self->bundles) {
	302	my %processed;
179	303	foreach my $bundle (@{ $self->bundles }) {
180		my ($file, $dir) = @$bundle;
181		push @$subdirs, $dir if -d $dir;
182		delete $prereq->{$file};
	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	}
183	315	}
	316	}
	317
	318	unless ( $self->makemaker('6.55_03') ) {
	319	%$prereq = (%$prereq,%$build_prereq);
	320	delete $args->{BUILD_REQUIRES};
184	321	}
185	322
186	323	if ( my $perl_version = $self->perl_version ) {
187	324	eval "use $perl_version; 1"
188	325	or die "ERROR: perl: Version $] is installed, "
189	326	. "but we need version >= $perl_version";
190		}
191
192		$args->{INSTALLDIRS} = $self->installdirs;
193
194		my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args;
	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;
195	341
196	342	my $user_preop = delete $args{dist}->{PREOP};
197		if (my $preop = $self->admin->preop($user_preop)) {
	343	if ( my $preop = $self->admin->preop($user_preop) ) {
198	344	foreach my $key ( keys %$preop ) {
199	345	$args{dist}->{$key} = $preop->{$key};
200	346	}

218	364	. ($self->postamble \|\| '');
219	365
220	366	local *MAKEFILE;
221		open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
	367	open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
	368	eval { flock MAKEFILE, LOCK_EX };
222	369	my $makefile = do { local $/; <MAKEFILE> };
223		close MAKEFILE or die $!;
224	370
225	371	$makefile =~ s/\b(test_harness$\$\(TEST_VERBOSE$, )/$1'inc', /;
226	372	$makefile =~ s/( -I\$$INST_ARCHLIB$)/ -Iinc$1/g;

240	386	# XXX - This is currently unused; not sure if it breaks other MM-users
241	387	# $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg;
242	388
243		open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
	389	seek MAKEFILE, 0, SEEK_SET;
	390	truncate MAKEFILE, 0;
244	391	print MAKEFILE "$preamble$makefile$postamble" or die $!;
245	392	close MAKEFILE or die $!;
246	393

264	411
265	412	__END__
266	413
267		#line 394
	414	#line 541

+348

-257

inc/Module/Install/Metadata.pm less more

5	5
6	6	use vars qw{$VERSION @ISA $ISCORE};
7	7	BEGIN {
8		$VERSION = '0.91';
	8	$VERSION = '1.00';
9	9	@ISA = 'Module::Install::Base';
10	10	$ISCORE = 1;
11	11	}

18	18	name
19	19	module_name
20	20	abstract
21		author
22	21	version
23	22	distribution_type
24	23	tests

42	41
43	42	my @array_keys = qw{
44	43	keywords
	44	author
45	45	};
	46
	47	*authors = \&author;
46	48
47	49	sub Meta { shift }
48	50	sub Meta_BooleanKeys { @boolean_keys }

175	177	$self->{values}->{perl_version} = $version;
176	178	}
177	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
178	447	#Stolen from M::B
179	448	my %license_urls = (
180	449	perl => 'http://dev.perl.org/licenses/',
181	450	apache => 'http://apache.org/licenses/LICENSE-2.0',
	451	apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1',
182	452	artistic => 'http://opensource.org/licenses/artistic-license.php',
183	453	artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php',
184	454	lgpl => 'http://opensource.org/licenses/lgpl-license.php',

202	472	my $license = shift or die(
203	473	'Did not provide a value to license()'
204	474	);
	475	$license = __extract_license($license) \|\| lc $license;
205	476	$self->{values}->{license} = $license;
206	477
207	478	# Automatically fill in license URLs

212	483	return 1;
213	484	}
214	485
215		sub all_from {
216		my ( $self, $file ) = @_;
217
218		unless ( defined($file) ) {
219		my $name = $self->name or die(
220		"all_from called with no args without setting name() first"
221		);
222		$file = join('/', 'lib', split(/-/, $name)) . '.pm';
223		$file =~ s{.*/}{} unless -e $file;
224		unless ( -e $file ) {
225		die("all_from cannot find $file from $name");
226		}
227		}
228		unless ( -f $file ) {
229		die("The path '$file' does not exist, or is not a file");
230		}
231
232		# Some methods pull from POD instead of code.
233		# If there is a matching .pod, use that instead
234		my $pod = $file;
235		$pod =~ s/\.pm$/.pod/i;
236		$pod = $file unless -e $pod;
237
238		# Pull the different values
239		$self->name_from($file) unless $self->name;
240		$self->version_from($file) unless $self->version;
241		$self->perl_version_from($file) unless $self->perl_version;
242		$self->author_from($pod) unless $self->author;
243		$self->license_from($pod) unless $self->license;
244		$self->abstract_from($pod) unless $self->abstract;
245
246		return 1;
247		}
248
249		sub provides {
250		my $self = shift;
251		my $provides = ( $self->{values}->{provides} \|\|= {} );
252		%$provides = (%$provides, @_) if @_;
253		return $provides;
254		}
255
256		sub auto_provides {
257		my $self = shift;
258		return $self unless $self->is_admin;
259		unless (-e 'MANIFEST') {
260		warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
261		return $self;
262		}
263		# Avoid spurious warnings as we are not checking manifest here.
264		local $SIG{__WARN__} = sub {1};
265		require ExtUtils::Manifest;
266		local *ExtUtils::Manifest::manicheck = sub { return };
267
268		require Module::Build;
269		my $build = Module::Build->new(
270		dist_name => $self->name,
271		dist_version => $self->version,
272		license => $self->license,
	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
273	499	);
274		$self->provides( %{ $build->find_dist_packages \|\| {} } );
275		}
276
277		sub feature {
278		my $self = shift;
279		my $name = shift;
280		my $features = ( $self->{values}->{features} \|\|= [] );
281		my $mods;
282
283		if ( @_ == 1 and ref( $_[0] ) ) {
284		# The user used ->feature like ->features by passing in the second
285		# argument as a reference. Accomodate for that.
286		$mods = $_[0];
	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);
287	544	} else {
288		$mods = \@_;
289		}
290
291		my $count = 0;
292		push @$features, (
293		$name => [
294		map {
295		ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_
296		} @$mods
297		]
298		);
299
300		return @$features;
301		}
302
303		sub features {
304		my $self = shift;
305		while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
306		$self->feature( $name, @$mods );
307		}
308		return $self->{values}->{features}
309		? @{ $self->{values}->{features} }
310		: ();
311		}
312
313		sub no_index {
314		my $self = shift;
315		my $type = shift;
316		push @{ $self->{values}->{no_index}->{$type} }, @_ if $type;
317		return $self->{values}->{no_index};
318		}
319
320		sub read {
321		my $self = shift;
322		$self->include_deps( 'YAML::Tiny', 0 );
323
324		require YAML::Tiny;
325		my $data = YAML::Tiny::LoadFile('META.yml');
326
327		# Call methods explicitly in case user has already set some values.
328		while ( my ( $key, $value ) = each %$data ) {
329		next unless $self->can($key);
330		if ( ref $value eq 'HASH' ) {
331		while ( my ( $module, $version ) = each %$value ) {
332		$self->can($key)->($self, $module => $version );
333		}
334		} else {
335		$self->can($key)->($self, $value);
336		}
337		}
338		return $self;
339		}
340
341		sub write {
342		my $self = shift;
343		return $self unless $self->is_admin;
344		$self->admin->write_meta;
345		return $self;
346		}
347
348		sub version_from {
349		require ExtUtils::MM_Unix;
350		my ( $self, $file ) = @_;
351		$self->version( ExtUtils::MM_Unix->parse_version($file) );
352		}
353
354		sub abstract_from {
355		require ExtUtils::MM_Unix;
356		my ( $self, $file ) = @_;
357		$self->abstract(
358		bless(
359		{ DISTNAME => $self->name },
360		'ExtUtils::MM_Unix'
361		)->parse_abstract($file)
362		);
363		}
364
365		# Add both distribution and module name
366		sub name_from {
367		my ($self, $file) = @_;
368		if (
369		Module::Install::_read($file) =~ m/
370		^ \s*
371		package \s*
372		([\w:]+)
373		\s* ;
374		/ixms
375		) {
376		my ($name, $module_name) = ($1, $1);
377		$name =~ s{::}{-}g;
378		$self->name($name);
379		unless ( $self->module_name ) {
380		$self->module_name($module_name);
381		}
382		} else {
383		die("Cannot determine name from $file\n");
384		}
385		}
386
387		sub perl_version_from {
388		my $self = shift;
389		if (
390		Module::Install::_read($_[0]) =~ m/
391		^
392		(?:use\|require) \s*
393		v?
394		([\d_\.]+)
395		\s* ;
396		/ixms
397		) {
398		my $perl_version = $1;
399		$perl_version =~ s{_}{}g;
400		$self->perl_version($perl_version);
401		} else {
402		warn "Cannot determine perl version info from $_[0]\n";
403		return;
404		}
405		}
406
407		sub author_from {
408		my $self = shift;
409		my $content = Module::Install::_read($_[0]);
410		if ($content =~ m/
411		=head \d \s+ (?:authors?)\b \s*
412		([^\n]*)
413		\|
414		=head \d \s+ (?:licen[cs]e\|licensing\|copyright\|legal)\b \s*
415		.? copyright .? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
416		([^\n]*)
417		/ixms) {
418		my $author = $1 \|\| $2;
419		$author =~ s{E<lt>}{<}g;
420		$author =~ s{E<gt>}{>}g;
421		$self->author($author);
422		} else {
423		warn "Cannot determine author info from $_[0]\n";
424		}
425		}
426
427		sub license_from {
428		my $self = shift;
429		if (
430		Module::Install::_read($_[0]) =~ m/
431		(
432		=head \d \s+
433		(?:licen[cs]e\|licensing\|copyright\|legal)\b
434		.*?
435		)
436		(=head\\d.\|=cut.\|)
437		\z
438		/ixms ) {
439		my $license_text = $1;
440		my @phrases = (
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,
456		);
457		while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
458		$pattern =~ s{\s+}{\\s+}g;
459		if ( $license_text =~ /\b$pattern\b/i ) {
460		$self->license($license);
461		return 1;
462		}
463		}
464		}
465
466		warn "Cannot determine license info from $_[0]\n";
467		return 'unknown';
	545	warn "Cannot determine license info from $_[0]\n";
	546	return 'unknown';
	547	}
468	548	}
469	549
470	550	sub _extract_bugtracker {
471		my @links = $_[0] =~ m#L<(\Qhttp://rt.cpan.org/\E[^>]+)>#g;
	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;
472	556	my %links;
473	557	@links{@links}=();
474	558	@links=keys %links;

484	568	return 0;
485	569	}
486	570	if ( @links > 1 ) {
487		warn "Found more than on rt.cpan.org link in $_[0]\n";
	571	warn "Found more than one bugtracker link in $_[0]\n";
488	572	return 0;
489	573	}
490	574

531	615	return $v;
532	616	}
533	617
534
535
	618	sub add_metadata {
	619	my $self = shift;
	620	my %hash = @_;
	621	for my $key (keys %hash) {
	622	warn "add_metadata: $key is not prefixed with 'x_'.\n" .
	623	"Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/;
	624	$self->{values}->{$key} = $hash{$key};
	625	}
	626	}
536	627
537	628
538	629	######################################################################

+1

-1

inc/Module/Install/Win32.pm less more

5	5
6	6	use vars qw{$VERSION @ISA $ISCORE};
7	7	BEGIN {
8		$VERSION = '0.91';
	8	$VERSION = '1.00';
9	9	@ISA = 'Module::Install::Base';
10	10	$ISCORE = 1;
11	11	}

+5

-2

inc/Module/Install/WriteAll.pm less more

5	5
6	6	use vars qw{$VERSION @ISA $ISCORE};
7	7	BEGIN {
8		$VERSION = '0.91';;
	8	$VERSION = '1.00';
9	9	@ISA = qw{Module::Install::Base};
10	10	$ISCORE = 1;
11	11	}

25	25
26	26	$self->check_nmake if $args{check_nmake};
27	27	unless ( $self->makemaker_args->{PL_FILES} ) {
28		$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	}
29	32	}
30	33
31	34	# Until ExtUtils::MakeMaker support MYMETA.yml, make sure

+141

-101

inc/Module/Install.pm less more

18	18
19	19	use 5.005;
20	20	use strict 'vars';
	21	use Cwd ();
	22	use File::Find ();
	23	use File::Path ();
21	24
22	25	use vars qw{$VERSION $MAIN};
23	26	BEGIN {

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

37	40
38	41	}
39	42
40
41
42
43
44		# Whether or not inc::Module::Install is actually loaded, the
45		# $INC{inc/Module/Install.pm} is what will still get set as long as
46		# the caller loaded module this in the documented manner.
47		# If not set, the caller may NOT have loaded the bundled version, and thus
48		# they may not have a MI version that works with the Makefile.PL. This would
49		# result in false errors or unexpected behaviour. And we don't want that.
50		my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
51		unless ( $INC{$file} ) { die <<"END_DIE" }
	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" }
52	62
53	63	Please invoke ${\__PACKAGE__} with:
54	64

60	70
61	71	END_DIE
62	72
63
64
65
66
67		# If the script that is loading Module::Install is from the future,
68		# then make will detect this and cause it to re-run over and over
69		# again. This is bad. Rather than taking action to touch it (which
70		# is unreliable on some platforms and requires write permissions)
71		# for now we should catch this and refuse to run.
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" }
	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" }
83	95
84	96	Your installer $0 has a modification time in the future ($s > $t).
85	97

88	100	Please correct this, then run $0 again.
89	101
90	102	END_DIE
91		}
92
93
94
95
96
97		# Build.PL was formerly supported, but no longer is due to excessive
98		# difficulty in implementing every single feature twice.
99		if ( $0 =~ /Build.PL$/i ) { die <<"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" }
100	109
101	110	Module::Install no longer supports Build.PL.
102	111

106	115
107	116	END_DIE
108	117
109
110
111
112
113		# To save some more typing in Module::Install installers, every...
114		# use inc::Module::Install
115		# ...also acts as an implicit use strict.
116		$^H \|= strict::bits(qw(refs subs vars));
117
118
119
120
121
122		use Cwd ();
123		use File::Find ();
124		use File::Path ();
125		use FindBin;
	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	}
126	154
127	155	sub autoload {
128	156	my $self = shift;

135	163	# Delegate back to parent dirs
136	164	goto &$code unless $cwd eq $pwd;
137	165	}
138		$$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
	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	}
139	181	my $method = $1;
140	182	if ( uc($method) eq $method ) {
141	183	# Do nothing

151	193	};
152	194	}
153	195
154		sub import {
155		my $class = shift;
156		my $self = $class->new(@_);
157		my $who = $self->_caller;
158
159		unless ( -f $self->{file} ) {
160		require "$self->{path}/$self->{dispatch}.pm";
161		File::Path::mkpath("$self->{prefix}/$self->{author}");
162		$self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
163		$self->{admin}->init;
164		@_ = ($class, _self => $self);
165		goto &{"$self->{name}::import"};
166		}
167
168		*{"${who}::AUTOLOAD"} = $self->autoload;
169		$self->preload;
170
171		# Unregister loader and worker packages so subdirs can use them again
172		delete $INC{"$self->{file}"};
173		delete $INC{"$self->{path}.pm"};
174
175		# Save to the singleton
176		$MAIN = $self;
177
178		return 1;
179		}
180
181	196	sub preload {
182	197	my $self = shift;
183	198	unless ( $self->{extensions} ) {

203	218
204	219	my $who = $self->_caller;
205	220	foreach my $name ( sort keys %seen ) {
	221	local $^W;
206	222	*{"${who}::$name"} = sub {
207	223	${"${who}::AUTOLOAD"} = "${who}::$name";
208	224	goto &{"${who}::AUTOLOAD"};

213	229	sub new {
214	230	my ($class, %args) = @_;
215	231
	232	delete $INC{'FindBin.pm'};
	233	{
	234	# to suppress the redefine warning
	235	local $SIG{__WARN__} = sub {};
	236	require FindBin;
	237	}
	238
216	239	# ignore the prefix on extension modules built from top level.
217	240	my $base_path = Cwd::abs_path($FindBin::Bin);
218	241	unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
219	242	delete $args{prefix};
220	243	}
221
222	244	return $args{_self} if $args{_self};
223	245
224	246	$args{dispatch} \|\|= 'Admin';

271	293	sub load_extensions {
272	294	my ($self, $path, $top) = @_;
273	295
	296	my $should_reload = 0;
274	297	unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
275	298	unshift @INC, $self->{prefix};
	299	$should_reload = 1;
276	300	}
277	301
278	302	foreach my $rv ( $self->find_extensions($path) ) {

280	304	next if $self->{pathnames}{$pkg};
281	305
282	306	local $@;
283		my $new = eval { require $file; $pkg->can('new') };
	307	my $new = eval { local $^W; require $file; $pkg->can('new') };
284	308	unless ( $new ) {
285	309	warn $@ if $@;
286	310	next;
287	311	}
288		$self->{pathnames}{$pkg} = delete $INC{$file};
	312	$self->{pathnames}{$pkg} =
	313	$should_reload ? delete $INC{$file} : $INC{$file};
289	314	push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
290	315	}
291	316

347	372	return $call;
348	373	}
349	374
	375	# Done in evals to avoid confusing Perl::MinimumVersion
	376	eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
350	377	sub _read {
351	378	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		}
	379	open( FH, '<', $_[0] ) or die "open($_[0]): $!";
357	380	my $string = do { local $/; <FH> };
358	381	close FH or die "close($_[0]): $!";
359	382	return $string;
360	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
361	393
362	394	sub _readperl {
363	395	my $string = Module::Install::_read($_[0]);

378	410	return $string;
379	411	}
380	412
	413	# Done in evals to avoid confusing Perl::MinimumVersion
	414	eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
381	415	sub _write {
382	416	local *FH;
383		if ( $] >= 5.006 ) {
384		open( FH, '>', $_[0] ) or die "open($_[0]): $!";
385		} else {
386		open( FH, "> $_[0]" ) or die "open($_[0]): $!";
387		}
	417	open( FH, '>', $_[0] ) or die "open($_[0]): $!";
388	418	foreach ( 1 .. $#_ ) {
389	419	print FH $_[$_] or die "print($_[0]): $!";
390	420	}
391	421	close FH or die "close($_[0]): $!";
392	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
393	433
394	434	# _version is for processing module versions (eg, 1.03_05) not
395	435	# Perl versions (eg, 5.8.1).

426	466
427	467	1;
428	468
429		# Copyright 2008 - 2009 Adam Kennedy.
	469	# Copyright 2008 - 2010 Adam Kennedy.

+1

-1

lib/Jifty/DBI/Collection/Union.pm less more

144	144
145	145	=head2 count
146	146
147		Returns the total number of elements in the Union'ed Collection
	147	Returns the total number of elements in the union collection
148	148
149	149	=cut
150	150

+63

-18

lib/Jifty/DBI/Collection.pm less more

535	535	my $alias = shift;
536	536	my $item = shift;
537	537	return map $alias ."." . $_ ." as ". $alias ."_". $_,
538		map $_->name, grep !$_->virtual, $item->columns;
	538	map $_->name, grep { !$_->virtual && !$_->computed } $item->columns;
539	539	}
540	540
541	541	=head2 prefetch PARAMHASH

931	931	return ( $self->next );
932	932	}
933	933
	934	=head2 distinct_column_values
	935
	936	Takes a column name and returns distinct values of the column.
	937	Only values in the current collection are returned.
	938
	939	Optional arguments are C<max> and C<sort> to limit number of
	940	values returned and it makes sense to sort results.
	941
	942	$col->distinct_column_values('column');
	943
	944	$col->distinct_column_values(column => 'column');
	945
	946	$col->distinct_column_values('column', max => 10, sort => 'asc');
	947
	948	=cut
	949
	950	sub distinct_column_values {
	951	my $self = shift;
	952	my %args = (
	953	column => undef,
	954	sort => undef,
	955	max => undef,
	956	@_%2 ? (column => @_) : (@_)
	957	);
	958
	959	return () if $self->derived;
	960
	961	my $query_string = $self->_build_joins;
	962	if ( $self->_is_limited ) {
	963	$query_string .= ' '. $self->_where_clause . " ";
	964	}
	965
	966	my $column = 'main.'. $args{'column'};
	967	$query_string = 'SELECT DISTINCT '. $column .' FROM '. $query_string;
	968
	969	if ( $args{'sort'} ) {
	970	$query_string .= ' ORDER BY '. $column
	971	.' '. ($args{'sort'} =~ /^des/i ? 'DESC' : 'ASC');
	972	}
	973
	974	my $dbh = $self->_handle->dbh;
	975	my $list = $dbh->selectcol_arrayref( $query_string, { MaxRows => $args{'max'} } );
	976	return $list? @$list : ();
	977	}
	978
934	979	=head2 items_array_ref
935	980
936	981	Return a reference to an array containing all objects found by this

965	1010	L</record_class> method is used to determine class of the object.
966	1011
967	1012	Each record class at least once is loaded using require. This method is
968		called each time a record fetched so load atemts are cached to avoid
	1013	called each time a record fetched so load attempts are cached to avoid
969	1014	penalties. If you're sure that all record classes are loaded before
970	1015	first use then you can override this method.
971	1016

1022	1067	=head2 redo_search
1023	1068
1024	1069	Takes no arguments. Tells Jifty::DBI::Collection that the next time
1025		it's asked for a record, it should requery the database
	1070	it is asked for a record, it should re-execute the query.
1026	1071
1027	1072	=cut
1028	1073

1075	1120
1076	1121	=item alias
1077	1122
1078		Unless alias is set, the join criterias will be taken from EXT_LINKcolumn
1079		and INT_LINKcolumn and added to the criterias. If alias is set, new
1080		criterias about the foreign table will be added.
	1123	Unless alias is set, the join criteria will be taken from EXT_LINKcolumn
	1124	and INT_LINKcolumn and added to the criteria. If alias is set, new
	1125	criteria about the foreign table will be added.
1081	1126
1082	1127	=item column
1083	1128

1099	1144
1100	1145	=item "!="
1101	1146
1102		Any other standard SQL comparision operators that your underlying
	1147	Any other standard SQL comparison operators that your underlying
1103	1148	database supports are also valid.
1104	1149
1105	1150	=item "LIKE"

1116	1161
1117	1162	=item "ends_with"
1118	1163
1119		ENDSWITH is like LIKE, except it prepends a % to the beginning of the string
	1164	ends_with is like LIKE, except it prepends a % to the beginning of the string
1120	1165
1121	1166	=item "IN"
1122	1167

1350	1395
1351	1396	=head2 open_paren CLAUSE
1352	1397
1353		Places an open paren at the current location in the given C<CLAUSE>.
1354		Note that this can be used for Deep Magic, and has a high likelyhood
	1398	Places an open parenthesis at the current location in the given C<CLAUSE>.
	1399	Note that this can be used for Deep Magic, and has a high likelihood
1355	1400	of allowing you to construct malformed SQL queries. Its interface
1356	1401	will probably change in the near future, but its presence allows for
1357	1402	arbitrarily complex queries.

1394	1439
1395	1440	=head2 close_paren CLAUSE
1396	1441
1397		Places a close paren at the current location in the given C<CLAUSE>.
1398		Note that this can be used for Deep Magic, and has a high likelyhood
	1442	Places a close parenthesis at the current location in the given C<CLAUSE>.
	1443	Note that this can be used for Deep Magic, and has a high likelihood
1399	1444	of allowing you to construct malformed SQL queries. Its interface
1400	1445	will probably change in the near future, but its presence allows for
1401	1446	arbitrarily complex queries.

1747	1792
1748	1793	Join instructs Jifty::DBI::Collection to join two tables.
1749	1794
1750		The standard form takes a param hash with keys C<alias1>, C<column1>, C<alias2>
	1795	The standard form takes a paramhash with keys C<alias1>, C<column1>, C<alias2>
1751	1796	and C<column2>. C<alias1> and C<alias2> are column aliases obtained from
1752	1797	$self->new_alias or a $self->limit. C<column1> and C<column2> are the columns
1753	1798	in C<alias1> and C<alias2> that should be linked, respectively. For this

1844	1889	=head2 first_row
1845	1890
1846	1891	Get or set the first row of the result set the database should return.
1847		Takes an optional single integer argrument. Returns the currently set
	1892	Takes an optional single integer argument. Returns the currently set
1848	1893	integer first row that the database should return.
1849	1894
1850	1895

2084	2129
2085	2130	=head2 columns_in_db table
2086	2131
2087		Return a list of columns in table, lowercased.
2088
2089		TODO: Why are they lowercased?
	2132	Return a list of columns in table, in lowercase.
	2133
	2134	TODO: Why are they in lowercase?
2090	2135
2091	2136	=cut
2092	2137

2166	2211	Returns list of the object's fields that should be copied.
2167	2212
2168	2213	If your subclass store references in the object that should be copied while
2169		clonning then you probably want override this method and add own values to
	2214	cloning then you probably want override this method and add own values to
2170	2215	the list.
2171	2216
2172	2217	=cut

+15

-2

lib/Jifty/DBI/Column.pm less more

15	15	max_length
16	16	mandatory
17	17	virtual
	18	computed
18	19	distinct
19	20	sort_order
20	21	refers_to by

61	62
62	63	=head1 NAME
63	64
64		Jifty::DBI::Column - Encapsulate's a single column in a Jifty::DBI::Record table
	65	Jifty::DBI::Column - Encapsulates a single column in a Jifty::DBI::Record table
65	66
66	67	=head1 DESCRIPTION
67	68
68	69
69		This class encapsulate's a single column in a Jifty::DBI::Record table
	70	This class encapsulates a single column in a Jifty::DBI::Record table
70	71	description. It replaces the _accessible method in
71	72	L<Jifty::DBI::Record>.
72	73

126	127	return 0;
127	128	}
128	129
	130	=head2 is_boolean
	131
	132	Returns true if this column is a boolean
	133
	134	=cut
	135
	136	sub is_boolean {
	137	my $self = shift;
	138	return 1 if grep { $_->isa('Jifty::DBI::Filter::Boolean') } $self->output_filters;
	139	return 1 if $self->type =~ /BOOL/i;
	140	return 0;
	141	}
129	142
130	143	=head2 serialize_metadata
131	144

+5

-5

lib/Jifty/DBI/Filter/Boolean.pm less more

41	41
42	42	=head2 decode
43	43
44		Transform the value into 1 or 0 so Perl's concept of the boolean's value agrees
45		with the database's concept of the boolean's value. (For example, 't' and 'f'
46		might be used -- 'f' is true in Perl)
	44	Transform the value into 1 or 0 so Perl's concept of the value agrees
	45	with the database's concept of the value. (For example, 't' and 'f'
	46	might be used in the database, but 'f' is true in Perl)
47	47
48	48	=cut
49	49

76	76	my $self = shift;
77	77	my $value_ref = $self->value_ref;
78	78
79		return unless defined $$value_ref or $self->column->mandatory;
80		return if uc $$value_ref eq "NULL" and not $self->column->mandatory;
	79	return unless defined($$value_ref) or $self->column->mandatory;
	80	return if uc($$value_ref\|\|'') eq "NULL" and not $self->column->mandatory;
81	81
82	82	if ($self->_is_true($$value_ref)) {
83	83	$$value_ref = $self->handle->canonical_true;

+1

-1

lib/Jifty/DBI/Filter/Truncate.pm less more

11	11
12	12	=head1 DESCRIPTION
13	13
14		You do not need to use this filter explicitly. This filter is used internally to enforce the L<Jifty::DBI::Schema/max_length> retrictions on columns:
	14	You do not need to use this filter explicitly. This filter is used internally to enforce the L<Jifty::DBI::Schema/max_length> restrictions on columns:
15	15
16	16	column name =>
17	17	type is 'text',

+7

-3

lib/Jifty/DBI/Filter/base64.pm less more

3	3	use strict;
4	4
5	5	use base qw\|Jifty::DBI::Filter\|;
	6	use Encode qw(encode_utf8 is_utf8);
6	7	use MIME::Base64 ();
7	8
8	9	=head1 NAME

16	17
17	18	=head2 encode
18	19
19		If value is defined, then encodes it using
20		L<MIME::Base64/encode_base64>. Does nothing if value is not defined.
	20	If value is defined, then encodes it using L<MIME::Base64/encode_base64> after
	21	passing it through L<Encode/encode_utf8>. Does nothing if value is not
	22	defined.
21	23
22	24	=cut
23	25

27	29	my $value_ref = $self->value_ref;
28	30	return unless defined $$value_ref;
29	31
30		$$value_ref = MIME::Base64::encode_base64($$value_ref);
	32	$$value_ref = MIME::Base64::encode_base64(
	33	is_utf8($$value_ref) ? encode_utf8($$value_ref) : $$value_ref
	34	);
31	35
32	36	return 1;
33	37	}

+2

-2

lib/Jifty/DBI/Filter/utf8.pm less more

14	14	This filter allow you to check that you operate with
15	15	valid UTF-8 data.
16	16
17		Usage as type specific filter is recommneded.
	17	Usage as type specific filter is recommended.
18	18
19	19	=head1 METHODS
20	20

50	50	=head2 decode
51	51
52	52	Checks whether value is correct UTF-8 data or not and
53		substitute all malformed data with 0xFFFD code point.
	53	substitute all malformed data with the C<0xFFFD> code point.
54	54
55	55	Always set UTF-8 flag on the value.
56	56

+1

-1

lib/Jifty/DBI/Filter.pm less more

68	68
69	69	=item handle
70	70
71		A L<Jifty::DBI::Handle> object, because some filters (ie
	71	A L<Jifty::DBI::Handle> object, because some filters (i.e.
72	72	L<Jifty::DBI::Filter::Boolean>) depend on what database system is being used.
73	73
74	74	=back

+1

-1

lib/Jifty/DBI/Handle/Informix.pm less more

75	75
76	76	=head2 disconnect
77	77
78		Disconnects and completely unreferences the handle for Informix.
	78	Disconnects and removes the reference to the handle for Informix.
79	79
80	80	=cut
81	81

+3

-3

lib/Jifty/DBI/Handle.pm less more

278	278
279	279	Used in instrumenting the SQL logging. You can use this to, for example, get a
280	280	stack trace for each query (so you can find out where the query is being made).
281		The name is required so that multiple hooks can be installed without stepping
282		on eachother's toes.
	281	The name is required so that multiple hooks can be installed, and inspected, by
	282	name.
283	283
284	284	The coderef is run in scalar context and (currently) receives no arguments.
285	285

649	649
650	650	If argument C<short> is true returns short variant, in other
651	651	case returns whatever database handle/driver returns. By default
652		returns short version, e.g. '4.1.23' or '8.0-rc4'.
	652	returns short version, e.g. C<4.1.23> or C<8.0-rc4>.
653	653
654	654	Returns empty string on error or if database couldn't return version.
655	655

+1

-1

lib/Jifty/DBI/HasFilters.pm less more

13	13
14	14	Jifty::DBI::HasFilters - abstract class for objects that has filters
15	15
16		=head1 SYNOPSYS
	16	=head1 SYNOPSIS
17	17
18	18	my $record = Jifty::DBI::Record->new(...);
19	19	$record->input_filters( 'Jifty::DBI::Filter::Truncate',

+5

-3

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

100	100	if ($rvalue) {
101	101	$self->_store();
102	102	if ( $key ne $self->_primary_key ) {
103		$MEMCACHED->add( $key, $self->_primary_cache_key,
104		$self->_cache_config->{'cache_for_sec'} );
	103	my $cache_key = $self->_primary_cache_key;
	104	$MEMCACHED->add( $key, $cache_key,
	105	$self->_cache_config->{'cache_for_sec'} )
	106	if defined $cache_key;
105	107	$self->{'loaded_by_cols'} = $key;
106	108	}
107	109	}

226	228	sub _primary_cache_key {
227	229	my ($self) = @_;
228	230
229		return undef unless ( $self->id );
	231	return undef unless ( defined $self->id );
230	232
231	233	unless ( $self->{'_jifty_cache_pkey'} ) {
232	234

+19

-9

lib/Jifty/DBI/Record.pm less more

271	271	no strict 'refs'; # We're going to be defining subs
272	272
273	273	if ( not $self->can($column_name) ) {
274
275	274	# Accessor
276	275	my $subref;
277		if ( $column->active ) {
	276
	277	if ($column->computed) {
	278	$subref = sub {
	279	Carp::croak("column '$column_name' in $package is computed but has no corresponding method");
	280	};
	281	}
	282	elsif ( $column->active ) {
278	283
279	284	if ( $column->readable ) {
280	285	if (UNIVERSAL::isa(

285	290	$subref = sub {
286	291	if ( @_ > 1 ) {
287	292	Carp::carp
288		"Value passed to column accessor. You probably want to use the mutator.";
	293	"Value passed to column $column_name accessor. You probably want to use the mutator.";
289	294	}
290	295	# This should be using _value, so we acl_check
291	296	# appropriately, except the acl checks often

307	312	$subref = sub {
308	313	if ( @_ > 1 ) {
309	314	Carp::carp
310		"Value passed to column accessor. You probably want to use the mutator.";
	315	"Value passed to column $column_name accessor. You probably want to use the mutator.";
311	316	}
312	317	return ( $_[0]->_value($column_name) );
313	318	};

404	409
405	410	=head2 null_reference
406	411
407		By default, Jifty::DBI::Record will return C<undef> for non-existant
	412	By default, Jifty::DBI::Record will return C<undef> for non-existent
408	413	foreign references which don't exist. That is, if each Employee
409	414	C<refers_to> a Department, but isn't required to,
410	415	C<<$model->department>> will return C<undef> for employees not in a

677	682
678	683	=head2 record values
679	684
680		As you've probably already noticed, C<Jifty::DBI::Record> autocreates
681		methods for your standard get/set accessors. It also provides you with
682		some hooks to massage the values being loaded or stored.
	685	As you've probably already noticed, C<Jifty::DBI::Record> automatically
	686	creates methods for your standard get/set accessors. It also provides you
	687	with some hooks to massage the values being loaded or stored.
683	688
684	689	When you fetch a record value by calling
685	690	C<$my_record-E<gt>some_field>, C<Jifty::DBI::Record> provides the

841	846
842	847	my $column_name = $column->{name}; # Speed optimization
843	848
	849	if ($column->computed) {
	850	return $self->$column_name;
	851	}
	852
844	853	# In the default case of "yeah, we have a value", return it as
845	854	# fast as we can.
846	855	return $self->{'values'}{$column_name}

1060	1069	sub load {
1061	1070	my $self = shift;
1062	1071	return unless @_ and defined $_[0];
	1072	Carp::carp("load called with more than one argument. Did you mean load_by_cols?") if @_ > 1;
1063	1073
1064	1074	return $self->load_by_cols( id => shift );
1065	1075	}

1335	1345
1336	1346	This method is called after attempting to insert the record into the
1337	1347	database. It gets handed a reference to the return value of the
1338		insert. That'll either be a true value or a L<Class::ReturnValue>.
	1348	insert. That will either be a true value or a L<Class::ReturnValue>.
1339	1349
1340	1350	Aborting the trigger merely causes C<create> to return a false
1341	1351	(undefined) value even thought he create may have succeeded. This

+12

-4

lib/Jifty/DBI/Schema.pm less more

549	549	=head2 by
550	550
551	551	Helper for C<references>. Used to specify what column name should be
552		used in the referenced model. See the documentation for C<references>e
	552	used in the referenced model. See the documentation for C<references>.
553	553
554	554	=head2 type
555	555

608	608
609	609	=head2 not_null
610	610
611		Same as L</mandatory>. This is deprecated. Currect usage would be
	611	Same as L</mandatory>. This is deprecated. Correct usage would be
612	612	C<is not_null>.
613	613
614	614	=head2 autocompleted

627	627
628	628	=head2 virtual
629	629
	630	Used to declare that a column references a collection, which hides
	631	it from many parts of Jifty. You probably do not want to set this manually,
	632	use C<references> instead.
	633
	634	=head2 computed
	635
630	636	Declares that a column is not backed by an actual column in the
631		database, but is instead computed on-the-fly.
	637	database, but is instead computed on-the-fly using a method written by
	638	the application author. Such columns cannot (yet) be used in searching,
	639	sorting, and so on, only inspected on an individual record.
632	640
633	641	=head2 sort_order
634	642

681	689	=head2 valid_values
682	690
683	691	A list of valid values for this column. Jifty will use this to
684		autoconstruct a validator for you. This list may also be used to
	692	automatically construct a validator for you. This list may also be used to
685	693	generate the user interface. Correct usage is C<valid_values are
686	694	qw/foo bar baz/>.
687	695

+5

-2

lib/Jifty/DBI/SchemaGenerator.pm less more

19	19
20	20	=head1 NAME
21	21
22		Jifty::DBI::SchemaGenerator - Generate table schemas from Jifty::DBI records
	22	Jifty::DBI::SchemaGenerator - Generate a table schema from Jifty::DBI records
23	23
24	24	=head1 DESCRIPTION
25	25

195	195
196	196	=head2 column_definition_sql TABLENAME COLUMNNAME
197	197
198		Given a tablename and a column name, returns the SQL fragment
	198	Given a table name and a column name, returns the SQL fragment
199	199	describing that column for the current database.
200	200
201	201	=cut

257	257
258	258	# Skip "Virtual" columns - (foreign keys to collections)
259	259	next if $column->virtual;
	260
	261	# Skip computed columns
	262	next if $column->computed;
260	263
261	264	# If schema_version is defined, make sure columns are for that version
262	265	if ($model->can('schema_version') and defined $model->schema_version) {

+8

-8

lib/Jifty/DBI.pm less more

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

14	14	This module provides an object-oriented mechanism for retrieving and
15	15	updating data in a DBI-accessible database.
16	16
17		This module is the direct descendent of L<DBIx::SearchBuilder>. If you're familiar
	17	This module is the direct descendant of L<DBIx::SearchBuilder>. If you're familiar
18	18	with SearchBuilder, Jifty::DBI should be quite familiar to you.
19	19
20	20	=head2 Purpose
21	21
22	22	Jifty::DBI::Record abstracts the agony of writing the common and generally
23		simple SQL statements needed to serialize and de-serialize an object to the
	23	simple SQL statements needed to serialize and deserialize an object to the
24	24	database. In a traditional system, you would define various methods on
25	25	your object 'create', 'read', 'update', and 'delete' being the most common.
26	26	In each method you would have a SQL statement like:

155	155	print "Foo : ", $s->foo(), "\n";
156	156	print "Bar : ", $s->bar(), "\n";
157	157
158		Thats all you have to to get the data, now to change the data!
	158	That's all you have to to get the data, now to change the data!
159	159
160	160
161	161	$s->set_bar('NewBar');
162	162
163		Pretty simple! Thats really all there is to it. Set<Field>($) returns
	163	Pretty simple! That's really all there is to it. Set<Field>($) returns
164	164	a boolean and a string describing the problem. Lets look at an example of
165	165	what will happen if we try to set a 'Id' which we previously defined as
166	166	read only.

198	198
199	199	And it's gone.
200	200
201		For simple use, thats more or less all there is to it. In the future, I hope to exapand
202		this HowTo to discuss using container classes, overloading, and what
	201	For simple use, that's more or less all there is to it. In the future, I hope to expand
	202	this how-to to discuss using container classes, overloading, and what
203	203	ever else I think of.
204	204
205	205	=head1 LICENSE
206	206
207		Jifty::DBI is Copyright 2005-2009 Best Practical Solutions, LLC.
	207	Jifty::DBI is Copyright 2005-2010 Best Practical Solutions, LLC.
208	208	Jifty::DBI is distributed under the same terms as Perl itself.
209	209
210	210	=cut

+2

-2

t/01records.t less more

82	82	is($msg, 'Immutable column', 'id is immutable column');
83	83	is($rec->id, $id, "The record still has its id");
84	84
85		# Check some non existant column
	85	# Check some non existent column
86	86	ok( !eval{ $rec->some_unexpected_column }, "The record has no 'some_unexpected_column'");
87	87	{
88	88	# test produce DBI warning

133	133	is($val, 0, "didn't find object");
134	134	is($msg, "Missing a primary key?", "reason is missing PK");
135	135
136		# _load_from_sql and not existant row
	136	# _load_from_sql and not existent row
137	137	$newrec = TestApp::Address->new( handle => $handle );
138	138	($val, $msg) = $newrec->_load_from_sql('SELECT id FROM addresses WHERE id = ?', 0);
139	139	is($val, 0, "didn't find object");

+280

-0

t/02searches_distinct_values.t less more

	0	#!/usr/bin/env perl -w
	1
	2	use strict;
	3	use warnings;
	4
	5	use File::Spec;
	6	use Test::More;
	7
	8	BEGIN { require "t/utils.pl" }
	9	our (@available_drivers);
	10
	11	use constant TESTS_PER_DRIVER => 10;
	12
	13	my $total = scalar(@available_drivers) * TESTS_PER_DRIVER;
	14	plan tests => $total;
	15
	16	foreach my $d ( @available_drivers ) {
	17	SKIP: {
	18	unless( has_schema( 'TestApp', $d ) ) {
	19	skip "No schema for '$d' driver", TESTS_PER_DRIVER;
	20	}
	21	unless( should_test( $d ) ) {
	22	skip "ENV is not defined for driver '$d'", TESTS_PER_DRIVER;
	23	}
	24
	25	my $handle = get_handle( $d );
	26	connect_handle( $handle );
	27	isa_ok($handle->dbh, 'DBI::db');
	28
	29	my $ret = init_schema( 'TestApp', $handle );
	30	isa_ok($ret, 'DBI::st', "Inserted the schema. got a statement handle back");
	31
	32	my $count_users = init_data( 'TestApp::User', $handle );
	33	ok( $count_users, "init users data" );
	34	my $count_groups = init_data( 'TestApp::Group', $handle );
	35	ok( $count_groups, "init groups data" );
	36	my $count_us2gs = init_data( 'TestApp::UserToGroup', $handle );
	37	ok( $count_us2gs, "init users&groups relations data" );
	38
	39	my $clean_obj = TestApp::UserCollection->new( handle => $handle );
	40	my $users_obj = $clean_obj->clone;
	41	is_deeply( $users_obj, $clean_obj, 'after Clone looks the same');
	42
	43	diag "distinct_column_values on clean" if $ENV{'TEST_VERBOSE'};
	44	{
	45	is_deeply(
	46	[sort $users_obj->distinct_column_values('country')],
	47	[qw(br ru us)],
	48	"full on non limitted collection"
	49	);
	50	is_deeply(
	51	[$users_obj->distinct_column_values('country', sort => 'asc')],
	52	[qw(br ru us)],
	53	"sorting in DB"
	54	);
	55	is_deeply(
	56	[$users_obj->distinct_column_values('country', sort => 'desc')],
	57	[qw(us ru br)],
	58	"reverse sorting in DB"
	59	);
	60	is_deeply(
	61	[$users_obj->distinct_column_values('country', sort => 'desc', max => 2)],
	62	[qw(us ru)],
	63	"sorting and limitted"
	64	);
	65	}
	66
	67
	68	cleanup_schema( 'TestApp', $handle );
	69	}} # SKIP, foreach blocks
	70
	71	1;
	72
	73
	74	package TestApp;
	75	sub schema_sqlite {
	76	[
	77	q{
	78	CREATE table users (
	79	id integer primary key,
	80	login varchar(36),
	81	country varchar(36)
	82	) },
	83	q{
	84	CREATE table user_to_groups (
	85	id integer primary key,
	86	user_id integer,
	87	group_id integer
	88	) },
	89	q{
	90	CREATE table groups (
	91	id integer primary key,
	92	name varchar(36)
	93	) },
	94	]
	95	}
	96
	97	sub schema_mysql {
	98	[
	99	q{
	100	CREATE TEMPORARY table users (
	101	id integer primary key AUTO_INCREMENT,
	102	login varchar(36),
	103	country varchar(36)
	104	) },
	105	q{
	106	CREATE TEMPORARY table user_to_groups (
	107	id integer primary key AUTO_INCREMENT,
	108	user_id integer,
	109	group_id integer
	110	) },
	111	q{
	112	CREATE TEMPORARY table groups (
	113	id integer primary key AUTO_INCREMENT,
	114	name varchar(36)
	115	) },
	116	]
	117	}
	118
	119	sub schema_pg {
	120	[
	121	q{
	122	CREATE TEMPORARY table users (
	123	id serial primary key,
	124	login varchar(36),
	125	country varchar(36)
	126	) },
	127	q{
	128	CREATE TEMPORARY table user_to_groups (
	129	id serial primary key,
	130	user_id integer,
	131	group_id integer
	132	) },
	133	q{
	134	CREATE TEMPORARY table groups (
	135	id serial primary key,
	136	name varchar(36)
	137	) },
	138	]
	139	}
	140
	141	sub schema_oracle { [
	142	"CREATE SEQUENCE users_seq",
	143	"CREATE table users (
	144	id integer CONSTRAINT users_Key PRIMARY KEY,
	145	login varchar(36),
	146	country varchar(36)
	147	)",
	148	"CREATE SEQUENCE user_to_groups_seq",
	149	"CREATE table user_to_groups (
	150	id integer CONSTRAINT user_to_groups_Key PRIMARY KEY,
	151	user_id integer,
	152	group_id integer
	153	)",
	154	"CREATE SEQUENCE groups_seq",
	155	"CREATE table groups (
	156	id integer CONSTRAINT groups_Key PRIMARY KEY,
	157	name varchar(36)
	158	)",
	159	] }
	160
	161	sub cleanup_schema_oracle { [
	162	"DROP SEQUENCE users_seq",
	163	"DROP table users",
	164	"DROP SEQUENCE groups_seq",
	165	"DROP table groups",
	166	"DROP SEQUENCE user_to_groups_seq",
	167	"DROP table user_to_groups",
	168	] }
	169
	170	package TestApp::User;
	171
	172	use base qw/Jifty::DBI::Record/;
	173
	174	BEGIN {
	175	use Jifty::DBI::Schema;
	176	use Jifty::DBI::Record schema {
	177	column login => type is 'varchar(36)';
	178	column country => type is 'varchar(36)';
	179	};
	180	}
	181
	182	sub _init {
	183	my $self = shift;
	184	$self->table('users');
	185	$self->SUPER::_init( @_ );
	186	}
	187
	188	sub init_data {
	189	return (
	190	[ 'login', 'country' ],
	191
	192	[ 'ivan', 'ru' ],
	193	[ 'john', 'us' ],
	194	[ 'bob', 'us' ],
	195	[ 'aurelia', 'br' ],
	196	);
	197	}
	198
	199	package TestApp::UserCollection;
	200
	201	use base qw/Jifty::DBI::Collection/;
	202
	203	sub _init {
	204	my $self = shift;
	205	$self->table('users');
	206	return $self->SUPER::_init( @_ );
	207	}
	208
	209	1;
	210
	211	package TestApp::Group;
	212
	213	use base qw/Jifty::DBI::Record/;
	214
	215	BEGIN {
	216	use Jifty::DBI::Schema;
	217	use Jifty::DBI::Record schema {
	218	column name => type is 'varchar(36)';
	219	};
	220	}
	221
	222	sub _init {
	223	my $self = shift;
	224	$self->table('groups');
	225	return $self->SUPER::_init( @_ );
	226	}
	227
	228	sub init_data {
	229	return (
	230	[ 'name' ],
	231
	232	[ 'Developers' ],
	233	[ 'Sales' ],
	234	[ 'Support' ],
	235	);
	236	}
	237
	238	package TestApp::GroupCollection;
	239
	240	use base qw/Jifty::DBI::Collection/;
	241
	242	sub _init {
	243	my $self = shift;
	244	$self->table('groups');
	245	return $self->SUPER::_init( @_ );
	246	}
	247
	248	1;
	249
	250	package TestApp::UserToGroup;
	251
	252	use base qw/Jifty::DBI::Record/;
	253
	254	BEGIN {
	255	use Jifty::DBI::Schema;
	256	use Jifty::DBI::Record schema {
	257	column user_id => type is 'int(11)';
	258	column group_id => type is 'int(11)';
	259	};
	260	}
	261
	262	sub init_data {
	263	return (
	264	[ 'group_id', 'user_id' ],
	265	# dev group
	266	[ 1, 1 ],
	267	[ 1, 2 ],
	268	[ 1, 4 ],
	269	# sales
	270	# [ 2, 0 ],
	271	# support
	272	[ 3, 1 ],
	273	);
	274	}
	275
	276	package TestApp::UserToGroupCollection;
	277	use base qw/Jifty::DBI::Collection/;
	278
	279	1;

+120

-0

t/06filter_base64.t less more

	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
	3
	4	use Encode qw(decode_utf8 is_utf8);
	5
	6	use Test::More;
	7	BEGIN { require "t/utils.pl" }
	8	our (@available_drivers);
	9
	10	use constant TESTS_PER_DRIVER => 20;
	11
	12	my $total = scalar(@available_drivers) * TESTS_PER_DRIVER;
	13	plan tests => $total;
	14
	15	my $normal_data = "Hi there";
	16	my $perl_data = "Hi there—";
	17	my $utf8_data = decode_utf8($perl_data);
	18
	19	foreach my $d (@available_drivers) {
	20	SKIP: {
	21	unless (has_schema('TestApp::User', $d)) {
	22	skip "No schema for '$d' driver", TESTS_PER_DRIVER;
	23	}
	24
	25	unless (should_test($d)) {
	26	skip "ENV is not defined for driver '$d'", TESTS_PER_DRIVER;
	27	}
	28
	29	diag("start testing with '$d' handle") if $ENV{TEST_VERBOSE};
	30
	31	my $handle = get_handle($d);
	32	connect_handle($handle);
	33	isa_ok($handle->dbh, 'DBI::db');
	34
	35	{
	36	my $ret = init_schema('TestApp::User', $handle);
	37	isa_ok($ret, 'DBI::st', 'init schema');
	38	}
	39
	40	# data ref, is_utf8 expected, base64 expected, handle
	41	store_data( \$normal_data, 0, "SGkgdGhlcmU=\n", $handle );
	42	store_data( \$perl_data, 0, "SGkgdGhlcmXigJQ=\n", $handle );
	43	store_data( \$utf8_data, 1, "SGkgdGhlcmXigJQ=\n", $handle );
	44
	45	cleanup_schema('TestApp', $handle);
	46	disconnect_handle($handle);
	47	}
	48	}
	49
	50	sub store_data {
	51	my $data = shift;
	52	my $isutf8 = shift;
	53	my $expected = shift;
	54	my $handle = shift;
	55
	56	my $utf8 = is_utf8($$data) ? 1 : 0;
	57
	58	ok $utf8 == $isutf8, "is_utf8 = $utf8 as expected";
	59
	60	my $rec = TestApp::User->new( handle => $handle );
	61	isa_ok($rec, 'Jifty::DBI::Record');
	62
	63	my $id;
	64
	65	eval { $id = $rec->create( content => $$data ); };
	66	ok($id, 'created record');
	67	ok($rec->load($id), 'loaded record');
	68	is($rec->id, $id, 'record id matches');
	69	is($rec->__raw_value('content'), $expected, "got expected base64");
	70	}
	71
	72	package TestApp::User;
	73	use base qw/ Jifty::DBI::Record /;
	74
	75	1;
	76
	77	sub schema_sqlite {
	78
	79	<<EOF;
	80	CREATE table users (
	81	id integer primary key,
	82	content text
	83	)
	84	EOF
	85
	86	}
	87
	88	sub schema_mysql {
	89
	90	<<EOF;
	91	CREATE TEMPORARY table users (
	92	id integer auto_increment primary key,
	93	content text
	94	)
	95	EOF
	96
	97	}
	98
	99	sub schema_pg {
	100
	101	<<EOF;
	102	CREATE TEMPORARY table users (
	103	id serial primary key,
	104	content text
	105	)
	106	EOF
	107
	108	}
	109
	110	BEGIN {
	111	use Jifty::DBI::Schema;
	112
	113	use Jifty::DBI::Record schema {
	114	column content =>
	115	type is 'text',
	116	filters are qw/ Jifty::DBI::Filter::base64 /;
	117	}
	118	}
	119

+1

-1

t/10schema.t less more

77	77	my $employee = Sample::Employee->new;
78	78
79	79	isa_ok($employee, 'Sample::Employee');
80		can_ok($employee, qw( label type dexterity ));
	80	can_ok($employee, qw( label type dexterity age ));
81	81
82	82	$ret = $SG->add_model($employee);
83	83

+9

-5

t/11schema_records.t less more

8	8	BEGIN { require "t/utils.pl" }
9	9	our (@available_drivers);
10	10
11		use constant TESTS_PER_DRIVER => 67;
	11	use constant TESTS_PER_DRIVER => 68;
12	12
13	13	my $total = scalar(@available_drivers) * TESTS_PER_DRIVER;
14	14	plan tests => $total;

34	34	ok($e_id, "Got an id for the new employee: $e_id");
35	35	$emp->load($e_id);
36	36	is($emp->id, $e_id);
37
	37	is($emp->pid, $$);
	38
38	39	my $phone_collection = $emp->phones;
39	40	isa_ok($phone_collection, 'TestApp::PhoneCollection');
40	41

264	265	BEGIN {
265	266	use Jifty::DBI::Schema;
266	267	use Jifty::DBI::Record schema {
267		column name => type is 'varchar';
268		column phones => references TestApp::PhoneCollection by 'employee';
269		}
	268	column name => type is 'varchar';
	269	column phones => references TestApp::PhoneCollection by 'employee';
	270	column pid => is computed;
	271	};
	272
	273	sub pid { $$ }
270	274	}
271	275
272	276	sub _value {

+13

-0

t/99-pod-coverage.t less more

	0	use Test::More;
	1	eval "use Test::Pod::Coverage 1.00";
	2	plan skip_all => "Test::Pod::Coverage 1.00 required for testing POD coverage" if $@;
	3	plan skip_all => "Coverage tests only run for authors" unless (-d 'inc/.author');
	4	all_pod_coverage_ok( );
	5
	6	# Workaround for dumb bug (fixed in 5.8.7) where Test::Builder thinks that
	7	# certain "die"s that happen inside evals are not actually inside evals,
	8	# because caller() is broken if you turn on $^P like Module::Refresh does
	9	#
	10	# (I mean, if we've gotten to this line, then clearly the test didn't die, no?)
	11	Test::Builder->new->{Test_Died} = 0;
	12

+109

-0

t/99-pod-spelling.t less more

	0	#!/usr/bin/env perl -w
	1
	2	use strict;
	3	use Test::More;
	4	eval "use Test::Spelling";
	5	plan skip_all => "Test::Spelling required for testing POD spelling" if $@;
	6	plan skip_all => "Coverage tests only run for authors" unless (-d 'inc/.author');
	7
	8	add_stopwords(<DATA>);
	9
	10	local $ENV{LC_ALL} = 'C';
	11	set_spell_cmd('aspell list -l en');
	12
	13	all_pod_files_spelling_ok();
	14
	15	__DATA__
	16	Autocommit
	17	autocompleted
	18	backend
	19	BYTEA
	20	canonicalizer
	21	canonicalizers
	22	Checkbox
	23	classdata
	24	COLUMNNAME
	25	Combobox
	26	cpan
	27	database's
	28	datasource
	29	DateTime
	30	DBD
	31	dbh
	32	DBI
	33	deserialize
	34	dsn
	35	formatter
	36	Glasser
	37	Hanenkamp
	38	hashrefs
	39	HookResults
	40	Informix
	41	Informix's
	42	InlineButton
	43	Jifty
	44	Knopp
	45	LLC
	46	login
	47	lookups
	48	lossy
	49	marshalling
	50	memcached
	51	metadata
	52	mhat
	53	mixin
	54	mixins
	55	MyModel
	56	myscript
	57	mysql's
	58	NULLs
	59	ODBC
	60	OtherClass
	61	OtherCollection
	62	paramhash
	63	Postgres
	64	postgres
	65	PostgreSQL
	66	prefetch
	67	prefetched
	68	prefetches
	69	preload
	70	prepends
	71	PrintError
	72	QUERYSTRING
	73	RaiseError
	74	recordset
	75	RequireSSL
	76	requiressl
	77	resultsets
	78	Ruslan
	79	SchemaGenerator
	80	SearchBuilder
	81	sid
	82	Spier
	83	SQL
	84	SQLite
	85	SQLite's
	86	STATEMENTREF
	87	STDERR
	88	Storable
	89	Sybase
	90	Sybase's
	91	Syck
	92	TABLENAME
	93	Tappe
	94	TODO
	95	unimported
	96	unlimit
	97	unmarshalling
	98	Unrendered
	99	username
	100	UTC
	101	UTF
	102	utf
	103	validator
	104	validators
	105	Vandiver
	106	wildcard
	107	YAML
	108	Zakirov

+5

-0

t/99-pod.t less more

	0	use Test::More;
	1	eval "use Test::Pod 1.00";
	2	plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
	3	plan skip_all => "Coverage tests only run for authors" unless (-d 'inc/.author');
	4	all_pod_files_ok();

+0

-12

~~t/pod-coverage.t~~ less more

0		use Test::More;
1		eval "use Test::Pod::Coverage 1.00";
2		plan skip_all => "Test::Pod::Coverage 1.00 required for testing POD coverage" if $@;
3		all_pod_coverage_ok( );
4
5		# Workaround for dumb bug (fixed in 5.8.7) where Test::Builder thinks that
6		# certain "die"s that happen inside evals are not actually inside evals,
7		# because caller() is broken if you turn on $^P like Module::Refresh does
8		#
9		# (I mean, if we've gotten to this line, then clearly the test didn't die, no?)
10		Test::Builder->new->{Test_Died} = 0;
11

+0

-4

~~t/pod.t~~ less more

0		use Test::More;
1		eval "use Test::Pod 1.00";
2		plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
3		all_pod_files_ok();

+6

-0

t/testmodels.pl less more

7	7	is indexed;
8	8	column label => type is 'varchar';
9	9	column type => type is 'varchar';
	10	column age => is computed;
10	11
11	12	};
	13
	14	sub age {
	15	my $self = shift;
	16	return $self->dexterity * 2;
	17	}
12	18
13	19	sub schema_sqlite {
14	20	return q{