Commit 5bfd952dde0cea4a0cfef428bceea5f5433eb0f3 - libdbi-perl

+24

-7

Changes less more

1	1
2	2	DBI::Changes - List of significant changes to the DBI
3	3
4		(As of $Date$ $Revision$)
5
6	4	=encoding ISO8859-1
7	5
8	6	=cut
	7
	8	=head2 Changes in DBI 1.628 - 22nd July 2013
	9
	10	Fixed missing fields on partial insert via DBI::DBD::SqlEngine
	11	engines (DBD::CSV, DBD::DBM etc.) [H.Merijn Brand, Jens Rehsack]
	12	Fixed stack corruption on callbacks RT#85562 RT#84974 [Aaron Schweiger]
	13	Fixed DBI::SQL::Nano_::Statement handling of "0" [Jens Rehsack]
	14	Fixed exit op precedence in test RT#87029 [Reni Urban]
	15
	16	Added support for finding tables in multiple directories
	17	via new DBD::File f_dir_search attribute [H.Merijn Brand]
	18	Enable compiling by C++ RT#84285 [Kurt Jaeger]
	19
	20	Typo fixes in pod and comment [David Steinbrunner]
	21	Change DBI's docs to refer to git not svn [H.Merijn Brand]
	22	Clarify bind_col TYPE attribute is sticky [Martin J. Evans]
	23	Fixed reference to $sth in selectall_arrayref docs RT#84873
	24	Spelling fixes [Ville Skyttä]
	25	Changed $VERSIONs to hardcoded strings [H.Merijn Brand]
9	26
10	27	=head2 Changes in DBI 1.627 - 16th May 2013
11	28

380	397	Fixed DBI::PurePerl neat() to behave more like XS neat().
381	398
382	399	Increased default $DBI::neat_maxlen from 400 to 1000.
383		Increased timeout on tests to accomodate very slow systems.
	400	Increased timeout on tests to accommodate very slow systems.
384	401	Changed behaviour of trace levels 1..4 to show less information
385	402	at lower levels.
386	403	Changed the format of the key used for $h->{CachedKids}

1189	1206
1190	1207	Documentation changes:
1191	1208	Documented $high_resolution_time = dbi_time() function.
1192		Documented that bind_col() can take an atribute hash.
	1209	Documented that bind_col() can take an attribute hash.
1193	1210	Clarified documentation for ParamValues attribute hash keys.
1194	1211	Many good DBI documentation tweaks from Jonathan Leffler,
1195	1212	including a major update to the DBI::DBD driver author guide.

1328	1345	: If you are still using perl 5.005_03 you should be making plans to
1329	1346	: upgrade to at least perl 5.6.1, or 5.8.0. Perl 5.8.0 is due to be
1330	1347	: released in the next week or so. (Although it's a "point 0" release,
1331		: it is the most throughly tested release ever.)
	1348	: it is the most thoroughly tested release ever.)
1332	1349
1333	1350	Added XS/C implementations of selectrow_array, selectrow_arrayref, and
1334	1351	selectall_arrayref to Driver.xst. See DBI 1.26 Changes for more info.

1372	1389
1373	1390	Added C implementations of selectrow_arrayref() and fetchall_arrayref()
1374	1391	in Driver.xst. All compiled drivers using Driver.xst will now be
1375		faster making those calls. Most noticable with fetchall_arrayref for
	1392	faster making those calls. Most noticeable with fetchall_arrayref for
1376	1393	many rows or selectrow_arrayref with a fast query. For example, using
1377	1394	DBD::mysql a selectrow_arrayref for a single row using a primary key
1378	1395	is ~20% faster, and fetchall_arrayref for 20000 rows is twice as fast!

2324	2341	Added DBI->internal->{DebugLog} = $filename;
2325	2342	Reworked internal logging.
2326	2343	Added $VERSION.
2327		Made disconnect_all a compulsary method for drivers.
	2344	Made disconnect_all a compulsory method for drivers.
2328	2345
2329	2346
2330	2347	=head1 ANCIENT HISTORY

+65

-58

DBI.pm less more

10	10	require 5.008_001;
11	11
12	12	BEGIN {
13		$VERSION = "1.627"; # ==> ALSO update the version in the pod text below!
	13	$VERSION = "1.628"; # ==> ALSO update the version in the pod text below!
14	14	}
15	15
16	16	=head1 NAME

136	136
137	137	=head2 NOTES
138	138
139		This is the DBI specification that corresponds to DBI version 1.627
	139	This is the DBI specification that corresponds to DBI version 1.628
140	140	(see L<DBI::Changes> for details).
141	141
142	142	The DBI is evolving at a steady pace, so it's good to check that

157	157
158	158	Extensions to the DBI API often use the C<DBIx::*> namespace.
159	159	See L</Naming Conventions and Name Space>. DBI extension modules
160		can be found at L<http://search.cpan.org/search?mode=module&query=DBIx>.
161		And all modules related to the DBI can be found at
162		L<http://search.cpan.org/search?query=DBI&mode=all>.
	160	can be found at L<https://metacpan.org/search?q=DBIx>. And all modules
	161	related to the DBI can be found at L<https://metacpan.org/search?q=DBI>.
163	162
164	163	=cut
165	164

693	692	my $rebless_class = $apply->{RootClass} \|\| ($class ne 'DBI' ? $class : '');
694	693	if ($rebless_class) {
695	694	no strict 'refs';
696		if ($apply->{RootClass}) { # explicit attribute (ie not static methd call class)
	695	if ($apply->{RootClass}) { # explicit attribute (ie not static method call class)
697	696	delete $apply->{RootClass};
698	697	DBI::_load_class($rebless_class, 0);
699	698	}

726	725	}
727	726	}
728	727
729		# confirm to driver (ie if subclassed) that we've connected sucessfully
	728	# confirm to driver (ie if subclassed) that we've connected successfully
730	729	# and finished the attribute setup. pass in the original arguments
731	730	$dbh->connected(@orig_args); #if ref $dbh ne 'DBI::db' or $proxy;
732	731

2527	2526	is null, and returns 1 if it is, or 0 if not.
2528	2527
2529	2528	Example 6, the least simple, is probably the most portable, i.e., it
2530		should work with with most, if not all, database engines.
	2529	should work with most, if not all, database engines.
2531	2530
2532	2531	Here is a table that indicates which examples above are known to
2533	2532	work on various database engines:

2548	2547	DBI provides a sample perl script that will test the examples above
2549	2548	on your database engine and tell you which ones work. It is located
2550	2549	in the F<ex/> subdirectory of the DBI source distribution, or here:
2551		L<http://svn.perl.org/modules/dbi/trunk/ex/perl_dbi_nulls_test.pl>
	2550	L<https://github.com/perl5-dbi/dbi/blob/master/ex/perl_dbi_nulls_test.pl>
2552	2551	Please use the script to help us fill-in and maintain this table.
2553	2552
2554	2553	B<Performance>

2682	2681	description of the syntax they require.
2683	2682
2684	2683	It is recommended that drivers support the ODBC style, shown in the
2685		last example above. It is also recommended that that they support the
	2684	last example above. It is also recommended that they support the
2686	2685	three common names 'C<host>', 'C<port>', and 'C<database>' (plus 'C<db>'
2687	2686	as an alias for C<database>). This simplifies automatic construction
2688	2687	of basic DSNs: C<"dbi:$driver:database=$db;host=$host;port=$port">.

4549	4548	If L</RaiseError> is not set and any method except C<fetchall_arrayref>
4550	4549	fails then C<selectall_arrayref> will return C<undef>; if
4551	4550	C<fetchall_arrayref> fails then it will return with whatever data
4552		has been fetched thus far. You should check C<$sth-E<gt>err>
	4551	has been fetched thus far. You should check C<$dbh-E<gt>err>
4553	4552	afterwards (or use the C<RaiseError> attribute) to discover if the data is
4554	4553	complete or was truncated due to an error.
4555	4554

6652	6651
6653	6652	Few drivers support specifying a data type via a C<bind_col> call
6654	6653	(most will simply ignore the data type). Fewer still allow the data
6655		type to be altered once set.
	6654	type to be altered once set. If you do set a column type the type
	6655	should remain sticky through further calls to bind_col for the same
	6656	column if the type is not overridden (this is important for instance
	6657	when you are using a slice in fetchall_arrayref).
6656	6658
6657	6659	The TYPE attribute for bind_col() was first specified in DBI 1.41.
6658	6660

8050	8052
8051	8053	Index of DBI related modules available from CPAN:
8052	8054
8053		http://search.cpan.org/search?mode=module&query=DBIx%3A%3A
8054		http://search.cpan.org/search?mode=doc&query=DBI
	8055	https://metacpan.org/search?q=DBD%3A%3A
	8056	https://metacpan.org/search?q=DBIx%3A%3A
	8057	https://metacpan.org/search?q=DBI
