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

Last change on this file since 420 was 420, checked in by kake, 14 years ago

Fixed bug introduced in [411] and filled in the hole in the test suite that had let this bug slip through.

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