source: wiki-toolkit/trunk/lib/Wiki/Toolkit/Store/Database.pm @ 477

Last change on this file since 477 was 477, checked in by kake, 13 years ago

Applied a modified version of tgj's patch (OpenGuides? ticket #23). Also fixed minor POD error while I was at it.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 70.8 KB
Line 
1package Wiki::Toolkit::Store::Database;
2
3use strict;
4
5use vars qw( $VERSION $timestamp_fmt );
6$timestamp_fmt = "%Y-%m-%d %H:%M:%S";
7
8use DBI;
9use Time::Piece;
10use Time::Seconds;
11use Carp qw( carp croak );
12use Digest::MD5 qw( md5_hex );
13
14$VERSION = '0.29';
15my $SCHEMA_VER = 10;
16
17# first, detect if Encode is available - it's not under 5.6. If we _are_
18# under 5.6, give up - we'll just have to hope that nothing explodes. This
19# is the current 0.54 behaviour, so that's ok.
20
21my $CAN_USE_ENCODE;
22BEGIN {
23    eval " use Encode ";
24    $CAN_USE_ENCODE = $@ ? 0 : 1;
25}
26
27=head1 NAME
28
29Wiki::Toolkit::Store::Database - parent class for database storage backends
30for Wiki::Toolkit
31
32=head1 SYNOPSIS
33
34This is probably only useful for Wiki::Toolkit developers.
35
36  # See below for parameter details.
37  my $store = Wiki::Toolkit::Store::MySQL->new( %config );
38
39=head1 METHODS
40
41=over 4
42
43=item B<new>
44
45  my $store = Wiki::Toolkit::Store::MySQL->new( dbname  => "wiki",
46                        dbuser  => "wiki",
47                        dbpass  => "wiki",
48                        dbhost  => "db.example.com",
49                        dbport  => 1234,
50                        charset => "iso-8859-1" );
51or
52
53  my $store = Wiki::Toolkit::Store::MySQL->new( dbh => $dbh );
54
55C<charset> is optional, defaults to C<iso-8859-1>, and does nothing
56unless you're using perl 5.8 or newer.
57
58If you do not provide an active database handle in C<dbh>, then
59C<dbname> is mandatory. C<dbpass>, C<dbuser>, C<dbhost> and C<dbport>
60are optional, but you'll want to supply them unless your database's
61connection method doesn't require them.
62
63If you do provide C<database> then it must have the following
64parameters set; otherwise you should just provide the connection
65information and let us create our own handle:
66
67=over 4
68
69=item *
70
71C<RaiseError> = 1
72
73=item *
74
75C<PrintError> = 0
76
77=item *
78
79C<AutoCommit> = 1
80
81=back
82
83=cut
84
85sub new {
86    my ($class, @args) = @_;
87    my $self = {};
88    bless $self, $class;
89    return $self->_init(@args);
90}
91
92sub _init {
93    my ($self, %args) = @_;
94
95    if ( $args{dbh} ) {
96        $self->{_dbh} = $args{dbh};
97        $self->{_external_dbh} = 1; # don't disconnect at DESTROY time
98    } else {
99        die "Must supply a dbname" unless defined $args{dbname};
100        $self->{_dbname} = $args{dbname};
101        $self->{_dbuser} = $args{dbuser} || "";
102        $self->{_dbpass} = $args{dbpass} || "";
103        $self->{_dbhost} = $args{dbhost} || "";
104        $self->{_dbport} = $args{dbport} || "";
105        $self->{_charset} = $args{charset} || "iso-8859-1";
106
107        # Connect to database and store the database handle.
108        my ($dbname, $dbuser, $dbpass, $dbhost, $dbport) =
109                           @$self{qw(_dbname _dbuser _dbpass _dbhost _dbport)};
110        my $dsn = $self->_dsn($dbname, $dbhost, $dbport)
111            or croak "No data source string provided by class";
112        $self->{_dbh} = DBI->connect( $dsn, $dbuser, $dbpass,
113                      { PrintError => 0, RaiseError => 1,
114                        AutoCommit => 1 } )
115            or croak "Can't connect to database $dbname using $dsn: "
116                   . DBI->errstr;
117    }
118
119    my ($cur_ver, $db_ver) = $self->schema_current;
120    if ($db_ver < $cur_ver) {
121        croak "Database schema version $db_ver is too old (need $cur_ver)";
122    } elsif ($db_ver > $cur_ver) {
123        croak "Database schema version $db_ver is too new (need $cur_ver)";
124    }
125
126    return $self;
127}
128
129# Internal method, used to handle the logic of how to add up return
130#  values from pre_ plugins
131sub handle_pre_plugin_ret {
132    my ($running_total_ref,$result) = @_;
133
134    if(($result && $result == 0) || !$result) {
135        # No opinion, no need to change things
136    } elsif($result == -1 || $result == 1) {
137        # Increase or decrease as requested
138        $$running_total_ref += $result;
139    } else {
140        # Invalid return code
141        warn("Pre_ plugin returned invalid accept/deny value of '$result'");
142    }
143}
144
145=item B<retrieve_node>
146
147  my $content = $store->retrieve_node($node);
148
149  # Or get additional meta-data too.
150  my %node = $store->retrieve_node("HomePage");
151  print "Current Version: " . $node{version};
152
153  # Maybe we stored some metadata too.
154  my $categories = $node{metadata}{category};
155  print "Categories: " . join(", ", @$categories);
156  print "Postcode: $node{metadata}{postcode}[0]";
157
158  # Or get an earlier version:
159  my %node = $store->retrieve_node(name    => "HomePage",
160                         version => 2 );
161  print $node{content};
162
163
164In scalar context, returns the current (raw Wiki language) contents of
165the specified node. In list context, returns a hash containing the
166contents of the node plus additional data:
167
168=over 4
169
170=item B<last_modified>
171
172=item B<version>
173
174=item B<checksum>
175
176=item B<metadata> - a reference to a hash containing any caller-supplied
177metadata sent along the last time the node was written
178
179=back
180
181The node parameter is mandatory. The version parameter is optional and
182defaults to the newest version. If the node hasn't been created yet,
183it is considered to exist but be empty (this behaviour might change).
184
185B<Note> on metadata - each hash value is returned as an array ref,
186even if that type of metadata only has one value.
187
188=cut
189
190sub retrieve_node {
191    my $self = shift;
192    my %args = scalar @_ == 1 ? ( name => $_[0] ) : @_;
193    unless($args{'version'}) { $args{'version'} = undef; }
194
195    # Call pre_retrieve on any plugins, in case they want to tweak anything
196    my @plugins = @{ $args{plugins} || [ ] };
197    foreach my $plugin (@plugins) {
198        if ( $plugin->can( "pre_retrieve" ) ) {
199            $plugin->pre_retrieve( 
200                node     => \$args{'name'},
201                version  => \$args{'version'}
202            );
203        }
204    }
205
206    # Note _retrieve_node_data is sensitive to calling context.
207    unless(wantarray) {
208        # Scalar context, will return just the content
209        return $self->_retrieve_node_data( %args );
210    }
211
212    my %data = $self->_retrieve_node_data( %args );
213    $data{'checksum'} = $self->_checksum(%data);
214    return %data;
215}
216
217# Returns hash or scalar depending on calling context.
218sub _retrieve_node_data {
219    my ($self, %args) = @_;
220    my %data = $self->_retrieve_node_content( %args );
221    unless(wantarray) {
222        # Scalar context, return just the content
223        return $data{content};
224    }
225
226    # If we want additional data then get it.  Note that $data{version}
227    # will already have been set by C<_retrieve_node_content>, if it wasn't
228    # specified in the call.
229    my $dbh = $self->dbh;
230    my $sql = "SELECT metadata_type, metadata_value "
231         . "FROM node "
232         . "INNER JOIN metadata ON (node_id = id) "
233         . "WHERE name=? "
234         . "AND metadata.version=?";
235    my $sth = $dbh->prepare($sql);
236    $sth->execute($args{name},$data{version}) or croak $dbh->errstr;
237
238    my %metadata;
239    while ( my ($type, $val) = $self->charset_decode( $sth->fetchrow_array ) ) {
240        if ( defined $metadata{$type} ) {
241            push @{$metadata{$type}}, $val;
242        } else {
243            $metadata{$type} = [ $val ];
244        }
245    }
246    $data{metadata} = \%metadata;
247    return %data;
248}
249
250# $store->_retrieve_node_content( name    => $node_name,
251#                                 version => $node_version );
252# Params: 'name' is compulsory, 'version' is optional and defaults to latest.
253# Returns a hash of data for C<retrieve_node> - content, version, last modified
254sub _retrieve_node_content {
255    my ($self, %args) = @_;
256    croak "No valid node name supplied" unless $args{name};
257    my $dbh = $self->dbh;
258    my $sql;
259
260    my $version_sql_val;
261    my $text_source;
262    if ( $args{version} ) {
263        # Version given - get that version, and the content for that version
264        $version_sql_val = $dbh->quote($self->charset_encode($args{version}));
265        $text_source = "content";
266    } else {
267        # No version given, grab latest version (and content for that)
268        $version_sql_val = "node.version";
269        $text_source = "node";
270    }
271    $sql = "SELECT "
272         . "     $text_source.text, content.version, "
273         . "     content.modified, content.moderated, "
274         . "     node.moderate "
275         . "FROM node "
276         . "INNER JOIN content ON (id = node_id) "
277         . "WHERE name=" . $dbh->quote($self->charset_encode($args{name}))
278         . " AND content.version=" . $version_sql_val;
279    my @results = $self->charset_decode( $dbh->selectrow_array($sql) );
280    @results = ("", 0, "") unless scalar @results;
281    my %data;
282    @data{ qw( content version last_modified moderated node_requires_moderation ) } = @results;
283    return %data;
284}
285
286# Expects a hash as returned by ->retrieve_node - it's actually slightly lax
287# in this, in that while ->retrieve_node always wraps up the metadata values in
288# (refs to) arrays, this method will accept scalar metadata values too.
289sub _checksum {
290    my ($self, %node_data) = @_;
291    my $string = $node_data{content};
292    my %metadata = %{ $node_data{metadata} || {} };
293    foreach my $key ( sort keys %metadata ) {
294        $string .= "\0\0\0" . $key . "\0\0";
295        my $val = $metadata{$key};
296        if ( ref $val eq "ARRAY" ) {
297            $string .= join("\0", sort @$val );
298        } else {
299            $string .= $val;
300        }
301    }
302    return md5_hex($self->charset_encode($string));
303}
304
305# Expects an array of hashes whose keys and values are scalars.
306sub _checksum_hashes {
307    my ($self, @hashes) = @_;
308    my @strings = "";
309    foreach my $hashref ( @hashes ) {
310        my %hash = %$hashref;
311        my $substring = "";
312        foreach my $key ( sort keys %hash ) {
313            $substring .= "\0\0" . $key . "\0" . $hash{$key};
314        }
315        push @strings, $substring;
316    }
317    my $string = join("\0\0\0", sort @strings);
318    return md5_hex($string);
319}
320
321=item B<node_exists>
322
323  my $ok = $store->node_exists( "Wombat Defenestration" );
324
325  # or ignore case - optional but recommended
326  my $ok = $store->node_exists(
327                                name        => "monkey brains",
328                                ignore_case => 1,
329                              ); 
330
331Returns true if the node has ever been created (even if it is
332currently empty), and false otherwise.
333
334By default, the case-sensitivity of C<node_exists> depends on your
335database.  If you supply a true value to the C<ignore_case> parameter,
336then you can be sure of its being case-insensitive.  This is
337recommended.
338
339=cut
340
341sub node_exists {
342    my $self = shift;
343    if ( scalar @_ == 1 ) {
344        my $node = shift;
345        return $self->_do_old_node_exists( $node );
346    } else {
347        my %args = @_;
348        return $self->_do_old_node_exists( $args{name} )
349            unless $args{ignore_case};
350        my $sql = $self->_get_node_exists_ignore_case_sql;
351        my $sth = $self->dbh->prepare( $sql );
352        $sth->execute( $args{name} );
353        my $found_name = $sth->fetchrow_array || "";
354        $sth->finish;
355        return lc($found_name) eq lc($args{name}) ? 1 : 0;
356    }
357}
358
359sub _do_old_node_exists {
360    my ($self, $node) = @_;
361    my %data = $self->retrieve_node($node) or return ();
362    return $data{version}; # will be 0 if node doesn't exist, >=1 otherwise
363}
364
365=item B<verify_checksum>
366
367  my $ok = $store->verify_checksum($node, $checksum);
368
369Sees whether your checksum is current for the given node. Returns true
370if so, false if not.
371
372B<NOTE:> Be aware that when called directly and without locking, this
373might not be accurate, since there is a small window between the
374checking and the returning where the node might be changed, so
375B<don't> rely on it for safe commits; use C<write_node> for that. It
376can however be useful when previewing edits, for example.
377
378=cut
379
380sub verify_checksum {
381    my ($self, $node, $checksum) = @_;
382#warn $self;
383    my %node_data = $self->_retrieve_node_data( name => $node );
384    return ( $checksum eq $self->_checksum( %node_data ) );
385}
386
387=item B<list_backlinks>
388
389  # List all nodes that link to the Home Page.
390  my @links = $store->list_backlinks( node => "Home Page" );
391
392=cut
393
394sub list_backlinks {
395    my ( $self, %args ) = @_;
396    my $node = $args{node};
397    croak "Must supply a node name" unless $node;
398    my $dbh = $self->dbh;
399    # XXX see comment in list_dangling_links
400    my $sql = "SELECT link_from FROM internal_links INNER JOIN
401               node AS node_from ON node_from.name=internal_links.link_from
402               WHERE link_to="
403            . $dbh->quote($node);
404    my $sth = $dbh->prepare($sql);
405    $sth->execute or croak $dbh->errstr;
406    my @backlinks;
407    while ( my ($backlink) = $self->charset_decode( $sth->fetchrow_array ) ) {
408        push @backlinks, $backlink;
409    }
410    return @backlinks;
411}
412
413=item B<list_dangling_links>
414
415  # List all nodes that have been linked to from other nodes but don't
416  # yet exist.
417  my @links = $store->list_dangling_links;
418
419Each node is returned once only, regardless of how many other nodes
420link to it.
421
422=cut
423
424sub list_dangling_links {
425    my $self = shift;
426    my $dbh = $self->dbh;
427    # XXX this is really hiding an inconsistency in the database;
428    # should really fix the constraints so that this inconsistency
429    # cannot be introduced; also rework this table completely so
430    # that it uses IDs, not node names (will simplify rename_node too)
431    my $sql = "SELECT DISTINCT internal_links.link_to
432               FROM internal_links INNER JOIN node AS node_from ON
433               node_from.name=internal_links.link_from LEFT JOIN node
434               AS node_to ON node_to.name=internal_links.link_to
435               WHERE node_to.version IS NULL";
436    my $sth = $dbh->prepare($sql);
437    $sth->execute or croak $dbh->errstr;
438    my @links;
439    while ( my ($link) = $self->charset_decode( $sth->fetchrow_array ) ) {
440        push @links, $link;
441    }
442    return @links;
443}
444
445=item B<write_node_post_locking>
446
447  $store->write_node_post_locking( node     => $node,
448                                   content  => $content,
449                                   links_to => \@links_to,
450                                   metadata => \%metadata,
451                                   requires_moderation => $requires_moderation,
452                                   plugins  => \@plugins   )
453      or handle_error();
454
455Writes the specified content into the specified node, then calls
456C<post_write> on all supplied plugins, with arguments C<node>,
457C<version>, C<content>, C<metadata>.
458
459Making sure that locking/unlocking/transactions happen is left up to
460you (or your chosen subclass). This method shouldn't really be used
461directly as it might overwrite someone else's changes. Croaks on error
462but otherwise returns the version number of the update just made.  A
463return value of -1 indicates that the change was not applied.  This
464may be because the plugins voted against the change, or because the
465content and metadata in the proposed new version were identical to the
466current version (a "null" change).
467
468Supplying a ref to an array of nodes that this ones links to is
469optional, but if you do supply it then this node will be returned when
470calling C<list_backlinks> on the nodes in C<@links_to>. B<Note> that
471if you don't supply the ref then the store will assume that this node
472doesn't link to any others, and update itself accordingly.
473
474The metadata hashref is also optional, as is requires_moderation.
475
476B<Note> on the metadata hashref: Any data in here that you wish to
477access directly later must be a key-value pair in which the value is
478either a scalar or a reference to an array of scalars.  For example:
479
480  $wiki->write_node( "Calthorpe Arms", "nice pub", $checksum,
481                     { category => [ "Pubs", "Bloomsbury" ],
482                       postcode => "WC1X 8JR" } );
483
484  # and later
485
486  my @nodes = $wiki->list_nodes_by_metadata(
487      metadata_type  => "category",
488      metadata_value => "Pubs"             );
489
490For more advanced usage (passing data through to registered plugins)
491you may if you wish pass key-value pairs in which the value is a
492hashref or an array of hashrefs. The data in the hashrefs will not be
493stored as metadata; it will be checksummed and the checksum will be
494stored instead (as C<__metadatatypename__checksum>). Such data can
495I<only> be accessed via plugins.
496
497=cut
498
499sub write_node_post_locking {
500    my ($self, %args) = @_;
501    my ($node, $content, $links_to_ref, $metadata_ref, $requires_moderation) =
502             @args{ qw( node content links_to metadata requires_moderation) };
503    my $dbh = $self->dbh;
504
505    my $timestamp = $self->_get_timestamp();
506    my @links_to = @{ $links_to_ref || [] }; # default to empty array
507    my $version;
508    unless($requires_moderation) { $requires_moderation = 0; }
509
510    # Call pre_write on any plugins, in case they want to tweak anything
511    my @preplugins = @{ $args{plugins} || [ ] };
512    my $write_allowed = 1;
513    foreach my $plugin (@preplugins) {
514        if ( $plugin->can( "pre_write" ) ) {
515            handle_pre_plugin_ret(
516                \$write_allowed,
517                $plugin->pre_write( 
518                    node     => \$node,
519                    content  => \$content,
520                    metadata => \$metadata_ref )
521            );
522        }
523    }
524    if($write_allowed < 1) {
525        # The plugins didn't want to allow this action
526        return -1;
527    }
528
529    if ( $self->_checksum( %args ) eq $args{checksum} ) {
530        # Refuse to commit as nothing has changed
531        return -1;
532    }
533
534    # Either inserting a new page or updating an old one.
535    my $sql = "SELECT count(*) FROM node WHERE name=" . $dbh->quote($node);
536    my $exists = @{ $dbh->selectcol_arrayref($sql) }[0] || 0;
537
538
539    # If it doesn't exist, add it right now
540    if(! $exists) {
541        # Add in a new version
542        $version = 1;
543
544        # Handle initial moderation
545        my $node_content = $content;
546        if($requires_moderation) {
547            $node_content = "=== This page has yet to be moderated. ===";
548        }
549
550        # Add the node and content
551        my $add_sql = 
552             "INSERT INTO node "
553            ."    (name, version, text, modified, moderate) "
554            ."VALUES (?, ?, ?, ?, ?)";
555        my $add_sth = $dbh->prepare($add_sql);
556        $add_sth->execute(
557            map{ $self->charset_encode($_) }
558                ($node, $version, $node_content, $timestamp, $requires_moderation)
559        ) or croak "Error updating database: " . DBI->errstr;
560    }
561
562    # Get the ID of the node we've added / we're about to update
563    # Also get the moderation status for it
564    $sql = "SELECT id, moderate FROM node WHERE name=" . $dbh->quote($node);
565    my ($node_id,$node_requires_moderation) = $dbh->selectrow_array($sql);
566
567    # Only update node if it exists, and moderation isn't enabled on the node
568    # Whatever happens, if it exists, generate a new version number
569    if($exists) {
570        # Get the new version number
571        $sql = "SELECT max(content.version) FROM node
572                INNER JOIN content ON (id = node_id)
573                WHERE name=" . $dbh->quote($node);
574        $version = @{ $dbh->selectcol_arrayref($sql) }[0] || 0;
575        croak "Can't get version number" unless $version;
576        $version++;
577
578        # Update the node only if node doesn't require moderation
579        if(!$node_requires_moderation) {
580            $sql = "UPDATE node SET version=" . $dbh->quote($version)
581             . ", text=" . $dbh->quote($self->charset_encode($content))
582             . ", modified=" . $dbh->quote($timestamp)
583             . " WHERE name=" . $dbh->quote($self->charset_encode($node));
584            $dbh->do($sql) or croak "Error updating database: " . DBI->errstr;
585        }
586
587        # You can't use this to enable moderation on an existing node
588        if($requires_moderation) {
589           warn("Moderation not added to existing node '$node', use normal moderation methods instead");
590        }
591    }
592
593
594    # Now node is updated (if required), add to the history
595    my $add_sql = 
596         "INSERT INTO content "
597        ."    (node_id, version, text, modified, moderated) "
598        ."VALUES (?, ?, ?, ?, ?)";
599    my $add_sth = $dbh->prepare($add_sql);
600    $add_sth->execute(
601        map { $self->charset_encode($_) }
602            ($node_id, $version, $content, $timestamp, (1-$node_requires_moderation))
603    ) or croak "Error updating database: " . DBI->errstr;
604
605
606    # Update the backlinks.
607    $dbh->do("DELETE FROM internal_links WHERE link_from="
608             . $dbh->quote($self->charset_encode($node)) ) or croak $dbh->errstr;
609    foreach my $links_to ( @links_to ) {
610        $sql = "INSERT INTO internal_links (link_from, link_to) VALUES ("
611             . join(", ", map { $dbh->quote($self->charset_encode($_)) } ( $node, $links_to ) ) . ")";
612        # Better to drop a backlink or two than to lose the whole update.
613        # Shevek wants a case-sensitive wiki, Jerakeen wants a case-insensitive
614        # one, MySQL compares case-sensitively on varchars unless you add
615        # the binary keyword.  Case-sensitivity to be revisited.
616        eval { $dbh->do($sql); };
617        carp "Couldn't index backlink: " . $dbh->errstr if $@;
618    }
619
620    # And also store any metadata.  Note that any entries already in the
621    # metadata table refer to old versions, so we don't need to delete them.
622    my %metadata = %{ $metadata_ref || {} }; # default to no metadata
623    foreach my $type ( keys %metadata ) {
624        my $val = $metadata{$type};
625
626        # We might have one or many values; make an array now to merge cases.
627        my @values = (ref $val and ref $val eq 'ARRAY') ? @$val : ( $val );
628
629        # Find out whether all values for this type are scalars.
630        my $all_scalars = 1;
631        foreach my $value (@values) {
632            $all_scalars = 0 if ref $value;
633        }
634
635        # For adding to metadata
636        my $add_sql = 
637              "INSERT INTO metadata "
638             ."   (node_id, version, metadata_type, metadata_value) "
639             ."VALUES (?, ?, ?, ?)";
640        my $add_sth = $dbh->prepare($add_sql);
641
642        # If all values for this type are scalars, strip out any duplicates
643        # and store the data.
644        if ( $all_scalars ) {
645            my %unique = map { $_ => 1 } @values;
646            @values = keys %unique;
647
648            foreach my $value ( @values ) {
649                $add_sth->execute(
650                    map { $self->charset_encode($_) }
651                        ( $node_id, $version, $type, $value )
652                ) or croak $dbh->errstr;
653            }
654        } else {
655            # Otherwise grab a checksum and store that.
656            my $type_to_store  = "__" . $type . "__checksum";
657            my $value_to_store = $self->_checksum_hashes( @values );
658            $add_sth->execute(
659                  map { $self->charset_encode($_) }
660                      ( $node_id, $version, $type_to_store, $value_to_store )
661            )  or croak $dbh->errstr;
662        }
663    }
664
665    # Finally call post_write on any plugins.
666    my @postplugins = @{ $args{plugins} || [ ] };
667    foreach my $plugin (@postplugins) {
668        if ( $plugin->can( "post_write" ) ) {
669            $plugin->post_write( 
670                node     => $node,
671                node_id  => $node_id,
672                version  => $version,
673                content  => $content,
674                metadata => $metadata_ref );
675        }
676    }
677
678    return $version;
679}
680
681# Returns the timestamp of now, unless epoch is supplied.
682sub _get_timestamp {
683    my $self = shift;
684    # I don't care about no steenkin' timezones (yet).
685    my $time = shift || localtime; # Overloaded by Time::Piece.
686    unless( ref $time ) {
687    $time = localtime($time); # Make it into an object for strftime
688    }
689    return $time->strftime($timestamp_fmt); # global
690}
691
692=item B<rename_node>
693
694  $store->rename_node(
695                         old_name  => $node,
696                         new_name  => $new_node,
697                         wiki      => $wiki,
698                         create_new_versions => $create_new_versions,
699                       );
700
701Renames a node, updating any references to it as required (assuming your
702chosen formatter supports rename, that is).
703
704Uses the internal_links table to identify the nodes that link to this
705one, and re-writes any wiki links in these to point to the new name.
706
707=cut
708
709sub rename_node {
710    my ($self, %args) = @_;
711    my ($old_name,$new_name,$wiki,$create_new_versions) = 
712        @args{ qw( old_name new_name wiki create_new_versions ) };
713    my $dbh = $self->dbh;
714    my $formatter = $wiki->{_formatter};
715
716    my $timestamp = $self->_get_timestamp();
717
718    # Call pre_rename on any plugins, in case they want to tweak anything
719    my @preplugins = @{ $args{plugins} || [ ] };
720    my $rename_allowed = 1;
721    foreach my $plugin (@preplugins) {
722        if ( $plugin->can( "pre_rename" ) ) {
723            handle_pre_plugin_ret(
724                \$rename_allowed,
725                $plugin->pre_rename( 
726                    old_name => \$old_name,
727                    new_name => \$new_name,
728                    create_new_versions => \$create_new_versions,
729                )
730            );
731        }
732    }
733    if($rename_allowed < 1) {
734        # The plugins didn't want to allow this action
735        return -1;
736    }
737
738    # Get the ID of the node
739    my $sql = "SELECT id FROM node WHERE name=?";
740    my $sth = $dbh->prepare($sql);
741    $sth->execute($old_name);
742    my ($node_id) = $sth->fetchrow_array;
743    $sth->finish;
744
745
746    # If the formatter supports it, get a list of the internal
747    #  links to the page, which will have their links re-written
748    # (Do now before we update the name of the node, in case of
749    #  self links)
750    my @links;
751    if($formatter->can("rename_links")) {
752        # Get a list of the pages that link to the page
753        $sql = "SELECT id, name, version "
754            ."FROM internal_links "
755            ."INNER JOIN node "
756            ."    ON (link_from = name) "
757            ."WHERE link_to = ?";
758        $sth = $dbh->prepare($sql);
759        $sth->execute($old_name);
760
761        # Grab them all, then update, so no locking problems
762        while(my @l = $sth->fetchrow_array) { push (@links, \@l); }
763    }
764
765   
766    # Rename the node
767    $sql = "UPDATE node SET name=? WHERE id=?";
768    $sth = $dbh->prepare($sql);
769    $sth->execute($new_name,$node_id);
770
771
772    # Fix the internal links from this page
773    # (Otherwise write_node will get confused if we rename links later on)
774    $sql = "UPDATE internal_links SET link_from=? WHERE link_from=?";
775    $sth = $dbh->prepare($sql);
776    $sth->execute($new_name,$old_name);
777
778
779    # Update the text of internal links, if the formatter supports it
780    if($formatter->can("rename_links")) {
781        # Update the linked pages (may include renamed page)
782        foreach my $l (@links) {
783            my ($page_id, $page_name, $page_version) = @$l;
784            # Self link special case
785            if($page_name eq $old_name) { $page_name = $new_name; }
786
787            # Grab the latest version of that page
788            my %page = $self->retrieve_node(
789                    name=>$page_name, version=>$page_version
790            );
791
792            # Update the content of the page
793            my $new_content = 
794                $formatter->rename_links($old_name,$new_name,$page{'content'});
795
796            # Did it change?
797            if($new_content ne $page{'content'}) {
798                # Write the updated page out
799                if($create_new_versions) {
800                    # Write out as a new version of the node
801                    # (This will also fix our internal links)
802                    $wiki->write_node(
803                                $page_name, 
804                                $new_content,
805                                $page{checksum},
806                                $page{metadata}
807                    );
808                } else {
809                    # Just update the content
810                    my $update_sql_a = "UPDATE node SET text=? WHERE id=?";
811                    my $update_sql_b = "UPDATE content SET text=? ".
812                                       "WHERE node_id=? AND version=?";
813
814                    my $u_sth = $dbh->prepare($update_sql_a);
815                    $u_sth->execute($new_content,$page_id);
816                    $u_sth = $dbh->prepare($update_sql_b);
817                    $u_sth->execute($new_content,$page_id,$page_version);
818                }
819            }
820        }
821
822        # Fix the internal links if we didn't create new versions of the node
823        if(! $create_new_versions) {
824            $sql = "UPDATE internal_links SET link_to=? WHERE link_to=?";
825            $sth = $dbh->prepare($sql);
826            $sth->execute($new_name,$old_name);
827        }
828    } else {
829        warn("Internal links not updated following node rename - unsupported by formatter");
830    }
831
832    # Call post_rename on any plugins, in case they want to do anything
833    my @postplugins = @{ $args{plugins} || [ ] };
834    foreach my $plugin (@postplugins) {
835        if ( $plugin->can( "post_rename" ) ) {
836            $plugin->post_rename( 
837                old_name => $old_name,
838                new_name => $new_name,
839                node_id => $node_id,
840            );
841        }
842    }
843}
844
845=item B<moderate_node>
846
847  $store->moderate_node(
848                         name    => $node,
849                         version => $version
850                       );
851
852Marks the given version of the node as moderated. If this is the
853highest moderated version, then update the node's contents to hold
854this version.
855
856=cut
857
858sub moderate_node {
859    my $self = shift;
860    my %args = scalar @_ == 2 ? ( name => $_[0], version => $_[1] ) : @_;
861    my $dbh = $self->dbh;
862
863    my ($name,$version) = ($args{name},$args{version});
864
865    # Call pre_moderate on any plugins.
866    my @plugins = @{ $args{plugins} || [ ] };
867    my $moderation_allowed = 1;
868    foreach my $plugin (@plugins) {
869        if ( $plugin->can( "pre_moderate" ) ) {
870            handle_pre_plugin_ret(
871                \$moderation_allowed,
872                $plugin->pre_moderate( 
873                    node     => \$name,
874                    version  => \$version )
875            );
876        }
877    }
878    if($moderation_allowed < 1) {
879        # The plugins didn't want to allow this action
880        return -1;
881    }
882
883    # Get the ID of this node
884    my $id_sql = "SELECT id FROM node WHERE name=?";
885    my $id_sth = $dbh->prepare($id_sql);
886    $id_sth->execute($name);
887    my ($node_id) = $id_sth->fetchrow_array;
888    $id_sth->finish;
889
890    # Check what the current highest moderated version is
891    my $hv_sql = 
892         "SELECT max(version) "
893        ."FROM content "
894        ."WHERE node_id = ? "
895        ."AND moderated = ?";
896    my $hv_sth = $dbh->prepare($hv_sql);
897    $hv_sth->execute($node_id, "1") or croak $dbh->errstr;
898    my ($highest_mod_version) = $hv_sth->fetchrow_array;
899    $hv_sth->finish;
900    unless($highest_mod_version) { $highest_mod_version = 0; }
901
902    # Mark this version as moderated
903    my $update_sql = 
904         "UPDATE content "
905        ."SET moderated = ? "
906        ."WHERE node_id = ? "
907        ."AND version = ?";
908    my $update_sth = $dbh->prepare($update_sql);
909    $update_sth->execute("1", $node_id, $version) or croak $dbh->errstr;
910
911    # Are we now the highest moderated version?
912    if(int($version) > int($highest_mod_version)) {
913        # Newly moderated version is newer than previous moderated version
914        # So, make the current version the latest version
915        my %new_data = $self->retrieve_node( name => $name, version => $version );
916
917        # Make sure last modified is properly null, if not set
918        unless($new_data{last_modified}) { $new_data{last_modified} = undef; }
919
920        my $newv_sql = 
921             "UPDATE node "
922            ."SET version=?, text=?, modified=? "
923            ."WHERE id = ?";
924        my $newv_sth = $dbh->prepare($newv_sql);
925        $newv_sth->execute(
926            $version, $self->charset_encode($new_data{content}), 
927            $new_data{last_modified}, $node_id
928        ) or croak $dbh->errstr;
929    } else {
930        # A higher version is already moderated, so don't change node
931    }
932
933    # TODO: Do something about internal links, if required
934
935    # Finally call post_moderate on any plugins.
936    @plugins = @{ $args{plugins} || [ ] };
937    foreach my $plugin (@plugins) {
938        if ( $plugin->can( "post_moderate" ) ) {
939            $plugin->post_moderate( 
940                node     => $name,
941                node_id  => $node_id,
942                version  => $version );
943        }
944    }
945
946    return 1;
947}
948
949=item B<set_node_moderation>
950
951  $store->set_node_moderation(
952                         name     => $node,
953                         required => $required
954                       );
955
956Sets if new node versions will require moderation or not
957
958=cut
959
960sub set_node_moderation {
961    my $self = shift;
962    my %args = scalar @_ == 2 ? ( name => $_[0], required => $_[1] ) : @_;
963    my $dbh = $self->dbh;
964
965    my ($name,$required) = ($args{name},$args{required});
966
967    # Get the ID of this node
968    my $id_sql = "SELECT id FROM node WHERE name=?";
969    my $id_sth = $dbh->prepare($id_sql);
970    $id_sth->execute($name);
971    my ($node_id) = $id_sth->fetchrow_array;
972    $id_sth->finish;
973
974    # Check we really got an ID
975    unless($node_id) {
976        return 0;
977    }
978
979    # Mark it as requiring / not requiring moderation
980    my $mod_sql = 
981         "UPDATE node "
982        ."SET moderate = ? "
983        ."WHERE id = ? ";
984    my $mod_sth = $dbh->prepare($mod_sql);
985    $mod_sth->execute("$required", $node_id) or croak $dbh->errstr;
986
987    return 1;
988}
989
990=item B<delete_node>
991
992  $store->delete_node(
993                       name    => $node,
994                       version => $version,
995                       wiki    => $wiki
996                     );
997
998C<version> is optional.  If it is supplied then only that version of
999the node will be deleted.  Otherwise the node and all its history will
1000be completely deleted.
1001
1002C<wiki> is also optional, but if you care about updating the backlinks
1003you want to include it.
1004
1005Again, doesn't do any locking. You probably don't want to let anyone
1006except Wiki admins call this. You may not want to use it at all.
1007
1008Croaks on error, silently does nothing if the node or version doesn't
1009exist, returns true if no error.
1010
1011=cut
1012
1013sub delete_node {
1014    my $self = shift;
1015    # Backwards compatibility.
1016    my %args = ( scalar @_ == 1 ) ? ( name => $_[0] ) : @_;
1017
1018    my $dbh = $self->dbh;
1019    my ($name, $version, $wiki) = @args{ qw( name version wiki ) };
1020
1021    # Grab the ID of this node
1022    # (It will only ever have one entry in node, but might have entries
1023    #  for other versions in metadata and content)
1024    my $id_sql = "SELECT id FROM node WHERE name=?";
1025    my $id_sth = $dbh->prepare($id_sql);
1026    $id_sth->execute($name);
1027    my ($node_id) = $id_sth->fetchrow_array;
1028    $id_sth->finish;
1029
1030    # Trivial case - delete the whole node and all its history.
1031    unless ( $version ) {
1032        my $sql;
1033        # Should start a transaction here.  FIXME.
1034        # Do deletes
1035        $sql = "DELETE FROM content WHERE node_id = $node_id";
1036        $dbh->do($sql) or croak "Deletion failed: " . DBI->errstr;
1037        $sql = "DELETE FROM internal_links WHERE link_from=".$dbh->quote($name);
1038        $dbh->do($sql) or croak $dbh->errstr;
1039        $sql = "DELETE FROM metadata WHERE node_id = $node_id";
1040        $dbh->do($sql) or croak $dbh->errstr;
1041        $sql = "DELETE FROM node WHERE id = $node_id";
1042        $dbh->do($sql) or croak "Deletion failed: " . DBI->errstr;
1043
1044        # And finish it here.
1045        post_delete_node($name,$node_id,$version,$args{plugins});
1046        return 1;
1047    }
1048
1049    # Skip out early if we're trying to delete a nonexistent version.
1050    my %verdata = $self->retrieve_node( name => $name, version => $version );
1051    unless($verdata{version}) {
1052        warn("Asked to delete non existant version $version of node $node_id ($name)");
1053        return 1;
1054    }
1055
1056    # Reduce to trivial case if deleting the only version.
1057    my $sql = "SELECT COUNT(*) FROM content WHERE node_id = $node_id";
1058    my $sth = $dbh->prepare( $sql );
1059    $sth->execute() or croak "Deletion failed: " . $dbh->errstr;
1060    my ($count) = $sth->fetchrow_array;
1061    $sth->finish;
1062    if($count == 1) {
1063        # Only one version, so can do the non version delete
1064        return $self->delete_node( name=>$name, plugins=>$args{plugins} );
1065    }
1066
1067    # Check whether we're deleting the latest (moderated) version.
1068    my %currdata = $self->retrieve_node( name => $name );
1069    if ( $currdata{version} == $version ) {
1070        # Deleting latest version, so need to update the copy in node
1071        # (Can't just grab version ($version - 1) since it may have been
1072        #  deleted itself, or might not be moderated.)
1073        my $try = $version - 1;
1074        my %prevdata;
1075        until ( $prevdata{version} && $prevdata{moderated} ) {
1076            %prevdata = $self->retrieve_node(
1077                                              name    => $name,
1078                                              version => $try,
1079                                            );
1080            $try--;
1081        }
1082
1083        # Move to new (old) version
1084        my $sql="UPDATE node
1085                 SET version=?, text=?, modified=?
1086                 WHERE name=?";
1087        my $sth = $dbh->prepare( $sql );
1088        $sth->execute( @prevdata{ qw( version content last_modified ) }, $name)
1089            or croak "Deletion failed: " . $dbh->errstr;
1090
1091        # Remove the current version from content
1092        $sql = "DELETE FROM content
1093                WHERE node_id = $node_id
1094                AND version = $version";
1095        $sth = $dbh->prepare( $sql );
1096        $sth->execute()
1097            or croak "Deletion failed: " . $dbh->errstr;
1098
1099        # Update the internal links to reflect the new version
1100        $sql = "DELETE FROM internal_links WHERE link_from=?";
1101        $sth = $dbh->prepare( $sql );
1102        $sth->execute( $name )
1103          or croak "Deletion failed: " . $dbh->errstr;
1104        my @links_to;
1105        my $formatter = $wiki->formatter;
1106        if ( $formatter->can( "find_internal_links" ) ) {
1107            # Supply $metadata to formatter in case it's needed to alter the
1108            # behaviour of the formatter, eg for Wiki::Toolkit::Formatter::Multiple
1109            my @all = $formatter->find_internal_links(
1110                                    $prevdata{content}, $prevdata{metadata} );
1111            my %unique = map { $_ => 1 } @all;
1112            @links_to = keys %unique;
1113        }
1114        $sql = "INSERT INTO internal_links (link_from, link_to) VALUES (?,?)";
1115        $sth = $dbh->prepare( $sql );
1116        foreach my $link ( @links_to ) {
1117            eval { $sth->execute( $name, $link ); };
1118            carp "Couldn't index backlink: " . $dbh->errstr if $@;
1119        }
1120
1121        # Delete the metadata for the old version
1122        $sql = "DELETE FROM metadata
1123                WHERE node_id = $node_id
1124                AND version = $version";
1125        $sth = $dbh->prepare( $sql );
1126        $sth->execute()
1127            or croak "Deletion failed: " . $dbh->errstr;
1128
1129        # All done
1130        post_delete_node($name,$node_id,$version,$args{plugins});
1131        return 1;
1132    }
1133
1134    # If we're still here, then we're deleting neither the latest
1135    # nor the only version.
1136    $sql = "DELETE FROM content
1137            WHERE node_id = $node_id
1138            AND version=?";
1139    $sth = $dbh->prepare( $sql );
1140    $sth->execute( $version )
1141        or croak "Deletion failed: " . $dbh->errstr;
1142    $sql = "DELETE FROM metadata
1143            WHERE node_id = $node_id
1144            AND version=?";
1145    $sth = $dbh->prepare( $sql );
1146    $sth->execute( $version )
1147        or croak "Deletion failed: " . $dbh->errstr;
1148
1149    # All done
1150    post_delete_node($name,$node_id,$version,$args{plugins});
1151    return 1;
1152}
1153
1154# Returns the name of the node with the given ID
1155# Not normally used except when doing low-level maintenance
1156sub node_name_for_id {
1157    my ($self, $node_id) = @_;
1158    my $dbh = $self->dbh;
1159
1160    my $name_sql = "SELECT name FROM node WHERE id=?";
1161    my $name_sth = $dbh->prepare($name_sql);
1162    $name_sth->execute($node_id);
1163    my ($name) = $name_sth->fetchrow_array;
1164    $name_sth->finish;
1165
1166    return $name;
1167}
1168
1169# Internal Method
1170sub post_delete_node {
1171    my ($name,$node_id,$version,$plugins) = @_;
1172
1173    # Call post_delete on any plugins, having done the delete
1174    my @plugins = @{ $plugins || [ ] };
1175    foreach my $plugin (@plugins) {
1176        if ( $plugin->can( "post_delete" ) ) {
1177            $plugin->post_delete( 
1178                node     => $name,
1179                node_id  => $node_id,
1180                version  => $version );
1181        }
1182    }
1183}
1184
1185=item B<list_recent_changes>
1186
1187  # Nodes changed in last 7 days - each node listed only once.
1188  my @nodes = $store->list_recent_changes( days => 7 );
1189
1190  # Nodes added in the last 7 days.
1191  my @nodes = $store->list_recent_changes(
1192                                           days     => 7,
1193                                           new_only => 1,
1194                                         );
1195
1196  # All changes in last 7 days - nodes changed more than once will
1197  # be listed more than once.
1198  my @nodes = $store->list_recent_changes(
1199                                           days => 7,
1200                                           include_all_changes => 1,
1201                                         );
1202
1203  # Nodes changed between 1 and 7 days ago.
1204  my @nodes = $store->list_recent_changes( between_days => [ 1, 7 ] );
1205
1206  # Nodes changed since a given time.
1207  my @nodes = $store->list_recent_changes( since => 1036235131 );
1208
1209  # Most recent change and its details.
1210  my @nodes = $store->list_recent_changes( last_n_changes => 1 );
1211  print "Node:          $nodes[0]{name}";
1212  print "Last modified: $nodes[0]{last_modified}";
1213  print "Comment:       $nodes[0]{metadata}{comment}";
1214
1215  # Last 5 restaurant nodes edited.
1216  my @nodes = $store->list_recent_changes(
1217      last_n_changes => 5,
1218      metadata_is    => { category => "Restaurants" }
1219  );
1220
1221  # Last 5 nodes edited by Kake.
1222  my @nodes = $store->list_recent_changes(
1223      last_n_changes => 5,
1224      metadata_was   => { username => "Kake" }
1225  );
1226
1227  # All minor edits made by Earle in the last week.
1228  my @nodes = $store->list_recent_changes(
1229      days           => 7,
1230      metadata_was   => { username  => "Earle",
1231                          edit_type => "Minor tidying." }
1232  );
1233
1234  # Last 10 changes that weren't minor edits.
1235  my @nodes = $store->list_recent_changes(
1236      last_n_changes => 10,
1237      metadata_wasnt  => { edit_type => "Minor tidying" }
1238  );
1239
1240You I<must> supply one of the following constraints: C<days>
1241(integer), C<since> (epoch), C<last_n_changes> (integer).
1242
1243You I<may> also supply moderation => 1 if you only want to see versions
1244that are moderated.
1245
1246Another optional parameter is C<new_only>, which if set to 1 will only
1247return newly added nodes.
1248
1249You I<may> also supply I<either> C<metadata_is> (and optionally
1250C<metadata_isnt>), I<or> C<metadata_was> (and optionally
1251C<metadata_wasnt>). Each of these should be a ref to a hash with
1252scalar keys and values.  If the hash has more than one entry, then
1253only changes satisfying I<all> criteria will be returned when using
1254C<metadata_is> or C<metadata_was>, but all changes which fail to
1255satisfy any one of the criteria will be returned when using
1256C<metadata_isnt> or C<metadata_is>.
1257
1258C<metadata_is> and C<metadata_isnt> look only at the metadata that the
1259node I<currently> has. C<metadata_was> and C<metadata_wasnt> take into
1260account the metadata of previous versions of a node.  Don't mix C<is>
1261with C<was> - there's no check for this, but the results are undefined.
1262
1263Returns results as an array, in reverse chronological order.  Each
1264element of the array is a reference to a hash with the following entries:
1265
1266=over 4
1267
1268=item * B<name>: the name of the node
1269
1270=item * B<version>: the latest version number
1271
1272=item * B<last_modified>: the timestamp of when it was last modified
1273
1274=item * B<metadata>: a ref to a hash containing any metadata attached
1275to the current version of the node
1276
1277=back
1278
1279Unless you supply C<include_all_changes>, C<metadata_was> or
1280C<metadata_wasnt>, each node will only be returned once regardless of
1281how many times it has been changed recently.
1282
1283By default, the case-sensitivity of both C<metadata_type> and
1284C<metadata_value> depends on your database - if it will return rows
1285with an attribute value of "Pubs" when you asked for "pubs", or not.
1286If you supply a true value to the C<ignore_case> parameter, then you
1287can be sure of its being case-insensitive.  This is recommended.
1288
1289=cut
1290
1291sub list_recent_changes {
1292    my $self = shift;
1293    my %args = @_;
1294    if ($args{since}) {
1295        return $self->_find_recent_changes_by_criteria( %args );
1296    } elsif ($args{between_days}) {
1297        return $self->_find_recent_changes_by_criteria( %args );
1298    } elsif ( $args{days} ) {
1299        my $now = localtime;
1300    my $then = $now - ( ONE_DAY * $args{days} );
1301        $args{since} = $then;
1302        delete $args{days};
1303        return $self->_find_recent_changes_by_criteria( %args );
1304    } elsif ( $args{last_n_changes} ) {
1305        $args{limit} = delete $args{last_n_changes};
1306        return $self->_find_recent_changes_by_criteria( %args );
1307    } else {
1308        croak "Need to supply some criteria to list_recent_changes.";
1309    }
1310}
1311
1312sub _find_recent_changes_by_criteria {
1313    my ($self, %args) = @_;
1314    my ($since, $limit, $between_days, $ignore_case, $new_only,
1315        $metadata_is,  $metadata_isnt, $metadata_was, $metadata_wasnt,
1316    $moderation, $include_all_changes ) =
1317         @args{ qw( since limit between_days ignore_case new_only
1318                    metadata_is metadata_isnt metadata_was metadata_wasnt
1319            moderation include_all_changes) };
1320    my $dbh = $self->dbh;
1321
1322    my @where;
1323    my @metadata_joins;
1324    my $use_content_table; # some queries won't need this
1325
1326    if ( $metadata_is ) {
1327        my $main_table = "node";
1328        if ( $include_all_changes ) {
1329            $main_table = "content";
1330            $use_content_table = 1;
1331        }
1332        my $i = 0;
1333        foreach my $type ( keys %$metadata_is ) {
1334            $i++;
1335            my $value  = $metadata_is->{$type};
1336            croak "metadata_is must have scalar values" if ref $value;
1337            my $mdt = "md_is_$i";
1338            push @metadata_joins, "LEFT JOIN metadata AS $mdt
1339                                   ON $main_table."
1340                                   . ( ($main_table eq "node") ? "id"
1341                                                               : "node_id" )
1342                                   . "=$mdt.node_id
1343                                   AND $main_table.version=$mdt.version\n";
1344            # Why is this inside 'if ( $metadata_is )'?
1345            # Shouldn't it apply to all cases?
1346            # What's it doing in @metadata_joins?
1347            if (defined $moderation) {
1348                push @metadata_joins, "AND $main_table.moderate=$moderation";
1349            }
1350            push @where, "( "
1351                         . $self->_get_comparison_sql(
1352                                          thing1      => "$mdt.metadata_type",
1353                                          thing2      => $dbh->quote($type),
1354                                          ignore_case => $ignore_case,
1355                                                     )
1356                         . " AND "
1357                         . $self->_get_comparison_sql(
1358                                          thing1      => "$mdt.metadata_value",
1359                                          thing2      => $dbh->quote( $self->charset_encode($value) ),
1360                                          Ignore_case => $ignore_case,
1361                                                     )
1362                         . " )";
1363    }
1364    }
1365
1366    if ( $metadata_isnt ) {
1367        foreach my $type ( keys %$metadata_isnt ) {
1368            my $value  = $metadata_isnt->{$type};
1369            croak "metadata_isnt must have scalar values" if ref $value;
1370    }
1371        my @omits = $self->_find_recent_changes_by_criteria(
1372            since        => $since,
1373            between_days => $between_days,
1374            metadata_is  => $metadata_isnt,
1375            ignore_case  => $ignore_case,
1376        );
1377        foreach my $omit ( @omits ) {
1378            push @where, "( node.name != " . $dbh->quote($omit->{name})
1379                 . "  OR node.version != " . $dbh->quote($omit->{version})
1380                 . ")";
1381    }
1382    }
1383
1384    if ( $metadata_was ) {
1385        $use_content_table = 1;
1386        my $i = 0;
1387        foreach my $type ( keys %$metadata_was ) {
1388            $i++;
1389            my $value  = $metadata_was->{$type};
1390            croak "metadata_was must have scalar values" if ref $value;
1391            my $mdt = "md_was_$i";
1392            push @metadata_joins, "LEFT JOIN metadata AS $mdt
1393                                   ON content.node_id=$mdt.node_id
1394                                   AND content.version=$mdt.version\n";
1395            push @where, "( "
1396                         . $self->_get_comparison_sql(
1397                                          thing1      => "$mdt.metadata_type",
1398                                          thing2      => $dbh->quote($type),
1399                                          ignore_case => $ignore_case,
1400                                                     )
1401                         . " AND "
1402                         . $self->_get_comparison_sql(
1403                                          thing1      => "$mdt.metadata_value",
1404                                          thing2      => $dbh->quote( $self->charset_encode($value) ),
1405                                          ignore_case => $ignore_case,
1406                                                     )
1407                         . " )";
1408        }
1409    }
1410
1411    if ( $metadata_wasnt ) {
1412        foreach my $type ( keys %$metadata_wasnt ) {
1413                my $value  = $metadata_was->{$type};
1414                croak "metadata_was must have scalar values" if ref $value;
1415    }
1416        my @omits = $self->_find_recent_changes_by_criteria(
1417                since        => $since,
1418                between_days => $between_days,
1419                metadata_was => $metadata_wasnt,
1420                ignore_case  => $ignore_case,
1421        );
1422        foreach my $omit ( @omits ) {
1423            push @where, "( node.name != " . $dbh->quote($omit->{name})
1424                 . "  OR content.version != " . $dbh->quote($omit->{version})
1425                 . ")";
1426    }
1427        $use_content_table = 1;
1428    }
1429
1430    # Figure out which table we should be joining to to check the dates and
1431    # versions - node or content.
1432    my $date_table = "node";
1433    if ( $include_all_changes || $new_only ) {
1434        $date_table = "content";
1435        $use_content_table = 1;
1436    }
1437    if ( $new_only ) {
1438        push @where, "content.version=1";
1439    }
1440
1441    if ( $since ) {
1442        my $timestamp = $self->_get_timestamp( $since );
1443        push @where, "$date_table.modified >= " . $dbh->quote($timestamp);
1444    } elsif ( $between_days ) {
1445        my $now = localtime;
1446        # Start is the larger number of days ago.
1447        my ($start, $end) = @$between_days;
1448        ($start, $end) = ($end, $start) if $start < $end;
1449        my $ts_start = $self->_get_timestamp( $now - (ONE_DAY * $start) ); 
1450        my $ts_end = $self->_get_timestamp( $now - (ONE_DAY * $end) ); 
1451        push @where, "$date_table.modified >= " . $dbh->quote($ts_start);
1452        push @where, "$date_table.modified <= " . $dbh->quote($ts_end);
1453    }
1454
1455    my $sql = "SELECT DISTINCT
1456                               node.name,
1457              ";
1458    if ( $include_all_changes || $new_only || $use_content_table ) {
1459        $sql .= " content.version, content.modified ";
1460    } else {
1461        $sql .= " node.version, node.modified ";
1462    }
1463    $sql .= " FROM node ";
1464    if ( $use_content_table ) {
1465        $sql .= " INNER JOIN content ON (node.id = content.node_id ) ";
1466    }
1467
1468    $sql .= join("\n", @metadata_joins)
1469            . (
1470                scalar @where
1471                              ? " WHERE " . join(" AND ",@where) 
1472                              : ""
1473              )
1474            . " ORDER BY "
1475            . ( $use_content_table ? "content" : "node" )
1476            . ".modified DESC";
1477    if ( $limit ) {
1478        croak "Bad argument $limit" unless $limit =~ /^\d+$/;
1479        $sql .= " LIMIT $limit";
1480    }
1481    my $nodesref = $dbh->selectall_arrayref($sql);
1482    my @finds = map { { name          => $_->[0],
1483                        version       => $_->[1],
1484                        last_modified => $_->[2] }
1485                    } @$nodesref;
1486    foreach my $find ( @finds ) {
1487        my %metadata;
1488        my $sth = $dbh->prepare( "SELECT metadata_type, metadata_value
1489                                  FROM node
1490                                  INNER JOIN metadata
1491                                  ON (id = node_id)
1492                                  WHERE name=?
1493                                  AND metadata.version=?" );
1494        $sth->execute( $find->{name}, $find->{version} );
1495        while ( my ($type, $value) = $self->charset_decode( $sth->fetchrow_array ) ) {
1496        if ( defined $metadata{$type} ) {
1497                push @{$metadata{$type}}, $value;
1498        } else {
1499                $metadata{$type} = [ $value ];
1500            }
1501    }
1502        $find->{metadata} = \%metadata;
1503    }
1504    return @finds;
1505}
1506
1507=item B<list_all_nodes>
1508
1509  my @nodes = $store->list_all_nodes();
1510  print "First node is $nodes[0]\n";
1511
1512  my @nodes = $store->list_all_nodes( with_details=> 1 );
1513  print "First node is ".$nodes[0]->{'name'}." at version ".$nodes[0]->{'version'}."\n";
1514
1515Returns a list containing the name of every existing node.  The list
1516won't be in any kind of order; do any sorting in your calling script.
1517
1518Optionally also returns the id, version and moderation flag.
1519
1520=cut
1521
1522sub list_all_nodes {
1523    my ($self,%args) = @_;
1524    my $dbh = $self->dbh;
1525    my @nodes;
1526
1527    if($args{with_details}) {
1528        my $sql = "SELECT id, name, version, moderate FROM node;";
1529        my $sth = $dbh->prepare( $sql );
1530        $sth->execute();
1531
1532        while(my @results = $sth->fetchrow_array) {
1533            my %data;
1534            @data{ qw( node_id name version moderate ) } = @results;
1535            push @nodes, \%data;
1536        }
1537    } else {
1538        my $sql = "SELECT name FROM node;";
1539        my $raw_nodes = $dbh->selectall_arrayref($sql); 
1540        @nodes = ( map { $self->charset_decode( $_->[0] ) } (@$raw_nodes) );
1541    }
1542    return @nodes;
1543}
1544
1545=item B<list_node_all_versions>
1546
1547  my @all_versions = $store->list_node_all_versions(
1548      name => 'HomePage',
1549      with_content => 1,
1550      with_metadata => 0
1551  );
1552
1553Returns all the versions of a node, optionally including the content
1554and metadata, as an array of hashes (newest versions first).
1555
1556=cut
1557
1558sub list_node_all_versions {
1559    my ($self, %args) = @_;
1560
1561    my ($node_id,$name,$with_content,$with_metadata) = 
1562                @args{ qw( node_id name with_content with_metadata ) };
1563
1564    my $dbh = $self->dbh;
1565    my $sql;
1566
1567    # If they only gave us the node name, get the node id
1568    unless ($node_id) {
1569        $sql = "SELECT id FROM node WHERE name=" . $dbh->quote($name);
1570        $node_id = $dbh->selectrow_array($sql);
1571    }
1572
1573    # If they didn't tell us what they wanted / we couldn't find it,
1574    #  return an empty array
1575    return () unless($node_id);
1576
1577    # Build up our SQL
1578    $sql = "SELECT id, name, content.version, content.modified ";
1579    if ( $with_content ) {
1580        $sql .= ", content.text ";
1581    }
1582    if ( $with_metadata ) {
1583        $sql .= ", metadata_type, metadata_value ";
1584    }
1585    $sql .= " FROM node INNER JOIN content ON (id = content.node_id) ";
1586    if ( $with_metadata ) {
1587        $sql .= " LEFT OUTER JOIN metadata ON "
1588           . "(id = metadata.node_id AND content.version = metadata.version) ";
1589    }
1590    $sql .= " WHERE id = ? ORDER BY content.version DESC";
1591
1592    # Do the fetch
1593    my $sth = $dbh->prepare( $sql );
1594    $sth->execute( $node_id );
1595
1596    # Need to hold onto the last row by hash ref, so we don't trash
1597    #  it every time
1598    my %first_data;
1599    my $dataref = \%first_data;
1600
1601    # Haul out the data
1602    my @versions;
1603    while ( my @results = $sth->fetchrow_array ) {
1604        my %data = %$dataref;
1605
1606        # Is it the same version as last time?
1607        if ( %data && $data{'version'} != $results[2] ) {
1608            # New version
1609            push @versions, $dataref;
1610            %data = ();
1611        } else {
1612            # Same version as last time, must be more metadata
1613        }
1614
1615        # Grab the core data (will be the same on multi-row for metadata)
1616        @data{ qw( node_id name version last_modified ) } = @results;
1617
1618        my $i = 4;
1619        if ( $with_content ) {
1620            $data{'content'} = $results[$i];
1621            $i++;
1622        }
1623        if ( $with_metadata ) {
1624            my ($m_type,$m_value) = @results[$i,($i+1)];
1625            unless ( $data{'metadata'} ) { $data{'metadata'} = {}; }
1626
1627            if ( $m_type ) {
1628                # If we have existing data, then put it into an array
1629                if ( $data{'metadata'}->{$m_type} ) {
1630                    unless ( ref($data{'metadata'}->{$m_type}) eq "ARRAY" ) {
1631                        $data{'metadata'}->{$m_type} =
1632                                             [ $data{'metadata'}->{$m_type} ];
1633                    }
1634                    push @{$data{'metadata'}->{$m_type}}, $m_value;
1635                } else {
1636                    # Otherwise, just store it in a normal string
1637                    $data{'metadata'}->{$m_type} = $m_value;
1638                }
1639            }
1640        }
1641
1642        # Save where we've got to
1643        $dataref = \%data;
1644    }
1645
1646    # Handle final row saving
1647    if ( $dataref ) {
1648        push @versions, $dataref;
1649    }
1650
1651    # Return
1652    return @versions;
1653}
1654
1655=item B<list_nodes_by_metadata>
1656
1657  # All documentation nodes.
1658  my @nodes = $store->list_nodes_by_metadata(
1659      metadata_type  => "category",
1660      metadata_value => "documentation",
1661      ignore_case    => 1,   # optional but recommended (see below)
1662  );
1663
1664  # All pubs in Hammersmith.
1665  my @pubs = $store->list_nodes_by_metadata(
1666      metadata_type  => "category",
1667      metadata_value => "Pub",
1668  );
1669  my @hsm  = $store->list_nodes_by_metadata(
1670      metadata_type  => "category",
1671      metadata_value  => "Hammersmith",
1672  );
1673  my @results = my_l33t_method_for_ANDing_arrays( \@pubs, \@hsm );
1674
1675Returns a list containing the name of every node whose caller-supplied
1676metadata matches the criteria given in the parameters.
1677
1678By default, the case-sensitivity of both C<metadata_type> and
1679C<metadata_value> depends on your database - if it will return rows
1680with an attribute value of "Pubs" when you asked for "pubs", or not.
1681If you supply a true value to the C<ignore_case> parameter, then you
1682can be sure of its being case-insensitive.  This is recommended.
1683
1684If you don't supply any criteria then you'll get an empty list.
1685
1686This is a really really really simple way of finding things; if you
1687want to be more complicated then you'll need to call the method
1688multiple times and combine the results yourself, or write a plugin.
1689
1690=cut
1691
1692sub list_nodes_by_metadata {
1693    my ($self, %args) = @_;
1694    my ( $type, $value ) = @args{ qw( metadata_type metadata_value ) };
1695    return () unless $type;
1696
1697    my $dbh = $self->dbh;
1698    if ( $args{ignore_case} ) {
1699        $type  = lc( $type  );
1700        $value = lc( $value );
1701    }
1702    my $sql =
1703         $self->_get_list_by_metadata_sql( ignore_case => $args{ignore_case} );
1704    my $sth = $dbh->prepare( $sql );
1705    $sth->execute( $type, $self->charset_encode($value) );
1706    my @nodes;
1707    while ( my ($id, $node) = $sth->fetchrow_array ) {
1708        push @nodes, $node;
1709    }
1710    return @nodes;
1711}
1712
1713=item B<list_nodes_by_missing_metadata>
1714Returns nodes where either the metadata doesn't exist, or is blank
1715
1716Unlike list_nodes_by_metadata(), the metadata value is optional.
1717
1718  # All nodes missing documentation
1719  my @nodes = $store->list_nodes_by_missing_metadata(
1720      metadata_type  => "category",
1721      metadata_value => "documentation",
1722      ignore_case    => 1,   # optional but recommended (see below)
1723  );
1724
1725  # All nodes which don't have a latitude defined
1726  my @nodes = $store->list_nodes_by_missing_metadata(
1727      metadata_type  => "latitude"
1728  );
1729
1730=cut
1731
1732sub list_nodes_by_missing_metadata {
1733    my ($self, %args) = @_;
1734    my ( $type, $value ) = @args{ qw( metadata_type metadata_value ) };
1735    return () unless $type;
1736
1737    my $dbh = $self->dbh;
1738    if ( $args{ignore_case} ) {
1739        $type  = lc( $type  );
1740        $value = lc( $value );
1741    }
1742
1743    my @nodes;
1744
1745    # If the don't want to match by value, then we can do it with
1746    #  a LEFT OUTER JOIN, and either NULL or LENGTH() = 0
1747    if( ! $value ) {
1748        my $sql = $self->_get_list_by_missing_metadata_sql( 
1749                                        ignore_case => $args{ignore_case}
1750              );
1751        my $sth = $dbh->prepare( $sql );
1752        $sth->execute( $type );
1753
1754        while ( my ($id, $node) = $sth->fetchrow_array ) {
1755            push @nodes, $node;
1756        }
1757    } else {
1758        # To find those without the value in this case would involve
1759        #  some seriously brain hurting SQL.
1760        # So, cheat - find those with, and return everything else
1761        my @with = $self->list_nodes_by_metadata(%args);
1762        my %with_hash;
1763        foreach my $node (@with) { $with_hash{$node} = 1; }
1764
1765        my @all_nodes = $self->list_all_nodes();
1766        foreach my $node (@all_nodes) {
1767            unless($with_hash{$node}) {
1768                push @nodes, $node;
1769            }
1770        }
1771    }
1772
1773    return @nodes;
1774}
1775
1776=item B<_get_list_by_metadata_sql>
1777
1778Return the SQL to do a match by metadata. Should expect the metadata type
1779as the first SQL parameter, and the metadata value as the second.
1780
1781If possible, should take account of $args{ignore_case}
1782
1783=cut
1784
1785sub _get_list_by_metadata_sql {
1786    # SQL 99 version
1787    #  Can be over-ridden by database-specific subclasses
1788    my ($self, %args) = @_;
1789    if ( $args{ignore_case} ) {
1790        return "SELECT node.id, node.name "
1791             . "FROM node "
1792             . "INNER JOIN metadata "
1793             . "   ON (node.id = metadata.node_id "
1794             . "       AND node.version=metadata.version) "
1795             . "WHERE ". $self->_get_lowercase_compare_sql("metadata.metadata_type")
1796             . " AND ". $self->_get_lowercase_compare_sql("metadata.metadata_value");
1797    } else {
1798        return "SELECT node.id, node.name "
1799             . "FROM node "
1800             . "INNER JOIN metadata "
1801             . "   ON (node.id = metadata.node_id "
1802             . "       AND node.version=metadata.version) "
1803             . "WHERE ". $self->_get_casesensitive_compare_sql("metadata.metadata_type")
1804             . " AND ". $self->_get_casesensitive_compare_sql("metadata.metadata_value");
1805    }
1806}
1807
1808=item B<_get_list_by_missing_metadata_sql>
1809
1810Return the SQL to do a match by missing metadata. Should expect the metadata
1811type as the first SQL parameter.
1812
1813If possible, should take account of $args{ignore_case}
1814
1815=cut
1816
1817sub _get_list_by_missing_metadata_sql {
1818    # SQL 99 version
1819    #  Can be over-ridden by database-specific subclasses
1820    my ($self, %args) = @_;
1821
1822    my $sql = "";
1823    if ( $args{ignore_case} ) {
1824        $sql = "SELECT node.id, node.name "
1825             . "FROM node "
1826             . "LEFT OUTER JOIN metadata "
1827             . "   ON (node.id = metadata.node_id "
1828             . "       AND node.version=metadata.version "
1829             . "       AND ". $self->_get_lowercase_compare_sql("metadata.metadata_type")
1830             . ")";
1831    } else {
1832        $sql = "SELECT node.id, node.name "
1833             . "FROM node "
1834             . "LEFT OUTER JOIN metadata "
1835             . "   ON (node.id = metadata.node_id "
1836             . "       AND node.version=metadata.version "
1837             . "       AND ". $self->_get_casesensitive_compare_sql("metadata.metadata_type")
1838             . ")";
1839    }
1840
1841    $sql .= "WHERE (metadata.metadata_value IS NULL OR LENGTH(metadata.metadata_value) = 0) ";
1842    return $sql;
1843}
1844
1845sub _get_lowercase_compare_sql {
1846    my ($self, $column) = @_;
1847    # SQL 99 version
1848    #  Can be over-ridden by database-specific subclasses
1849    return "lower($column) = ?";
1850}
1851sub _get_casesensitive_compare_sql {
1852    my ($self, $column) = @_;
1853    # SQL 99 version
1854    #  Can be over-ridden by database-specific subclasses
1855    return "$column = ?";
1856}
1857
1858sub _get_comparison_sql {
1859    my ($self, %args) = @_;
1860    # SQL 99 version
1861    #  Can be over-ridden by database-specific subclasses
1862    return "$args{thing1} = $args{thing2}";
1863}
1864
1865sub _get_node_exists_ignore_case_sql {
1866    # SQL 99 version
1867    #  Can be over-ridden by database-specific subclasses
1868    return "SELECT name FROM node WHERE name = ? ";
1869}
1870
1871=item B<list_unmoderated_nodes>
1872
1873  my @nodes = $wiki->list_unmoderated_nodes();
1874  my @nodes = $wiki->list_unmoderated_nodes(
1875                                                only_where_latest => 1
1876                                            );
1877
1878  $nodes[0]->{'name'}              # The name of the node
1879  $nodes[0]->{'node_id'}           # The id of the node
1880  $nodes[0]->{'version'}           # The version in need of moderation
1881  $nodes[0]->{'moderated_version'} # The newest moderated version
1882
1883  With only_where_latest set, return the id, name and version of all the
1884   nodes where the most recent version needs moderation.
1885  Otherwise, returns the id, name and version of all node versions that need
1886   to be moderated.
1887
1888=cut
1889
1890sub list_unmoderated_nodes {
1891    my ($self,%args) = @_;
1892
1893    my $only_where_lastest = $args{'only_where_latest'};
1894
1895    my $sql =
1896         "SELECT "
1897        ."    id, name, "
1898        ."    node.version AS last_moderated_version, "
1899        ."    content.version AS version "
1900        ."FROM content "
1901        ."INNER JOIN node "
1902        ."    ON (id = node_id) "
1903        ."WHERE moderated = ? "
1904    ;
1905    if($only_where_lastest) {
1906        $sql .= "AND node.version = content.version ";
1907    }
1908    $sql .= "ORDER BY name, content.version ";
1909
1910    # Query
1911    my $dbh = $self->dbh;
1912    my $sth = $dbh->prepare( $sql );
1913    $sth->execute( "0" );
1914
1915    my @nodes;
1916    while(my @results = $sth->fetchrow_array) {
1917        my %data;
1918        @data{ qw( node_id name moderated_version version ) } = @results;
1919        push @nodes, \%data;
1920    }
1921
1922    return @nodes;
1923}
1924
1925=item B<list_last_version_before>
1926
1927    List the last version of every node before a given date.
1928    If no version existed before that date, will return undef for version.
1929    Returns a hash of id, name, version and date
1930
1931    my @nv = $wiki->list_last_version_before('2007-01-02 10:34:11')
1932    foreach my $data (@nv) {
1933       
1934    }
1935
1936=cut
1937
1938sub list_last_version_before {
1939    my ($self, $date) = @_;
1940
1941    my $sql =
1942         "SELECT "
1943        ."    id, name, "
1944        ."MAX(content.version) AS version, MAX(content.modified) AS modified "
1945        ."FROM node "
1946        ."LEFT OUTER JOIN content "
1947        ."    ON (id = node_id "
1948        ."      AND content.modified <= ?) "
1949        ."GROUP BY id, name "
1950        ."ORDER BY id "
1951    ;
1952
1953    # Query
1954    my $dbh = $self->dbh;
1955    my $sth = $dbh->prepare( $sql );
1956    $sth->execute( $date );
1957
1958    my @nodes;
1959    while(my @results = $sth->fetchrow_array) {
1960        my %data;
1961        @data{ qw( id name version modified ) } = @results;
1962        $data{'node_id'} = $data{'id'};
1963        unless($data{'version'}) { $data{'version'} = undef; }
1964        push @nodes, \%data;
1965    }
1966
1967    return @nodes;
1968}
1969
1970
1971# Internal function only, used when querying latest metadata
1972sub _current_node_id_versions {
1973    my ($self) = @_;
1974
1975    my $dbh = $self->dbh;
1976
1977    my $nv_sql = 
1978       "SELECT node_id, MAX(version) ".
1979       "FROM content ".
1980       "WHERE moderated ".
1981       "GROUP BY node_id ";
1982    my $sth = $dbh->prepare( $nv_sql );
1983    $sth->execute();
1984
1985    my @nv_where;
1986    while(my @results = $sth->fetchrow_array) {
1987        my ($node_id, $version) = @results;
1988        my $where = "(node_id=$node_id AND version=$version)";
1989        push @nv_where, $where;
1990    }
1991    return @nv_where;
1992}
1993
1994=item B<list_metadata_by_type>
1995
1996    List all the currently defined values of the given type of metadata.
1997
1998    Will only return data from the latest moderated version of each node
1999
2000    # List all of the different metadata values with the type 'category'
2001    my @categories = $wiki->list_metadata_by_type('category');
2002
2003=cut
2004sub list_metadata_by_type {
2005    my ($self, $type) = @_;
2006
2007    return undef unless $type;
2008    my $dbh = $self->dbh;
2009
2010    # Ideally we'd do this as one big query
2011    # However, this would need a temporary table on many
2012    #  database engines, so we cheat and do it as two
2013    my @nv_where = $self->_current_node_id_versions();
2014
2015    # Now the metadata bit
2016    my $sql = 
2017       "SELECT DISTINCT metadata_value ".
2018       "FROM metadata ".
2019       "WHERE metadata_type = ? ".
2020       "AND (".
2021       join(" OR ", @nv_where).
2022       ")";
2023    my $sth = $dbh->prepare( $sql );
2024    $sth->execute($type);
2025
2026    my $values = $sth->fetchall_arrayref([0]);
2027    return ( map { $self->charset_decode( $_->[0] ) } (@$values) );
2028}
2029
2030
2031=item B<list_metadata_names>
2032
2033    List all the currently defined kinds of metadata, eg Locale, Postcode
2034
2035    Will only return data from the latest moderated version of each node
2036
2037    # List all of the different kinds of metadata
2038    my @metadata_types = $wiki->list_metadata_names()
2039
2040=cut
2041sub list_metadata_names {
2042    my ($self) = @_;
2043
2044    my $dbh = $self->dbh;
2045
2046    # Ideally we'd do this as one big query
2047    # However, this would need a temporary table on many
2048    #  database engines, so we cheat and do it as two
2049    my @nv_where = $self->_current_node_id_versions();
2050
2051    # Now the metadata bit
2052    my $sql = 
2053       "SELECT DISTINCT metadata_type ".
2054       "FROM metadata ".
2055       "WHERE (".
2056       join(" OR ", @nv_where).
2057       ")";
2058    my $sth = $dbh->prepare( $sql );
2059    $sth->execute();
2060
2061    my $types = $sth->fetchall_arrayref([0]);
2062    return ( map { $self->charset_decode( $_->[0] ) } (@$types) );
2063}
2064
2065
2066=item B<schema_current>
2067
2068  my ($code_version, $db_version) = $store->schema_current;
2069  if ($code_version == $db_version)
2070      # Do stuff
2071  } else {
2072      # Bail
2073  }
2074
2075=cut
2076
2077sub schema_current {
2078    my $self = shift;
2079    my $dbh = $self->dbh;
2080    my $sth;
2081    eval { $sth = $dbh->prepare("SELECT version FROM schema_info") };
2082    if ($@) {
2083        return ($SCHEMA_VER, 0);
2084    }
2085    eval { $sth->execute };
2086    if ($@) {
2087        return ($SCHEMA_VER, 0);
2088    }
2089    my $version;
2090    eval { $version = $sth->fetchrow_array };
2091    if ($@) {
2092        return ($SCHEMA_VER, 0);
2093    } else {
2094        return ($SCHEMA_VER, $version);
2095    }
2096}
2097
2098
2099=item B<dbh>
2100
2101  my $dbh = $store->dbh;
2102
2103Returns the database handle belonging to this storage backend instance.
2104
2105=cut
2106
2107sub dbh {
2108    my $self = shift;
2109    return $self->{_dbh};
2110}
2111
2112=item B<dbname>
2113
2114  my $dbname = $store->dbname;
2115
2116Returns the name of the database used for backend storage.
2117
2118=cut
2119
2120sub dbname {
2121    my $self = shift;
2122    return $self->{_dbname};
2123}
2124
2125=item B<dbuser>
2126
2127  my $dbuser = $store->dbuser;
2128
2129Returns the username used to connect to the database used for backend storage.
2130
2131=cut
2132
2133sub dbuser {
2134    my $self = shift;
2135    return $self->{_dbuser};
2136}
2137
2138=item B<dbpass>
2139
2140  my $dbpass = $store->dbpass;
2141
2142Returns the password used to connect to the database used for backend storage.
2143
2144=cut
2145
2146sub dbpass {
2147    my $self = shift;
2148    return $self->{_dbpass};
2149}
2150
2151=item B<dbhost>
2152
2153  my $dbhost = $store->dbhost;
2154
2155Returns the optional host used to connect to the database used for
2156backend storage.
2157
2158=cut
2159
2160sub dbhost {
2161    my $self = shift;
2162    return $self->{_dbhost};
2163}
2164
2165# Cleanup.
2166sub DESTROY {
2167    my $self = shift;
2168    return if $self->{_external_dbh};
2169    my $dbh = $self->dbh;
2170    $dbh->disconnect if $dbh;
2171}
2172
2173# decode a string of octets into perl's internal encoding, based on the
2174# charset parameter we were passed. Takes a list, returns a list.
2175sub charset_decode {
2176    my $self = shift;
2177    my @input = @_;
2178    if ($CAN_USE_ENCODE) {
2179        my @output;
2180        for (@input) {
2181            push( @output, Encode::decode( $self->{_charset}, $_ ) );
2182        }
2183        return @output;
2184    }
2185    return @input;
2186}
2187
2188# convert a perl string into a series of octets we can put into the database
2189# takes a list, returns a list
2190sub charset_encode {
2191    my $self = shift;
2192    my @input = @_;
2193    if ($CAN_USE_ENCODE) {
2194        my @output;
2195        for (@input) {
2196            push( @output, Encode::encode( $self->{_charset}, $_ ) );
2197        }
2198        return @output;
2199    }
2200    return @input;
2201}
2202
22031;
Note: See TracBrowser for help on using the repository browser.