8055	8058
8056	8059	For a good comparison of RDBMS-OO mappers and some OO-RDBMS mappers
8057	8060	(including Class::DBI, Alzabo, and DBIx::RecordSet in the former

8158	8161	Contact me for details.
8159	8162
8160	8163	=head2 Sponsor Enhancements
8161
8162		The DBI Roadmap is available at L<http://search.cpan.org/~timb/DBI/Roadmap.pod>
8163	8164
8164	8165	If your company would benefit from a specific new DBI feature,
8165	8166	please consider sponsoring its development. Work is performed

8191	8192	"Programming the Perl DBI" book and letting me jump on board.
8192	8193
8193	8194	The DBI and DBD::Oracle were originally developed while I was Technical
8194		Director (CTO) of Ingeneering in the UK (L<http://www.ig.co.uk>) (formerly known as the
8195		Paul Ingram Group). So I'd especially like to thank Paul for his generosity
8196		and vision in supporting this work for many years.
	8195	Director (CTO) of the Paul Ingram Group in the UK. So I'd especially like
	8196	to thank Paul for his generosity and vision in supporting this work for many years.
8197	8197
8198	8198	A couple of specific DBI features have been sponsored by enlightened companies:
8199	8199

8202	8202	The development of DBD::Gofer and related modules was sponsored by
8203	8203	Shopzilla.com (L<http://Shopzilla.com>), where I currently work.
8204	8204
8205
8206	8205	=head1 CONTRIBUTING
8207	8206
8208	8207	As you can see above, many people have contributed to the DBI and
8209	8208	drivers in many ways over many years.
8210	8209
8211		If you'd like to help then see L<http://dbi.perl.org/contributing>
8212		and L<http://search.cpan.org/~timb/DBI/Roadmap.pod>
	8210	If you'd like to help then see L<http://dbi.perl.org/contributing>.
8213	8211
8214	8212	If you'd like the DBI to do something new or different then a good way
8215	8213	to make that happen is to do it yourself and send me a patch to the

8218	8216
8219	8217	=head2 Browsing the source code repository
8220	8218
8221		Use http://svn.perl.org/modules/dbi/trunk (basic)
8222		or http://svn.perl.org/viewcvs/modules/ (more useful)
8223
8224		=head2 How to create a patch using Subversion
8225
8226		The DBI source code is maintained using Subversion (a replacement
8227		for CVS, see L<http://subversion.tigris.org/>). To access the source
8228		you'll need to install a Subversion client. Then, to get the source
8229		code, do:
8230
8231		svn checkout http://svn.perl.org/modules/dbi/trunk
8232
8233		If it prompts for a username and password use your perl.org account
8234		if you have one, else just 'guest' and 'guest'. The source code will
8235		be in a new subdirectory called C<trunk>.
8236
8237		To keep informed about changes to the source you can send an empty email
8238		to svn-commit-modules-dbi-subscribe@perl.org after which you'll get an email
8239		with the change log message and diff of each change checked-in to the source.
8240
8241		After making your changes you can generate a patch file, but before
8242		you do, make sure your source is still up to date using:
8243
8244		svn update
	8219	Use https://github.com/perl5-dbi/dbi
	8220
	8221	=head2 How to create a patch using Git
	8222
	8223	The DBI source code is maintained using Git. To access the source
	8224	you'll need to install a Git client. Then, to get the source code, do:
	8225
	8226	git clone https://github.com/perl5-dbi/dbi.git DBI-git
	8227
	8228	The source code will now be available in the new subdirectory C<DBI-git>.
	8229
	8230	When you want to synchronize later, issue the command
	8231
	8232	git pull --all
	8233
	8234	Make your changes, test them, test them again until everything passes.
	8235	If there are no tests for the new feature you added or a behaviour change,
	8236	the change should include a new test. Then commit the changes. Either use
	8237
	8238	git gui
	8239
	8240	or
	8241
	8242	git commit -a -m 'Message to my changes'
8245	8243
8246	8244	If you get any conflicts reported you'll need to fix them first.
8247		Then generate the patch file from within the C<trunk> directory using:
8248
8249		svn diff > foo.patch
8250
	8245
	8246	Then generate the patch file to be mailed:
	8247
	8248	git format-patch -1 --attach
	8249
	8250	which will create a file 0001-.patch (where relates to the commit message).
8251	8251	Read the patch file, as a sanity check, and then email it to dbi-dev@perl.org.
8252	8252
8253		=head2 How to create a patch without Subversion
	8253	If you have a L<github\|https://github.com> account, you can also fork the
	8254	repository, commit your changes to the forked repository and then do a
	8255	pull request.
	8256
	8257	=head2 How to create a patch without Git
8254	8258
8255	8259	Unpack a fresh copy of the distribution:
8256	8260
8257		tar xfz DBI-1.40.tar.gz
	8261	wget http://cpan.metacpan.org/authors/id/T/TI/TIMB/DBI-1.627.tar.gz
	8262	tar xfz DBI-1.627.tar.gz
8258	8263
8259	8264	Rename the newly created top level directory:
8260	8265
8261		mv DBI-1.40 DBI-1.40.your_foo
8262
8263		Edit the contents of DBI-1.40.your_foo/* till it does what you want.
	8266	mv DBI-1.627 DBI-1.627.your_foo
	8267
	8268	Edit the contents of DBI-1.627.your_foo/* till it does what you want.
8264	8269
8265	8270	Test your changes and then remove all temporary files:
8266	8271

8272	8277
8273	8278	Unpack I<another> copy of the original distribution you started with:
8274	8279
8275		tar xfz DBI-1.40.tar.gz
	8280	tar xfz DBI-1.627.tar.gz
8276	8281
8277	8282	Then create a patch file by performing a recursive C<diff> on the two
8278	8283	top level directories:
8279	8284
8280		diff -r -u DBI-1.40 DBI-1.40.your_foo > DBI-1.40.your_foo.patch
	8285	diff -purd DBI-1.627 DBI-1.627.your_foo > DBI-1.627.your_foo.patch
8281	8286
8282	8287	=head2 Speak before you patch
8283	8288

8287	8292	of them being rejected because they don't fit into some larger plans
8288	8293	you may not be aware of.
8289	8294
	8295	You can also reach the developers on IRC (chat). If they are on-line,
	8296	the most likely place to talk to them is the #dbi channel on irc.perl.org
	8297
8290	8298	=head1 TRANSLATIONS
8291	8299
8292	8300	A German translation of this manual (possibly slightly out of date) is

8298	8306
8299	8307	http://cronopio.net/perl/ - Spanish
8300	8308	http://member.nifty.ne.jp/hippo2000/dbimemo.htm - Japanese
8301
8302	8309
8303	8310	=head1 TRAINING
8304	8311

+1

-1

DBI.xs less more

3515	3515	*/
3516	3516	/* we want to localize $_ for the callback but can't just do that alone
3517	3517	* because we're not using SAVETMPS & FREETMPS, so we have to get sneaky.
3518		* We still localize, so we're safe from the callback dieing,
	3518	* We still localize, so we're safe from the callback die-ing,
3519	3519	* but after the callback we manually restore the original $_.
3520	3520	*/
3521	3521	orig_defsv = DEFSV; /* remember the current $_ */

+1

-1

DBIXS.h less more

40	40	#include "dbi_sql.h"
41	41
42	42
43		#define DBIXS_VERSION 93 /* superceeded by DBIXS_REVISION */
	43	#define DBIXS_VERSION 93 /* superseded by DBIXS_REVISION */
44	44
45	45	#ifdef NEED_DBIXS_VERSION
46	46	#if NEED_DBIXS_VERSION > DBIXS_VERSION

+10

-5

Driver.xst less more

92	92	D_imp_dbh(dbh);
93	93	#if !defined(dbd_db_login6_sv)
94	94	STRLEN lna;
95		char *u = (SvOK(username)) ? SvPV(username,lna) : "";
96		char *p = (SvOK(password)) ? SvPV(password,lna) : "";
	95	char u = (SvOK(username)) ? SvPV(username,lna) : (char)"";
	96	char p = (SvOK(password)) ? SvPV(password,lna) : (char)"";
97	97	#endif
98	98	#ifdef dbd_db_login6_sv
99	99	ST(0) = dbd_db_login6_sv(dbh, imp_dbh, dbname, username, password, attribs) ? &PL_sv_yes : &PL_sv_no;

111	111	SV *sth;
112	112	SV **maxrows_svp;
113	113	SV **tmp_svp;
	114	SV *tmp_sv;
114	115	SV *attr = &PL_sv_undef;
115	116	imp_sth_t *imp_sth;
116	117	CODE:

156	157	}
157	158	/* --- fetchall --- */
158	159	maxrows_svp = DBD_ATTRIB_GET_SVP(attr, "MaxRows", 7);
159		ST(0) = dbdxst_fetchall_arrayref(sth, &PL_sv_undef, (maxrows_svp) ? *maxrows_svp : &PL_sv_undef);
	160	tmp_sv = dbdxst_fetchall_arrayref(sth, &PL_sv_undef, (maxrows_svp) ? *maxrows_svp : &PL_sv_undef);
	161	SPAGAIN;
	162	ST(0) = tmp_sv;
160	163
161	164
162	165	void

300	303	/* still exists. This possibly needs some more thought. */
301	304	if (DBIc_ACTIVE_KIDS(imp_dbh) && DBIc_WARN(imp_dbh) && !PL_dirty) {
302	305	STRLEN lna;
303		char *plural = (DBIc_ACTIVE_KIDS(imp_dbh)==1) ? "" : "s";
	306	char plural = (DBIc_ACTIVE_KIDS(imp_dbh)==1) ? (char)"" : (char*)"s";
304	307	warn("%s->disconnect invalidates %d active statement handle%s %s",
305	308	SvPV(dbh,lna), (int)DBIc_ACTIVE_KIDS(imp_dbh), plural,
306	309	"(either destroy statement handles or call finish on them before disconnecting)");

659	662	ST(0) = tmp;
660	663	}
661	664	else {
662		ST(0) = dbdxst_fetchall_arrayref(sth, slice, batch_row_count);
	665	SV *tmp = dbdxst_fetchall_arrayref(sth, slice, batch_row_count);
	666	SPAGAIN;
	667	ST(0) = tmp;
663	668	}
664	669
665	670

+1

-1

INSTALL less more

23	23	Synaptic for Ubuntu, port for FreeBSD etc)
24	24
25	25	---
26		If you get compiler errors refering to Perl's own header files
	26	If you get compiler errors referring to Perl's own header files
27	27	(.../CORE/...h) or the compiler complains about bad options etc then
28	28	there is something wrong with your perl installation. If the compiler complains
29	29	of missing files (.../perl.h: error: sys/types.h: No such file) then you may

+2

-2

META.json less more

3	3	"Tim Bunce (dbi-users@perl.org)"
4	4	],
5	5	"dynamic_config" : 1,
6		"generated_by" : "ExtUtils::MakeMaker version 6.62, CPAN::Meta::Converter version 2.120921",
	6	"generated_by" : "ExtUtils::MakeMaker version 6.68, CPAN::Meta::Converter version 2.131560",
7	7	"license" : [
8	8	"perl_5"
9	9	],

64	64	},
65	65	"x_MailingList" : "mailto:dbi-dev@perl.org"
66	66	},
67		"version" : "1.627"
	67	"version" : "1.628"
68	68	}

+3

-3

META.yml less more

15	15	DBD::RAM: 0.072
16	16	SQL::Statement: 1.33
17	17	dynamic_config: 1
18		generated_by: 'ExtUtils::MakeMaker version 6.62, CPAN::Meta::Converter version 2.120921'
	18	generated_by: 'ExtUtils::MakeMaker version 6.68, CPAN::Meta::Converter version 2.131560'
19	19	license: perl
20	20	meta-spec:
21	21	url: http://module-build.sourceforge.net/META-spec-v1.4.html

35	35	requires:
36	36	perl: 5.008
37	37	resources:
	38	MailingList: mailto:dbi-dev@perl.org
38	39	homepage: http://dbi.perl.org/
39	40	license: http://dev.perl.org/licenses/
40	41	repository: https://github.com/perl5-dbi/dbi
41		x_MailingList: mailto:dbi-dev@perl.org
42		version: 1.627
	42	version: 1.628

+2

-2

dbiprof.PL less more

75	75	while (my ($key, $val) = each %match) {
76	76	if ($val =~ m!^/(.+)/$!) {
77	77	$val = $case_sensitive ? qr/$1/ : qr/$1/i;
78		}
	78	}
79	79	$prof->match($key, $val, case_sensitive => $case_sensitive);
80	80	}
81	81	}

84	84	while (my ($key, $val) = each %exclude) {
85	85	if ($val =~ m!^/(.+)/$!) {
86	86	$val = $case_sensitive ? qr/$1/ : qr/$1/i;
87		}
	87	}
88	88	$prof->exclude($key, $val, case_sensitive => $case_sensitive);
89	89	}
90	90	}

+1

-1

dbiproxy.PL less more

159	159
160	160	=item B<--version>
161	161
162		Supresses startup of the server; instead the version string will
	162	Suppresses startup of the server; instead the version string will
163	163	be printed and the program exits immediately.
164	164
165	165	=back

+1

-1

lib/Bundle/DBI.pm less more

1	1
2	2	package Bundle::DBI;
3	3
4		our $VERSION = sprintf("12.%06d", q$Revision: 8695 $ =~ /(\d+)/o);
	4	our $VERSION = "12.008696";
5	5
6	6	1;
7	7

+1

-1

lib/DBD/DBM.pm less more

175	175	eval {
176	176	$dver = $meta->{dbm_type}->VERSION();
177	177
178		# *) when we're still alive here, everthing went ok - no need to check for $@
	178	# *) when we're still alive here, everything went ok - no need to check for $@
179	179	$dtype .= " ($dver)";
180	180	};
181	181	if ( $meta->{dbm_mldbm} )

+1

-2

lib/DBD/ExampleP.pm less more

7	7	require File::Spec;
8	8
9	9	@EXPORT = qw(); # Do NOT @EXPORT anything.
10		$VERSION = sprintf("12.%06d", q$Revision: 14310 $ =~ /(\d+)/o);
11
	10	$VERSION = "12.014311";
12	11
13	12	# $Id: ExampleP.pm 14310 2010-08-02 06:35:25Z Jens $
14	13	#

+99

-57

lib/DBD/File.pm less more

34	34	use Carp;
35	35	use vars qw( @ISA $VERSION $drh );
36	36
37		$VERSION = "0.41";
	37	$VERSION = "0.42";
38	38
39	39	$drh = undef; # holds driver handle(s) once initialized
40	40

46	46	# We use a hash here to have one singleton per subclass.
47	47	# (Otherwise DBD::CSV and DBD::DBM, for example, would
48	48	# share the same driver object which would cause problems.)
49		# An alternative would be not not cache the $drh here at all
	49	# An alternative would be to not cache the $drh here at all
50	50	# and require that subclasses do that. Subclasses should do
51	51	# their own caching, so caching here just provides extra safety.
52	52	$drh->{$class} and return $drh->{$class};

129	129	{
130	130	my ($dbh, $attr, @other) = @_;
131	131	ref ($attr) eq "HASH" or $attr = {};
132		exists $attr->{f_dir} or $attr->{f_dir} = $dbh->{f_dir};
	132	exists $attr->{f_dir} or $attr->{f_dir} = $dbh->{f_dir};
	133	exists $attr->{f_dir_search} or $attr->{f_dir_search} = $dbh->{f_dir_search};
133	134	return $dbh->SUPER::data_sources ($attr, @other);
134	135	} # data_source
135	136

