File Coverage

blib/lib/DBIx/DataStore.pm
Criterion Covered Total %
statement 240 580 41.3
branch 117 438 26.7
condition 61 198 30.8
subroutine 19 28 67.8
pod 17 17 100.0
total 454 1261 36.0


line stmt bran cond sub pod time code
1             package DBIx::DataStore;
2             $DBIx::DataStore::VERSION = '0.097';
3 2     2   178147 use strict;
  2         5  
  2         61  
4 2     2   9 use warnings;
  2         2  
  2         61  
5              
6             # ABSTRACT: Abstracts away oft-repeated parts of DBI and simplifies the way SQL is issued.
7              
8 2     2   3312 use DBI;
  2         33427  
  2         15784  
9              
10             =head1 NAME
11              
12             DBIx::DataStore
13              
14             =head1 DESCRIPTION
15              
16             DBIx::DataStore is designed to abstract away the oft-repeated parts of DBI and to
17             simplify the way you issue SQL statements to your database(s).
18              
19             =head1 EXAMPLE
20              
21             As a fairly contrived example, below is a chunk of code using this module in a
22             relatively simple way. It starts by instantiating a new DBIx::DataStore object
23             connected to the "commerce" data store. It then issues a single SELECT query,
24             with the optional paginating feature turned on and set to the first page of
25             results. It then gets a Data::Page object through the pager() method and loops
26             over the first page's worth of results from the database to print them.
27              
28             use DBIx::DataStore ( config => 'yaml' );
29              
30             my $db = DBIx::DataStore->new('commerce');
31              
32             my $results = $db->do({ page => 1, per_page => 15 }, q{
33             select p.name, p.price, c.name as category
34             from products p
35             join product_categories pc on (pc.produc_id = p.id)
36             join categories c on (c.id = pc.category_id)
37             where c.id in ???
38             and p.price between ? and ?
39             order by p.price desc, p.name asc
40             }, [2,3,5], 17, 23);
41              
42             my $pager = $results->pager;
43              
44             while ($results->next) {
45             print sprintf("%s was found in category %s for \$%.2f.\n",
46             @{$results}{qw( name category price )});
47             }
48              
49             print sprintf("\nShowing %d to %d of %d total results.\n",
50             $pager->first, $pager->last, $pager->total_entries);
51              
52             And here is what the output from that code might look like.
53              
54             Golden Apple was found in category Food for $22.24.
55             Mermaid Statue was found in category Artwork for $17.76.
56             Norton's Epaulets was found in category Clothing for $17.76.
57              
58             Showing 1 to 3 of 3 total results.
59              
60             =head2 IMPORTANT NOTICE
61              
62             This is the legacy release of DBIx::DataStore and has a low chance of seeing
63             future (non-critical bug fix) releases. It is being published for the primary
64             purpose of easing the maintenance of existing installations.
65              
66             Future versions of this module will make attempts to maintain as much backwards
67             compatibility as possible, but there are no guarantees that every feature or
68             method will carry over unchanged from the user perspective. It is recommended
69             that if you do build something around this module that you pin to pre-1.0
70             versions. A future release which breaks functionality with what is presented
71             here will begin with a new major version.
72              
73             This code has been in heavy production use at multiple companies for almost
74             fifteen years and is considered pretty (though not perfectly) stable. You are
75             welcome to make use of it, in the form presented here, in your own projects.
76             Significant feature requests for this version will likely be met with a
77             somewhat low priority, and development of new applications or libraries with it
78             is not strongly encouraged.
79              
80             Critical security and bug fix requests will be reviewed.
81              
82             =head1 CONCEPTS
83              
84             In using DBIx::DataStore, there are three main types of objects with which you'll
85             generally interact.
86              
87             =over
88              
89             =item *
90              
91             Database objects
92              
93             These objects manage the connections to your database servers (either one or two
94             servers at all times, depending on whether you have any reader databases
95             configured) and are used to issue all commands to your database backend.
96              
97             =item *
98              
99             Result Set objects
100              
101             Every time you issue a read-oriented query through the C method of a
102             database object, a new result set object is created. These objects are what you
103             use to access the results of your query. Unlike the normal method of accessing
104             a row's data using DBI methods directly, with DBIx::DataStore result set objects,
105             the current row's data is accessed through the result set object itself.
106              
107             Result set objects also contain a single result row object at any given time (or
108             no result row object if you haven't yet called the C method on a result
109             set object). You don't actually directly interact with a distinct object for
110             each row -- row methods are issued through the result set object to act on the
111             currently visible row, and will simply fall through to the row object.
112              
113             =item *
114              
115             Pager objects
116              
117             These objects are used only when you request one by calling the C
118             method on a result set object. They are normal L objects, so refer
119             to the documentation for that module for further details. Please note that you
120             can only use pager objects on a result set when you passed in at least one of
121             C or C arguments to the C method. Without either of those
122             arguments, your query will be performed in I mode and you will trigger
123             an error if you attempt to call the C method on your result set. You
124             will also get an error if you explicitly turned paging support off when loading
125             DBIx::DataStore.
126              
127             =back
128              
129             =head1 MODULE ARGUMENTS
130              
131             DBIx::DataStore allows a number of options to be specified at the time you
132             import the module into your code. These options, and their effects, are
133             described here. Arguments are passed as a hash (not a reference) to the
134             module as part of the use statement. For example, to load DBIx::DataStore
135             with the default options, except for debugging which we'll set to "5", do:
136              
137             use DBIx::DataStore ( debug => 5 );
138              
139             Below is a description of each option that can be fiddled with on module
140             import. The name in parentheses at the start of each subsection is the
141             key name to use in the hash passed to DBIx::DataStore during use.
142              
143             =head2 Debugging (debug)
144              
145             Accepts any integer value. Non-integer values, or any numbers zero or lower
146             will turn off debugging. Any positive integers will turn on debugging, with
147             higher numbers producing more debugging output. Typically, a debugging level
148             of 1 will only produce non-fatal-but-concerning debug messages, analogous to
149             an INFO level. At level 2 messages will generally be produced that are more
150             warning-only in nature, but not serious issues. Debugging level 3 introduces
151             submodule and method entry messages into the output. Debugging level 4 and
152             above are more or less reserved for "here" statements to trace detailed
153             code execution.
154              
155             Debugging level 5 is (or at least should) be the highest number that actually
156             introduces any changes in the output. This level should not actually trigger
157             any more calls to the internal logger, so in terms of the number of statements
158             it should be functionally equivalent to debugging level 4. However, unlike
159             lower levels of output, this will cause a full stack trace to be produced for
160             every single call to the logger. As such, this debugging level is only
161             recommended for tracking down really nasty bugs or for general use by the
162             clinically insane.
163              
164             Calls to the internal logger are handled by a foldable constant, so there
165             should be no performance penalty at all when debugging is turned off -- the
166             Perl compiler should remove those calls from the code entirely.
167              
168             =head2 Configuration Loader (config)
169              
170             DBIx::DataStore can use multiple configuration formats. Right now support
171             only exists for YAML, but if you'd rather use INI files or on-disk Storable
172             seralized data structures (and if a DBIx::DataStore::Config submodule has
173             been written to support it) you're more than welcome to change that. This
174             is done by passing in the config argument when loading DBIx::DataStore.
175              
176             You can also indicate that none of the configuration loader submodules should
177             be used by not passing in a config argument at all. If you do this, you
178             will be expected to pass in an appropriate configuration data structure
179             (details on that later in this document) to the constructor.
180              
181             Note that if you do use a configuration loader, they read their actual
182             configuration files and do the processing work immediately when DBIx::DataStore
183             is imported, then cache the parsed configuration data. Thus, you shouldn't
184             have to worry about the performance in web-based applications if you
185             have a facility to pre-load this module (such as mod_perl in Apache)
186             when you start the web server.
187              
188             =head2 Home Directory Configurations (use_home)
189              
190             This option goes in hand with the config option, and indicates to any
191             relevant configuration loaders that they should also look inside the
192             current user's home directory for configuration files. This is turned off
193             by default because of the extra modules that are loaded (File::HomeDir and
194             all of its dependencies) as well as the extra CPU time and stat calls
195             necessary to do these checks.
196              
197             =head2 Result Set Paginating (paging)
198              
199             By default, Data::Page is automatically imported for use by the C
200             method on result sets. In situations where you have no need for paging
201             of your result sets and wish to avoid the extra time and memory spent on
202             that code, you can explicitly disable it. Note that if you do so and then
203             try to call the pager method on a result set, you will trigger a fatal
204             error.
205              
206             You can also set this option to "auto" which allows you to call pager()
207             without dying, but won't load Data::Page and its dependencies until the
208             first time you need it. This load-on-demand can be bad in some cases,
209             though, even if it seems likes a good idea. In single-process code that
210             may or may not ever need to page something, setting this to auto would
211             make sense. In a situation like mod_perl in Apache, it is advised
212             against.
213              
214             With load on demand in mod_perl, you end up only loading it
215             for a single Apache process when it's first needed. If more than one
216             process needs it, more than one copy is loaded. If those processes are
217             eventually killed (through max keepalive request like settings) and its
218             needed again, then it has to be loaded all over again. Instead, preloading
219             it in the main Apache process creates a single copy available to every
220             child Apache process for the lifetime of that Apache run.
221              
222             =head1 DATABASE METHODS
223              
224             =head2 General methods
225              
226             The following methods are your primary interface to database objects. Typically
227             you will only be calling the C method once your applications, but unless
228             you have very simple database needs you will almost certainly be making many
229             calls to the C method.
230              
231             =over
232              
233             =item new()
234              
235             The constructor method actually supports multiple distinct syntaxes. The first
236             is the old syntax from the SQL::Wrapper module (the immediate predecessor to
237             DBIx::DataStore and never widely released). This syntax is deprecated and
238             will some day be removed, so it is not discussed here (look at the code if you
239             really must know what it is).
240              
241             There are three main forms of the currently-supported constructor syntax. The
242             first of these is to simply specify the name of the data store to which you
243             want to connect and optionally and alternate schema list:
244              
245             my $db = DBIx::DataStore->new($datastore);
246             my $db = DBIx::DataStore->new($datastore, @schemas);
247              
248             This should be a single scalar value containing a string that matches the name of
249             one of the datastores defined in your configuration (whether it be YAML or any of
250             the other configuration loaders supported).
251              
252             The second form allows more control over specific parts of a datastore's
253             configuration and connection parameters:
254              
255             my $db = DBIx::DataStore->new({ store => $datastore, ... });
256              
257             This version allows for overriding not just the schemas, but which reader
258             should be used, changing the default settings for statement preparation, statement
259             caching and so on.
260              
261             TODO: Go into more detail on how exactly to set these extra options.
262              
263             The last is the simplest, to pass in no arguments at all to the constructor.
264             One of three things will happen. First, DBIx::DataStore will get a list
265             of all the package names from the caller's stack, and starting with the
266             bottom, working its way up to the very top of the stack, will look for any
267             datastore which matches one of those package names with the regular
268             expression in its "packages" variable. The first match to succeed will
269             cause that datastore to be used for the connection.
270              
271             If no matches were found, then a datastore is looked for which has the
272             "is_default" flag set to a true value. If there is one, then that datastore
273             will be used. If that check fails, then an error is produced indicating that
274             there was no suitable choice for a default datastore connection.
275              
276             =item do(\%options, $query, @binds)
277              
278             This method requires at least one argument (C<$query>) but can in some cases be
279             called with far more than that. The first argument is optional and is used
280             primarily to enable automated pagination of query results. If passed in, it
281             should contain at least one of "page" (which will default to 1 if not specified)
282             or "per_page" (which defaults to 25). If neither is passed in, automatic
283             pagination will not be available for the returned result set.
284              
285             If you do take advantage of the paginating options to this method, do not
286             include any sort of row limit clause in your actual query (such as "LIMIT x
287             OFFSET y", "ROWS x TO y" or whatever the flavor is for your particular database
288             server). This method will add that clause to your query as appropriate.
289              
290             The next argument (which would be the first one if you choose to leave
291             pagination disabled) is required and must contain the SQL statement you would
292             like issued to your database server. Regular scalar placeholders are allowed,
293             as well as a non-DBI placeholder that can be used with arrays and hashes (in
294             specific contexts). Refer to the L section of this document
295             for details.
296              
297             All arguments after the query will be used as your bind variables when executing
298             the SQL statement. They must be in the same order as the actual placeholders
299             within your query and you must provide the exact same number of bind variables
300             as you did placeholders. Failure to do so will result in a fatal error.
301              
302             This method, when successful, returns a DBIx::DataStore result set object (see
303             L for details on what you can do with these).
304              
305             =back
306              
307             =head2 Transaction related methods
308              
309             The following methods are used when dealing with transactions. If your database
310             server does not support transactions, these will be useless to you. You'll
311             probably also receive fatal errors if you try to use them.
312              
313             =over
314              
315             =item begin()
316              
317             This method starts a new transaction block in your current database session.
318             Please note that not all databases support nested transactions (and even those
319             that do may have limits on how deeply they can be nested). You will receive an
320             error if you attempt to call this method multiple times (with no intervening
321             C or C calls) when using a database that does not support
322             nested transactions. You may want to look into whether savepoints will suffice
323             for your needs in those cases.
324              
325             As soon as you open a transaction, B queries issued to your database
326             through the C method will be sent to your primary server. No queries will
327             be issued to your reader database until you either commit or rollback the
328             transaction.
329              
330             =item commit()
331              
332             This method ends the current transaction block in your database session. If you
333             are using a database server which supports nested transactions, you may need to
334             call this method as many times as you called C (or you may not -- at
335             least some versions of Oracle, for instance, default to commiting B your
336             open transactions unless you set a server/session variable).
337              
338             =item rollback($savepoint)
339              
340             This method takes one optional argument. Called with no arguments, it rolls
341             back all of the changes you've made to your database within the current
342             transaction block. If you are using a database server that supports savepoints,
343             you may also pass in a single argument with the name of an already defined
344             savepoint (it B have been defined within the current transaction block,
345             and not have already been cleared out by another rollback) to undo all of the
346             changes made I the savepoint was created. Passing in an invalid
347             savepoint name will generate a fatal error.
348              
349             =item savepoint($name)
350              
351             Calling this method on a database server which supports savepoints will create a
352             new savepoint at the current point of your open transaction with the name you
353             provide. This method can only be called when you have an open transaction
354             block. Attempts to call it outside of a transaction will trigger a fatal error.
355             It is also your responsibility to make sure you use a unique name for each of
356             your savepoints if you require more than one.
357              
358             =item in_transaction()
359              
360             This method returns true if your database object is currently in an open
361             transaction.
362              
363             =back
364              
365             =head2 Convenience methods
366              
367             =over
368              
369             =item base_tables()
370              
371             This method returns a list of the tables, excluding any views.
372              
373             =item databases()
374              
375             This method returns a list of the database (schema) names available on the
376             primary database server.
377              
378             =item db_primary()
379              
380             This method returns a hash reference containing the following information about
381             the primary database server: name (always "primary"), driver, host and database.
382              
383             =item db_reader()
384              
385             This method returns a hash reference containing the following information about
386             the currently selected reader database: name, driver, host and database.
387              
388             =item last_insert_id()
389              
390             This method is a pass-through for DBI's C function. All the
391             same caveats apply to this method. But just in case you aren't familiar with
392             them, basically consider this method unreliable on many database servers. It
393             should only be used with care, and only if you know your underlying RDBMS's
394             DBD driver will do The Right Thing.
395              
396             =item ping()
397              
398             This method, when called, attempts to issue a very simple SQL statement
399             (generally "select 1") against both the primary and reader database servers (or
400             primary only if no reader has been selected). A true value will be returned if
401             the statements were successful.
402              
403             =item schemas()
404              
405             If called with no arguments, returns a list of the schemas currently in the
406             search path for the primary server connection. If called with a list of
407             scalar arguments, sets the connection's search path to those schemas (in
408             the order they were provided).
409              
410             =item servers()
411              
412             Returns a list of hash references, detailing the database servers defined in the
413             YAML config file. All servers defined are returned, regardless of whether they
414             have, or will, respond to connections.
415              
416             Within each hash reference the following key/value pairs are provided: name (as
417             defined in the configuration file), driver, host and database. The first hash
418             reference in the returned list will always be the server defined as the primary,
419             followed by the readers sorted by their names.
420              
421             =item tables()
422              
423             This method returns a list of the table names that are present within the
424             currently selected database (schema) on the primary server. The list returned
425             will also include views (use C if you don't want the views).
426              
427             =item views()
428              
429             This method will return a list of the views defined within your current schema.
430              
431             =back
432              
433             =head1 RESULT SET METHODS
434              
435             Every call to the C method on a database object which contains a
436             read-oriented SQL query returns a result set object. These objects can then be
437             used to access the data contained within the database query's results.
438              
439             =over
440              
441             =item Hash and Array accessors
442              
443             Each time you retrieve a record (aka "result row") from a query's result set,
444             the values for each column in that record can be transparently accessed through
445             hash keys (where the keys are the column names as defined by the original query)
446             or array indices (in the order the columns were defined by the query). Both
447             methods of accessing the record's values are available at all times (unlike the
448             standard DBI methods where you have to choose up front between using
449             C or C). Thus, something like the
450             following is perfectly acceptable:
451              
452             my $result = $db->do(q{
453             select id, name from users order by name asc
454             });
455             while ($result->next) {
456             print sprintf("ID %d: %s\n",
457             $result->[0],
458             $result->{'name'}
459             );
460             }
461              
462             =item next()
463              
464             Retrieves the next row of results from the result set. The row's data is then
465             directly accessible through the result set object itself (see L
466             accessors">). This method also returns a reference to the result set object,
467             making the following two snippets of code effectively identical (though the
468             second is unnecessarily verbose):
469              
470             while ($result->next) {
471             print $result->{'some_col_name'};
472             }
473              
474             or
475              
476             while (my $row = $result->next) {
477             print $row->{'some_col_name'};
478             }
479              
480             The return value will be undef when there are no more rows to retrieve from the
481             database.
482              
483             =item next_hashref()
484              
485             Similar to a next() call, in that it moves to the next row in the result set
486             (or returns an undefined value when all rows have been read already). However,
487             this method returns a stand-alone hash reference containing as keys the column
488             names from the query, and as values the contents of the current row of the
489             result set.
490              
491             =item hashref()
492              
493             Returns the exact same data structure as next_hashref(), except that it does
494             not move to the next row in the result set first. You get a hash representation
495             of the current row from the results, not the next row.
496              
497             =item all()
498              
499             This method retrieves all rows from the database at once and returns a list of
500             result set row objects, each one containing a single row from the result set.
501             It is functionally equivalent to the following:
502              
503             my (@rows);
504             while (my $row = $result->next) {
505             push(@rows, $row);
506             }
507              
508             Please keep in mind that, internally, that is effectively what this method does
509             itself (though slightly more efficiently). So C won't actually return
510             I if you've already called C one or more times on your
511             result set. You will only get the rows you have not yet retrieved via other
512             means -- which also means that only the first call to this method will actually
513             do anything.
514              
515             It is recommended you don't use this method if you will actually be operating on
516             each row's data in your Perl code. You're better off using C and doing
517             whatever processing you need to on each row. However, this method is useful if
518             you're passing the results of your SQL query directly into another module like
519             Template Toolkit and don't actually need to do any processing on the data before
520             handing it off.
521              
522             =item columns()
523              
524             This method returns a list of the column names from your SQL query, in the same
525             order they were returned by the database.
526              
527             =item count()
528              
529             This method will return the number of rows that were either returned by the
530             database (in the case of read-oriented queries) or the number of the rows that
531             were affected by your query (in the case of updates, inserts, etc.).
532              
533             If you used pagination in your call to the C method, the number returned
534             by this method is the number of rows your select query would have returned
535             B pagination. This makes it very simple to do simple pagination of
536             your query results, but still be able to display to the end user of your
537             application how many total results there are.
538              
539             There is a catch to this feature, though. Your database server B support
540             subqueries against derived tables for this method to succeed. If you aren't
541             sure whether your database supports this feature (most of them which support
542             subqueries do), you can try to run the following SQL query (change "some_table"
543             to a table name that actually exists first):
544              
545             select count(*) from (select * from some_table) derived
546              
547             Some database servers, such as Oracle, don't allow you to give a name to a
548             derived table in a SQL query like the one above. But if you're running Oracle,
549             this method is properly supported anyway (for what it's worth, the only change
550             to that query above to have it work on Oracle is to omit the word "derived" at
551             the end).
552              
553             =item pager()
554              
555             This method will return a L object which you can use for easier
556             paginating of your database query results. You cannot call this method on a
557             result set object which was created from a call to C that lacked the
558             optional pagination options. Attempting to do so will generate a fatal error.
559              
560             =back
561              
562             =head1 PLACEHOLDERS
563              
564             In addition to the standard scalar-value placeholder available through standard
565             DBI calls, this module adds another type of placeholder which can be used for
566             inserting entire arrays or hashes into your queries. There are limitations on
567             how and where they can be used, though. Both types of placeholders are written
568             as a series of three question marks.
569              
570             These additional forms for placeholders are B in your queries. You
571             are not forced to always use array placeholders for your IN clauses, nor are you
572             forced to use the hash placeholders for your UPDATEs and INSERTs. You are more
573             than welcome to use the regular style placeholders if you really prefer them (or
574             have some other reason to not use the more convenient forms added by this
575             module). You can also mix and match the styles within any single query as well,
576             having one IN specified with single-value placeholders and another IN with an
577             array placeholder in a single query.
578              
579             =over
580              
581             =item *
582              
583             Array placeholders
584              
585             These allow you to pass in a list of values to be used in an IN (...) clause,
586             without you having to know or care how many elements are in the array. They
587             cannot be used anywhere else but as part of an IN (although placing the
588             parentheses around the placeholder is optional -- it will be added if you didn't
589             include it).
590              
591             Example:
592              
593             my $result = $db->do(q{
594             select * from users where id in (???)
595             }, \@userid_list);
596              
597             If your list of user IDs contained the values "1", "2" and "3" this would have
598             achieved the same exact effect as you writing out the C call more
599             verbosely as:
600              
601             my $result = $db->do(q{
602             select * from users where id in (?,?,?)
603             }, 1, 2, 3);
604              
605             But then, you would have needed to know exactly how many elements were going to
606             be in the list of IDs you wanted to match against and would have had to write
607             that many single placeholders in the query yourself. Because the values in your
608             list remain as real placeholders under the hood of this module, you can still
609             take advantage of statement caching and the like from the underlying DBI methods
610             (assuming you have that turned on), and the values you pass into the query will
611             be safely escaped as usual.
612              
613             =item *
614              
615             Hash placeholders for UPDATE
616              
617             These can be used to fill in the SET portion of your UPDATE statement. Each
618             key/value pair will be turned into "column = ?" with the values of your hash
619             remaining as placeholders so the same advantages of array placeholders apply
620             here as well.
621              
622             Example:
623              
624             my $num_rows_updated = $db->do(q{
625             update users set ??? where id = ?
626             }, { name => $new_name }, $user_id);
627              
628             Writing out the normal placeholder(s) yourself would work too, but would get
629             pretty annoying if you're updating many columns at once.
630              
631             =item *
632              
633             Hash placeholders for INSERT
634              
635             The second place in which hash placeholders can be used is for INSERT
636             statements. Multiple record inserts are also supported, just put all the hash
637             references containing each record's data into an array reference.
638              
639             There is one slight I with using hash placeholders in INSERT statements.
640             You cannot specify the column name list inside your SQL query. The C
641             method will fill that in for you when it processes the placeholder. The
642             I keyword in your query is optional, but if present, the placeholder
643             must come after it, not before.
644              
645             Example:
646              
647             my $num_rows_inserted = $db->do(q{
648             insert into users values ???
649             }, { name => $name, email => $email, ... });
650              
651             =back
652              
653             =head1 EXCEPTIONS
654              
655             =head2 Exceptions to selection of secondary servers for read-only statements
656              
657             If indicated by the "reader" argument to new(), a secondary server may be used
658             for distributing the load of read-only statements. However, no statements
659             within a transaction will be issued to any server other than the primary,
660             regardless of the "reader" setting. Also, if only a single server (the primary)
661             is defined in the config, but "__random" is indicated in new()'s arguments, it
662             will have no effect (all statements will be issued through the primary) and no
663             errors will be reported. Thus, it is safe to use "__random" even if you have no
664             secondary databases (and can save you time updating your code later if you add
665             more database servers down the road).
666              
667             =head1 CONFIGURATION
668              
669             Database server configuration may current be done through either a YAML file or
670             by passing in an equivalent datastructure to your C call. Other
671             file formats would be possible with an appropriate config loader,
672             but YAML is the only one currently supported.
673              
674             You can override where the configuration file is located when calling the new()
675             method, or you can pass in a scalar containing raw, unprocessed YAML, or even
676             pass in a hash reference which contains a data structure identical to what YAML
677             would have returned itself if you need to bypass the YAML parsing for any
678             reason. The latter is particularly useful if your application already has its
679             own configuration files and you wish to embed the DBIx::DataStore config data
680             within them.
681              
682             Your configuration must contain at least one "primary" server definition, and
683             may contain any number of "reader" server definitions (or none at all if you
684             only have a single server). Each server definition in the config must contain
685             the following: DBD driver name, host address, database name, username and
686             password. You may optionally include a list of key/value pairs for each server
687             under the heading "dbd_opts" which will be passed directly through to any
688             connection setup to that server. For details on what settings are available,
689             check the documentation for DBI and for any relevant DBD::* modules you will be
690             using.
691              
692             For some database servers, depending on your configuration, you may also need to
693             specify a list of schemas for your connection's search path. This is currently
694             only handled for PostgreSQL connections, and is only necessary if you will be
695             accessing tables, functions, etc. that exist outside the default "public"
696             schema. If unspecified, you will only be able to access objects in the default
697             schema, unless you provide fully qualified identifiers (and assuming you have
698             appropriate permissions to do so). If specified, you must list all schemas for
699             which you want in your search path, including the "public" schema. Any number
700             of schemas may be listed, and they will be added to your search path in the
701             same order you specify in the configuration. For all non-PostgreSQL servers,
702             the schemas option will be ignored if specified.
703              
704             In addition to the definition of individual servers, there are a few top-level
705             configuration settings.
706              
707             =over
708              
709             =item *
710              
711             default_reader
712              
713             Defines which reader database to use. Valid values are: the name of one of your
714             defined reader databases, "__random" (which will, as the name implies, choose a
715             random reader database from the list), "primary" and "none". The last two have
716             the same effect as not defining a default reader at all. Without a specific
717             reader named, or "__random" to choose one randomly, no reader database will be
718             used and all queries will be issued to the primary server.
719              
720             =item *
721              
722             reader_failover
723              
724             Valid values are one or zero (defaults to zero). With this option turned on,
725             every query issued to a reader database will be preceded by a C call.
726             If the ping fails, then a new reader database will be selected (for the current
727             and all future queries issued to the reader). A warning will be printed each
728             time a new reader database needs to be selected due to a failed ping, but no
729             error will be issued unless a new reader cannot be selected.
730              
731             Please note that each time a new reader database needs to be selected, B
732             readers will be considered, even if they had failed before. This is done in the
733             event that a previously unresponsive reader becomes available again. You can
734             turn this off (and only consider readers that have not failed before) by turning
735             on the I option.
736              
737             =item *
738              
739             flag_bad_readers
740              
741             If both this option and I are turned on, then a reader database
742             will be taken out of consideration for all future reconnection attempts if it
743             has failed a ping attempt at any point within the current process.
744              
745             =item *
746              
747             cache_connections
748              
749             With this option turned on, new database connections will be created through
750             DBI's C method instead of the normal C method. This
751             allows for basic connection pooling. For the full details, check DBI's
752             documentation. Basically what happens is if you make multiple calls to
753             C with the exact same arguments (including the extra
754             connection parameters like I, I, etc. -- not just the
755             DSN, username and password) you will get back the same database connection
756             handle each time, instead of brand new and untainted handles. The exception is
757             if an existing, and cached, database handle still has an active statement handle
758             on it, it will not be returned. Instead it will be removed from the cache and a
759             fully-new connection to the database will be established, cached and returned.
760              
761             =item *
762              
763             cache_statements
764              
765             When this option is turned on, statement preparation in DBI will use
766             C instead of C. For some databases this can
767             provide measurable performance improvements if you issue the same query (this
768             includes the placeholders, but not the values being used within those
769             placeholders) repeatedly. Not all databases' DBD modules show much or any
770             difference in performance between C and C, but
771             preparation caching is generally very safe.
772              
773             =back
774              
775             =head2 YAML Configuration Example
776              
777             default_reader: __random
778             reader_failover: 1
779             flag_bad_readers: 0
780             cache_connections: 0
781             cache_statements: 1
782             primary:
783             driver: Pg
784             db: mydatabase
785             host: db-1
786             user: username
787             pass: password
788             schemas:
789             - myschema
790             - public
791             dbd_opts:
792             AutoCommit: 0
793             readers:
794             reader1:
795             driver: Pg
796             db: mydatabase
797             host: db-2
798             user: username
799             schemas:
800             - myschema
801             - public
802             secondreader:
803             driver: Pg
804             db: mydatabase
805             host: 10.1.2.3
806             port: 8306
807             user: username
808             schemas:
809             - myschema
810             - public
811              
812             =head2 Explicit Hashref Configuration Example
813              
814             my $config = {
815             default_reader => '__random',
816             reader_failover => 1,
817             flag_bad_readers => 0,
818             cache_connections => 0,
819             cache_statements => 1,
820             primary => {
821             driver => 'Pg',
822             db => 'mydatabase',
823             host => 'db-1',
824             user => 'username',
825             pass => 'password',
826             schemas => ['myschema','public'],
827             dbd_opts => {
828             AutoCommit => 0,
829             }
830             },
831             readers => {
832             reader1 => {
833             driver => 'Pg',
834             db => 'mydatabase',
835             host => 'db-2',
836             user => 'username',
837             schemas => ['myschema','public']
838             },
839             reader2 => {
840             driver => 'Pg',
841             db => 'mydatabase',
842             host => '10.1.2.3',
843             port => 8306,
844             user => 'username',
845             schemas => ['myschema','public']
846             }
847             }
848             };
849             my $db = DBIx::DataStore->new({ config => $config });
850              
851             =head2 Configuring Database Passwords
852              
853             Because DBIx::DataStore uses the normal DBI/DBD layers underneath, all the
854             usual methods of locating and presenting database credentials to the
855             appropriate database server are available. This includes methods such as the
856             C<.pgpass> file for PostgreSQL and equivalents for other RDBMSes. If your
857             DBIx::DataStore configuration does not include a C attribute for a given
858             database host, these alternate methods will be used as long as they are
859             properly configured.
860              
861             =head1 SEE ALSO
862              
863             L, L, L
864              
865             =head1 AUTHORS
866              
867             Jon Sime Ejonsime@gmail.comE,
868             Buddy Burden Ebuddy@barefoot.netE
869              
870             =head1 LICENSE
871              
872             This program is free software; you can redistribute it and/or modify it
873             under the same terms as Perl itself.
874              
875             =cut
876              
877             my $HASH_PH = qr/\?\?\?/;
878             my $ARRAY_PH = $HASH_PH;
879              
880             my $USE_PAGER = 1;
881              
882             # some "true" values/strings reused in a few places (mostly submodules)
883             our %TV = map { $_ => 1 } qw( 1 yes true on enable enabled );
884             # same thing, but for "false"
885             our %FV = map { $_ => 1 } qw( 0 no false off disable disabled );
886              
887             sub import {
888 2     2   23 my ($pkg, %t) = @_;
889              
890 2         156 foreach (keys %t) {
891 0         0 $t{lc($_)} = lc($t{$_});
892 0 0       0 delete $t{$_} unless lc($_) eq $_;
893             }
894              
895             # set up debugging and logger
896             $t{'debug'} = $ENV{'DATASTORE_DEBUG'} if (!defined $t{'debug'} || $t{'debug'} !~ /^\d+$/o)
897 2 50 33     30 && defined $ENV{'DATASTORE_DEBUG'} && $ENV{'DATASTORE_DEBUG'} =~ /^\d+$/o;
      33        
      33        
898 2 50 33     9 $t{'debug'} = 0 unless defined $t{'debug'} && $t{'debug'} =~ /^\d+$/o;
899 2     2   1016 eval("use DBIx::DataStore::Debug ($t{'debug'});");
  2         4  
  2         21  
  2         186  
900              
901 2 50       8 if (defined $t{'paging'}) {
902 0 0       0 if (exists $TV{lc($t{'paging'})}) { #load Data::Page now
    0          
903 0         0 $USE_PAGER = 1;
904 0         0 eval("use Data::Page");
905             } elsif (exists $FV{lc($t{'paging'})}) { #don't ever load Data::Page
906 0         0 $USE_PAGER = 0;
907             } else { # auto-loading of Data::Page on first use
908 0         0 $USE_PAGER = -1;
909             }
910             }
911              
912             # call the config loader submodule
913 2 50 33     9 $t{'use_home'} = 0 if !defined $t{'use_home'} || $t{'use_home'} !~ /^\d+$/o;
914             eval("use DBIx::DataStore::Config ('$t{'config'}', $t{'use_home'});")
915 2 50 33     17 if defined $t{'config'} && length($t{'config'}) > 0;
916              
917             # we do these mandatory loads here instead of the normal area because we need to
918             # delay their loading until after we've done things like define DEBUG and such
919 2     2   916 eval("use DBIx::DataStore::ResultRow");
  2         4  
  2         50  
  2         99  
920 2     2   867 eval("use DBIx::DataStore::ResultSet");
  2         6  
  2         47  
  2         106  
921             }
922              
923             sub new {
924 1     1 1 10064 my $class = shift;
925              
926 1         3 my $self = { error => '' };
927 1         2 my $opts = {};
928 1         7 my @configs = ();
929              
930             # check for options hashref to override config file path and/or secondary DB selection
931 1 50 33     9 if (scalar(@_) > 0 && ref($_[0]) eq 'HASH') {
932 1         2 $opts = shift;
933             }
934              
935 1         2 my @args = @_;
936              
937             # check first to see if a config option was passed in, and if so whether it was a
938             # hashref containing the already-parsed config data, a scalar with raw YAML markup
939             # in it that still needs to be parsed, or a filesystem path to a YAML file...
940             # alternatively, if no config option was passed in, fall back on the default paths
941 1         1 my $found_config = 0;
942 1 50       4 if (exists $opts->{'config'}) {
943 1 50       31 dslog(q{Deprecated config-in-hashref constructor syntax used. This feature won't exist someday!}) if DEBUG();
944 1 50 0     4 if (ref($opts->{'config'}) eq 'HASH') {
    0          
    0          
945             # blindly assume hashref contains a valid config structure for now... if it
946             # doesn't, that will be caught soon enough
947 1         1 $self->{'config'} = { %{$opts->{'config'}} };
  1         4  
948 1         2 $found_config = 1;
949             } elsif ($opts->{'config'} =~ /^\// && -r $opts->{'config'}) {
950             # scalar contained what appeared to be a path, and lo and behold it pointed to
951             # file we're able to read... we don't set found_config here, though... just add
952             # it to the list of configs to check further down to make sure it's actually
953             # valid
954 0         0 @configs = ($opts->{'config'});
955             } elsif (length($opts->{'config'}) > 0) {
956             # fall back on assumining it must be raw YAML that needs to be parsed, so
957             # give that a shot now
958 0         0 eval("use YAML::Syck qw()");
959 0 0       0 if ($self->{'config'} = YAML::Syck::Load($opts->{'config'})) {
960 0         0 $found_config = 1;
961             }
962             }
963              
964 1 50       3 if (scalar(@configs) > 0) {
965 0         0 eval("use YAML::Syck qw()");
966              
967 0         0 foreach my $path (@configs) {
968 0 0       0 next unless -r $path;
969 0 0       0 if ($self->{'config'} = YAML::Syck::LoadFile($path)) {
970 0         0 $found_config = 1;
971 0         0 last;
972             } else {
973 0 0       0 dslog(qq{Configuration file "$path" could not be loaded. Skipping.}) if DEBUG();
974             }
975             }
976             }
977              
978 1 50       3 die dslog(q{Instance config variable present, but no valid config found.}) unless $found_config;
979              
980             # Check whether connection caching should be enabled
981 1 50       5 if (defined $opts->{'cache_connections'}) {
    50          
982 0         0 $self->{'config'}->{'cache_connections'} = $opts->{'cache_connections'};
983             } elsif (!defined $self->{'config'}->{'cache_connections'}) {
984 0         0 $self->{'config'}->{'cache_connections'} = 0;
985             }
986              
987             # Check whether statement handler caching should be used
988 1 50       5 if (defined $opts->{'cache_statements'}) {
    50          
989 0         0 $self->{'config'}->{'cache_statements'} = $opts->{'cache_statements'};
990             } elsif (!defined $self->{'config'}->{'cache_statements'}) {
991 0         0 $self->{'config'}->{'cache_statements'} = 0;
992             }
993             }
994              
995             # now for the new DBIx::DataStore syntax (the previous block was to support the
996             # old SQL::Wrapper syntax -- it will likely be dropped some day down the road
997 1 0 33     3 if ($found_config != 1 && defined $opts->{'store'} && length($opts->{'store'}) > 0) {
      33        
998 0         0 eval(q|$self->{'config'} = DBIx::DataStore::Config::get_store($opts->{'store'})|);
999 0 0 0     0 if ($@ || !defined $self->{'config'}) {
1000 0         0 die dslog(q{Error getting configuration for datastore:}, $opts->{'store'}, q{[}, $@, q{]});
1001             } else {
1002 0         0 $found_config = 1;
1003             }
1004             }
1005              
1006             # check for the alternate-new syntax of "new($store, @schemas)" (where @schemas is optional)
1007 1 50 33     6 if ($found_config != 1 && scalar(@args) > 0) {
1008 0         0 eval(q|$self->{'config'} = DBIx::DataStore::Config::get_store($args[0])|);
1009 0 0 0     0 if ($@ || !defined $self->{'config'}) {
1010 0 0       0 dslog(q{Non-hashref args passed in, but first one is not a valid datastore config name.}) if DEBUG();
1011             } else {
1012 0 0       0 dslog(q{Alternate constructor syntax [new($datastore, @schemas)] used.}) if DEBUG() >= 3;
1013 0         0 $found_config = 1;
1014 0         0 shift(@args); # remove datastore name from remaining args
1015 0         0 my @manual_schemas = grep { $_ =~ /^\w+$/o } @args;
  0         0  
1016 0 0       0 if (scalar(@manual_schemas) > 0) {
1017 0 0       0 dslog(q{Overriding configuration's schemas with custom list:}, join(', ', @manual_schemas)) if DEBUG() >= 2;
1018 0         0 $self->{'config'}->{'primary'}->{'schemas'} = [@manual_schemas];
1019 0 0 0     0 if (defined $self->{'config'}->{'readers'} && ref($self->{'config'}->{'readers'}) eq 'ARRAY') {
1020 0         0 foreach my $reader (@{$self->{'config'}->{'readers'}}) {
  0         0  
1021 0         0 $self->{'config'}->{'readers'}->{$reader}->{'schemas'} = [@manual_schemas];
1022             }
1023             }
1024             }
1025             }
1026             }
1027              
1028 1         1 my ($i);
1029              
1030             # if we still don't have a config, use the package-matching option
1031 1 50       2 if ($found_config != 1) {
1032 0         0 my @packages;
1033 0         0 for ($i = 0; my @p = caller($i); $i++) {
1034 0 0       0 push(@packages, $p[0]) unless $p[0] eq 'main';
1035             }
1036 0 0       0 if (scalar(@packages) > 0) {
1037 0         0 eval(q|$self->{'config'} = DBIx::DataStore::Config::match_store(\@packages)|);
1038 0 0 0     0 if ($@ || !defined $self->{'config'}) {
1039 0 0       0 dslog(q{Locating configuration based on packages in stack failed.}) if DEBUG();
1040             } else {
1041 0         0 $found_config = 1;
1042             }
1043             }
1044             }
1045              
1046             # if that still doesn't work, return the default-marked configuration
1047 1 50       6 if ($found_config != 1) {
1048 0         0 eval(q|$self->{'config'} = DBIx::DataStore::Config::get_default()|);
1049 0 0 0     0 if ($@ || !defined $self->{'config'}) {
1050 0         0 die dslog(q{No configuration could be located and used for this connection!});
1051             }
1052             }
1053              
1054             # Validate connection to primary database
1055 1         1 $self->{'handles'} = {};
1056 1 50       2 unless ($self->{'handles'}->{'primary'} = _db_connect(
1057             cache => $self->{'config'}->{'cache_connections'},
1058 1         5 %{$self->{'config'}->{'primary'}})
1059             ) {
1060 0         0 die dslog("Validation of connection to primary database failed!");
1061             }
1062             $self->{'handles'}->{'primary'} = _set_schema_searchpath(
1063             $self->{'handles'}->{'primary'},
1064             $self->{'config'}->{'primary'}->{'driver'},
1065 1   50     6 $self->{'config'}->{'primary'}->{'schemas'}
1066             ) || die dslog(q{Error setting schema search path.});
1067              
1068             # Select the default reader DB
1069             my $num_readers = defined $self->{'config'}->{'readers'} && ref($self->{'config'}->{'readers'}) eq 'HASH'
1070 1 50 33     5 ? scalar keys %{$self->{'config'}->{'readers'}} : 0;
  0         0  
1071              
1072 1 50       2 $self->{'config'}->{'default_reader'} = $opts->{'reader'} if defined $opts->{'reader'};
1073             $self->{'config'}->{'default_reader'} = 'primary'
1074             if !defined $self->{'config'}->{'default_reader'}
1075             || lc($self->{'config'}->{'default_reader'}) eq 'none'
1076 1 0 33     4 || length($self->{'config'}->{'default_reader'}) < 1
      33        
      0        
1077             || $num_readers < 1;
1078              
1079 1         2 my @reader_list = ();
1080              
1081             # if a non-primary reader was selected (either in the YAML config or the opts hashref), populate
1082             # the reader_list array with candidates (__random will fill the list with all defined readers in
1083             # a randomized order; if a specific server was selected the list will contain only that entry)
1084 1 50 33     7 if (defined $self->{'config'}->{'default_reader'} && $self->{'config'}->{'default_reader'} ne 'primary') {
1085 0 0       0 if ($self->{'config'}->{'default_reader'} eq '__random') {
1086 0 0       0 if ($num_readers > 0) {
1087 0         0 @reader_list = keys %{$self->{'config'}->{'readers'}};
  0         0  
1088 0         0 $i = $#reader_list;
1089 0         0 while ($i--) {
1090 0         0 my $j = int rand ($i+1);
1091 0         0 @reader_list[$i,$j] = @reader_list[$j,$i];
1092             }
1093             }
1094             } else {
1095             die dslog("Non-existent reader database ($self->{'config'}->{'default_reader'}) selected!")
1096 0 0       0 unless exists $self->{'config'}->{'readers'}->{ $self->{'config'}->{'default_reader'} };
1097 0         0 @reader_list = ($self->{'config'}->{'default_reader'});
1098             }
1099             }
1100              
1101 1 50       3 if (scalar(@reader_list) < 1) {
1102             # if there is no selection for a reader, copy the objref of the primary DB
1103 1         9 $self->{'handles'}->{'reader'} = $self->{'handles'}->{'primary'};
1104 1         2 $self->{'config'}->{'default_reader'} = 'primary';
1105 1         3 $self->{'config'}->{'readers'} = { primary => $self->{'config'}->{'primary'} };
1106 1         2 $self->{'reader'} = 'primary';
1107             } else {
1108 0         0 my $found_reader = 0;
1109 0         0 foreach my $reader (@reader_list) {
1110 0         0 my ($dbh);
1111 0 0       0 if ($dbh = _db_connect(
1112             cache => $self->{'config'}->{'cache_connections'},
1113 0         0 %{$self->{'config'}->{'readers'}->{$reader}})
1114             ) {
1115             $self->{'handles'}->{'reader'} = _set_schema_searchpath(
1116             $dbh,
1117             $self->{'config'}->{'readers'}->{$reader}->{'driver'},
1118 0         0 $self->{'config'}->{'readers'}->{$reader}->{'schemas'}
1119             );
1120 0         0 $self->{'reader'} = $reader;
1121 0         0 $found_reader = 1;
1122 0         0 last;
1123             }
1124             }
1125              
1126 0 0       0 if ($found_reader != 1) {
1127 0         0 die dslog("No valid connection could be made to a reader database!");
1128             }
1129             }
1130              
1131             # quick reference flag for whether AutoCommit was turned off on the primary DB
1132             $self->{'autocommit'} =
1133             defined $self->{'config'}->{'primary'}->{'dbd_opts'}
1134             && ref($self->{'config'}->{'primary'}->{'dbd_opts'}) eq 'HASH'
1135             && defined $self->{'config'}->{'primary'}->{'dbd_opts'}->{'AutoCommit'}
1136 1 50 0     5 && $self->{'config'}->{'primary'}->{'dbd_opts'}->{'AutoCommit'} == 0
1137             ? 0 : 1;
1138              
1139             # Init the "in transaction" flag
1140 1         5 $self->{'in_tx'} = 0;
1141              
1142             # Init the statement counter. This counter is used to check if there have
1143             # been any non-select statements issued to the primary DB since the last
1144             # commit() or rollback(). While technically it is incremented for each
1145             # non-select statement, it cannot be relied on for an exact count of the
1146             # statements since the last rollback()/commit(), as selective rollbacks
1147             # of savepoints or nested transactions will not reset this counter (it is
1148             # only reset by the rollback() method if that rollback has the side effect
1149             # of the in_tx flag == 0. Why bother if it's not an exact counter? I'm
1150             # glad you asked! When AutoCommit is turned off for the primary DB, this
1151             # counter is used to determine whether to silence warnings/errors on the
1152             # extraneous calls to transaction methods, particularly in DESTROY. For
1153             # the exact details of when this silencing will occur, check out the
1154             # code in the various transaction methods.
1155 1         1 $self->{'st_count'} = 0;
1156              
1157             # if AutoCommit is set to 0 for the primary server, we automatically start out inside a
1158             # transaction
1159 1 50       3 if ($self->{'autocommit'} == 0) {
1160 0         0 $self->{'in_tx'} = 1;
1161             }
1162              
1163             # set up arrayref to hold any error strings (usually DBI errors)
1164 1         2 $self->{'errors'} = [];
1165              
1166 1         5 return bless($self, $class);
1167             }
1168              
1169             sub base_tables {
1170 0     0 1 0 my ($self) = @_;
1171              
1172 0         0 my $driver = lc($self->{'config'}->{'primary'}->{'driver'});
1173 0         0 my $schema = $self->{'handles'}->{'primary'}->quote($self->{'config'}->{'primary'}->{'db'});
1174              
1175 0         0 my ($sql);
1176              
1177 0 0       0 if ($driver eq 'mysql') {
    0          
    0          
    0          
1178 0         0 $sql = qq{
1179             select table_name
1180             from information_schema.tables
1181             where table_schema in ($schema)
1182             and table_type = 'BASE TABLE'
1183             order by table_name asc
1184             };
1185             } elsif ($driver eq 'pg') {
1186             # make sure we only list the relations visible in the current search_path
1187 0 0 0     0 if (defined $self->{'config'}->{'primary'}->{'schemas'}
1188             && ref($self->{'config'}->{'primary'}->{'schemas'}) eq 'ARRAY') {
1189 0         0 $schema = join(',', @{$self->{'config'}->{'primary'}->{'schemas'}});
  0         0  
1190             } else {
1191 0         0 $schema = q{'public'};
1192             }
1193              
1194 0         0 $sql = qq{
1195             select c.relname
1196             from pg_catalog.pg_class c
1197             join pg_catalog.pg_roles r on (r.oid = c.relowner)
1198             left join pg_catalog.pg_namespace n on (n.oid = c.relnamespace)
1199             where c.relkind in ('r')
1200             and n.nspname in ($schema)
1201             and pg_catalog.pg_table_is_visible(c.oid)
1202             order by relname asc
1203             };
1204             } elsif ($driver eq 'oracle') {
1205 0         0 $sql = q{
1206             select object_name
1207             from user_objects
1208             where object_type in ('TABLE')
1209             order by object_name asc
1210             };
1211             } elsif ($driver eq 'db2') {
1212 0         0 $sql = q{
1213             select tabname
1214             from syscat.tables
1215             where tabschema not like 'SYS%' and type in ('T')
1216             order by tabname asc
1217             };
1218             } else {
1219 0         0 die dslog("This method is not yet implemented for your database server ($driver).");
1220             }
1221              
1222 0         0 my $res = $self->do($sql);
1223              
1224 0 0       0 if ($res) {
1225 0         0 my @tables = ();
1226              
1227 0         0 while ($res->next) {
1228 0         0 push(@tables, $res->[0]);
1229             }
1230              
1231 0         0 return @tables;
1232             } else {
1233 0         0 die dslog("Error encountered when retrieving list of tables: $DBI::errstr");
1234             }
1235             }
1236              
1237             sub begin {
1238 2     2 1 665 my ($self) = shift;
1239              
1240             die dslog("Somehow there appears to be no driver defined for the primary database!")
1241 2 50       25 unless defined $self->{'config'}->{'primary'}->{'driver'};
1242              
1243 2         6 my $driver = lc($self->{'config'}->{'primary'}->{'driver'});
1244              
1245             # If AutoCommit is turned off, new transactions are automatically started on
1246             # connect and immediately after any existing transactions are closed (either
1247             # through commit or rollback). This has the side-effect of causing begin()
1248             # to trigger a fatal error from DBI's begin_work() every time it is called
1249             # (in the "DBI Way of Doing Things" you never actually call begin_work()
1250             # yourself if you turn off AutoCommit). Personally, I find this annoying
1251             # and a bit counter-intuitive, so DBIx::DataStore will let you call begin()
1252             # if you are currently in one of the implicitly created transactions and
1253             # you have AutoCommit turned off *and* you have issued NO non-select
1254             # statements to the database since either a) connecting or b) closing the
1255             # last transaction.
1256 2 0 33     26 if ($self->{'st_count'} == 0 && $self->{'in_tx'} == 1 && $self->{'autocommit'} == 0) {
      33        
1257 0         0 return 1;
1258             }
1259              
1260             # We need to make sure the primary database server supports transactions,
1261             # and further that it supports nested transactions if we're already inside
1262             # one when ->begin() is called.
1263 2 50       15 if ($driver eq 'mysql') {
    50          
    50          
    0          
1264 0 0       0 if ($self->{'in_tx'} > 0) {
1265 0         0 die dslog("MySQL does not support nested transactions!");
1266             }
1267             } elsif ($driver eq 'pg') {
1268 0 0       0 if ($self->{'in_tx'} > 0) {
1269 0         0 die dslog("PostgreSQL does not support nested transactions (use savepoints instead)!");
1270             }
1271             } elsif ($driver eq 'sqlite') {
1272 2 50       13 if ($self->{'in_tx'} > 0) {
1273 0         0 die dslog("SQLite does not support nested transactions!");
1274             }
1275             } elsif ($driver eq 'db2') {
1276 0 0       0 if ($self->{'in_tx'} > 0) {
1277 0         0 die dslog("DB2 does not support nested transactions (use savepoints instead)!");
1278             }
1279             }
1280              
1281 2 50       23 $self->{'handles'}->{'primary'}->begin_work
1282             || die dslog("Error encountered during attempt to begin transaction: $DBI::errstr");
1283              
1284 2         74 $self->{'in_tx'}++;
1285 2         15 return 1;
1286             }
1287              
1288             sub commit {
1289 1     1 1 2 my ($self) = @_;
1290              
1291 1 50       7 die dslog("Commit attempted without any open transactions!") unless $self->{'in_tx'} > 0;
1292              
1293 1 50       23 $self->{'handles'}->{'primary'}->commit
1294             || die dslog("Error encountered during attempt to commit transaction: $DBI::errstr");
1295              
1296 1         2 $self->{'in_tx'}--;
1297 1         2 $self->{'st_count'} = 0;
1298              
1299             # if AutoCommit is turned off on the primary DB, then the closing of a transaction
1300             # (either through a rollback or commit) automatically begins a new transaction, in
1301             # which case we need to re-increment the in_tx count
1302 1 50       4 if ($self->{'autocommit'} == 0) {
1303 0         0 $self->{'in_tx'}++;
1304             }
1305              
1306             # reset the search path when AutoCommit is turned off (since everything, including
1307             # the initial setting of this on connect happens within transactions)
1308 1 50 33     5 if ($self->{'autocommit'} == 0 && defined $self->{'config'}->{'primary'}->{'schemas'}) {
1309             _set_schema_searchpath($self->{'handles'}->{'primary'}, $self->{'config'}->{'primary'}->{'driver'},
1310 0         0 $self->{'config'}->{'primary'}->{'schemas'});
1311             }
1312              
1313 1         5 return 1;
1314             }
1315              
1316             sub databases {
1317 0     0 1 0 my ($self) = @_;
1318              
1319 0         0 my $driver = lc($self->{'config'}->{'primary'}->{'driver'});
1320              
1321 0         0 my ($sql);
1322              
1323 0 0       0 if ($driver eq 'mysql') {
    0          
    0          
1324 0         0 $sql = q{
1325             select schema_name
1326             from information_schema.schemata
1327             where schema_name not in ('information_schema','cluster')
1328             order by schema_name asc
1329             };
1330             } elsif ($driver eq 'pg') {
1331 0         0 $sql = q{
1332             select d.datname
1333             from pg_catalog.pg_database d
1334             join pg_catalog.pg_roles r on (d.datdba = r.oid)
1335             where datname not in ('postgres')
1336             and datname not like 'template%'
1337             order by datname asc
1338             };
1339             } elsif ($driver eq 'db2') {
1340 0         0 $sql = q{
1341             select schemaname
1342             from syscat.schemata
1343             where schemaname not like 'SYS%'
1344             order by schemaname asc
1345             };
1346             } else {
1347 0         0 die dslog("This method is not yet implemented for your database server ($driver).");
1348             }
1349              
1350 0         0 my $res = $self->do($sql);
1351              
1352 0 0       0 if ($res) {
1353 0         0 my @schemas = ();
1354              
1355 0         0 while ($res->next) {
1356 0         0 push(@schemas, $res->[0]);
1357             }
1358              
1359 0         0 return @schemas;
1360             } else {
1361 0         0 die dslog("Error encountered when retrieving list of database schemas: $DBI::errstr");
1362             }
1363             }
1364              
1365             sub db_primary {
1366 0     0 1 0 my ($self) = @_;
1367              
1368 0         0 my %config = %{$self->{'config'}->{'primary'}};
  0         0  
1369 0         0 $config{'name'} = 'primary';
1370              
1371             # remove "sensitive" fields from config
1372 0 0       0 delete $config{'pass'} if defined $config{'pass'};
1373              
1374 0         0 return { %config };
1375             }
1376              
1377             sub db_reader {
1378 0     0 1 0 my ($self) = @_;
1379              
1380             return unless defined $self->{'config'}->{'default_reader'}
1381 0 0 0     0 && exists $self->{'config'}->{'readers'}->{$self->{'config'}->{'default_reader'}};
1382              
1383 0         0 my %config = %{$self->{'config'}->{'readers'}->{$self->{'config'}->{'default_reader'}}};
  0         0  
1384              
1385 0 0       0 delete $config{'pass'} if defined $config{'pass'};
1386              
1387 0         0 return { %config };
1388             }
1389              
1390             sub do {
1391 19     19 1 9198 my ($self, @args) = @_;
1392              
1393 19         40 my $opts = {};
1394              
1395             # check first argument to see if options hashref was passed in before a SQL statement
1396 19 100 100     115 if (scalar(@args) > 1 && ref($args[0]) eq 'HASH') {
1397 1         5 $opts = shift @args;
1398             }
1399              
1400             # Default the pager settings unless caller passed in their own values. A
1401             # "page" value of <=0 denotes no paging to be used (IOW the query will not
1402             # be limited (at least by us -- the caller might have their own LIMIT in
1403             # there) and all possible results from the database will be available.
1404 19 100 66     108 $opts->{'per_page'} = 25 unless defined $opts->{'per_page'} && $opts->{'per_page'} =~ /^\d+$/o;
1405 19 100 66     87 $opts->{'page'} = -1 unless defined $opts->{'page'} && $opts->{'page'} =~ /^\d+$/o;
1406              
1407             # allow for overriding of statement preparation & caching on a per-query basis
1408             $opts->{'prepare'} = $self->{'config'}->{'prepare_statements'}
1409 19 50 33     92 unless defined $opts->{'prepare'} && $opts->{'prepare'} =~ /^\d+$/o;
1410              
1411             # pass the rest straight through for conversion from convenient-bindings to normal-bindings
1412 19         64 my ($st_type, $sql, @binds) = _transform_bindings(@args);
1413              
1414             # Figure out which DB handler we'll be using. If we're inside of a transaction,
1415             # it has to be the primary DB. But if we're not, then we check whether
1416             # reader_failover is turned on; if it is not, we just blindly set the currently
1417             # selected reader's handle, otherwise we go through the ping tests (keeping in
1418             # mind the flag_bad_readers setting as well) to find a new reader DB if the
1419             # current one doesn't succeed
1420 19         28 my $dbh;
1421 19 100 100     124 if ($self->{'in_tx'} > 0 || $st_type ne 'select') {
1422 11         32 $dbh = $self->{'handles'}->{'primary'};
1423             } else {
1424 8 50 33     36 if (exists $self->{'config'}->{'reader_failover'} && $self->{'config'}->{'reader_failover'} == 1) {
1425 0 0 0     0 my $flag_bad = exists $self->{'config'}->{'flag_bad_readers'} && $self->{'config'}->{'flag_bad_readers'} == 1
1426             ? 1 : 0;
1427 0 0       0 if (!$self->{'handles'}->{'reader'}->do("select 1")) {
1428 0 0       0 if ($self->{'config'}->{'default_reader'} eq 'primary') {
1429             # current reader was the primary DB... we're in trouble now
1430 0         0 die dslog("Primary database server failed connectivity test.");
1431             }
1432              
1433 0         0 my $reader_found = 0;
1434             # if flag_bad_readers is not turned on, we need to have a quasi-reasonable limit to the number
1435             # attempts we'll make to find a new reader, since the @new_readers list will never exhaust
1436             # itself (all readers will end up in it every single time, just in a random order)
1437 0         0 my $check_limit = scalar(keys(%{$self->{'config'}->{'readers'}})) * 2;
  0         0  
1438              
1439             CHECK_READER:
1440 0         0 while (!$reader_found) {
1441 0 0       0 if ($check_limit < 1) {
1442 0 0       0 dslog("Exhausted connection attempts to new reader databases. Giving up.") if DEBUG();
1443 0         0 last CHECK_READER;
1444             }
1445 0 0       0 dslog("Current reader $self->{'config'}->{'default_reader'} failed ping test. Choosing new reader.")
1446             if DEBUG();
1447              
1448 0         0 my (@new_readers);
1449 0 0       0 if ($flag_bad) {
1450 0         0 $self->{'config'}->{'readers'}->{ $self->{'config'}->{'default_reader'} }->{'failure'} = time();
1451 0         0 @new_readers = grep { !exists $self->{'config'}->{'readers'}->{$_}->{'failure'} }
1452 0         0 keys %{$self->{'config'}->{'readers'}};
  0         0  
1453             } else {
1454 0         0 @new_readers = keys %{$self->{'config'}->{'readers'}};
  0         0  
1455             }
1456              
1457 0 0       0 last CHECK_READER if scalar(@new_readers) < 1;
1458              
1459             # randomly sort the new reader DB list
1460 0         0 my $i = $#new_readers;
1461 0         0 while ($i--) {
1462 0         0 my $j = int rand ($i+1);
1463 0         0 @new_readers[$i,$j] = @new_readers[$j,$i];
1464             }
1465              
1466 0         0 my $reader = $new_readers[0];
1467              
1468 0 0       0 if ($dbh = _db_connect(
1469             cache => $self->{'config'}->{'cache_connections'},
1470 0         0 %{$self->{'config'}->{'readers'}->{$reader}}))
1471             {
1472             # touch of extra paranoia... make sure we really did connect properly (since
1473             # there is an ever-so-slight chance that connection caching, if turned on,
1474             # might be deceiving us)
1475 0 0       0 if ($dbh->do("select 1")) {
1476 0         0 $self->{'config'}->{'default_reader'} = $reader;
1477 0         0 $self->{'handles'}->{'reader'} = $dbh;
1478 0         0 $reader_found = 1;
1479             }
1480             }
1481 0         0 $check_limit--;
1482             }
1483              
1484             # if a new reader wasn't found, make one last attempt by pinging the primary and using it
1485 0 0       0 if (!$reader_found) {
1486 0 0       0 if ($self->{'handles'}->{'primary'}->do("select 1")) {
1487 0         0 $self->{'handles'}->{'reader'} = $self->{'handles'}->{'primary'};
1488 0         0 $self->{'config'}->{'default_reader'} = 'primary';
1489 0         0 $dbh = $self->{'handles'}->{'primary'};
1490             } else {
1491 0         0 die dslog("Failure attempting to fall back on primary database for reads after all readers failed.");
1492             }
1493             }
1494             } else {
1495 0         0 $dbh = $self->{'handles'}->{'reader'};
1496             }
1497             } else {
1498 8         22 $dbh = $self->{'handles'}->{'reader'};
1499             }
1500             }
1501              
1502             # if we intend to bypass normal statement preparation with placeholders, we need to
1503             # now replace all of them with their actual values (properly quoted, of course) so
1504             # the underlying DBD::* driver doesn't spend time on this
1505 19 50       52 if (!$opts->{'prepare'}) {
1506 19 50       779 dslog("Manually replacing placeholders prior to statement execution.") if DEBUG();
1507 19         88 $sql =~ s{(\s+|,|\(|\=)\?(\s*)}{$1 . $dbh->quote(shift(@binds)) . $2}egsix;
  15         138  
1508             }
1509              
1510 19         83 my $unpaged_sql = $sql;
1511              
1512 19 100       63 if ($opts->{'page'} > 0) {
1513             # Caller wants auto-paging, so validate that the original query doesn't end with a
1514             # LIMIT clause and add our own
1515             my $driver = $self->{'in_tx'} > 0
1516             ? lc($self->{'config'}->{'primary'}->{'driver'})
1517 1 50       14 : lc($self->{'config'}->{'readers'}->{$self->{'config'}->{'default_reader'}}->{'driver'});
1518              
1519             # Warn if it appears there is already a limiting clause in the original query (but in
1520             # the event we misidentify something else as a limiting clause, give it a chance to run
1521             # and let the database server reject it if it really is invalid).
1522 1 50 33     19 if ($sql =~ /limit\s+\d+(\s+offset\s+\d+|\s*,\s*\d+)\s*$/ois
1523             || $sql =~ /rows\s+\d+(\s+to\s+\d+)\s*$/ois
1524             ) {
1525 0 0       0 dslog("Paging requested on a query that appears to already have a limiting clause. Attempting anyway.")
1526             if DEBUG();
1527             }
1528              
1529 1         6 my $limit_offset = ($opts->{'page'} - 1) * $opts->{'per_page'};
1530 1 50       20 $limit_offset = 0 unless $limit_offset > 0;
1531 1         3 my $limit_last = $limit_offset + $opts->{'per_page'} - 1;
1532              
1533             # Add appropriate limiting clause syntax based on current database server
1534 1 50       5 if (exists { map { $_ => '' } qw( mysql pg sqlite ) }->{$driver}) {
  3 0       15  
1535 1         9 $sql .= qq{ limit $opts->{'per_page'} offset $limit_offset };
1536 0         0 } elsif (exists { map { $_ => '' } qw( interbase firebird ) }->{$driver}) {
1537 0         0 $sql .= qq{ rows $limit_offset to $limit_last };
1538             } else {
1539             # TODO: Possibly use SQL::Abstract::Limit to handle other databases (which all pretty
1540             # pretty much support much more complicated ways of achieving the same effect).
1541 0         0 die dslog("Automated result set paging is not currently supported for this database server ($driver). Sorry.");
1542             }
1543             }
1544              
1545             # prepare & execute the query
1546 19         23 my ($dbi_res, $sth);
1547              
1548 19         28 my $error = 0;
1549              
1550 19 50       40 if ($opts->{'prepare'}) {
1551 0 0 0     0 if (defined $self->{'config'}->{'cache_statements'} && $self->{'config'}->{'cache_statements'} == 1) {
1552             # DBI prepare_cached's "if_active" argument (the third one) is passed in as 3 since
1553             # that is supposed to be the safest method (if there's a cached version of the same
1554             # query, but it's currently active, it's removed from the cache and a new statement
1555             # is created -- thus the currently-active handle that was in the cache is not
1556             # affected in any way by what may be done with the new handle)
1557 0 0       0 unless ($sth = $dbh->prepare_cached($sql, $opts, 3)) {
1558 0 0       0 dslog("Error encountered when preparing cached SQL statement: $DBI::errstr") if DEBUG();
1559 0         0 $error = 1;
1560             }
1561             } else {
1562 0 0       0 unless ($sth = $dbh->prepare($sql, $opts)) {
1563 0 0       0 dslog("Error encountered when preparing SQL statement: $DBI::errstr") if DEBUG();
1564 0         0 $error = 1;
1565             }
1566             }
1567              
1568 0 0       0 if ($error == 0) {
1569 0 0       0 unless ($dbi_res = $sth->execute(@binds)) {
1570 0 0       0 dslog("Error encountered when executing SQL statement: $DBI::errstr") if DEBUG();
1571 0         0 $error = 1;
1572             }
1573             }
1574             } else {
1575             # query will run without prior preparation (this can be desired with some databases on
1576             # various queries where to come up with the best (or even a reasonable) plan requires
1577             # the database's planner to know the actual values instead of having placeholders)...
1578             # if we're in here, it also means that _transform_binds() removed all the placeholders
1579             # and put in the actual values, so we don't need to pass @binds into execute()
1580 19 100 66     113 if ($st_type ne 'select' && $sql !~ /\s+returning\s+\w+(\s*,\s*\w+)*\s*/ois) {
1581             # no intermediary statement handler necessary, since we're apparently issuing
1582             # non-SELECT DML that does not end with a RETURNING clause
1583 8         34 $sth = { NAME => [], NAME_hash => [] }; # dummy these up so we don't die below
1584              
1585 8 50       63 unless ($dbi_res = $dbh->do($sql)) {
1586 0 0       0 dslog("Error calling DBI do() method on pre-bound, unprepared SQL statement: $DBI::errstr") if DEBUG();
1587 0         0 $error = 1;
1588             }
1589             } else {
1590 11 50       120 if ($sth = $dbh->prepare($sql, $opts)) {
1591 11 50       2304 unless ($dbi_res = $sth->execute()) {
1592 0 0       0 dslog("Error executing pre-bound SQL statement: $DBI::errstr") if DEBUG();
1593 0         0 $error = 1;
1594             }
1595             } else {
1596 0 0       0 dslog("Error encountered preparing pre-bound SQL statement: $DBI::errstr") if DEBUG();
1597 0         0 $error = 1;
1598             }
1599             }
1600             }
1601              
1602 19 100       1483 $self->{'st_count'}++ unless $st_type eq 'select';
1603              
1604             # Set up skeleton for a DBIx::DataStore::ResultSet object
1605 19         133 my $results = DBIx::DataStore::ResultRow->new({},{},[]);
1606 19         42 bless($results, 'DBIx::DataStore::ResultSet');
1607              
1608 19 50       46 $$results->{'error'} = $DBI::errstr if $error;
1609              
1610 19         89 $$results->{'_st_type'} = $st_type;
1611 19         31 $$results->{'_sql'} = $unpaged_sql;
1612 19         48 $$results->{'_binds'} = [ @binds ];
1613              
1614 19         34 $$results->{'_rows'} = $dbi_res;
1615 19         32 $$results->{'_dbh'} = $dbh;
1616 19         55 $$results->{'_sth'} = $sth;
1617              
1618 19         61 $$results->{'_page_num'} = $opts->{'page'};
1619 19         34 $$results->{'_page_per'} = $opts->{'per_page'};
1620              
1621 19         191 $$results->{'impl'}->[DBIx::DataStore::ResultRow::KEYS()] = $sth->{'NAME'};
1622 19         253 $$results->{'impl'}->[DBIx::DataStore::ResultRow::INDEX()] = $sth->{'NAME_hash'};
1623              
1624 19         162 return $results;
1625             }
1626              
1627             sub in_transaction {
1628 1     1 1 4 my ($self) = @_;
1629              
1630 1 50 33     18 return 1 if defined $self->{'in_tx'} && $self->{'in_tx'} > 0;
1631 0         0 return;
1632             }
1633              
1634             sub last_insert_id {
1635 2     2 1 748 my ($self, @args) = @_;
1636              
1637 2         5 my $driver = lc($self->{'config'}->{'primary'}->{'driver'});
1638              
1639             # fill in pass-through args with dummy values, since MySQL & Informix don't actually
1640             # support the full possibilities of this DBI function
1641 2 50       4 if (exists { map { $_ => '' } qw( mysql informix ) }->{$driver}) {
  4         16  
1642 0         0 $args[$_] = 'X' for (1..3);
1643             }
1644              
1645 2 50       17 if (my $id = $self->{'handles'}->{'primary'}->last_insert_id(@args)) {
1646 2         13 return $id;
1647             } else {
1648 0         0 die dslog("Error obtaining the Last Insert ID: $DBI::errstr");
1649             }
1650             }
1651              
1652             sub ping {
1653 0     0 1 0 my ($self) = @_;
1654              
1655             # Make sure we don't double-ping the primary server if it is both primary & reader
1656 0 0       0 my @servers = $self->{'config'}->{'default_reader'} eq 'primary' ? qw( primary ) : qw( primary reader );
1657              
1658 0         0 foreach my $server (@servers) {
1659 0 0       0 if (!$self->{'handles'}->{$server}->do("select 1")) {
1660 0 0       0 dslog("Error pinging $server database server: " . $self->{'handles'}->{$server}->errstr) if DEBUG();
1661 0         0 return;
1662             }
1663             }
1664              
1665 0         0 return 1;
1666             }
1667              
1668             sub rollback {
1669 2     2 1 7 my ($self, $savepoint) = @_;
1670              
1671 2 50       10 die dslog("Rollback attempted without any open transactions!") unless $self->{'in_tx'} > 0;
1672              
1673             # If a savepoint name was passed in, we have to issue the rollback statement ourselves,
1674             # since DBI doesn't support that syntax through it's rollback() method and an informally
1675             # proposed rollbackto() method on dbi-users hasn't been accepted by the DBI devs yet.
1676 2 100       8 if (defined $savepoint) {
1677 1         6 my $driver = lc($self->{'config'}->{'primary'}->{'driver'});
1678 1         4 my ($sql);
1679              
1680 1 50       9 if ($driver eq 'sybase') {
    50          
1681 0         0 die dslog("Savepoints are not supported by Sybase!");
1682             } elsif ($driver eq 'pg') {
1683 0 0       0 if (!$self->{'handles'}->{'primary'}->pg_rollback_to($savepoint)) {
1684 0         0 die dslog("Error rolling back to savepoint '$savepoint':", $self->{'handles'}->{'primary'}->errstr);
1685             }
1686             } else {
1687             $savepoint = $self->{'handles'}->{'primary'}->quote($savepoint)
1688 1   50     10 || die dslog("Error encountered when safe-quoting savepoint name:", $self->{'handles'}->{'primary'}->errstr);
1689              
1690 1         22 $sql = qq{ rollback to savepoint $savepoint };
1691              
1692 1 50       11 if (!$self->{'handles'}->{'primary'}->do($sql)) {
1693 0         0 die dslog("Error rolling back to savepoint '$savepoint':", $self->{'handles'}->{'primary'}->errstr);
1694             }
1695             }
1696              
1697             # Note that we do not decrement the transaction level counter, since we rolled
1698             # back *within* a transaction, we didn't rollback the transaction itself.
1699             } else {
1700 1 50       30 $self->{'handles'}->{'primary'}->rollback
1701             || die dslog("Error encountered during attempt to roll back transaction: $DBI::errstr");
1702              
1703 1         3 $self->{'in_tx'}--;
1704 1         2 $self->{'st_count'} = 0;
1705             }
1706              
1707             # if AutoCommit is turned off on the primary DB, then the closing of a transaction
1708             # (either through a rollback or commit) automatically begins a new transaction, in
1709             # which case we need to re-increment the in_tx count
1710 2 50       67 if ($self->{'autocommit'} == 0) {
1711 0         0 $self->{'in_tx'}++;
1712             }
1713              
1714             # reset schema search path if AutoCommit is turned off (since the setting of the
1715             # search path on connect would have occurred inside a transaction -- how annoying)
1716 2 50 33     10 if ($self->{'autocommit'} == 0 && defined $self->{'config'}->{'primary'}->{'schemas'}) {
1717             _set_schema_searchpath($self->{'handles'}->{'primary'}, $self->{'config'}->{'primary'}->{'driver'},
1718 0         0 $self->{'config'}->{'primary'}->{'schemas'});
1719             }
1720              
1721 2         11 return 1;
1722             }
1723              
1724             sub savepoint {
1725 1     1 1 2 my ($self, $savepoint) = @_;
1726              
1727 1 50       5 die dslog("Cannot create a savepoint outside of a transaction context!") unless $self->{'in_tx'} > 0;
1728 1 50 33     45 die dslog("No savepoint name was provided!") unless defined $savepoint && $savepoint =~ /\w+/o;
1729              
1730 1         6 my $driver = lc($self->{'config'}->{'primary'}->{'driver'});
1731              
1732             # DBI does not provide savepoint related methods (yet, at least -- there's been discussion
1733             # on the mailing lists about whether or not it should, and if so what they should be), so
1734             # we need to just build the statement ourself and issue it.
1735 1         3 my ($sql);
1736              
1737 1 50       33 if ($driver eq 'sybase') {
    50          
1738 0         0 die dslog("Sybase does not support transaction savepoints!");
1739             } elsif ($driver eq 'pg') {
1740 0 0       0 if (!$self->{'handles'}->{'primary'}->pg_savepoint($savepoint)) {
1741 0         0 die dslog("Error creating transaction savepoint '$savepoint': " . $self->{'handles'}->{'primary'}->errstr);
1742             }
1743             } else {
1744             $savepoint = $self->{'handles'}->{'primary'}->quote($savepoint)
1745 1   50     11 || die dslog("Error encountered when safe-quoting savepoint name: " . $self->{'handles'}->{'primary'}->errstr);
1746              
1747 1         23 $sql = qq{ savepoint $savepoint };
1748              
1749 1 50       9 if (!$self->{'handles'}->{'primary'}->do($sql)) {
1750 0         0 die dslog("Error creating transaction savepoint '$savepoint': " . $self->{'handles'}->{'primary'}->errstr);
1751             }
1752             }
1753              
1754 1         37 return 1;
1755             }
1756              
1757             sub schemas {
1758 0     0 1 0 my ($self, $schemas) = @_;
1759              
1760 0 0 0     0 if (defined $schemas && ref($schemas) eq 'ARRAY') {
1761 0 0       0 dslog(q{Got request to change schemas on existing connection.}) if DEBUG() >= 2;
1762 0         0 $self->{'config'}->{'primary'}->{'schemas'} = [@{$schemas}];
  0         0  
1763             $self->{'config'}->{'readers'}->{$self->{'reader'}}->{'schemas'} = $self->{'config'}->{'primary'}->{'schemas'}
1764 0 0       0 if $self->{'reader'} ne 'primary';
1765             _set_schema_searchpath(
1766             $self->{'handles'}->{'primary'},
1767 0         0 $self->{'config'}->{'primary'}->{'driver'},
1768             $schemas
1769             );
1770             _set_schema_searchpath(
1771             $self->{'handles'}->{'reader'},
1772             $self->{'config'}->{'readers'}->{$self->{'reader'}}->{'driver'},
1773             $schemas
1774 0 0       0 ) if $self->{'reader'} ne 'primary';
1775             } else {
1776 0 0       0 dslog(q{Current schema search path requested.}) if DEBUG() >= 4;
1777 0         0 return @{$self->{'config'}->{'primary'}->{'schemas'}}
1778             if defined $self->{'config'}->{'primary'}->{'schemas'}
1779             && ref($self->{'config'}->{'primary'}->{'schemas'}) eq 'ARRAY'
1780 0 0 0     0 && scalar(@{$self->{'config'}->{'primary'}->{'schemas'}}) > 0;
  0   0     0  
1781             }
1782              
1783 0         0 return;
1784             }
1785              
1786             sub servers {
1787 0     0 1 0 my ($self) = @_;
1788              
1789 0         0 my @servers = ();
1790              
1791 0         0 my %config = %{$self->{'config'}->{'primary'}};
  0         0  
1792 0         0 $config{'name'} = 'primary';
1793 0 0       0 delete $config{'password'} if defined $config{'password'};
1794              
1795 0         0 push(@servers, { %config });
1796              
1797 0         0 foreach my $reader (sort keys %{$self->{'config'}->{'readers'}}) {
  0         0  
1798 0         0 %config = %{$self->{'config'}->{'readers'}->{$reader}};
  0         0  
1799 0 0       0 delete $config{'password'} if defined $config{'password'};
1800 0         0 $config{'name'} = $reader;
1801 0         0 push(@servers, { %config });
1802             }
1803              
1804 0         0 return @servers;
1805             }
1806              
1807             sub tables {
1808 0     0 1 0 my ($self) = @_;
1809              
1810 0         0 my $driver = lc($self->{'config'}->{'primary'}->{'driver'});
1811 0         0 my $schema = $self->{'handles'}->{'primary'}->quote($self->{'config'}->{'primary'}->{'db'});
1812              
1813 0         0 my ($sql);
1814              
1815 0 0       0 if ($driver eq 'mysql') {
    0          
    0          
    0          
1816 0         0 $sql = qq{
1817             select table_name
1818             from information_schema.tables
1819             where table_schema in ($schema)
1820             order by table_name asc
1821             };
1822             } elsif ($driver eq 'pg') {
1823             # make sure we only list the relations visible in the current search_path
1824 0 0 0     0 if (defined $self->{'config'}->{'primary'}->{'schemas'}
1825             && ref($self->{'config'}->{'primary'}->{'schemas'}) eq 'ARRAY') {
1826 0         0 $schema = join(',', @{$self->{'config'}->{'primary'}->{'schemas'}});
  0         0  
1827             } else {
1828 0         0 $schema = q{'public'};
1829             }
1830              
1831 0         0 $sql = qq{
1832             select c.relname
1833             from pg_catalog.pg_class c
1834             join pg_catalog.pg_roles r on (r.oid = c.relowner)
1835             left join pg_catalog.pg_namespace n on (n.oid = c.relnamespace)
1836             where c.relkind in ('r','v')
1837             and n.nspname in ($schema)
1838             and pg_catalog.pg_table_is_visible(c.oid)
1839             order by relname asc
1840             };
1841             } elsif ($driver eq 'oracle') {
1842 0         0 $sql = q{
1843             select object_name
1844             from user_objects
1845             where object_type in ('TABLE','VIEW')
1846             order by object_name asc
1847             };
1848             } elsif ($driver eq 'db2') {
1849 0         0 $sql = q{
1850             select tabname
1851             from syscat.tables
1852             where tabschema not like 'SYS%' and type in ('T','V')
1853             order by tabname asc
1854             };
1855             } else {
1856 0         0 die dslog("This method is not yet implemented for your database server ($driver).");
1857             }
1858              
1859 0         0 my $res = $self->do($sql);
1860              
1861 0 0       0 if ($res) {
1862 0         0 my @tables = ();
1863              
1864 0         0 while ($res->next) {
1865 0         0 push(@tables, $res->[0]);
1866             }
1867              
1868 0         0 return @tables;
1869             } else {
1870 0         0 die dslog("Error encountered when retrieving list of tables: $DBI::errstr");
1871             }
1872             }
1873              
1874             sub views {
1875 0     0 1 0 my ($self) = @_;
1876              
1877 0         0 my $driver = lc($self->{'config'}->{'primary'}->{'driver'});
1878 0         0 my $schema = $self->{'handles'}->{'primary'}->quote($self->{'config'}->{'primary'}->{'db'});
1879              
1880 0         0 my ($sql);
1881              
1882 0 0       0 if ($driver eq 'mysql') {
    0          
    0          
    0          
1883 0         0 $sql = qq{
1884             select table_name
1885             from information_schema.tables
1886             where table_schema in ($schema)
1887             and table_type = 'VIEW'
1888             order by table_name asc
1889             };
1890             } elsif ($driver eq 'pg') {
1891             # make sure we only list the relations visible in the current search_path
1892 0 0 0     0 if (defined $self->{'config'}->{'primary'}->{'schemas'}
1893             && ref($self->{'config'}->{'primary'}->{'schemas'}) eq 'ARRAY') {
1894 0         0 $schema = join(',', @{$self->{'config'}->{'primary'}->{'schemas'}});
  0         0  
1895             } else {
1896 0         0 $schema = q{'public'};
1897             }
1898              
1899 0         0 $sql = qq{
1900             select c.relname
1901             from pg_catalog.pg_class c
1902             join pg_catalog.pg_roles r on (r.oid = c.relowner)
1903             left join pg_catalog.pg_namespace n on (n.oid = c.relnamespace)
1904             where c.relkind in ('v')
1905             and n.nspname in ($schema)
1906             and pg_catalog.pg_table_is_visible(c.oid)
1907             order by relname asc
1908             };
1909             } elsif ($driver eq 'oracle') {
1910 0         0 $sql = q{
1911             select object_name
1912             from user_objects
1913             where object_type = 'VIEW'
1914             order by object_name asc
1915             };
1916             } elsif ($driver eq 'db2') {
1917 0         0 $sql = q{
1918             select tabname
1919             from syscat.tables
1920             where tabschema not like 'SYS%' and type in ('V')
1921             order by tabname asc
1922             };
1923             } else {
1924 0         0 die dslog("This method is not yet implemented for your database server ($driver).");
1925             }
1926              
1927 0         0 my $res = $self->do($sql);
1928              
1929 0 0       0 if ($res) {
1930 0         0 my @views = ();
1931              
1932 0         0 while ($res->next) {
1933 0         0 push(@views, $res->[0]);
1934             }
1935              
1936 0         0 return @views;
1937             } else {
1938 0         0 die dslog("Error encountered when retrieving list of tables: $DBI::errstr");
1939             }
1940             }
1941              
1942             #######################################################################
1943             # Internal/Private Subroutines
1944              
1945             sub DESTROY {
1946 1     1   679 my ($self) = shift;
1947              
1948             # If primary handle is in a transaction, cluck out a warning and issue a rollback
1949             # (Note that the while{} is used to support nested-transactions, assuming the
1950             # underlying DB supports them -- whether nested transactions are supported is
1951             # actually checked elsewhere, so if it isn't this while loop will only ever
1952             # have a single iteration).
1953 1         260 while ($self->{'in_tx'} > 0) {
1954             # Don't issue the warning when AutoCommit is turned off, we're in an implicitly created
1955             # transaction and no non-select statements have been issued in the current transaction
1956 0 0 0     0 unless ($self->{'st_count'} == 0 && $self->{'in_tx'} == 1 && $self->{'autocommit'} == 0) {
      0        
1957 0 0       0 dslog("Database connection killed during a transaction!") if DEBUG();
1958             }
1959 0 0       0 $self->{'handles'}->{'primary'}->rollback
1960             || dslog("Attempted to rollback unclosed transaction but failed: $DBI::errstr");
1961 0         0 $self->{'in_tx'}--;
1962             }
1963             }
1964              
1965             sub _db_connect {
1966 1     1   3 my %args = (
1967             cache => 0,
1968             dbd_opts => {},
1969             @_,
1970             );
1971              
1972 1         1 my ($dsn);
1973              
1974             # if a custom DSN was present in the configuration, then just use it
1975 1 50 33     6 if (defined $args{'dsn'} && length($args{'dsn'}) > 0) {
1976             # Required DBI connection arguments when manual DSN specified
1977 1         3 foreach (qw( driver )) {
1978 1 50       3 if (!exists $args{$_}) {
1979 0 0       0 dslog("DBI connection attempted without providing '$_' argument!") if DEBUG() >= 3;
1980 0         0 return;
1981             }
1982             }
1983              
1984 1         2 $dsn = $args{'dsn'};
1985             # otherwise, build the DSN ourselves
1986             } else {
1987             # Required DBI connection arguments
1988 0         0 foreach (qw( driver database host )) {
1989 0 0       0 if (!exists $args{$_}) {
1990 0 0       0 dslog("DBI connection attempted without providing '$_' argument!") if DEBUG() >= 3;
1991 0         0 return;
1992             }
1993             }
1994              
1995             # Technically optional arguments that are almost always actually required for a good connection
1996 0         0 foreach (qw( user password )) {
1997 0 0       0 if (!exists $args{$_}) {
1998 0 0       0 dslog("DBI connection arguments do not contain '$_' argument. We'll try connecting anyway.") if DEBUG() >= 3;
1999 0         0 $args{$_} = '';
2000             }
2001             }
2002              
2003 0         0 $dsn = qq|dbi:$args{'driver'}:database=$args{'database'};host=$args{'host'}|;
2004 0 0 0     0 $dsn .= qq|;port=$args{'port'}| if defined $args{'port'} && $args{'port'} =~ /^\d+$/;
2005             }
2006              
2007 1 50       25 dslog(q{Connecting with DSN}, $dsn) if DEBUG();
2008              
2009 1         2 my ($dbh);
2010              
2011             # if DBI connection caching is desired, use connect_cached() method instead
2012             # also, issue immediate rollback after connecting, just in case we've been
2013             # returned a stale cached connection that had never closed its transaction
2014 1 50 33     15 if ($args{'cache'} && ($dbh = DBI->connect_cached($dsn, $args{'user'}, $args{'password'}, $args{'dbd_opts'}))) {
    50 33        
2015 0 0       0 $dbh->rollback if $dbh->ping >= 3;
2016 0 0       0 dslog(q{Returning DB connection from DBI's connect_cached.}) if DEBUG() >= 3;
2017 0         0 return $dbh;
2018             } elsif (!$args{'cache'} && ($dbh = DBI->connect($dsn, $args{'user'}, $args{'password'}, $args{'dbd_opts'}))) {
2019 1 50       1277 $dbh->rollback if $dbh->ping >= 3;
2020 1 50       60 dslog(q{Returning DB connection from DBI's connect.}) if DEBUG() >= 3;
2021 1         6 return $dbh;
2022             } else {
2023 0 0       0 dslog("DBI connection attempt failed: $DBI::errstr") if DEBUG();
2024 0         0 return;
2025             }
2026              
2027 0         0 return;
2028             }
2029              
2030             sub _set_schema_searchpath {
2031 1     1   3 my ($dbh, $driver, $schemas) = @_;
2032              
2033 1 50       26 dslog(q{Search path setter entered.}) if DEBUG() >= 4;
2034              
2035 1 50       3 if (!defined $driver) {
2036 0 0       0 dslog("No driver name supplied during search path configuration") if DEBUG();
2037 0         0 return;
2038             }
2039              
2040             # schema search path support is only available for PostgreSQL for now
2041 1 50       6 return $dbh unless lc($driver) eq 'pg';
2042              
2043 0 0 0     0 if (!defined $schemas || ref($schemas) ne 'ARRAY' || scalar(@{$schemas}) < 1) {
  0   0     0  
2044 0 0       0 dslog("No schema names provided for inclusion in search path") if DEBUG();
2045 0         0 return;
2046             }
2047              
2048 0 0       0 dslog(q{Changing connection's schema search path to}, join(', ', @{$schemas})) if DEBUG() >= 2;
  0         0  
2049              
2050             # quote the schema names for paranoia
2051 0         0 my @s;
2052 0         0 push(@s, $dbh->quote($_)) for @{$schemas};
  0         0  
2053              
2054 0         0 my ($sql);
2055              
2056 0 0       0 if (lc($driver) eq 'pg') {
2057 0         0 $sql = 'set search_path to ' . join(', ', @s);
2058             }
2059              
2060 0 0       0 if (length($sql) > 0) {
2061 0 0       0 if ($dbh->do($sql)) {
2062 0         0 return $dbh;
2063             } else {
2064 0         0 dslog(q{Error occurred when setting schema search path:}, $dbh->errstr);
2065 0         0 return;
2066             }
2067             } else {
2068 0 0       0 dslog(q{No SQL to issue for setting schemas.}) if DEBUG() >= 2;
2069 0         0 return $dbh;
2070             }
2071              
2072 0         0 return;
2073             }
2074              
2075             sub _transform_bindings {
2076 19     19   38 my ($sql, @binds) = @_;
2077              
2078             # certain SQL statement types allow different styles of binding (i.e. hashrefs for insert/update
2079             # but not select, delete, create, etc.)
2080 19         156 $sql =~ s/(^\s+|\s+$)//os;
2081 19         103 my $st_type = lc( ($sql =~ /^(\w+)\s+/os)[0] );
2082 19 50       58 $st_type = 'select' if $st_type eq 'with'; # ugh (stupid workaround for legacy DataStore - rewrite is/will be much smarter about this and not just take random stabs in the dark)
2083              
2084             # if no bound variables were passed in, we can save a few cycles by returning right here
2085 19 100 66     109 return ($st_type, $sql) if !@binds || scalar(@binds) < 1;
2086              
2087 6         8 my @final_binds = ();
2088              
2089             # verify that binds passed in are appropriate for the type of statement being used
2090 6 50 66     120 if ($st_type eq 'update' && $sql =~ /\s+set\s+$HASH_PH/ois && (scalar(@binds) < 1 || ref($binds[0]) ne 'HASH')) {
    50 33        
    100 66        
      66        
      33        
      66        
      66        
2091 0         0 die dslog("First bind on UPDATE statements must be a hash reference when not using an explicit SET clause!");
2092             } elsif ($st_type eq 'insert' && $sql =~ /^\s*insert\s+into\s+\S+\s+(values\s+)?$HASH_PH/ois
2093             && (scalar(@binds) < 1 || !(ref($binds[0]) eq 'ARRAY' || ref($binds[0]) eq 'HASH'))) {
2094 0         0 die dslog("First bind on INSERT must be hash reference (or array reference of hash references) when using "
2095             . "a hash placeholder in the columns-values clause!");
2096             } elsif ($st_type eq 'select' && scalar(@binds) > 0) {
2097 3         6 foreach (@binds) {
2098 3 50       10 if (ref($_) eq 'HASH') {
2099 0         0 die dslog("Hash reference binds not permitted for SELECT statements!");
2100             }
2101             }
2102             }
2103              
2104             # for update statements, rework the first placeholder into a "set key = ?, ..." form and take
2105             # it off the list of binds. this is only done if a hashref placeholder was used, though
2106 6 100 66     19 if ($st_type eq 'update' && $sql =~ /$HASH_PH/o) {
2107 1 50       16 if ($sql =~ s/(set\s+)$HASH_PH(\s*)/ $1 . join(', ', map { "$_ = ?" } sort keys %{$binds[0]}) . $2 /siex) {
  1         2  
  1         9  
  1         4  
2108 1         1 push(@final_binds, $binds[0]->{$_}) for sort keys %{$binds[0]};
  1         5  
2109             # remove the bind from the list so that the catch-all bind code down below doesn't
2110             # try to reuse it (since updates can, and almost always will, have additional binds
2111             # after the hashref in the SET clause)
2112 1         2 shift @binds;
2113             }
2114             }
2115              
2116             # -- this only happens when a hash placeholder is used in the col-vals clause of an insert --
2117             # for insert statements, we need to figure out which columns we're inserting, place those
2118             # into $sql, then add the actual values list(s)' placeholders... however, we only do
2119             # any of this if the caller used a '???' placeholder in the query (if the caller passed in
2120             # something like "insert into tblX (a,b,c) values (?,?,?)" then we won't do anything
2121             # special here, and the placeholders will just be handled by the catch-all code lower down
2122 6 100 66     37 if ($st_type eq 'insert' && $sql =~ /^\s*insert\s+into\s+\S+\s+(values\s+)?$HASH_PH/ois) {
2123 2         4 my @cols = ();
2124 2 100       7 if (ref($binds[0]) eq 'HASH') {
    50          
2125 1         2 @cols = sort keys %{$binds[0]};
  1         5  
2126             } elsif (ref($binds[0]) eq 'ARRAY') {
2127 1         3 @cols = sort keys %{$binds[0]->[0]};
  1         6  
2128             }
2129              
2130 2 50       6 die dslog("No columns defined for insert statement!") if scalar(@cols) < 1;
2131              
2132 2         5 my $ph_replacement = '(' . join(',', @cols) . ') values ';
2133              
2134 2 100       5 my $rec_count = ref($binds[0]) eq 'ARRAY' ? scalar(@{$binds[0]}) : 1;
  1         2  
2135              
2136 2         15 $ph_replacement .= join(', ', ('(' . join(',', ('?') x scalar(@cols)) . ')') x $rec_count);
2137              
2138 2         40 $sql =~ s/^(\s*insert\s+into\s+\S+)\s+(?:values\s+)?$HASH_PH\s+(.*)/$1 $ph_replacement $2/si;
2139              
2140 2 100       7 if (ref($binds[0]) eq 'ARRAY') {
2141 1         1 foreach my $rec (@{$binds[0]}) {
  1         13  
2142 3         9 push(@final_binds, $rec->{$_}) for @cols;
2143             }
2144             } else {
2145 1         4 push(@final_binds, $binds[0]->{$_}) for @cols;
2146             }
2147              
2148             # remove the first bind from the list in case there are others (almost exclusively
2149             # in the case where the insert is getting its values from a select)
2150 2         5 shift @binds;
2151             }
2152              
2153             # now that the special cases have been handled, we can loop through the remaining
2154             # binds, handling the arrayref ones (for IN (...) lists) as we run into them
2155 6         9 foreach my $bind (@binds) {
2156 4 100       8 if (ref($bind) eq 'ARRAY') {
2157             # arrayref binds can only be used with IN (...) lists or ARRAY[] constructors, so if we don't have
2158             # one available in $sql to modify, error out
2159 1 50       37 if ($sql =~ /((in\s+)([(]?\s*$ARRAY_PH\s*[)]?)|(array\s*\[\s*$ARRAY_PH\s*\]))/is) {
2160 1         3 my $ph_block = $1;
2161 1 50       4 if ($ph_block =~ /^in/is) {
    0          
2162 1 50       20 if ($sql =~ s/(in\s+)([(]?\s*$ARRAY_PH\s*[)]?)/ $1 . '( ' . join(', ', ('?') x scalar(@{$bind})) . ' )' /siex) {
  1         2  
  1         7  
2163 1         1 push(@final_binds, @{$bind});
  1         5  
2164             }
2165             } elsif ($ph_block =~ /^array/is) {
2166 0 0       0 if ($sql =~ s/\s*array\s*\[\s*$ARRAY_PH\s*\]/ ' array [ ' . join(', ', ('?') x scalar(@{$bind})) . ' ] ' /siex) {
  0         0  
  0         0  
2167 0         0 push(@final_binds, @{$bind});
  0         0  
2168             }
2169             } else {
2170 0         0 die dslog("Encountered arrayref placeholder syntax that cannot be understood at this time");
2171             }
2172             } else {
2173 0         0 die dslog("Arrayref bind was used without corresponding array placeholder as part of an IN (...) list or an ARRAY[] constructor!");
2174             }
2175             } else {
2176 3         13 push(@final_binds, $bind);
2177             }
2178             }
2179              
2180             # need to "fix" the statement type value now for queries that use a RETURNING
2181             # clause at the end of an INSERT, UPDATE or DELETE... for placeholder binding
2182             # purposes we treat them as their real type, but for everything else in datastore
2183             # they should be treated as SELECTs since that's effectively what comes back
2184             # from the database
2185 6 50 66     8 if (scalar(grep { $st_type eq $_ } qw( insert update delete )) > 0 && $sql =~ m{\s+returning\s+(\*|\w)}ois) {
  18         58  
2186 0         0 $st_type = 'select';
2187             }
2188              
2189 6 50       170 dslog(q{Binding transformation completed. SQL is now [[}, $sql, q{]] with bindings [[}, join(', ', @final_binds), q{]]})
2190             if DEBUG() >= 2;
2191              
2192 6         23 return ($st_type, $sql, @final_binds);
2193             }
2194              
2195             1;