File Coverage

blib/lib/Data/Toolkit/Connector/DBI.pm
Criterion Covered Total %
statement 242 256 94.5
branch 70 138 50.7
condition 13 33 39.3
subroutine 22 23 95.6
pod 14 14 100.0
total 361 464 77.8


line stmt bran cond sub pod time code
1             #!/usr/bin/perl -w
2             #
3             # Data::Toolkit::Connector::DBI
4             #
5             # Andrew Findlay
6             # Dec 2006
7             # andrew.findlay@skills-1st.co.uk
8             #
9             # $Id: DBI.pm 388 2013-08-30 15:19:23Z remotesvn $
10              
11             package Data::Toolkit::Connector::DBI;
12              
13 1     1   717 use strict;
  1         2  
  1         33  
14 1     1   5 use Carp;
  1         30  
  1         65  
15 1     1   5 use Clone qw(clone);
  1         2  
  1         36  
16 1     1   8902 use DBI;
  1         20451  
  1         56  
17 1     1   648 use Data::Toolkit::Entry;
  1         7  
  1         26  
18 1     1   6 use Data::Toolkit::Connector;
  1         1  
  1         18  
19 1     1   4 use Data::Dumper;
  1         1  
  1         74  
20              
21             our @ISA = ("Data::Toolkit::Connector");
22              
23             =head1 NAME
24              
25             Data::Toolkit::Connector::DBI
26              
27             =head1 DESCRIPTION
28              
29             Connector for relational databases accessed through Perl's DBI methods
30              
31             =head1 SYNOPSIS
32              
33             $dbiConn = Data::Toolkit::Connector::DBI->new();
34              
35             $dbi = DBI->connect( $data_source, $username, $auth, \%attr ) or die "$@";
36              
37             $dbiConn->server( $dbi );
38              
39             $spec = $dbiConn->filterspec( "SELECT joinkey,name FROM people WHERE joinkey = '%mykey%'" );
40             $msg = $dbiConn->search( $entry );
41             while ( $entry = $dbiConn->next() ) {
42             process $entry.....
43             }
44              
45             $msg = $dbiConn->search( $entry );
46             $entry = $dbiConn->allrows();
47              
48             $spec = $dbiConn->addspec( "INSERT INTO people (joinkey,name) VALUES (%mykey%,%myname%)" );
49             $dbiConn->add( $entry );
50              
51             $spec = $dbiConn->updatespec( "UPDATE people set name = %myname% WHERE joinkey = %mykey%" );
52             $dbiConn->update( $entry );
53              
54             $spec = $dbiConn->deletespec( "DELETE FROM people WHERE joinkey = %mykey%" );
55             $msg = $dbiConn->delete( $entry );
56              
57             Data::Toolkit::Connector::DBI does not do any commits or rollbacks. If you need
58             transactions, you should call the DBI commit and rollback methods directly.
59              
60             Note that all data is supplied via placeholders rather than being interpolated
61             into the SQL strings. Thus for example, this addspec:
62              
63             INSERT INTO people (joinkey,name) VALUES (%mykey%,%myname%)
64              
65             is translated before passing to the database engine, becoming:
66              
67             INSERT INTO people (joinkey,name) VALUES (?,?)
68              
69             and the actual values of the 'mykey' and 'myname' attributes are passed as parameters.
70             This avoids all problems with quoting and SQL-injection attacks. It does make some
71             SELECT statements a bit harder to compose, particularly when you want to use LIKE
72             to do substring searches. The solution is to use CONCAT():
73              
74             SELECT joinkey,sn FROM people WHERE sn LIKE CONCAT(%firstletter%, '%%')
75              
76             The value of the 'firstletter' attribute will become a parameter when the
77             select operation is executed.
78              
79             =head1 Non-SQL databases
80              
81             Not using SQL? No problem: Data::Toolkit::Connector::DBI does not attempt to
82             understand the strings that you give it. All it does is attribute-name
83             substitution, so provided your database query language understands the '?'
84             placeholder convention it will all work.
85              
86             =head1 DEPENDENCIES
87              
88             Carp
89             Clone
90             DBI
91             DBD::CSV (for testing)
92              
93             =cut
94              
95             ########################################################################
96             # Package globals
97             ########################################################################
98              
99 1     1   4 use vars qw($VERSION);
  1         1  
  1         2616  