148	149	$dbh->{f_valid_attrs} = {
149	150	f_version => 1, # DBD::File version
150	151	f_dir => 1, # base directory
	152	f_dir_search => 1, # extended search directories
151	153	f_ext => 1, # file extension
152	154	f_schema => 1, # schema name
153	155	f_lock => 1, # Table locking mode

183	185	if (0 == $phase) {
184	186	# f_ext should not be initialized
185	187	# f_map is deprecated (but might return)
186		$dbh->{f_dir} = Cwd::abs_path (File::Spec->curdir ());
	188	$dbh->{f_dir} = Cwd::abs_path (File::Spec->curdir ());
187	189
188	190	push @{$dbh->{sql_init_order}{90}}, "f_meta";
189	191

193	195	if (exists $dbh->{$drv_prefix . "meta"} and !$dbh->{sql_engine_in_gofer}) {
194	196	my $attr = $dbh->{$drv_prefix . "meta"};
195	197	defined $dbh->{f_valid_attrs}{f_meta}
196		and $dbh->{f_valid_attrs}{f_meta} = 1;
	198	and $dbh->{f_valid_attrs}{f_meta} = 1;
197	199
198	200	$dbh->{f_meta} = $dbh->{$attr};
199	201	}

243	245	eval {
244	246	$dver = IO::File->VERSION ();
245	247
246		# when we're still alive here, everthing went ok - no need to check for $@
	248	# when we're still alive here, everything went ok - no need to check for $@
247	249	$dtype .= " ($dver)";
248	250	};
249	251

345	347	delete $attrs{f_dir};
346	348	my $dsn_quote = $drh->{ImplementorClass}->can ("dsn_quote");
347	349	my $dsnextra = join ";", map { $_ . "=" . &{$dsn_quote} ($attrs{$_}) } keys %attrs;
348		my $dirh = IO::Dir->new ($dir);
349		unless (defined $dirh) {
350		$drh->set_err ($DBI::stderr, "Cannot open directory $dir: $!");
351		return;
352		}
353
354		my ($file, @dsns, %names, $driver);
355		$driver = $drh->{ImplementorClass} =~ m/^dbd\:\:([^\:]+)\:\:/i ? $1 : "File";
356
357		while (defined ($file = $dirh->read ())) {
358		my $d = File::Spec->catdir ($dir, $file);
359		# allow current dir ... it can be a data_source too
360		$file ne File::Spec->updir () && -d $d and
361		push @dsns, "DBI:$driver:f_dir=" . &{$dsn_quote} ($d) . ($dsnextra ? ";$dsnextra" : "");
	350	my @dir = ($dir);
	351	$attr->{f_dir_search} && ref $attr->{f_dir_search} eq "ARRAY" and
	352	push @dir, grep { -d $_ } @{$attr->{f_dir_search}};
	353	my @dsns;
	354	foreach $dir (@dir) {
	355	my $dirh = IO::Dir->new ($dir);
	356	unless (defined $dirh) {
	357	$drh->set_err ($DBI::stderr, "Cannot open directory $dir: $!");
	358	return;
	359	}
	360
	361	my ($file, %names, $driver);
	362	$driver = $drh->{ImplementorClass} =~ m/^dbd\:\:([^\:]+)\:\:/i ? $1 : "File";
	363
	364	while (defined ($file = $dirh->read ())) {
	365	my $d = File::Spec->catdir ($dir, $file);
	366	# allow current dir ... it can be a data_source too
	367	$file ne File::Spec->updir () && -d $d and
	368	push @dsns, "DBI:$driver:f_dir=" . &{$dsn_quote} ($d) . ($dsnextra ? ";$dsnextra" : "");
	369	}
362	370	}
363	371	return @dsns;
364	372	} # data_sources

367	375	{
368	376	my ($self, $dbh) = @_;
369	377
370		my $dir = $dbh->{f_dir};
	378	my $dir = $dbh->{f_dir};
371	379	defined $dir or return; # Stream based db's cannot be queried for tables
372		my $dirh = IO::Dir->new ($dir);
373
374		unless (defined $dirh) {
375		$dbh->set_err ($DBI::stderr, "Cannot open directory $dir: $!");
376		return;
377		}
378
379		my $class = $dbh->FETCH ("ImplementorClass");
380		$class =~ s/::db$/::Table/;
381		my ($file, %names);
382		my $schema = exists $dbh->{f_schema}
383		? defined $dbh->{f_schema} && $dbh->{f_schema} ne ""
384		? $dbh->{f_schema} : undef
385		: eval { getpwuid ((stat $dir)[4]) }; # XXX Win32::pwent
	380
386	381	my %seen;
387	382	my @tables;
388		while (defined ($file = $dirh->read ())) {
389		my ($tbl, $meta) = $class->get_table_meta ($dbh, $file, 0, 0) or next; # XXX
390		# $tbl && $meta && -f $meta->{f_fqfn} or next;
391		$seen{defined $schema ? $schema : "\0"}{$tbl}++ or
392		push @tables, [ undef, $schema, $tbl, "TABLE", "FILE" ];
393		}
394		$dirh->close () or
395		$dbh->set_err ($DBI::stderr, "Cannot close directory $dir: $!");
	383	my @dir = ($dir);
	384	$dbh->{f_dir_search} && ref $dbh->{f_dir_search} eq "ARRAY" and
	385	push @dir, grep { -d $_ } @{$dbh->{f_dir_search}};
	386	foreach $dir (@dir) {
	387	my $dirh = IO::Dir->new ($dir);
	388
	389	unless (defined $dirh) {
	390	$dbh->set_err ($DBI::stderr, "Cannot open directory $dir: $!");
	391	return;
	392	}
	393
	394	my $class = $dbh->FETCH ("ImplementorClass");
	395	$class =~ s/::db$/::Table/;
	396	my ($file, %names);
	397	my $schema = exists $dbh->{f_schema}
	398	? defined $dbh->{f_schema} && $dbh->{f_schema} ne ""
	399	? $dbh->{f_schema} : undef
	400	: eval { getpwuid ((stat $dir)[4]) }; # XXX Win32::pwent
	401	while (defined ($file = $dirh->read ())) {
	402	my ($tbl, $meta) = $class->get_table_meta ($dbh, $file, 0, 0) or next; # XXX
	403	# $tbl && $meta && -f $meta->{f_fqfn} or next;
	404	$seen{defined $schema ? $schema : "\0"}{$dir}{$tbl}++ or
	405	push @tables, [ undef, $schema, $tbl, "TABLE", "FILE" ];
	406	}
	407	$dirh->close () or
	408	$dbh->set_err ($DBI::stderr, "Cannot close directory $dir: $!");
	409	}
396	410
397	411	return @tables;
398	412	} # avail_tables

517	531	}
518	532
519	533	# (my $tbl = $file) =~ s/$ext$//i;
520		my ($tbl, $basename, $dir, $fn_ext, $user_spec_file);
	534	my ($tbl, $basename, $dir, $fn_ext, $user_spec_file, $searchdir);
521	535	if ($file_is_table and defined $meta->{f_file}) {
522	536	$tbl = $file;
523	537	($basename, $dir, $fn_ext) = File::Basename::fileparse ($meta->{f_file}, $fn_any_ext_regex);

526	540	}
527	541	else {
528	542	($basename, $dir, undef) = File::Basename::fileparse ($file, $ext);
	543	# $dir is returned with trailing (back)slash. We just need to check
	544	# if it is ".", "./", or ".\" or "[]" (VMS)
	545	if ($dir =~ m{^(?:[.][/\\]?\|\[\])$} && ref $meta->{f_dir_search} eq "ARRAY") {
	546	foreach my $d ($meta->{f_dir}, @{$meta->{f_dir_search}}) {
	547	my $f = File::Spec->catdir ($d, $file);
	548	-f $f or next;
	549	$searchdir = Cwd::abs_path ($d);
	550	$dir = "";
	551	last;
	552	}
	553	}
529	554	$file = $tbl = $basename;
530	555	$user_spec_file = 0;
531	556	}

539	564	$tbl = lc $tbl;
540	565	}
541	566
542		my $searchdir = File::Spec->file_name_is_absolute ($dir)
543		? ($dir =~ s{/$}{}, $dir)
544		: Cwd::abs_path (File::Spec->catdir ($meta->{f_dir}, $dir));
	567	unless (defined $searchdir) {
	568	$searchdir = File::Spec->file_name_is_absolute ($dir)
	569	? ($dir =~ s{/$}{}, $dir)
	570	: Cwd::abs_path (File::Spec->catdir ($meta->{f_dir}, $dir));
	571	}
545	572	-d $searchdir or
546	573	croak "-d $searchdir: $!";
547	574

752	779
753	780	$self->SUPER::bootstrap_table_meta ($dbh, $meta, $table, @other);
754	781
755		exists $meta->{f_dir} or $meta->{f_dir} = $dbh->{f_dir};
756		defined $meta->{f_ext} or $meta->{f_ext} = $dbh->{f_ext};
757		defined $meta->{f_encoding} or $meta->{f_encoding} = $dbh->{f_encoding};
758		exists $meta->{f_lock} or $meta->{f_lock} = $dbh->{f_lock};
759		exists $meta->{f_lockfile} or $meta->{f_lockfile} = $dbh->{f_lockfile};
760		defined $meta->{f_schema} or $meta->{f_schema} = $dbh->{f_schema};
	782	exists $meta->{f_dir} or $meta->{f_dir} = $dbh->{f_dir};
	783	exists $meta->{f_dir_search} or $meta->{f_dir_search} = $dbh->{f_dir_search};
	784	defined $meta->{f_ext} or $meta->{f_ext} = $dbh->{f_ext};
	785	defined $meta->{f_encoding} or $meta->{f_encoding} = $dbh->{f_encoding};
	786	exists $meta->{f_lock} or $meta->{f_lock} = $dbh->{f_lock};
	787	exists $meta->{f_lockfile} or $meta->{f_lockfile} = $dbh->{f_lockfile};
	788	defined $meta->{f_schema} or $meta->{f_schema} = $dbh->{f_schema};
761	789
762	790	defined $meta->{f_open_file_needed} or
763	791	$meta->{f_open_file_needed} = $self->can ("open_file") != DBD::File::Table->can ("open_file");

780	808	} # get_table_meta
781	809
782	810	my %reset_on_modify = (
783		f_file => [ "f_fqfn", "sql_data_source" ],
784		f_dir => "f_fqfn",
785		f_ext => "f_fqfn",
786		f_lockfile => "f_fqfn", # forces new file2table call
	811	f_file => [ "f_fqfn", "sql_data_source" ],
	812	f_dir => "f_fqfn",
	813	f_dir_search => [],
	814	f_ext => "f_fqfn",
	815	f_lockfile => "f_fqfn", # forces new file2table call
787	816	);
788	817
789	818	__PACKAGE__->register_reset_on_modify (\%reset_on_modify);

962	991	the appropriate absolute path name (based on the current working
963	992	directory) when the dbh attribute is set.
964	993
	994	f_dir => "/data/foo/csv",
	995
965	996	See L<KNOWN BUGS AND LIMITATIONS>.
	997
	998	=head4 f_dir_search
	999
	1000	This optional attribute can be set to pass a list of folders to also
	1001	find existing tables. It will B<not> be used to create new files.
	1002
	1003	f_dir_search => [ "/data/bar/csv", "/dump/blargh/data" ],
966	1004
967	1005	=head4 f_ext
968	1006

972	1010
973	1011	where the /flag is optional and the extension is case-insensitive.
974	1012	C<f_ext> allows you to specify an extension which:
	1013
	1014	f_ext => ".csv/r",
975	1015
976	1016	=over
977	1017

1253	1293
1254	1294	=item f_dir
1255	1295
	1296	=item f_dir_search
	1297
1256	1298	=item f_lock
1257	1299
1258	1300	=item f_lockfile

+4

-4

lib/DBD/Gofer/Policy/Base.pm less more

10	10	use warnings;
11	11	use Carp;
12	12
13		our $VERSION = sprintf("0.%06d", q$Revision: 10087 $ =~ /(\d+)/o);
	13	our $VERSION = "0.010088";
14	14	our $AUTOLOAD;
15	15
16	16	my %policy_defaults = (

49	49	sub create_policy_subs {
50	50	my ($class, $policy_defaults) = @_;
51	51
52		while ( my ($policy_name, $policy_default) = each %$policy_defaults) {
	52	while ( my ($policy_name, $policy_default) = each %$policy_defaults) {
53	53	my $policy_attr_name = "go_$policy_name";
54	54	my $sub = sub {
55	55	# $policy->foo($attr, ...)

105	105	=head1 POLICY CLASSES
106	106
107	107	Three policy classes are supplied with DBD::Gofer:
108
	108
109	109	L<DBD::Gofer::Policy::pedantic> is most 'transparent' but slowest because it
110	110	makes more round-trips to the Gofer server.
111	111
112	112	L<DBD::Gofer::Policy::classic> is a reasonable compromise - it's the default policy.
113
	113
114	114	L<DBD::Gofer::Policy::rush> is fastest, but may require code changes in your applications.
115	115
116	116	Generally the default C<classic> policy is fine. When first testing an existing

+1

-1

lib/DBD/Gofer/Policy/classic.pm less more

9	9	use strict;
10	10	use warnings;
11	11
12		our $VERSION = sprintf("0.%06d", q$Revision: 10087 $ =~ /(\d+)/o);
	12	our $VERSION = "0.010088";
13	13
14	14	use base qw(DBD::Gofer::Policy::Base);
15	15

+1

-1

lib/DBD/Gofer/Policy/pedantic.pm less more

9	9	use strict;
10	10	use warnings;
11	11
12		our $VERSION = sprintf("0.%06d", q$Revision: 10087 $ =~ /(\d+)/o);
	12	our $VERSION = "0.010088";
13	13
14	14	use base qw(DBD::Gofer::Policy::Base);
15	15

+1

-1

lib/DBD/Gofer/Policy/rush.pm less more

9	9	use strict;
10	10	use warnings;
11	11
12		our $VERSION = sprintf("0.%06d", q$Revision: 10087 $ =~ /(\d+)/o);
	12	our $VERSION = "0.010088";
13	13
14	14	use base qw(DBD::Gofer::Policy::Base);
15	15

+3

-3

lib/DBD/Gofer/Transport/Base.pm less more

11	11
12	12	use base qw(DBI::Gofer::Transport::Base);
13	13
14		our $VERSION = sprintf("0.%06d", q$Revision: 14120 $ =~ /(\d+)/o);
	14	our $VERSION = "0.014121";
15	15
16	16	__PACKAGE__->mk_accessors(qw(
17	17	trace

37	37	$args->{keep_meta_frozen} \|\|= 1 if $args->{go_cache};
38	38	#warn "args @{[ %$args ]}\n";
39	39	return $class->SUPER::new($args);
40		}
	40	}
41	41
42	42
43	43	sub _init_trace { $ENV{DBD_GOFER_TRACE} \|\| 0 }

183	183	# This is the main decision point. We don't retry requests that got
184	184	# as far as executing because the error is probably from the database
185	185	# (not transport) so retrying is unlikely to help. But note that any
186		# severe transport error occuring after execute is likely to return
	186	# severe transport error occurring after execute is likely to return
187	187	# a new response object that doesn't have the execute flag set. Beware!
188	188	return 0 if $response->executed_flag_set;
189	189

+3

-3

lib/DBD/Gofer/Transport/null.pm less more

13	13
14	14	use DBI::Gofer::Execute;
15	15
16		our $VERSION = sprintf("0.%06d", q$Revision: 10087 $ =~ /(\d+)/o);
	16	our $VERSION = "0.010088";
17	17
18	18	__PACKAGE__->mk_accessors(qw(
19	19	pending_response
20	20	transmit_count
21		));
	21	));
22	22
23	23	my $executor = DBI::Gofer::Execute->new();
24	24

85	85
86	86	Also, by measuring the difference in performance between normal connections and
87	87	connections via C<dbi:Gofer:transport=null> the basic cost of using DBD::Gofer
88		can be measured. Furthermore, the additional cost of more advanced transports can be
	88	can be measured. Furthermore, the additional cost of more advanced transports can be
89	89	isolated by comparing their performance with the null transport.
90	90
91	91	The C<t/85gofer.t> script in the DBI distribution includes a comparative benchmark.

+3

-3

lib/DBD/Gofer/Transport/pipeone.pm less more

17	17
18	18	use base qw(DBD::Gofer::Transport::Base);
19	19
20		our $VERSION = sprintf("0.%06d", q$Revision: 10087 $ =~ /(\d+)/o);
	20	our $VERSION = "0.010088";
21	21
22	22	__PACKAGE__->mk_accessors(qw(
23	23	connection_info
24	24	go_perl
25		));
	25	));
26	26
27	27
28	28	sub new {

43	43
44	44
45	45	# nonblock($fh) puts filehandle into nonblocking mode
46		sub nonblock {
	46	sub nonblock {
47	47	my $fh = shift;
48	48	my $flags = fcntl($fh, F_GETFL, 0)
49	49	or croak "Can't get flags for filehandle $fh: $!";

+3

-3

lib/DBD/Gofer/Transport/stream.pm less more

13	13
14	14	use base qw(DBD::Gofer::Transport::pipeone);
15	15
16		our $VERSION = sprintf("0.%06d", q$Revision: 14598 $ =~ /(\d+)/o);
	16	our $VERSION = "0.014599";
17	17
18	18	__PACKAGE__->mk_accessors(qw(
19	19	go_persist
20		));
	20	));
21	21
22	22	my $persist_all = 5;
23	23	my %persist;

196	196	$response->add_err(0, $stderr_msg, undef, $trace)
197	197	# but ignore warning from old version of blib
198	198	unless $stderr_msg =~ /^Using .*blib/ && "@$cmd" =~ /-Mblib/;
199		}
	199	}
