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

Last change on this file since 302 was 302, checked in by Dominic Hargreaves, 14 years ago

Clean up after Nick, mutter mutter

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