100             $VERSION = '1.0';
101              
102             # Set this non-zero for debug logging
103             #
104             my $debug = 0;
105              
106             ########################################################################
107             # Constructors and destructors
108             ########################################################################
109              
110             =head1 Constructor
111              
112             =head2 new
113              
114             my $dbiConn = Data::Toolkit::Connector::DBI->new();
115              
116             Creates an object of type Data::Toolkit::Connector::DBI
117              
118             =cut
119              
120             sub new {
121 1     1 1 3 my $class = shift;
122              
123 1         16 my $self = $class->SUPER::new(@_);
124 1         4 bless ($self, $class);
125              
126 1 50       5 carp "Data::Toolkit::Connector::DBI->new $self" if $debug;
127 1         3 return $self;
128             }
129              
130             sub DESTROY {
131 1     1   3 my $self = shift;
132 1 50       32 carp "Data::Toolkit::Connector::DBI Destroying $self" if $debug;
133             }
134              
135             ########################################################################
136             # Methods
137             ########################################################################
138              
139             =head1 Methods
140              
141             =cut
142              
143             ########################################
144              
145             =head2 server
146              
147             Define the database server for the connector to use.
148             This should be an object of type DBI
149              
150             my $res = $dbiConn->server( DBI->connect($data_source, $username, $auth) );
151              
152             Returns the object that it is passed.
153              
154             =cut
155              
156             sub server {
157 1     1 1 76446 my $self = shift;
158 1         4 my $server = shift;
159              
160 1 50       9 croak "Data::Toolkit::Connector::DBI->server expects a parameter" if !$server;
161 1 50       6 carp "Data::Toolkit::Connector::DBI->server $self" if $debug;
162              
163 1         11 return $self->{server} = $server;
164             }
165              
166              
167              
168             ########################################
169              
170             =head2 filterspec
171              
172             Supply or fetch filterspec
173              
174             $hashref = $ldapConn->filterspec();
175             $hashref = $ldapConn->filterspec( "SELECT key,name FROM people WHERE key = '%mykey'" );
176              
177             Parameters are indicated thus: %name% - this will result in a '?'-style placeholder in
178             the SQL statement and the named attribute will be extracted from the supplied entry
179             by the search() method.
180              
181             =cut
182              
183             sub filterspec {
184 7     7 1 594 my $self = shift;
185 7         16 my $filterspec = shift;
186              
187 7 50       23 carp "Data::Toolkit::Connector::DBI->filterspec $self $filterspec " if $debug;
188              
189 7 50       26 croak "Data::Toolkit::Connector::DBI->filterspec called before server connection opened" if !$self->{server};
190              
191             # No arg supplied - just return existing setting
192 7 50       20 return $self->{filterspec} if (!$filterspec);
193              
194             # We have a new filterspec so stash it for future reference
195 7         18 $self->{filterspec} = $filterspec;
196              
197             # We need to parse the spec to find the list of args that it calls for.
198             # Start by clearing the arglist and filter string
199 7         14 my $filter = '';
200 7         11 my @arglist;
201 7         18 $self->{search_arglist} = \@arglist;
202              
203             # Parameter names are between pairs of % characters
204             # Where we want a literal '%' it is represented by '%%'
205             # so if the search string has at least two '%' left then there is work to be done
206 7         40 while ($filterspec =~ /%.*%/) {
207 4         24 my ($left,$name,$right) = ($filterspec =~ /^([^%]*)%([a-zA-Z0-9_]*)%(.*)$/);
208             # Everything before the first % gets added to the filter
209 4         10 $filter .= $left;
210 4 100       10 if ($name) {
211             # Add the name to the list of attributes needed when the search is performed
212 2         6 push @arglist, $name;
213             # Put the placeholder in the actual filter
214 2         4 $filter .= '?';
215             }
216             else {
217             # We got '%%' so add a literal '%' to the filter
218 2         4 $filter .= '%';
219             }
220             # The remainder of the filterspec goes round again
221 4         15 $filterspec = $right;
222             }
223             # Anything left in the filterspec gets appended to the filter
224 7         17 $filter .= $filterspec;
225              
226             # Stash the resulting string and associated list of attributes
227 7         13 $self->{selectstatement} = $filter;
228              
229             # Prepare the statement and stash the statement handle
230 7         77 $self->{search_sth} = $self->{server}->prepare( $filter );
231 7 50       1263 croak "Failed to prepare filter '$filter'" if !$self->{search_sth};
232              
233             # Return the spec string that we were given
234 7         28 return $self->{filterspec};
235             }
236              
237             ########################################
238              
239             =head2 search
240              
241             Search the database.
242             If an entry is supplied, attributes from it may be used in the search.
243              
244             $msg = $dbiConn->search();
245             $msg = $dbiConn->search( $entry );
246              
247             Returns the result of the DBI execute() operation.
248             This will be false if an error occurred.
249              
250             =cut
251              
252             sub search {
253 9     9 1 23 my $self = shift;
254 9         13 my $entry = shift;
255              
256 9 50       32 croak "Data::Toolkit::Connector::DBI->search called before searchspec has been defined" if !$self->{search_sth};
257 9 50       27 carp "Data::Toolkit::Connector::DBI->search $self" if $debug;
258              
259             # Sanity check
260 9 50 66     57 if ($entry and not $entry->isa('Data::Toolkit::Entry')) {
261 0         0 croak "Data::Toolkit::Connector::DBI->search parameter must be an entry";
262             }
263              
264             # Invalidate the current result entry
265 9         17 $self->{current} = undef;
266 9         18 $self->{currentDBRow} = undef;
267              
268             # The args to be passed to the SQL SELECT statement
269 9         12 my @args;
270             # The array of names that came from the filterspec
271 9         16 my @arglist = @{$self->{search_arglist}};
  9         26  
272             # Check that we have an entry to get params from
273 9 50       33 print "ARGLIST for search: ", (join '/', @arglist), "\n" if $debug;
274 9 50 66     38 if ($arglist[0] and !$entry) {
275 0         0 croak "Data::Toolkit::Connector::DBI->search requires an entry when the searchspec includes parameters";
276             }
277              
278             # Extract the args from the entry
279 9         12 my $arg;
280 9         20 foreach $arg (@arglist) {
281 3         11 my $value = $entry->get($arg);
282 3 50       16 croak "search spec calls for a '$arg' attribute but the entry does not have one" if !$value;
283             # We only use the first value from the list.
284             # This is permitted to bu undef or the null string.
285 3         7 $value = $value->[0];
286 3         11 push @args, $value;
287             }
288              
289             # Start the search and return the statement handle having stashed a copy internally
290 9         1009 return $self->{searchresult} = $self->{search_sth}->execute( @args );
291             }
292              
293              
294              
295             ########################################
296              
297             =head2 next
298              
299             Return the next entry from the SQL search as a Data::Toolkit::Entry object.
300             Optionally apply a map to the data.
301              
302             Updates the "current" entry (see "current" method description below).
303              
304             my $entry = $dbConn->next();
305             my $entry = $dbConn->next( $map );
306              
307             The result is a Data::Toolkit::Entry object if there is data left to be read,
308             otherwise it is undef.
309              
310             =cut
311              
312             sub next {
313 8     8 1 27 my $self = shift;
314 8         13 my $map = shift;
315              
316 8 50       32 carp "Data::Toolkit::Connector::DBI->next $self" if $debug;
317              
318             # Invalidate the old 'current entry' in case we have to return early
319 8         20 $self->{current} = undef;
320              
321             # Sanity check
322 8 50       24 croak "Data::Toolkit::Connector::DBI->next called but no search has been started" if !$self->{search_sth};
323              
324             # Pull out the next row from the database
325 8         309 my $dbRow = $self->{search_sth}->fetchrow_hashref("NAME_lc");
326 8 100       42 return undef if !$dbRow;
327              
328             # Build an entry
329 6         45 my $entry = Data::Toolkit::Entry->new();
330              
331             # Now step through the list of columns and assign data to attributes in the entry
332 6         8 my $attrib;
333              
334 6         23 foreach $attrib (keys %$dbRow) {
335 14         144 $entry->set( $attrib, [ $dbRow->{$attrib} ] );
336             }
337              
338             # Save this as the current entry
339 6         71 $self->{current} = $entry;
340 6         11 $self->{currentRow} = $dbRow;
341              
342 6 50       21 carp "Data::Toolkit::Connector::DBI->next using row: ".(join ',', (keys %$dbRow)) if $debug;
343             # Do we have a map to apply?
344 6 50       14 if ($map) {
345 0         0 return $entry->map($map);
346             }
347              
348 6         18 return $entry;
349             }
350              
351             ########################################
352              
353             =head2 allrows
354              
355             Merges the data from all rows returned by the SQL search into a single
356             Data::Toolkit::Entry object, so that each attribute has multiple values.
357             Optionally apply a map to the data.
358              
359             After this method if called, the "current" entry will be empty
360             (see "current" method description below).
361              
362             my $entry = $dbConn->allrows();
363             my $entry = $dbConn->allrows( $map );
364              
365             The result is a Data::Toolkit::Entry object if there is data left to be read,
366             otherwise it is undef.
367              
368             =cut
369              
370             sub allrows {
371 1     1 1 3 my $self = shift;
372 1         2 my $map = shift;
373              
374 1 50       15 carp "Data::Toolkit::Connector::DBI->allrows $self" if $debug;
375              
376             # Invalidate the old 'current entry' in case we have to return early
377 1         3 $self->{current} = undef;
378             # We will use up all the rows so clear this
379 1         3 $self->{currentRow} = undef;
380              
381             # Sanity check
382 1 50       7 croak "Data::Toolkit::Connector::DBI->allrows called but no search has been started" if !$self->{search_sth};
383              
384             # Pull out the next row from the database
385 1         31 my $dbRow = $self->{search_sth}->fetchrow_hashref("NAME_lc");
386 1 50       7 return undef if !$dbRow;
387              
388             # Build an entry
389 1         5 my $entry = Data::Toolkit::Entry->new();
390              
391             # While the search returns rows of data, slurp them up and add the values to the entry
392 1         3 my $count = 0;
393 1         5 while ($dbRow) {
394             # Step through the list of columns and add data to attributes in the entry
395 2         4 my $attrib;
396 2         3 $count++;
397              
398 2         7 foreach $attrib (keys %$dbRow) {
399 4         41 $entry->add( $attrib, [ $dbRow->{$attrib} ] );
400             }
401              
402             # Fetch the next row
403 2         71 $dbRow = $self->{search_sth}->fetchrow_hashref("NAME_lc");
404             }
405              
406             # Save this as the current entry
407 1         2 $self->{current} = $entry;
408              
409 1 50       4 carp "Data::Toolkit::Connector::DBI->allrows found $count rows" if $debug;
410              
411             # Do we have a map to apply?
412 1 50       4 if ($map) {
413 0         0 return $entry->map($map);
414             }
415              
416 1         3 return $entry;
417             }
418              
419              
420             ########################################
421              
422             =head2 current
423              
424             Return the current entry in the list of search results.
425             The current entry is not defined until the "next" method has been called after a search.
426              
427             $entry = $dbConn->current();
428              
429             =cut
430              
431             sub current {
432 0     0 1 0 my $self = shift;
433              
434 0 0       0 carp "Data::Toolkit::Connector::DBI->current $self" if $debug;
435              
436 0         0 return $self->{current};
437             }
438              
439              
440              
441             ########################################
442              
443             =head2 addspec
444              
445             Supply or fetch spec for add
446              
447             $spec = $dbiConn->addspec();
448             $spec = $dbiConn->addspec( "INSERT INTO people (joinkey,name) VALUES (%key%, %myname%)" );
449              
450             Parameters are indicated thus: %name% - this will result in a '?'-style placeholder in
451             the SQL statement and the named attribute will be extracted from the supplied entry
452             by the add() method. Note that these parameters should not be quoted - they are not
453             passed as text to the database engine.
454              
455             =cut
456              
457             sub addspec {
458 1     1 1 19 my $self = shift;
459 1         3 my $addspec = shift;
460              
461 1 50       5 carp "Data::Toolkit::Connector::DBI->addspec $self $addspec " if $debug;
462              
463 1 50       6 croak "Data::Toolkit::Connector::DBI->addspec called before server connection opened" if !$self->{server};
464              
465             # No arg supplied - just return existing setting
466 1 50       4 return $self->{addspec} if (!$addspec);
467              
468             # We have a new addspec so stash it for future reference
469 1         3 $self->{addspec} = $addspec;
470              
471             # We need to parse the spec to find the list of args that it calls for.
472             # Start by clearing the arglist and add string
473 1         2 my $add = '';
474 1         4 my @arglist;
475 1         3 $self->{add_arglist} = \@arglist;
476              
477             # Parameter names are between pairs of % characters
478             # Where we want a literal '%' it is represented by '%%'
479             # so if the add string has at least two '%' left then there is work to be done
480 1         9 while ($addspec =~ /%.*%/) {
481 3         21 my ($left,$name,$right) = ($addspec =~ /^([^%]*)%([a-zA-Z0-9_]*)%(.*)$/);
482             # Everything before the first % gets added to the add string
483 3         14 $add .= $left;
484 3 50       10 if ($name) {
485             # Add the name to the list of attributes needed when the add is performed
486 3         6 push @arglist, $name;
487             # Put the placeholder in the actual add string
488 3         6 $add .= '?';
489             }
490             else {
491             # We got '%%' so add a literal '%' to the add string
492 0         0 $add .= '%';
493             }
494             # The remainder of the addspec goes round again
495 3         13 $addspec = $right;
496             }
497             # Anything left in the addspec gets appended to the add string
498 1         2 $add .= $addspec;
499              
500             # Stash the resulting string
501 1         3 $self->{add_statement} = $add;
502              
503             # Prepare the statement and stash the statement handle
504 1         8 $self->{add_sth} = $self->{server}->prepare( $add );
505 1 50       96 croak "Failed to prepare add '$add'" if !$self->{add_sth};
506              
507             # Return the spec string that we were given
508 1         5 return $self->{addspec};
509             }
510              
511             ########################################
512              
513             =head2 add
514              
515             Update a row in the database using data from a source entry and an optional map.
516             If a map is supplied, it is used to transform data from the source entry before
517             it is applied to the database operation.
518              
519             Returns the result of the DBI execute operation.
520              
521             $msg = $dbConn->add($sourceEntry);
522             $msg = $dbConn->add($sourceEntry, $addMap);
523              
524             A suitable add operation must have been defined using the addspec() method
525             before add() is called:
526              
527             $spec = $dbiConn->addspec( "INSERT INTO people (joinkey,name) VALUES (%key%, %myname%)" );
528             $msg = $dbiConn->add( $entry );
529              
530             NOTE that only the first value of a given attribute is used, as relational databases expect
531             a single value for each column in a given row.
532              
533             =cut
534              
535             sub add {
536 1     1 1 7 my $self = shift;
537 1         2 my $source = shift;
538 1         2 my $map = shift;
539              
540 1 50       5 croak "Data::Toolkit::Connector::DBI->add called before addspec has been defined" if !$self->{add_sth};
541 1 50 33     14 croak "Data::Toolkit::Connector::DBI->add first parameter should be a Data::Toolkit::Entry"
542             if ($source and !$source->isa('Data::Toolkit::Entry'));
543 1 50 33     14 croak "Data::Toolkit::Connector::DBI->add second parameter should be a Data::Toolkit::Map"
544             if ($map and !$map->isa('Data::Toolkit::Map'));
545              
546 1 50       4 carp "Data::Toolkit::Connector::DBI->add $self $source" if $debug;
547              
548             # Apply the map if we have one
549 1 50       4 $source = $source->map($map) if $map;
550              
551             # The args to be passed to the SQL UPDATE statement
552 1         2 my @args;
553             # The array of names that came from the addspec
554 1         3 my @arglist = @{$self->{add_arglist}};
  1         5  
555             # Check that we have an entry to get params from
556 1 50       4 print "ARGLIST for add: ", (join '/', @arglist), "\n" if $debug;
557 1 50 33     10 if ($arglist[0] and !$source) {
558 0         0 croak "Data::Toolkit::Connector::DBI->add requires an entry when the addspec includes parameters";
559             }
560              
561             # Extract the args from the entry
562 1         1 my $arg;
563 1         3 foreach $arg (@arglist) {
564 3         13 my $value = $source->get($arg);
565 3 50       11 croak "add spec calls for a '$arg' attribute but the entry does not have one" if !$value;
566             # We only use the first value from the list.
567             # This is permitted to be undef or the null string.
568 3         11 $value = $value->[0];
569 3         10 push @args, $value;
570             }
571              
572             # Start the operation and return the statement handle having stashed a copy internally
573 1         16560 return $self->{add_result} = $self->{add_sth}->execute( @args );
574             }
575              
576              
577             ########################################
578              
579             =head2 updatespec
580              
581             Supply or fetch spec for update
582              
583             $spec = $dbiConn->updatespec();
584             $spec = $dbiConn->updatespec( "UPDATE people set name = %myname% WHERE joinkey = %mykey%" );
585              
586             Parameters are indicated thus: %name% - this will result in a '?'-style placeholder in
587             the SQL statement and the named attribute will be extracted from the supplied entry
588             by the update() method.
589              
590             =cut
591              
592             sub updatespec {
593 1     1 1 3 my $self = shift;
594 1         2 my $updatespec = shift;
595              
596 1 50       4 carp "Data::Toolkit::Connector::DBI->updatespec $self $updatespec " if $debug;
597              
598 1 50       5 croak "Data::Toolkit::Connector::DBI->updatespec called before server connection opened" if !$self->{server};
599              
600             # No arg supplied - just return existing setting
601 1 50       4 return $self->{updatespec} if (!$updatespec);
602              
603             # We have a new updatespec so stash it for future reference
604 1         5 $self->{updatespec} = $updatespec;
605              
606             # We need to parse the spec to find the list of args that it calls for.
607             # Start by clearing the arglist and update string
608 1         3 my $update = '';
609 1         2 my @arglist;
610 1         12 $self->{update_arglist} = \@arglist;
611              
612             # Parameter names are between pairs of % characters
613             # Where we want a literal '%' it is represented by '%%'
614             # so if the update string has at least two '%' left then there is work to be done
615 1         10 while ($updatespec =~ /%.*%/) {
616 3         18 my ($left,$name,$right) = ($updatespec =~ /^([^%]*)%([a-zA-Z0-9_]*)%(.*)$/);
617             # Everything before the first % gets added to the update string
618 3         5 $update .= $left;
619 3 50       7 if ($name) {
620             # Add the name to the list of attributes needed when the update is performed
621 3         4 push @arglist, $name;
622             # Put the placeholder in the actual update string
623 3         5 $update .= '?';
624             }
625             else {
626             # We got '%%' so add a literal '%' to the update string
627 0         0 $update .= '%';
628             }
629             # The remainder of the updatespec goes round again
630 3         11 $updatespec = $right;
631             }
632             # Anything left in the updatespec gets appended to the update string
633 1         2 $update .= $updatespec;
634              
635             # Stash the resulting string and associated list of attributes
636 1         2 $self->{update_statement} = $update;
637              
638             # Prepare the statement and stash the statement handle
639 1         8 $self->{update_sth} = $self->{server}->prepare( $update );
640 1 50       151 croak "Failed to prepare update '$update'" if !$self->{update_sth};
641              
642 1 50       4 carp "Data::Toolkit::Connector::DBI->updatespec setting '$update', (" . (join ',',@arglist) . ")" if $debug;
643              
644             # Return the spec string that we were given
645 1         4 return $self->{updatespec};
646             }
647              
648             ########################################
649              
650             =head2 update
651              
652             Update a row in the database using data from a source entry and an optional map.
653             If a map is supplied, it is used to transform data from the source entry before
654             it is applied to the database operation.
655              
656             Returns the result of the DBI execute operation.
657              
658             $msg = $dbConn->update($sourceEntry);
659             $msg = $dbConn->update($sourceEntry, $updateMap);
660              
661             A suitable update operation must have been defined using the updatespec() method
662             before update() is called:
663              
664             $spec = $dbiConn->updatespec( "UPDATE people set name = %myname% WHERE key = %mykey%" );
665             $msg = $dbiConn->update( $entry );
666              
667             NOTE that only the first value of a given attribute is used, as relational databases expect
668             a single value for each column in a given row.
669              
670             Note also that multiple rows could be affected by a single call to this method, depending
671             on how the updatespec has been defined.
672              
673             =cut
674              
675             sub update {
676 1     1 1 2 my $self = shift;
677 1         4 my $source = shift;
678 1         1 my $map = shift;
679              
680 1 50       6 croak "Data::Toolkit::Connector::DBI->update called before updatespec has been defined" if !$self->{update_sth};
681 1 50 33     13 croak "Data::Toolkit::Connector::DBI->update first parameter should be a Data::Toolkit::Entry"
682             if ($source and !$source->isa('Data::Toolkit::Entry'));
683 1 50 33     5 croak "Data::Toolkit::Connector::DBI->update second parameter should be a Data::Toolkit::Map"
684             if ($map and !$map->isa('Data::Toolkit::Map'));
685              
686 1 50       4 carp "Data::Toolkit::Connector::DBI->update $self $source" if $debug;
687              
688             # Apply the map if we have one
689 1 50       4 $source = $source->map($map) if $map;
690              
691             # The args to be passed to the SQL UPDATE statement
692 1         1 my @args;
693             # The array of names that came from the updatespec
694 1         2 my @arglist = @{$self->{update_arglist}};
  1         4  
695             # Check that we have an entry to get params from
696 1 50       5 print "ARGLIST for update: ", (join ',', @arglist), "\n" if $debug;
697 1 50 33     9 if ($arglist[0] and !$source) {
698 0         0 croak "Data::Toolkit::Connector::DBI->update requires an entry when the updatespec includes parameters";
699             }
700              
701             # Extract the args from the entry
702 1         8 my $arg;
703 1         4 foreach $arg (@arglist) {
704 3         8 my $value = $source->get($arg);
705 3 50       8 croak "update spec calls for a '$arg' attribute but the entry does not have one" if !$value;
706             # We only use the first value from the list.
707             # This is permitted to be the null string.
708             # It should not be undef, as that would need an 'IS NULL' clause in SQL.
709 3         6 $value = $value->[0];
710 3         8 push @args, $value;
711             }
712              
713             # Start the search and return the statement handle having stashed a copy internally
714 1         6125 return $self->{update_result} = $self->{update_sth}->execute( @args );
715             }
716              
717              
718             ########################################
719              
720             =head2 deletespec
721              
722             Supply or fetch spec for delete
723              
724             $spec = $dbiConn->deletespec();
725             $spec = $dbiConn->deletespec( "DELETE from people WHERE joinkey = %mykey%" );
726              
727             Parameters are indicated thus: %name% - this will result in a '?'-style placeholder in
728             the SQL statement and the named attribute will be extracted from the supplied entry
729             by the delete() method.
730              
731             =cut
732              
733             sub deletespec {
734 1     1 1 2 my $self = shift;
735 1         3 my $deletespec = shift;
736              
737 1 50       4 carp "Data::Toolkit::Connector::DBI->deletespec $self $deletespec " if $debug;
738              
739 1 50       6 croak "Data::Toolkit::Connector::DBI->deletespec called before server connection opened" if !$self->{server};
740              
741             # No arg supplied - just return existing setting
742 1 50       5 return $self->{deletespec} if (!$deletespec);
743              
744             # We have a new deletespec so stash it for future reference
745 1         3 $self->{deletespec} = $deletespec;
746              
747             # We need to parse the spec to find the list of args that it calls for.
748             # Start by clearing the arglist and delete string
749 1         3 my $delete = '';
750 1         1 my @arglist;
751 1         3 $self->{delete_arglist} = \@arglist;
752              
753             # Parameter names are between pairs of % characters
754             # Where we want a literal '%' it is represented by '%%'
755             # so if the delete string has at least two '%' left then there is work to be done
756 1         8 while ($deletespec =~ /%.*%/) {
757 1         7 my ($left,$name,$right) = ($deletespec =~ /^([^%]*)%([a-zA-Z0-9_]*)%(.*)$/);
758             # Everything before the first % gets added to the delete string
759 1         3 $delete .= $left;
760 1 50       4 if ($name) {
761             # Add the name to the list of attributes needed when the delete is performed
762 1         2 push @arglist, $name;
763             # Put the placeholder in the actual delete string
764 1         2 $delete .= '?';
765             }
766             else {
767             # We got '%%' so add a literal '%' to the delete string
768 0         0 $delete .= '%';
769             }
770             # The remainder of the deletespec goes round again
771 1         3 $deletespec = $right;
772             }
773             # Anything left in the deletespec gets appended to the delete string
774 1         14 $delete .= $deletespec;
775              
776             # Stash the resulting string and associated list of attributes
777 1         3 $self->{delete_statement} = $delete;
778              
779             # Prepare the statement and stash the statement handle
780 1         15 $self->{delete_sth} = $self->{server}->prepare( $delete );
781 1 50       110 croak "Failed to prepare delete '$delete'" if !$self->{delete_sth};
782              
783 1 50       4 carp "Data::Toolkit::Connector::DBI->deletespec setting '$delete', (" . (join ',',@arglist) . ")" if $debug;
784              
785             # Return the spec string that we were given
786 1         4 return $self->{deletespec};
787             }
788              
789             ########################################
790              
791             =head2 delete
792              
793             Delete a row from the database using data from a source entry and an optional map.
794             If a map is supplied, it is used to transform data from the source entry before
795             it is applied to the database operation.
796              
797             Returns the result of the DBI execute operation.
798              
799             $msg = $dbConn->delete($sourceEntry);
800             $msg = $dbConn->delete($sourceEntry, $deleteMap);
801              
802             A suitable delete operation must have been defined using the deletespec() method
803             before delete() is called:
804              
805             $spec = $dbiConn->deletespec( "DELETE FROM people WHERE joinkey = %mykey%" );
806             $msg = $dbiConn->delete( $entry );
807              
808             NOTE that only the first value of a given attribute is used.
809              
810             Note also that multiple rows could be affected by a single call to this method, depending
811             on how the deletespec has been defined.
812              
813             =cut
814              
815             sub delete {
816 1     1 1 2 my $self = shift;
817 1         2 my $source = shift;
818 1         2 my $map = shift;
819              
820 1 50       5 croak "Data::Toolkit::Connector::DBI->delete called before deletespec has been defined" if !$self->{delete_sth};
821 1 50 33     18 croak "Data::Toolkit::Connector::DBI->delete first parameter should be a Data::Toolkit::Entry"
822             if ($source and !$source->isa('Data::Toolkit::Entry'));
823 1 50 33     10 croak "Data::Toolkit::Connector::DBI->delete second parameter should be a Data::Toolkit::Map"
824             if ($map and !$map->isa('Data::Toolkit::Map'));
825              
826 1 50       18 carp "Data::Toolkit::Connector::DBI->delete $self $source" if $debug;
827              
828             # Apply the map if we have one
829 1 50       4 $source = $source->map($map) if $map;
830              
831             # The args to be passed to the SQL UPDATE statement
832 1         2 my @args;
833             # The array of names that came from the deletespec
834 1         2 my @arglist = @{$self->{delete_arglist}};
  1         3  
835             # Check that we have an entry to get params from
836 1 50       9 print "ARGLIST for delete: ", (join ',', @arglist), "\n" if $debug;
837 1 50 33     8 if ($arglist[0] and !$source) {
838 0         0 croak "Data::Toolkit::Connector::DBI->delete requires an entry when the deletespec includes parameters";
839             }
840              
841             # Extract the args from the entry
842 1         2 my $arg;
843 1         2 foreach $arg (@arglist) {
844 1         4 my $value = $source->get($arg);
845 1 50       4 croak "delete spec calls for a '$arg' attribute but the entry does not have one" if !$value;
846             # We only use the first value from the list.
847             # This is permitted to be the null string.
848             # It should not be undef, as that would need an 'IS NULL' clause in SQL.
849 1         2 $value = $value->[0];
850 1         3 push @args, $value;
851             }
852              
853             # Start the search and return the statement handle having stashed a copy internally
854 1         15554 return $self->{delete_result} = $self->{delete_sth}->execute( @args );
855             }
856              
857             ########################################################################
858             # Debugging methods
859             ########################################################################
860              
861             =head1 Debugging methods
862              
863             =head2 debug
864              
865             Set and/or get the debug level for Data::Toolkit::Connector
866              
867             my $currentDebugLevel = Data::Toolkit::Connector::LDAP->debug();
868             my $newDebugLevel = Data::Toolkit::Connector::LDAP->debug(1);
869              
870             Any non-zero debug level causes the module to print copious debugging information.
871              
872             Note that this is a package method, not an object method. It should always be
873             called exactly as shown above.
874              
875             All debug information is reported using "carp" from the Carp module, so if
876             you want a full stack backtrace included you can run your program like this:
877              
878             perl -MCarp=verbose myProg
879              
880             =cut
881              
882             # Class method to set and/or get debug level
883             #
884             sub debug {
885 1     1 1 63 my $class = shift;
886 1 50       6 if (ref $class) { croak "Class method 'debug' called as object method" }
  0         0  
887             # print "DEBUG: ", (join '/', @_), "\n";
888 1 50       5 $debug = shift if (@_ == 1);
889 1         11 return $debug
890             }
891              
892              
893             ########################################################################
894             ########################################################################
895              
896             =head1 Author
897              
898             Andrew Findlay
899              
900             Skills 1st Ltd
901              
902             andrew.findlay@skills-1st.co.uk
903              
904             http://www.skills-1st.co.uk/
905              
906             =cut
907              
908             ########################################################################
909             ########################################################################
910             1;