200	200
201	201	return $response;
202	202	}

+4

-4

lib/DBD/Gofer.pm less more

7	7	require DBI::Gofer::Response;
8	8	require Carp;
9	9
10		our $VERSION = sprintf("0.%06d", q$Revision: 15326 $ =~ /(\d+)/o);
	10	our $VERSION = "0.015327";
11	11
12	12	# $Id: Gofer.pm 15326 2012-06-06 16:32:38Z Tim $
13	13	#

692	692	or return undef; # no more result sets
693	693	#warn "more_results: ".Data::Dumper::Dumper($meta);
694	694
695		# pull out the special non-atributes first
	695	# pull out the special non-attributes first
696	696	my ($rowset, $err, $errstr, $state)
697	697	= delete @{$meta}{qw(rowset err errstr state)};
698	698

1158	1158	$transport = $h->{go_transport};
1159	1159	$retry = $transport->go_retry_hook->($request, $response, $transport);
1160	1160
1161		If it returns true then the request will be retried, upto the C<retry_limit>.
	1161	If it returns true then the request will be retried, up to the C<retry_limit>.
1162	1162	If it returns a false but defined value then the request will not be retried.
1163	1163	If it returns undef then the default behaviour will be used, as if C<retry_hook>
1164	1164	had not been specified.
1165	1165
1166	1166	The default behaviour is to retry requests where $request->is_idempotent is true,
1167	1167	or the error message matches C</induced by DBI_GOFER_RANDOM/>.
1168
	1168
1169	1169	=head3 cache
1170	1170
1171	1171	Specifies that client-side caching should be performed. The value is the name

+6

-6

lib/DBD/NullP.pm less more

4	4	require Carp;
5	5
6	6	@EXPORT = qw(); # Do NOT @EXPORT anything.
7		$VERSION = sprintf("12.%06d", q$Revision: 14714 $ =~ /(\d+)/o);
	7	$VERSION = "12.014715";
8	8
9	9	# $Id: NullP.pm 14714 2011-02-22 17:27:07Z Tim $
10	10	#

40	40	sub connect { # normally overridden, but a handy default
41	41	my $dbh = shift->SUPER::connect(@_)
42	42	or return;
43		$dbh->STORE(Active => 1);
	43	$dbh->STORE(Active => 1);
44	44	$dbh;
45	45	}
46	46

104	104	$sth->{ParamAttr}{$param} = $attr
105	105	if defined $attr; # attr is sticky if not explicitly set
106	106	return 1;
107		}
	107	}
108	108
109	109	sub execute {
110	110	my $sth = shift;
111	111	$sth->bind_param($_, $_[$_-1]) for (1..@_);
112	112	if ($sth->{Statement} =~ m/^ \s* SELECT \s+/xmsi) {
113		$sth->STORE(NUM_OF_FIELDS => 1);
	113	$sth->STORE(NUM_OF_FIELDS => 1);
114	114	$sth->{NAME} = [ "fieldname" ];
115	115	# just for the sake of returning something, we return the params
116	116	my $params = $sth->{ParamValues} \|\| {};
117	117	$sth->{dbd_nullp_data} = [ @{$params}{ sort keys %$params } ];
118		$sth->STORE(Active => 1);
	118	$sth->STORE(Active => 1);
119	119	}
120	120	# force a sleep - handy for testing
121	121	elsif ($sth->{Statement} =~ m/^ \s* SLEEP \s+ (\S+) /xmsi) {

131	131	elsif ($sth->{Statement} =~ m/^ \s* ERROR \s+ (\d+) \s* (.*) /xmsi) {
132	132	return $sth->set_err($1, $2);
133	133	}
134		# anything else is silently ignored, sucessfully
	134	# anything else is silently ignored, successfully
135	135	1;
136	136	}
137	137

+1

-1

lib/DBD/Proxy.pm less more

884	884
885	885	However, if you set the I<proxy_no_finish> attribute to a TRUE value,
886	886	either in the database handle or in the statement handle, then finish()
887		calls will be supressed. This is what you want, for example, in small
	887	calls will be suppressed. This is what you want, for example, in small
888	888	and fast CGI applications.
889	889
890	890	=item proxy_quote

+3

-4

lib/DBD/Sponge.pm less more

4	4	require Carp;
5	5
6	6	our @EXPORT = qw(); # Do NOT @EXPORT anything.
7		our $VERSION = sprintf("12.%06d", q$Revision: 10002 $ =~ /(\d+)/o);
8
	7	our $VERSION = "12.010003";
9	8
10	9	# $Id: Sponge.pm 10002 2007-09-26 21:03:25Z Tim $
11	10	#

213	212
214	213	1;
215	214
216		__END__
	215	__END__
217	216
218	217	=pod
219	218

273	272	=item *
274	273
275	274	C<$names> is a reference an array of column names for the C<$data> you are providing.
276		The number and order should match the number and ordering of the C<$data> columns.
	275	The number and order should match the number and ordering of the C<$data> columns.
277	276
278	277	=item *
279	278

+1

-2

lib/DBI/Const/GetInfo/ANSI.pm less more

37	37	=cut
38	38
39	39	my
40		$VERSION = sprintf("2.%06d", q$Revision: 8696 $ =~ /(\d+)/o);
41
	40	$VERSION = "2.008697";
42	41
43	42	%InfoTypes =
44	43	(

+4

-5

lib/DBI/Const/GetInfo/ODBC.pm less more

21	21
22	22	Information requested by GetInfo().
23	23
24		The API for this module is private and subject to change.
	24	The API for this module is private and subject to change.
25	25
26	26	=head1 REFERENCES
27	27

34	34	=cut
35	35
36	36	my
37		$VERSION = sprintf("2.%06d", q$Revision: 11373 $ =~ /(\d+)/o);
38
	37	$VERSION = "2.011374";
39	38
40	39	%InfoTypes =
41	40	(

99	98	, SQL_CURSOR_SENSITIVITY => 10001
100	99	, SQL_DATA_SOURCE_NAME => 2
101	100	, SQL_DATA_SOURCE_READ_ONLY => 25
102		, SQL_DATABASE_NAME => 16
	101	, SQL_DATABASE_NAME => 16
103	102	, SQL_DATETIME_LITERALS => 119
104	103	, SQL_DBMS_NAME => 17
105	104	, SQL_DBMS_VER => 18

328	327	, SQL_CURSOR_SENSITIVITY => 'SQLUINTEGER' # 10001
329	328	, SQL_DATA_SOURCE_NAME => 'SQLCHAR' # 2
330	329	, SQL_DATA_SOURCE_READ_ONLY => 'SQLCHAR' # 25
331		, SQL_DATABASE_NAME => 'SQLCHAR' # 16
	330	, SQL_DATABASE_NAME => 'SQLCHAR' # 16
332	331	, SQL_DATETIME_LITERALS => 'SQLUINTEGER bitmask' # 119
333	332	, SQL_DBMS_NAME => 'SQLCHAR' # 17
334	333	, SQL_DBMS_VER => 'SQLCHAR' # 18

+1

-2

lib/DBI/Const/GetInfoReturn.pm less more

18	18	@EXPORT = qw(%GetInfoReturnTypes %GetInfoReturnValues);
19	19
20	20	my
21		$VERSION = sprintf("2.%06d", q$Revision: 8696 $ =~ /(\d+)/o);
22
	21	$VERSION = "2.008697";
23	22
24	23	=head1 NAME
25	24

+1

-2

lib/DBI/Const/GetInfoType.pm less more

18	18	@EXPORT = qw(%GetInfoType);
19	19
20	20	my
21		$VERSION = sprintf("2.%06d", q$Revision: 8696 $ =~ /(\d+)/o);
22
	21	$VERSION = "2.008697";
23	22
24	23	=head1 NAME
25	24

+1

-2

lib/DBI/DBD/Metadata.pm less more

17	17	@ISA = qw(Exporter);
18	18	@EXPORT = qw(write_getinfo_pm write_typeinfo_pm);
19	19
20		$VERSION = sprintf("2.%06d", q$Revision: 14213 $ =~ /(\d+)/o);
21
	20	$VERSION = "2.014214";
22	21
23	22	use strict;
24	23

+3

-3

lib/DBI/DBD/SqlEngine.pm less more

53	53	# We use a hash here to have one singleton per subclass.
54	54	# (Otherwise DBD::CSV and DBD::DBM, for example, would
55	55	# share the same driver object which would cause problems.)
56		# An alternative would be not not cache the $drh here at all
	56	# An alternative would be to not cache the $drh here at all
57	57	# and require that subclasses do that. Subclasses should do
58	58	# their own caching, so caching here just provides extra safety.
59	59	$drh->{$class} and return $drh->{$class};

1268	1268	{
1269	1269	$sth->set_err(
1270	1270	$DBI::stderr,
1271		"Attempt to fetch row without a preceeding execute () call or from a non-SELECT statement"
	1271	"Attempt to fetch row without a preceding execute () call or from a non-SELECT statement"
1272	1272	);
1273	1273	return;
1274	1274	}

2023	2023
2024	2024	$dbh->func( "list_tables" );
2025	2025
2026		Everytime where an C<\%attr> argument can be specified, this C<\%attr>
	2026	Every time where an C<\%attr> argument can be specified, this C<\%attr>
2027	2027	object's C<sql_table_source> attribute is preferred over the C<$dbh>
2028	2028	attribute or the driver default, eg.
2029	2029

+8

-9

lib/DBI/DBD.pm less more

4	4
5	5	# don't use Revision here because that's not in svn:keywords so that the
6	6	# examples that use it below won't be messed up
7		$VERSION = sprintf("12.%06d", q$Id: DBD.pm 15128 2012-02-04 20:51:39Z Tim $ =~ /(\d+)/o);
8
	7	$VERSION = "12.015129";
9	8
10	9	# $Id: DBD.pm 15128 2012-02-04 20:51:39Z Tim $
11	10	#

693	692
694	693	For Subversion you could use:
695	694
696		$VERSION = sprintf("12.%06d", q$Revision: 12345 $ =~ /(\d+)/o);
	695	$VERSION = "12.012346";
697	696
698	697	(use lots of leading zeros on the second portion so if you move the code to a
699	698	shared repository like svn.perl.org the much larger revision numbers won't
700	699	cause a problem, at least not for a few years). For RCS or CVS you can use:
701	700
702		$VERSION = sprintf "%d.%02d", '$Revision: 11.21 $ ' =~ /(\d+)\.(\d+)/;
	701	$VERSION = "11.22";
703	702
704	703	which pads out the fractional part with leading zeros so all is well
705	704	(so long as you don't go past x.99)

796	795
797	796	Methods installed using install_method default to the standard error
798	797	handling behaviour for DBI methods: clearing err and errstr before
799		calling the method, and checking for errors to trigger RaiseError
800		etc. on return. This differs from the default behaviour of func().
	798	calling the method, and checking for errors to trigger RaiseError
	799	etc. on return. This differs from the default behaviour of func().
801	800
802	801	Note for driver authors: The DBD::Foo::xx->install_method call won't
803	802	work until the class-hierarchy has been setup. Normally the DBI

3453	3452	my $dbi_driver_xst= File::Spec->catfile($dbi_instarch_dir, 'Driver.xst');
3454	3453	my $xstf_h = File::Spec->catfile($dbi_instarch_dir, 'Driver_xst.h');
3455	3454
3456		# we must be careful of quotes, expecially for Win32 here.
	3455	# we must be careful of quotes, especially for Win32 here.
3457	3456	return '
3458	3457	# --- This section was generated by DBI::DBD::dbd_postamble()
3459	3458	DBI_INSTARCH_DIR='.$dbi_instarch_dir.'
3460	3459	DBI_DRIVER_XST='.$dbi_driver_xst.'
3461	3460
3462		# The main dependancy (technically correct but probably not used)
	3461	# The main dependency (technically correct but probably not used)
3463	3462	$(BASEEXT).c: $(BASEEXT).xsi
3464	3463
3465		# This dependancy is needed since MakeMaker uses the .xs.o rule
	3464	# This dependency is needed since MakeMaker uses the .xs.o rule
3466	3465	$(BASEEXT)$(OBJ_EXT): $(BASEEXT).xsi
3467	3466
3468	3467	$(BASEEXT).xsi: $(DBI_DRIVER_XST) '.$xstf_h.'

+34

-35

lib/DBI/FAQ.pm less more

7	7	### This document is Copyright (c)1994-2000 Alligator Descartes, with portions
8	8	### Copyright (c)1994-2000 their original authors. This module is released under
9	9	### the 'Artistic' license which you can find in the perl distribution.
10		###
	10	###
11	11	### This document is Copyright (c)1997-2000 Alligator Descartes. All rights reserved.
12	12	### Permission to distribute this document, in full or in part, via email,
13	13	### Usenet, ftp archives or http is granted providing that no charges are involved,
14	14	### reasonable attempt is made to use the most current version and all credits
15	15	### and copyright notices are retained ( the I<AUTHOR> and I<COPYRIGHT> sections ).
16		### Requests for other distribution rights, including incorporation into
	16	### Requests for other distribution rights, including incorporation into
17	17	### commercial products, such as books, magazine articles or CD-ROMs should be
18	18	### made to Alligator Descartes.
19		###
	19	###
20	20
21	21	package DBI::FAQ;
22	22
23		our $VERSION = sprintf("1.%06d", q$Revision: 14934 $ =~ /(\d+)/o);
24
	23	our $VERSION = "1.014935";
25	24
26	25	=head1 NAME
27	26

139	138	DBD::Informix Isqlperl Under development
140	139	DBD::Ingres Ingperl Complete?
141	140	DBD::Sybase Sybperl Working? ( Needs verification )
142		DBD::mSQL Msqlperl Experimentally released with
	141	DBD::mSQL Msqlperl Experimentally released with
143	142	DBD::mSQL-0.61
144	143
145	144	The I<Msqlperl> emulation is a special case. I<Msqlperl> is a perl5 driver

153	152
154	153	The Comprehensive Perl Archive Network
155	154	resources should be used for retrieving up-to-date versions of the DBI
156		and drivers. CPAN may be accessed I<via> Tom Christiansen's splendid
	155	and drivers. CPAN may be accessed I<via> Tom Christiansen's splendid
157	156	I<CPAN multiplexer> program located at:
158	157
159	158	http://www.perl.com/CPAN/

168	167
169	168	=head2 1.3. Where can I get more information?
170	169
171		There are a few information sources on DBI.
	170	There are a few information sources on DBI.
172	171
173	172	=over 4
174	173

250	249
251	250	I<POD>s are chunks of documentation usually embedded within perl programs
252	251	that document the code ``I<in place>'', providing a useful resource for
253		programmers and users of modules. POD for DBI and drivers is beginning to
	252	programmers and users of modules. POD for DBI and drivers is beginning to
254	253	become more commonplace, and documentation for these modules can be read
255	254	with the C<perldoc> program included with Perl.
256	255
257		=over 4
	256	=over 4
258	257
259	258	=item The DBI Specification
260	259

282	281
283	282	perldoc <driver>
284	283
285		For example, the I<DBD::mSQL> driver is bundled with driver-specific
	284	For example, the I<DBD::mSQL> driver is bundled with driver-specific
286	285	documentation that can be accessed by typing
287	286
288	287	perldoc DBD::mSQL

310	309
311	310	Users with the Tk module installed may be interested to learn there is a
312	311	Tk-based POD reader available called C<tkpod>, which formats POD in a convenient
313		and readable way. This is available I<via> CPAN as the module called
	312	and readable way. This is available I<via> CPAN as the module called
314	313	I<Tk::POD> and is highly recommended.
315	314
316	315	=back

348	347
349	348	=item I<README files>
350	349
351		The I<README> files included with each driver occasionally contains
	350	The I<README> files included with each driver occasionally contains
352	351	some useful information ( no, really! ) that may be pertinent to the user.
353	352	Please read them. It makes our worthless existences more bearable. These
354	353	can all be read from the main DBI WWW page at:

395	394
396	395	=head2 2.1. Compilation problems or "It fails the test!"
397	396
398		First off, consult the README for that driver in case there is useful
399		information about the problem. It may be a known problem for your given
	397	First off, consult the README for that driver in case there is useful
	398	information about the problem. It may be a known problem for your given
400	399	architecture and operating system or database. You can check the README
401	400	files for each driver in advance online at:
402	401
403	402	http://dbi.perl.org/
404	403
405		If it's a known problem, you'll probably have to wait till it gets fixed. If
	404	If it's a known problem, you'll probably have to wait till it gets fixed. If
406	405	you're I<really> needing it fixed, try the following:
407	406
408	407	=over 4

425	424
426	425	=item *
427	426
428		Platform information, database version, perl version, module version and
	427	Platform information, database version, perl version, module version and
429	428	DBI version.
430	429
431	430	=back

473	472
474	473	=back
475	474
476		Remember, the more information you send us, the quicker we can track
	475	Remember, the more information you send us, the quicker we can track
477	476	problems down. If you send us no useful information, expect nothing back.
478	477
479	478	Finally, please be aware that some authors, including Tim Bunce, specifically

553	552	come on by great leaps and bounds.
554	553
555	554	The I<DBI> and I<DBD::Oracle> Win32 ports are now a standard part of DBI,
556		so, downloading I<DBI> of version higher than I<0.81> should work fine as
	555	so, downloading I<DBI> of version higher than I<0.81> should work fine as
557	556	should using the most recent I<DBD::Oracle> version.
558	557
559	558	=head2 3.4 Can I access Microsoft Access or SQL-Server databases with DBI?

598	597	limitation on the usefulness of dbm systems.
599	598
600	599	However, dbm systems still provide a useful function for users with
601		simple datasets and limited resources, since they are fast, robust and
	600	simple datasets and limited resources, since they are fast, robust and
602	601	extremely well-tested. Perl modules to access dbm systems have now
603	602	been integrated into the core Perl distribution via the
604	603	AnyDBM_File module.''
605	604
606	605	To sum up, DBM is a perfectly satisfactory solution for essentially read-only
607		databases, or small and simple datasets. However, for more
608		scaleable dataset handling, not to mention robust transactional locking,
	606	databases, or small and simple datasets. However, for more
	607	scalable dataset handling, not to mention robust transactional locking,
609	608	users are recommended to use a more powerful database engine I<via> I<DBI>.
610	609
611	610	Chapter 2 of "Programming the Perl DBI" discusses DBM files in detail.

683	682
684	683	Contributed by John D. Groenveld
685	684
686		The Apache C<httpd> maintains a pool of C<httpd> children to service client
	685	The Apache C<httpd> maintains a pool of C<httpd> children to service client
687	686	requests.
688	687
689		Using the Apache I<mod_perl> module by I<Doug MacEachern>, the perl
690		interpreter is embedded with the C<httpd> children. The CGI, DBI, and your
691		other favorite modules can be loaded at the startup of each child. These
	688	Using the Apache I<mod_perl> module by I<Doug MacEachern>, the perl
	689	interpreter is embedded with the C<httpd> children. The CGI, DBI, and your
	690	other favorite modules can be loaded at the startup of each child. These
692	691	modules will not be reloaded unless changed on disk.
693	692
694	693	For more information on Apache, see the Apache Project's WWW site:

703	702
704	703	Contributed by John D. Groenveld
705	704
706		Using Edmund Mergl's I<Apache::DBI> module, database logins are stored in a
707		hash with each of these C<httpd> child. If your application is based on a
708		single database user, this connection can be started with each child.
	705	Using Edmund Mergl's I<Apache::DBI> module, database logins are stored in a
	706	hash with each of these C<httpd> child. If your application is based on a
	707	single database user, this connection can be started with each child.
709	708	Currently, database connections cannot be shared between C<httpd> children.
710	709
711	710	I<Apache::DBI> can be downloaded from CPAN I<via>:

725	724
726	725	One way to solve this problem is to set the environment for your database in a
727	726	C<BEGIN { }> block at the top of your script. Another technique is to configure
728		your WWW server to pass-through certain environment variables to your CGI
	727	your WWW server to pass-through certain environment variables to your CGI
729	728	scripts.
730	729
731	730	Similarly, you should check your C<httpd> error logfile for any clues,

737	736
738	737	http://www.perl.com/perl/faq/index.html
739	738
740		as can the ``Perl CGI Programming FAQ''. Read I<BOTH> these documents
	739	as can the ``Perl CGI Programming FAQ''. Read I<BOTH> these documents
741	740	carefully!
742	741
743	742	=head2 4.5 How do I get the number of rows returned from a C<SELECT> statement?

755	754
756	755	It is expected that some future version of the DBI will at least be
757	756	thread-safe (but not thread-hot) by automatically blocking threads
758		intering the DBI while it's already in use.
	757	entering the DBI while it's already in use.
759	758
760	759	=head2 5.2 How do I handle BLOB data with DBI?
761	760

787	786	size of C<LongReadLen> if it is longer. This does not cause an error to
788	787	occur, but may make your fetched BLOB data useless.
789	788
790		This behaviour is regulated by the C<LongTruncOk> attribute which is
791		defaultly set to a false value ( thus making overlong BLOB fetches fail ).
	789	This behaviour is regulated by the C<LongTruncOk> attribute which is
	790	set to a false value by default ( thus making overlong BLOB fetches fail ).
792	791
793	792	### Set BLOB handling such that it's 16Kb and can be truncated
794	793	$dbh->{LongReadLen} = 16384;

955	954	Usenet, ftp archives or http is granted providing that no charges are involved,
956	955	reasonable attempt is made to use the most current version and all credits
957	956	and copyright notices are retained ( the I<AUTHOR> and I<COPYRIGHT> sections ).
958		Requests for other distribution rights, including incorporation into
	957	Requests for other distribution rights, including incorporation into
959	958	commercial products, such as books, magazine articles or CD-ROMs should be
960	959	made to Alligator Descartes.
961	960

+6

-6

lib/DBI/Gofer/Execute.pm less more

17	17
18	18	use base qw(DBI::Util::_accessor);
19	19
20		our $VERSION = sprintf("0.%06d", q$Revision: 14282 $ =~ /(\d+)/o);
	20	our $VERSION = "0.014283";
21	21
22	22	our @all_dbh_methods = sort map { keys %$_ } $DBI::DBI_methods{db}, $DBI::DBI_methods{common};
23	23	our %all_dbh_methods = map { $_ => (DBD::_::db->can($_)\|\|undef) } @all_dbh_methods;

212	212	$dbh->{ShowErrorStatement} = 1 if $local_log;
213	213
214	214	# XXX should probably just be a Callbacks => arg to connect_cached
215		# with a cache of pre-built callback hooks (memoized, without $self)
	215	# with a cache of pre-built callback hooks (memoized, without $self)
216	216	if (my $random = $self->{forced_gofer_random} \|\| $ENV{DBI_GOFER_RANDOM}) {
217	217	$self->_install_rand_callbacks($dbh, $random);
218	218	}

372	372
373	373	# XXX piggyback installed_methods onto dbh_attributes for now
374	374	$dbh_attr_values{dbi_installed_methods} = { DBI->installed_methods };
375
	375
376	376	# XXX piggyback default_methods onto dbh_attributes for now
377	377	$dbh_attr_values{dbi_default_methods} = _get_default_methods($dbh);
378
	378
379	379	return \%dbh_attr_values;
380	380	}
381	381

498	498	my $sth_attr = {};
499	499	$sth_attr->{$_} = 1 for @$attr_names;
500	500
501		# let the client add/remove sth atributes
	501	# let the client add/remove sth attributes
502	502	if (my $sth_result_attr = $request->sth_result_attr) {
503	503	$sth_attr->{$_} = $sth_result_attr->{$_}
504	504	for keys %$sth_result_attr;

612	612	next;
613	613	}
614	614	unless (defined $fail_percent or defined $delay_percent) {
615		warn "Ignored DBI_GOFER_RANDOM item '$spec' because not preceeded by 'fail=N' and/or 'delayN=N'";
	615	warn "Ignored DBI_GOFER_RANDOM item '$spec' because not preceded by 'fail=N' and/or 'delayN=N'";
616	616	next;
617	617	}
618	618

+2

-2

lib/DBI/Gofer/Request.pm less more

12	12
13	13	use base qw(DBI::Util::_accessor);
14	14
15		our $VERSION = sprintf("0.%06d", q$Revision: 12536 $ =~ /(\d+)/o);
	15	our $VERSION = "0.012537";
16	16
17	17	use constant GOf_REQUEST_IDEMPOTENT => 0x0001;
18	18	use constant GOf_REQUEST_READONLY => 0x0002;

111	111	$method \|\|= 'connect_cached';
112	112	$pass = '***' if defined $pass;
113	113	my $tmp = '';
114		if ($attr) {
	114	if ($attr) {
115	115	$tmp = { %{$attr\|\|{}} }; # copy so we can edit
116	116	$tmp->{Password} = '***' if exists $tmp->{Password};
117	117	$tmp = "{ ".neat_list([ %$tmp ])." }";

+8

-8

lib/DBI/Gofer/Response.pm less more

13	13
14	14	use base qw(DBI::Util::_accessor Exporter);
15	15
16		our $VERSION = sprintf("0.%06d", q$Revision: 11565 $ =~ /(\d+)/o);
	16	our $VERSION = "0.011566";
17	17
18	18	use constant GOf_RESPONSE_EXECUTED => 0x0001;
19	19

42	42	$args->{version} \|\|= $VERSION;
43	43	chomp $args->{errstr} if $args->{errstr};
44	44	return $self->SUPER::new($args);
45		}
	45	}
46	46
47	47
48	48	sub err_errstr_state {

76	76	$r_errstr .= sprintf " [state was %s now %s]", $r_state, $state
77	77	if $r_state and $r_state ne "S1000" && $state && $r_state ne $state;
78	78	$r_errstr .= "\n$errstr" if $r_errstr ne $errstr;
79		}
80		else {
	79	}
	80	else {
81	81	$r_errstr = $errstr;
82	82	}
83	83

120	120	my @keys = sort keys %$dbh_attr;
121	121	push @s, sprintf "dbh= { %s }", join(", ", map { "$_=>".neat($dbh_attr->{$_},100) } @keys)
122	122	if @keys;
123		}
	123	}
124	124
125	125	for my $rs (@{$self->sth_resultsets \|\| []}) {
126	126	my ($rowset, $err, $errstr, $state)

134	134	$summary .= sprintf ", err=%s, errstr=%s", $err, neat($errstr) if defined $err;
135	135	if ($rows) {
136	136	my $NAME = $rs->{NAME};
137		# generate
	137	# generate
138	138	my @colinfo = map { "$NAME->[$_]=".neat($rowset->[0][$_], 30) } 0..@{$NAME}-1;
139	139	$summary .= sprintf " [%s]", join ", ", @colinfo;
140	140	$summary .= ",..." if $rows > 1;

148	148	chomp $w;
149	149	push @s, "warning: $w";
150	150	}
151		if ($context && %$context) {
	151	if ($context && %$context) {
152	152	my @keys = sort keys %$context;
153	153	push @s, join(", ", map { "$_=>".$context->{$_} } @keys);
154		}
	154	}
155	155	return join("\n\t", @s). "\n";
156	156	}
157	157

+1

-1

lib/DBI/Gofer/Serializer/Base.pm less more

34	34
35	35	use Carp qw(croak);
36	36
37		our $VERSION = sprintf("0.%06d", q$Revision: 9949 $ =~ /(\d+)/o);
	37	our $VERSION = "0.009950";
38	38
39	39
40	40	sub new {

+1

-1

lib/DBI/Gofer/Serializer/DataDumper.pm less more

2	2	use strict;
3	3	use warnings;
4	4
5		our $VERSION = sprintf("0.%06d", q$Revision: 9949 $ =~ /(\d+)/o);
	5	our $VERSION = "0.009950";
6	6
7	7	# $Id: DataDumper.pm 9949 2007-09-18 09:38:15Z Tim $
8	8	#

+1

-1

lib/DBI/Gofer/Serializer/Storable.pm less more

37	37
38	38	use Storable qw(nfreeze thaw);
39	39
40		our $VERSION = sprintf("0.%06d", q$Revision: 15585 $ =~ /(\d+)/o);
	40	our $VERSION = "0.015586";
41	41
42	42	use base qw(DBI::Gofer::Serializer::Base);
43	43

+1

-3

lib/DBI/Gofer/Transport/Base.pm less more

16	16	use DBI::Gofer::Serializer::Storable;
17	17	use DBI::Gofer::Serializer::DataDumper;
18	18
19
20		our $VERSION = sprintf("0.%06d", q$Revision: 12536 $ =~ /(\d+)/o);
21
	19	our $VERSION = "0.012537";
22	20
23	21	__PACKAGE__->mk_accessors(qw(
24	22	trace

+1

-1

lib/DBI/Gofer/Transport/pipeone.pm less more

13	13
14	14	use base qw(DBI::Gofer::Transport::Base Exporter);
15	15
16		our $VERSION = sprintf("0.%06d", q$Revision: 12536 $ =~ /(\d+)/o);
	16	our $VERSION = "0.012537";
17	17
18	18	our @EXPORT = qw(run_one_stdio);
19	19

+1

-1

lib/DBI/Gofer/Transport/stream.pm less more

14	14
15	15	use base qw(DBI::Gofer::Transport::pipeone Exporter);
16	16
17		our $VERSION = sprintf("0.%06d", q$Revision: 12536 $ =~ /(\d+)/o);
	17	our $VERSION = "0.012537";
18	18
19	19	our @EXPORT = qw(run_stdio_hex);
20	20

+13

-14

lib/DBI/Profile.pm less more

475	475	If not specified it defaults to $dbh->{Profile}{Data}.
476	476
477	477	The $path argument can be used to specify a list of path elements that will be
478		added to each element of the returned list. If not specified it defaults to a a
	478	added to each element of the returned list. If not specified it defaults to a
479	479	ref to an empty array.
480	480
481	481	=head2 as_text

546	546	my $totals=[],
547	547	[ 10, 0.51, 0.11, 0.01, 0.22, 1023110000, 1023110010 ],
548	548	[ 15, 0.42, 0.12, 0.02, 0.23, 1023110005, 1023110009 ],
549		);
	549	);
550	550
551	551	$totals will then contain
552	552

555	555	and $time_in_dbi will be 0.93;
556	556
557	557	The second argument need not be just leaf nodes. If given a reference to a hash
558		then the hash is recursively searched for for leaf nodes and all those found
	558	then the hash is recursively searched for leaf nodes and all those found
559	559	are merged.
560	560
561	561	For example, to get the time spent 'inside' the DBI during an http request,

662	662	much better than integer resolution. This limited resolution means
663	663	that fast method calls will often register as taking 0 time. And
664	664	timings in general will have much more 'jitter' depending on where
665		within the 'current millisecond' the start and and timing was taken.
	665	within the 'current millisecond' the start and end timing was taken.
666	666
667	667	This documentation could be more clear. Probably needs to be reordered
668	668	to start with several examples and build from there. Trying to

680	680
681	681	use DBI qw(dbi_time dbi_profile dbi_profile_merge_nodes dbi_profile_merge);
682	682
683		$VERSION = sprintf("2.%06d", q$Revision: 15064 $ =~ /(\d+)/o);
684
	683	$VERSION = "2.015065";
685	684
686	685	@ISA = qw(Exporter);
687	686	@EXPORT = qw(

719	718	# assigned to the Profile attribute. For example
720	719	# dbi:mysql(RaiseError=>1,Profile=>!Statement:!MethodName/DBIx::MyProfile/arg1:arg2):dbname
721	720	# This sub works out what to do and returns a suitable hash ref.
722
	721
723	722	$arg =~ s/^DBI::/2\/DBI::/
724	723	and carp "Automatically changed old-style DBI::Profile specification to $arg";
725	724

757	756	}
758	757	}
759	758
760		eval "require $package" if $package; # sliently ignores errors
	759	eval "require $package" if $package; # silently ignores errors
761	760	$package \|\|= $class;
762	761
763	762	return $package->new(Path => \@Path, @args);

768	767	my $self = shift;
769	768	DBI->trace_msg("profile data discarded\n",0) if $self->{Trace};
770	769	$self->{Data} = undef;
771		}
	770	}
772	771
773	772	sub filename { # baseclass method, see DBI::ProfileDumper
774	773	return undef;

786	785	sub as_node_path_list {
787	786	my ($self, $node, $path) = @_;
788	787	# convert the tree into an array of arrays
789		# from
	788	# from
790	789	# {key1a}{key2a}[node1]
791	790	# {key1a}{key2b}[node2]
792	791	# {key1b}{key2a}{key3a}[node3]

815	814	\|\| "%s"; # or e.g., " key%2$d='%s'"
816	815	my $format = $args_ref->{format}
817	816	\|\| '%1$s: %11$fs / %10$d = %2$fs avg (first %12$fs, min %13$fs, max %14$fs)'."\n";
818
	817
819	818	my @node_path_list = $self->as_node_path_list(undef, $args_ref->{path});
820	819
821	820	$args_ref->{sortsub}->(\@node_path_list) if $args_ref->{sortsub};

838	837	($node->[0] ? $node->[1]/$node->[0] : 0), # 2=avg
839	838	@spare_slots,
840	839	@$node; # 10=count, 11=dur, 12=first_dur, 13=min, 14=max, 15=first_called, 16=last_called
841		}
	840	}
842	841	return @text if wantarray;
843	842	return join "", @text;
844		}
	843	}
845	844
846	845
847	846	sub format {
848	847	my $self = shift;
849	848	my $class = ref($self) \|\| $self;
850
	849
851	850	my $prologue = "$class: ";
852	851	my $detail = $self->format_profile_thingy(
853	852	$self->{Data}, 0, " ",

+28

-29

lib/DBI/ProfileData.pm less more

35	35	$prof->match(key1 => qr/^SELECT/i);
36	36
37	37	# produce a formatted report with the given number of items
38		$report = $prof->report(number => 10);
	38	$report = $prof->report(number => 10);
39	39
40	40	# clone the profile data set
41	41	$clone = $prof->clone();

55	55	=head1 DESCRIPTION
56	56
57	57	This module offers the ability to read, manipulate and format
58		DBI::ProfileDumper profile data.
	58	DBI::ProfileDumper profile data.
59	59
60	60	Conceptually, a profile consists of a series of records, or nodes,
61	61	each of each has a set of statistics and set of keys. Each record

68	68
69	69	=cut
70	70
71
72		our $VERSION = sprintf("2.%06d", q$Revision: 10007 $ =~ /(\d+)/o);
	71	our $VERSION = "2.010008";
73	72
74	73	use Carp qw(croak);
75	74	use Symbol;

99	98
100	99	=head2 $prof = DBI::ProfileData->new(Files => [ "dbi.prof.1", "dbi.prof.2" ])
101	100
102		Creates a a new DBI::ProfileData object. Takes either a single file
	101	Creates a new DBI::ProfileData object. Takes either a single file
103	102	through the File option or a list of Files in an array ref. If
104	103	multiple files are specified then the header data from the first file
105	104	is used.

162	161
163	162	sub new {
164	163	my $pkg = shift;
165		my $self = {
	164	my $self = {
166	165	Files => [ "dbi.prof" ],
167	166	Filter => undef,
168	167	DeleteFiles => 0,

174	173	@_
175	174	};
176	175	bless $self, $pkg;
177
	176
178	177	# File (singular) overrides Files (plural)
179	178	$self->{Files} = [ $self->{File} ] if exists $self->{File};
180	179

188	187	my $files = $self->{Files};
189	188	my $read_header = 0;
190	189	my @files_to_delete;
191
	190
192	191	my $fh = gensym;
193	192	foreach (@$files) {
194	193	my $filename = $_;

211	210	or croak("Unable to read profile file '$filename': $!");
212	211
213	212	# lock the file in case it's still being written to
214		# (we'll be foced to wait till the write is complete)
	213	# (we'll be forced to wait till the write is complete)
215	214	flock($fh, LOCK_SH) if $self->{LockFile};
216	215
217	216	if (-s $fh) { # not empty

220	219	$self->_read_body($fh, $filename);
221	220	}
222	221	close($fh); # and release lock
223
	222
224	223	push @files_to_delete, $filename
225	224	if $self->{DeleteFiles};
226	225	}

231	230	warn "Can't delete '$_': $!";
232	231	}
233	232	}
234
	233
235	234	# discard node_lookup now that all files are read
236	235	delete $self->{_node_lookup};
237	236	}

254	253	/^(\S+)\s=\s(.*)/
255	254	or croak("Syntax error in header in $filename line $.: $_");
256	255	# XXX should compare new with existing (from previous file)
257		# and warn if they differ (diferent program or path)
	256	# and warn if they differ (different program or path)
258	257	$self->{_header}{$1} = unescape_key($2) if $keep;
259	258	}
260	259	}

449	448	my $self = shift;
450	449	my $nodes = $self->{_nodes};
451	450	my %opt = @_;
452
	451
453	452	croak("Missing required field option.") unless $opt{field};
454	453
455	454	my $index = $FIELDS{$opt{field}};
456
	455
457	456	croak("Unrecognized sort field '$opt{field}'.")
458	457	unless defined $index;
459	458
460	459	# sort over index
461	460	if ($opt{reverse}) {
462		@$nodes = sort {
463		$a->[$index] <=> $b->[$index]
	461	@$nodes = sort {
	462	$a->[$index] <=> $b->[$index]
464	463	} @$nodes;
465	464	} else {
466		@$nodes = sort {
467		$b->[$index] <=> $a->[$index]
	465	@$nodes = sort {
	466	$b->[$index] <=> $a->[$index]
468	467	} @$nodes;
469	468	}
470	469

508	507	if (UNIVERSAL::isa($val,"Regexp")) {
509	508	# regex match
510	509	@$nodes = grep {
511		$#$_ < $index or $_->[$index] !~ /$val/
	510	$#$_ < $index or $_->[$index] !~ /$val/
512	511	} @$nodes;
513	512	} else {
514	513	if ($opt{case_sensitive}) {
515		@$nodes = grep {
	514	@$nodes = grep {
516	515	$#$_ < $index or $_->[$index] ne $val;
517	516	} @$nodes;
518	517	} else {
519	518	$val = lc $val;
520		@$nodes = grep {
	519	@$nodes = grep {
521	520	$#$_ < $index or lc($_->[$index]) ne $val;
522	521	} @$nodes;
523	522	}

559	558	if (UNIVERSAL::isa($val,"Regexp")) {
560	559	# regex match
561	560	@$nodes = grep {
562		$#$_ >= $index and $_->[$index] =~ /$val/
	561	$#$_ >= $index and $_->[$index] =~ /$val/
563	562	} @$nodes;
564	563	} else {
565	564	if ($opt{case_sensitive}) {
566		@$nodes = grep {
	565	@$nodes = grep {
567	566	$#$_ >= $index and $_->[$index] eq $val;
568	567	} @$nodes;
569	568	} else {
570	569	$val = lc $val;
571		@$nodes = grep {
	570	@$nodes = grep {
572	571	$#$_ >= $index and lc($_->[$index]) eq $val;
573	572	} @$nodes;
574	573	}

615	614	sub format {
616	615	my ($self, $node) = @_;
617	616	my $format;
618
	617
619	618	# setup keys
620	619	my $keys = "";
621	620	for (my $i = PATH; $i <= $#$node; $i++) {
622	621	my $key = $node->[$i];
623
	622
624	623	# remove leading and trailing space
625	624	$key =~ s/^\s+//;
626	625	$key =~ s/\s+$//;

643	642	Shortest Time : %3.6f seconds
644	643	Average Time : %3.6f seconds
645	644	END
646		return sprintf($format, @{$node}[COUNT,TOTAL,LONGEST,SHORTEST],
	645	return sprintf($format, @{$node}[COUNT,TOTAL,LONGEST,SHORTEST],
647	646	$node->[TOTAL] / $node->[COUNT]) . $keys;
648	647	} else {
649	648	$format = <<END;

674	673
675	674	my $report = $self->_report_header($opt{number});
676	675	for (0 .. $opt{number} - 1) {
677		$report .= sprintf("#" x 5 . "[ %d ]". "#" x 59 . "\n",
	676	$report .= sprintf("#" x 5 . "[ %d ]". "#" x 59 . "\n",
678	677	$_ + 1);
679	678	$report .= $self->format($nodes->[$_]);
680	679	$report .= "\n";

710	709	$header .= sprintf(<<END, $node_count, $number, $self->{_sort}, $count, $time);
711	710	Total Records : %d (showing %d, sorted by %s)
712	711	Total Count : %d
713		Total Runtime : %3.6f seconds
	712	Total Runtime : %3.6f seconds
714	713
715	714	END
716	715

+1

-1

lib/DBI/ProfileDumper/Apache.pm less more

158	158
159	159	=cut
160	160
161		our $VERSION = sprintf("2.%06d", q$Revision: 14120 $ =~ /(\d+)/o);
	161	our $VERSION = "2.014121";
162	162
163	163	our @ISA = qw(DBI::ProfileDumper);
164	164

+5

-5

lib/DBI/ProfileDumper.pm less more

91	91	$profile->flush_to_disk()
92	92
93	93	Flushes all collected profile data to disk and empties the Data hash. Returns
94		the filename writen to. If no profile data has been collected then the file is
	94	the filename written to. If no profile data has been collected then the file is
95	95	not written and flush_to_disk() returns undef.
96	96
97	97	The file is locked while it's being written. A process 'consuming' the files

176	176
177	177	our @ISA = ("DBI::Profile");
178	178
179		our $VERSION = sprintf("2.%06d", q$Revision: 15324 $ =~ /(\d+)/o);
	179	our $VERSION = "2.015325";
180	180
181	181	use Carp qw(croak);
182	182	use Fcntl qw(:flock);

235	235	if (($self->{_wrote_header}\|\|'') eq $filename) {
236	236	# append more data to the file
237	237	# XXX assumes that Path hasn't changed
238		open($fh, ">>", $filename)
	238	open($fh, ">>", $filename)
239	239	or croak("Unable to open '$filename' for $class output: $!");
240	240	} else {
241	241	# create new file (or overwrite existing)

245	245	rename($filename, $bak)
246	246	or warn "Error renaming $filename to $bak: $!\n";
247	247	}
248		open($fh, ">", $filename)
	248	open($fh, ">", $filename)
249	249	or croak("Unable to open '$filename' for $class output: $!");
250	250	}
251	251	# lock the file (before checking size and writing the header)

309	309	# XXX it's valid for $data to be an ARRAY ref, i.e., Path is empty.
310	310	# produce an empty profile for invalid $data
311	311	return 0 unless $data and UNIVERSAL::isa($data,'HASH');
312
	312
313	313	# isolate us against globals which affect print
314	314	local ($\, $,);
315	315

+2

-2

lib/DBI/ProfileSubs.pm less more

0	0	package DBI::ProfileSubs;
1	1
2		our $VERSION = sprintf("0.%06d", q$Revision: 9395 $ =~ /(\d+)/o);
	2	our $VERSION = "0.009396";
3	3
4	4	=head1 NAME
5	5

25	25	# way to compose them in various combinations into multiple subs.
26	26	# Perhaps via AUTOLOAD where \&auto_X_Y_Z creates a sub that does X, Y, and Z.
27	27	# The final subs always need to be very fast.
28		#
	28	#
29	29
30	30	sub norm_std_n3 {
31	31	# my ($h, $method_name) = @_;

+4

-4

lib/DBI/ProxyServer.pm less more

623	623	# hint to organize:
624	624	# the most specialized rules for single machines/users are 1st
625	625	# then the denying rules
626		# the the rules about whole networks
	626	# then the rules about whole networks
627	627
628	628	# rule: internal_webserver
629	629	# desc: to get statistical information

650	650	},
651	651
652	652	# rule: employee_workplace
653		# desc: get detailled information
	653	# desc: get detailed information
654	654	{
655	655	# any IP-address is meant here
656	656	mask => '^10\.95\.81\.(\d+)$',

808	808
809	809	=item * "mask" is a perl regular expression against the plain ip-address of the machine which wishes to connect _or_ the reverse-lookup from a nameserver.
810	810
811		=item * "accept" tells the dbiproxy-server wether ip-adresse like in "mask" are allowed to connect or not (0/1)
	811	=item * "accept" tells the dbiproxy-server whether ip-adresse like in "mask" are allowed to connect or not (0/1)
812	812
813	813	=item * "users" is a reference to a list of usernames which must be matched, this is NOT a regular expression.
814	814

816	816
817	817	Controlling which SQL-statements are allowed
818	818
819		You can put every SQL-statement you like in simply ommiting "sql => ...", but the more important thing is to restrict the connection so that only allowed queries are possible.
	819	You can put every SQL-statement you like in simply omitting "sql => ...", but the more important thing is to restrict the connection so that only allowed queries are possible.
820	820
821	821	If you include an sql-section in your config-file like this:
822	822

+5

-5

lib/DBI/PurePerl.pm less more

27	27	} unless defined &utf8::is_utf8;
28	28
29	29	$DBI::PurePerl = $ENV{DBI_PUREPERL} \|\| 1;
30		$DBI::PurePerl::VERSION = sprintf("2.%06d", q$Revision: 14285 $ =~ /(\d+)/o);
	30	$DBI::PurePerl::VERSION = "2.014286";
31	31
32	32	$DBI::neat_maxlen \|\|= 400;
33	33

119	119	use constant IMA_NO_TAINT_OUT => 0x0020; #/* don't taint results */
120	120	use constant IMA_COPY_UP_STMT => 0x0040; #/* copy sth Statement to dbh */
121	121	use constant IMA_END_WORK => 0x0080; #/* set on commit & rollback */
122		use constant IMA_STUB => 0x0100; #/* donothing eg $dbh->connected */
	122	use constant IMA_STUB => 0x0100; #/* do nothing eg $dbh->connected */
123	123	use constant IMA_CLEAR_STMT => 0x0200; #/* clear Statement before call */
124	124	use constant IMA_UNRELATED_TO_STMT=> 0x0400; #/* profile as empty Statement */
125	125	use constant IMA_NOT_FOUND_OKAY => 0x0800; #/* not error if not found */

756	756	for keys %$hash_ref;
757	757	$num_sort = $sort_guess;
758	758	}
759
	759
760	760	my @keys = keys %$hash_ref;
761	761	no warnings 'numeric';
762	762	my @sorted = ($num_sort)

950	950	my $dbh = shift;
951	951	# A reasonable default implementation based on the one in DBI.xs.
952	952	# Typically a pure-perl driver would have their own take_imp_data method
953		# that would delete all but the essential items in the hash before einding with:
	953	# that would delete all but the essential items in the hash before ending with:
954	954	# return $dbh->SUPER::take_imp_data();
955	955	# Of course it's useless if the driver doesn't also implement support for
956	956	# the dbi_imp_data attribute to the connect() method.

1131	1131
1132	1132	DBI_PUREPERL == 2 Always use PurePerl
1133	1133
1134		You may set the enviornment variable in your shell (e.g. with
	1134	You may set the environment variable in your shell (e.g. with
1135	1135	set or setenv or export, etc) or else set it in your script like
1136	1136	this:
1137	1137

+30

-20

lib/DBI/SQL/Nano.pm less more

27	27
28	28	BEGIN
29	29	{
30		$VERSION = sprintf( "1.%06d", q$Revision: 15543 $ =~ /(\d+)/o );
	30	$VERSION = "1.015544";
31	31
32	32	$versions->{nano_version} = $VERSION;
33	33	if ( $ENV{DBI_SQL_NANO} \|\| !eval { require SQL::Statement; $SQL::Statement::VERSION ge '1.400' } )

82	82	{
83	83	$self->{command} = 'CREATE';
84	84	$self->{table_name} = $1;
85		$self->{column_names} = parse_coldef_list($2) if $2;
	85	defined $2 and $2 ne "" and
	86	$self->{column_names} = parse_coldef_list($2);
86	87	$self->{column_names} or croak "Can't find columns";
87	88	};
88	89	/^\sDROP\s+TABLE\s+(IF\s+EXISTS\s+)?(.?)\s*$/is

90	91	{
91	92	$self->{command} = 'DROP';
92	93	$self->{table_name} = $2;
93		$self->{ignore_missing_table} = 1 if $1;
	94	defined $1 and $1 ne "" and
	95	$self->{ignore_missing_table} = 1;
94	96	};
95	97	/^\sSELECT\s+(.?)\s+FROM\s+(\S+)((.*))?/is
96	98	&& do
97	99	{
98	100	$self->{command} = 'SELECT';
99		$self->{column_names} = parse_comma_list($1) if $1;
	101	defined $1 and $1 ne "" and
	102	$self->{column_names} = parse_comma_list($1);
100	103	$self->{column_names} or croak "Can't find columns";
101	104	$self->{table_name} = $2;
102	105	if ( my $clauses = $4 )

114	117	{
115	118	$self->{command} = 'INSERT';
116	119	$self->{table_name} = $1;
117		$self->{column_names} = parse_comma_list($2) if $2;
118		$self->{values} = $self->parse_values_list($4) if $4;
	120	defined $2 and $2 ne "" and
	121	$self->{column_names} = parse_comma_list($2);
	122	defined $4 and $4 ne "" and
	123	$self->{values} = $self->parse_values_list($4);
119	124	$self->{values} or croak "Can't parse values";
120	125	};
121	126	/^\sDELETE\s+FROM\s+(\S+)((.))?/is

123	128	{
124	129	$self->{command} = 'DELETE';
125	130	$self->{table_name} = $1;
126		$self->{where_clause} = $self->parse_where_clause($3) if $3;
	131	defined $3 and $3 ne "" and
	132	$self->{where_clause} = $self->parse_where_clause($3);
127	133	};
128	134	/^\s*UPDATE\s+(\S+)\s+SET\s+(.+)(\s+WHERE\s+.+)/is
129	135	&& do
130	136	{
131	137	$self->{command} = 'UPDATE';
132	138	$self->{table_name} = $1;
133		$self->parse_set_clause($2) if $2;
134		$self->{where_clause} = $self->parse_where_clause($3) if $3;
	139	defined $2 and $2 ne "" and
	140	$self->parse_set_clause($2);
	141	defined $3 and $3 ne "" and
	142	$self->{where_clause} = $self->parse_where_clause($3);
135	143	};
136	144	}
137	145	croak "Couldn't parse" unless ( $self->{command} and $self->{table_name} );

328	336	my ( $self, $data, $params ) = @_;
329	337	my $table = $self->open_tables( $data, 0, 1 );
330	338	$self->verify_columns($table);
	339	my $all_columns = $table->{col_names};
331	340	$table->seek( $data, 0, 2 ) unless ( $table->can('insert_one_row') );
332	341	my ($array) = [];
333	342	my ( $val, $col, $i );

335	344	my $cNum = scalar( @{ $self->{column_names} } ) if ( $self->{column_names} );
336	345	my $param_num = 0;
337	346
338		if ($cNum)
339		{
340		for ( $i = 0; $i < $cNum; $i++ )
341		{
342		$col = $self->{column_names}->[$i];
343		$array->[ $self->column_nums( $table, $col ) ] = $self->row_values($i);
344		}
345		}
346		else
347		{
	347	$cNum or
348	348	croak "Bad col names in INSERT";
349		}
	349
	350	my $maxCol = $#$all_columns;
	351
	352	for ( $i = 0; $i < $cNum; $i++ )
	353	{
	354	$col = $self->{column_names}->[$i];
	355	$array->[ $self->column_nums( $table, $col ) ] = $self->row_values($i);
	356	}
	357
	358	# Extend row to put values in ALL fields
	359	$#$array < $maxCol and $array->[$maxCol] = undef;
350	360
351	361	$table->can('insert_new_row') ? $table->insert_new_row( $data, $array ) : $table->push_row( $data, $array );
352	362

+1

-1

lib/DBI/Util/CacheMemory.pm less more

59	59
60	60	=cut
61	61
62		our $VERSION = sprintf("0.%06d", q$Revision: 10314 $ =~ /(\d+)/o);
	62	our $VERSION = "0.010315";
63	63
64	64	my %cache;
65	65

+1

-1

lib/DBI/Util/_accessor.pm less more

0	0	package DBI::Util::_accessor;
1	1	use strict;
2	2	use Carp;
3		our $VERSION = sprintf("0.%06d", q$Revision: 9478 $ =~ /(\d+)/);
	3	our $VERSION = "0.009479";
4	4
5	5	# inspired by Class::Accessor::Fast
6	6

+1

-1

lib/DBI/W32ODBC.pm less more

86	86	my($h, $statement, $attribs, @params) = @_;
87	87	Carp::carp "\$h->do() attribs unused" if $attribs;
88	88	my $new_h = $h->prepare($statement) or return undef; ##
89		pop @{ $h->{'___sths'} }; ## certian death assured
	89	pop @{ $h->{'___sths'} }; ## certain death assured
90	90	$new_h->execute(@params) or return undef; ##
91	91	my $rows = $new_h->rows; ##
92	92	$new_h->finish; ## bang bang

+2

-2

lib/Win32/DBIODBC.pm less more

95	95	$self->{'DBI_NAME'} = $sth->{NAME};
96	96	}
97	97
98		# [R] provide compatibility with Win32::ODBC's way of identifying erraneous SQL statements
	98	# [R] provide compatibility with Win32::ODBC's way of identifying erroneous SQL statements
99	99	return ($self->{'DBI_ERR'})?1:undef;
100	100	# -[R]-
101	101	}

115	115	if (scalar(@row)>0)
116	116	{
117	117	#-- the row of result is not nul
118		#-- return somthing nothing will be return else
	118	#-- return something nothing will be return else
119	119	return 1;
120	120	}
121	121	}

+2

-2

t/01basics.t less more

140	140
141	141	## testing neat_list
142	142
143		is(neat_list([ 1 + 1, "2", undef, "foobarbaz"], 8, "\|"), "2\|'2'\|undef\|'foo...'", '... test array argument w/seperator and maxlen');
144		is(neat_list([ 1 + 1, "2", undef, "foobarbaz"]), "2, '2', undef, 'foobarbaz'", '... test array argument w/out seperator or maxlen');
	143	is(neat_list([ 1 + 1, "2", undef, "foobarbaz"], 8, "\|"), "2\|'2'\|undef\|'foo...'", '... test array argument w/separator and maxlen');
	144	is(neat_list([ 1 + 1, "2", undef, "foobarbaz"]), "2, '2', undef, 'foobarbaz'", '... test array argument w/out separator or maxlen');
145	145
146	146
147	147	## ----------------------------------------------------------------------------

+8

-8

t/03handle.t less more

72	72	[ values %{$ck} ],
73	73	[ $sth1 ]
74	74	),
75		'... our statment handle should be in the CachedKids');
76
77		ok($sth1->{Active}, '... our first statment is Active');
	75	'... our statement handle should be in the CachedKids');
	76
	77	ok($sth1->{Active}, '... our first statement is Active');
78	78
79	79	{
80	80	my $warn = 0; # use this to check that we are warned

86	86	is($sth1, $sth2, '... prepare_cached returned the same statement handle');
87	87	cmp_ok($warn,'==', 1, '... we got warned about our first statement handle being still active');
88	88
89		ok(!$sth1->{Active}, '... our first statment is no longer Active since we re-prepared it');
	89	ok(!$sth1->{Active}, '... our first statement is no longer Active since we re-prepared it');
90	90
91	91	my $sth3 = $dbh->prepare_cached($sql, { foo => 1 });
92	92	isa_ok($sth3, 'DBI::st');

97	97	[ values %{$ck} ],
98	98	[ $sth1, $sth3 ]
99	99	),
100		'... both statment handles should be in the CachedKids');
	100	'... both statement handles should be in the CachedKids');
101	101
102	102	ok($sth1->execute("."), '... executing first statement handle again');
103	103	ok($sth1->{Active}, '... first statement handle is now active again');

113	113	[ values %{$ck} ],
114	114	[ $sth2, $sth4 ]
115	115	),
116		'... second and fourth statment handles should be in the CachedKids');
	116	'... second and fourth statement handles should be in the CachedKids');
117	117
118	118	$sth1->finish;
119	119	ok(!$sth1->{Active}, '... first statement handle is no longer active');

135	135	[ values %{$ck} ],
136	136	[ $sth2, $sth5 ]
137	137	),
138		'... second and fourth/fifth statment handles should be in the CachedKids');
	138	'... second and fourth/fifth statement handles should be in the CachedKids');
139	139	}
140	140
141	141	SKIP: {

218	218	# this test checks for reference leaks by testing the Kids attribute
219	219	# which is not supported by DBI::PurePerl, so we just do not run this
220	220	# for DBI::PurePerl all together. Even though some of the tests would
221		# pass, it does not make sense becuase in the end, what is actually
	221	# pass, it does not make sense because in the end, what is actually
222	222	# being tested for will give a false positive
223	223
224	224	sub work {

+4

-4

t/06attrs.t less more

37	37	ok( $dbh->{Active}, '... checking Active attribute for dbh');
38	38	ok( $dbh->{AutoCommit}, '... checking AutoCommit attribute for dbh');
39	39	ok(!$dbh->{CompatMode}, '... checking CompatMode attribute for dbh');
40		ok(!$dbh->{InactiveDestroy}, '... checking InactiveDestory attribute for dbh');
41		ok(!$dbh->{AutoInactiveDestroy}, '... checking AutoInactiveDestory attribute for dbh');
	40	ok(!$dbh->{InactiveDestroy}, '... checking InactiveDestroy attribute for dbh');
	41	ok(!$dbh->{AutoInactiveDestroy}, '... checking AutoInactiveDestroy attribute for dbh');
42	42	ok(!$dbh->{PrintError}, '... checking PrintError attribute for dbh');
43	43	ok( $dbh->{PrintWarn}, '... checking PrintWarn attribute for dbh'); # true because of perl -w above
44	44	ok( $dbh->{RaiseError}, '... checking RaiseError attribute for dbh');

110	110	ok( $drh->{Active}, '... checking Active attribute for drh');
111	111	ok( $drh->{AutoCommit}, '... checking AutoCommit attribute for drh');
112	112	ok(!$drh->{CompatMode}, '... checking CompatMode attribute for drh');
113		ok(!$drh->{InactiveDestroy}, '... checking InactiveDestory attribute for drh');
114		ok(!$drh->{AutoInactiveDestroy}, '... checking AutoInactiveDestory attribute for drh');
	113	ok(!$drh->{InactiveDestroy}, '... checking InactiveDestroy attribute for drh');
	114	ok(!$drh->{AutoInactiveDestroy}, '... checking AutoInactiveDestroy attribute for drh');
115	115	ok(!$drh->{PrintError}, '... checking PrintError attribute for drh');
116	116	ok( $drh->{PrintWarn}, '... checking PrintWarn attribute for drh'); # true because of perl -w above
117	117	ok(!$drh->{RaiseError}, '... checking RaiseError attribute for drh');

+1

-1

t/16destroy.t less more

77	77	sub DESTROY {
78	78	if ($expect_active < 0) { # inside child
79	79	my $self = shift;
80		exit $self->FETCH('Active') \|\| 0 unless $^O eq 'MSWin32';
	80	exit ($self->FETCH('Active') \|\| 0) unless $^O eq 'MSWin32';
81	81
82	82	# On Win32, the forked child is actually a thread. So don't exit,
83	83	# and report failure directly.

+2

-2

t/30subclass.t less more

55	55	if $row->[0] < 0;
56	56	# ... and providing alternate results
57	57	# (although typically would trap and hide and error from SUPER::fetch)
58		return $sth->set_err(2,"Don't exagerate",undef, undef, [ 42,"zz",0 ])
	58	return $sth->set_err(2,"Don't exaggerate",undef, undef, [ 42,"zz",0 ])
59	59	if $row->[0] > 42;
60	60	}
61	61	return $row;

129	129	isa_ok($row, 'ARRAY');
130	130	is($row->[0], 42);
131	131	is($DBI::err, 2);
132		like($DBI::errstr, qr/Don't exagerate/);
	132	like($DBI::errstr, qr/Don't exaggerate/);
133	133	is($@ =~ /Don't be so negative/, $@);
134	134
135	135

+57

-1

t/51dbm_file.t less more

118	118	}
119	119	);
120	120
	121	my @tbl;
	122	@tbl = $dbh->tables (undef, undef, undef, undef);
	123	is( scalar @tbl, 1, "Found 1 tables");
	124
121	125	$r = $dbh->selectall_arrayref(q/select * from Fred/);
122	126	ok( @$r == 2, 'rows found after reconnect using "dbm_tables"' );
123	127
124		ok( $dbh->do(q/drop table if exists FRED/), 'drop table' );
	128	my $deep_dir = File::Spec->catdir( $dir, 'deep' );
	129	mkpath $deep_dir;
	130
	131	$dbh = DBI->connect( 'dbi:DBM:', undef, undef, {
	132	f_dir => $deep_dir,
	133	sql_identifier_case => 2, # SQL_IC_LOWER
	134	}
	135	);
	136	ok( $dbh->do( q{create table wilma (a integer, b char (10))} ), "Create wilma" );
	137	ok( $dbh->do( q{insert into wilma values (1, 'Barney')} ), "insert Barney" );
	138	ok( $dbh->disconnect(), "disconnect" );
	139
	140	$dbh = DBI->connect( 'dbi:DBM:', undef, undef, {
	141	f_dir => $dir,
	142	sql_identifier_case => 2, # SQL_IC_LOWER
	143	}
	144	);
	145
	146	# Make sure wilma is not found without f_dir_search
	147	@tbl = $dbh->tables (undef, undef, undef, undef);
	148	is( scalar @tbl, 1, "Found 1 table");
	149	ok( $dbh->disconnect(), "disconnect" );
	150
	151	$dbh = DBI->connect( 'dbi:DBM:', undef, undef, {
	152	f_dir => $dir,
	153	f_dir_search => [ $deep_dir ],
	154	sql_identifier_case => 2, # SQL_IC_LOWER
	155	}
	156	);
	157
	158	@tbl = $dbh->tables (undef, undef, undef, undef);
	159	is( scalar @tbl, 2, "Found 2 tables");
	160	# f_dir should always appear before f_dir_search
	161	like( $tbl[0], qr{(?:^\|\.)fred$}i, "Fred first" );
	162	like( $tbl[1], qr{(?:^\|\.)wilma$}i, "Fred second" );
	163
	164	my( $n, $sth );
	165	ok( $sth = $dbh->prepare( 'select * from fred' ), "select from fred" );
	166	ok( $sth->execute, "execute fred" );
	167	$n = 0;
	168	$n++ while $sth->fetch;
	169	is( $n, 2, "2 entry in fred" );
	170	ok( $sth = $dbh->prepare( 'select * from wilma' ), "select from wilma" );
	171	ok( $sth->execute, "execute wilma" );
	172	$n = 0;
	173	$n++ while $sth->fetch;
	174	is( $n, 1, "1 entry in wilma" );
	175
	176	ok( $dbh->do(q/drop table if exists FRED/), 'drop table fred' );
125	177	ok( !-f File::Spec->catfile( $dir, "fred$dirfext" ), "fred$dirfext removed" );
126	178	ok( !-f File::Spec->catfile( $dir, "fred$tblfext" ), "fred$tblfext removed" );
	179
	180	ok( $dbh->do(q/drop table if exists wilma/), 'drop table wilma' );
	181	ok( !-f File::Spec->catfile( $deep_dir, "wilma$dirfext" ), "wilma$dirfext removed" );
	182	ok( !-f File::Spec->catfile( $deep_dir, "wilma$tblfext" ), "wilma$tblfext removed" );
127	183	}
128	184
129	185	done_testing();

+1

-1

t/85gofer.t less more

85	85	#http => { url => "http://localhost:8001/gofer" },
86	86	);
87	87
88		# too dependant on local config to make a standard test
	88	# too dependent on local config to make a standard test
89	89	delete $trials{http} unless $username eq 'timbo' && -d '.svn';
90	90
91	91	my @transports = ($opt_transport) ? ($opt_transport) : (sort keys %trials);

+1

-1

t/lib.pl less more

0	0	#!/usr/bin/perl
1	1
2	2	# lib.pl is the file where database specific things should live,
3		# whereever possible. For example, you define certain constants
	3	# wherever possible. For example, you define certain constants
4	4	# here and the like.
5	5
6	6	use strict;