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

Last change on this file since 423 was 423, checked in by nick, 14 years ago

Command line delete tool

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 64.8 KB
Line 
1package Wiki::Toolkit::Store::Database;
2
3use strict;
4
5use vars qw( $VERSION $timestamp_fmt );
6$timestamp_fmt = "%Y-%m-%d %H:%M:%S";
7
8use DBI;
9use Time::Piece;
10use Time::Seconds;
11use Carp qw( carp croak );
12use Digest::MD5 qw( md5_hex );
13
14$VERSION = '0.29';
15my $SCHEMA_VER = 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# Returns the name of the node with the given ID
1127# Not normally used except when doing low-level maintenance
1128sub node_name_for_id {
1129        my ($self, $node_id) = @_;
1130    my $dbh = $self->dbh;
1131
1132    my $name_sql = "SELECT name FROM node WHERE id=?";
1133    my $name_sth = $dbh->prepare($name_sql);
1134    $name_sth->execute($node_id);
1135        my ($name) = $name_sth->fetchrow_array;
1136    $name_sth->finish;
1137
1138        return $name;
1139}
1140
1141# Internal Method
1142sub post_delete_node {
1143        my ($name,$node_id,$version,$plugins) = @_;
1144
1145    # Call post_delete on any plugins, having done the delete
1146    my @plugins = @{ $plugins || [ ] };
1147    foreach my $plugin (@plugins) {
1148        if ( $plugin->can( "post_delete" ) ) {
1149            $plugin->post_delete( 
1150                                node     => $name,
1151                                node_id  => $node_id,
1152                                version  => $version );
1153        }
1154    }
1155}
1156
1157=item B<list_recent_changes>
1158
1159  # Nodes changed in last 7 days - each node listed only once.
1160  my @nodes = $store->list_recent_changes( days => 7 );
1161
1162  # Nodes added in the last 7 days.
1163  my @nodes = $store->list_recent_changes(
1164                                           days     => 7,
1165                                           new_only => 1,
1166                                         );
1167
1168  # All changes in last 7 days - nodes changed more than once will
1169  # be listed more than once.
1170  my @nodes = $store->list_recent_changes(
1171                                           days => 7,
1172                                           include_all_changes => 1,
1173                                         );
1174
1175  # Nodes changed between 1 and 7 days ago.
1176  my @nodes = $store->list_recent_changes( between_days => [ 1, 7 ] );
1177
1178  # Nodes changed since a given time.
1179  my @nodes = $store->list_recent_changes( since => 1036235131 );
1180
1181  # Most recent change and its details.
1182  my @nodes = $store->list_recent_changes( last_n_changes => 1 );
1183  print "Node:          $nodes[0]{name}";
1184  print "Last modified: $nodes[0]{last_modified}";
1185  print "Comment:       $nodes[0]{metadata}{comment}";
1186
1187  # Last 5 restaurant nodes edited.
1188  my @nodes = $store->list_recent_changes(
1189      last_n_changes => 5,
1190      metadata_is    => { category => "Restaurants" }
1191  );
1192
1193  # Last 5 nodes edited by Kake.
1194  my @nodes = $store->list_recent_changes(
1195      last_n_changes => 5,
1196      metadata_was   => { username => "Kake" }
1197  );
1198
1199  # All minor edits made by Earle in the last week.
1200  my @nodes = $store->list_recent_changes(
1201      days           => 7,
1202      metadata_was   => { username  => "Earle",
1203                          edit_type => "Minor tidying." }
1204  );
1205
1206  # Last 10 changes that weren't minor edits.
1207  my @nodes = $store->list_recent_changes(
1208      last_n_changes => 10,
1209      metadata_wasnt  => { edit_type => "Minor tidying" }
1210  );
1211
1212You I<must> supply one of the following constraints: C<days>
1213(integer), C<since> (epoch), C<last_n_changes> (integer).
1214
1215You I<may> also supply moderation => 1 if you only want to see versions
1216that are moderated.
1217
1218Another optional parameter is C<new_only>, which if set to 1 will only
1219return newly added nodes.
1220
1221You I<may> also supply I<either> C<metadata_is> (and optionally
1222C<metadata_isnt>), I<or> C<metadata_was> (and optionally
1223C<metadata_wasnt>). Each of these should be a ref to a hash with
1224scalar keys and values.  If the hash has more than one entry, then
1225only changes satisfying I<all> criteria will be returned when using
1226C<metadata_is> or C<metadata_was>, but all changes which fail to
1227satisfy any one of the criteria will be returned when using
1228C<metadata_isnt> or C<metadata_is>.
1229
1230C<metadata_is> and C<metadata_isnt> look only at the metadata that the
1231node I<currently> has. C<metadata_was> and C<metadata_wasnt> take into
1232account the metadata of previous versions of a node.  Don't mix C<is>
1233with C<was> - there's no check for this, but the results are undefined.
1234
1235Returns results as an array, in reverse chronological order.  Each
1236element of the array is a reference to a hash with the following entries:
1237
1238=over 4
1239
1240=item * B<name>: the name of the node
1241
1242=item * B<version>: the latest version number
1243
1244=item * B<last_modified>: the timestamp of when it was last modified
1245
1246=item * B<metadata>: a ref to a hash containing any metadata attached
1247to the current version of the node
1248
1249=back
1250
1251Unless you supply C<include_all_changes>, C<metadata_was> or
1252C<metadata_wasnt>, each node will only be returned once regardless of
1253how many times it has been changed recently.
1254
1255By default, the case-sensitivity of both C<metadata_type> and
1256C<metadata_value> depends on your database - if it will return rows
1257with an attribute value of "Pubs" when you asked for "pubs", or not.
1258If you supply a true value to the C<ignore_case> parameter, then you
1259can be sure of its being case-insensitive.  This is recommended.
1260
1261=cut
1262
1263sub list_recent_changes {
1264    my $self = shift;
1265    my %args = @_;
1266    if ($args{since}) {
1267        return $self->_find_recent_changes_by_criteria( %args );
1268    } elsif ($args{between_days}) {
1269        return $self->_find_recent_changes_by_criteria( %args );
1270    } elsif ( $args{days} ) {
1271        my $now = localtime;
1272        my $then = $now - ( ONE_DAY * $args{days} );
1273        $args{since} = $then;
1274        delete $args{days};
1275        return $self->_find_recent_changes_by_criteria( %args );
1276    } elsif ( $args{last_n_changes} ) {
1277        $args{limit} = delete $args{last_n_changes};
1278        return $self->_find_recent_changes_by_criteria( %args );
1279    } else {
1280        croak "Need to supply some criteria to list_recent_changes.";
1281    }
1282}
1283
1284sub _find_recent_changes_by_criteria {
1285    my ($self, %args) = @_;
1286    my ($since, $limit, $between_days, $ignore_case, $new_only,
1287        $metadata_is,  $metadata_isnt, $metadata_was, $metadata_wasnt,
1288        $moderation, $include_all_changes ) =
1289         @args{ qw( since limit between_days ignore_case new_only
1290                    metadata_is metadata_isnt metadata_was metadata_wasnt
1291                    moderation include_all_changes) };
1292    my $dbh = $self->dbh;
1293
1294    my @where;
1295    my @metadata_joins;
1296    my $use_content_table; # some queries won't need this
1297
1298    if ( $metadata_is ) {
1299        my $main_table = "node";
1300        if ( $include_all_changes ) {
1301            $main_table = "content";
1302            $use_content_table = 1;
1303        }
1304        my $i = 0;
1305        foreach my $type ( keys %$metadata_is ) {
1306            $i++;
1307            my $value  = $metadata_is->{$type};
1308            croak "metadata_is must have scalar values" if ref $value;
1309            my $mdt = "md_is_$i";
1310            push @metadata_joins, "LEFT JOIN metadata AS $mdt
1311                                   ON $main_table."
1312                                   . ( ($main_table eq "node") ? "id"
1313                                                               : "node_id" )
1314                                   . "=$mdt.node_id
1315                                   AND $main_table.version=$mdt.version\n";
1316            # Why is this inside 'if ( $metadata_is )'?
1317            # Shouldn't it apply to all cases?
1318            # What's it doing in @metadata_joins?
1319            if (defined $moderation) {
1320                push @metadata_joins, "AND $main_table.moderate=$moderation";
1321            }
1322            push @where, "( "
1323                         . $self->_get_comparison_sql(
1324                                          thing1      => "$mdt.metadata_type",
1325                                          thing2      => $dbh->quote($type),
1326                                          ignore_case => $ignore_case,
1327                                                     )
1328                         . " AND "
1329                         . $self->_get_comparison_sql(
1330                                          thing1      => "$mdt.metadata_value",
1331                                          thing2      => $dbh->quote( $self->charset_encode($value) ),
1332                                          Ignore_case => $ignore_case,
1333                                                     )
1334                         . " )";
1335        }
1336    }
1337
1338    if ( $metadata_isnt ) {
1339        foreach my $type ( keys %$metadata_isnt ) {
1340            my $value  = $metadata_isnt->{$type};
1341            croak "metadata_isnt must have scalar values" if ref $value;
1342        }
1343        my @omits = $self->_find_recent_changes_by_criteria(
1344            since        => $since,
1345            between_days => $between_days,
1346            metadata_is  => $metadata_isnt,
1347            ignore_case  => $ignore_case,
1348        );
1349        foreach my $omit ( @omits ) {
1350            push @where, "( node.name != " . $dbh->quote($omit->{name})
1351                 . "  OR node.version != " . $dbh->quote($omit->{version})
1352                 . ")";
1353        }
1354    }
1355
1356    if ( $metadata_was ) {
1357        $use_content_table = 1;
1358        my $i = 0;
1359        foreach my $type ( keys %$metadata_was ) {
1360            $i++;
1361            my $value  = $metadata_was->{$type};
1362            croak "metadata_was must have scalar values" if ref $value;
1363            my $mdt = "md_was_$i";
1364            push @metadata_joins, "LEFT JOIN metadata AS $mdt
1365                                   ON content.node_id=$mdt.node_id
1366                                   AND content.version=$mdt.version\n";
1367            push @where, "( "
1368                         . $self->_get_comparison_sql(
1369                                          thing1      => "$mdt.metadata_type",
1370                                          thing2      => $dbh->quote($type),
1371                                          ignore_case => $ignore_case,
1372                                                     )
1373                         . " AND "
1374                         . $self->_get_comparison_sql(
1375                                          thing1      => "$mdt.metadata_value",
1376                                          thing2      => $dbh->quote( $self->charset_encode($value) ),
1377                                          ignore_case => $ignore_case,
1378                                                     )
1379                         . " )";
1380        }
1381    }
1382
1383    if ( $metadata_wasnt ) {
1384        foreach my $type ( keys %$metadata_wasnt ) {
1385                my $value  = $metadata_was->{$type};
1386                croak "metadata_was must have scalar values" if ref $value;
1387        }
1388        my @omits = $self->_find_recent_changes_by_criteria(
1389                since        => $since,
1390                between_days => $between_days,
1391                metadata_was => $metadata_wasnt,
1392                ignore_case  => $ignore_case,
1393        );
1394        foreach my $omit ( @omits ) {
1395            push @where, "( node.name != " . $dbh->quote($omit->{name})
1396                 . "  OR content.version != " . $dbh->quote($omit->{version})
1397                 . ")";
1398        }
1399        $use_content_table = 1;
1400    }
1401
1402    # Figure out which table we should be joining to to check the dates and
1403    # versions - node or content.
1404    my $date_table = "node";
1405    if ( $include_all_changes || $new_only ) {
1406        $date_table = "content";
1407        $use_content_table = 1;
1408    }
1409    if ( $new_only ) {
1410        push @where, "content.version=1";
1411    }
1412
1413    if ( $since ) {
1414        my $timestamp = $self->_get_timestamp( $since );
1415        push @where, "$date_table.modified >= " . $dbh->quote($timestamp);
1416    } elsif ( $between_days ) {
1417        my $now = localtime;
1418        # Start is the larger number of days ago.
1419        my ($start, $end) = @$between_days;
1420        ($start, $end) = ($end, $start) if $start < $end;
1421        my $ts_start = $self->_get_timestamp( $now - (ONE_DAY * $start) ); 
1422        my $ts_end = $self->_get_timestamp( $now - (ONE_DAY * $end) ); 
1423        push @where, "$date_table.modified >= " . $dbh->quote($ts_start);
1424        push @where, "$date_table.modified <= " . $dbh->quote($ts_end);
1425    }
1426
1427    my $sql = "SELECT DISTINCT
1428                               node.name,
1429              ";
1430    if ( $include_all_changes || $new_only || $use_content_table ) {
1431        $sql .= " content.version, content.modified ";
1432    } else {
1433        $sql .= " node.version, node.modified ";
1434    }
1435    $sql .= " FROM node ";
1436    if ( $use_content_table ) {
1437        $sql .= " INNER JOIN content ON (node.id = content.node_id ) ";
1438    }
1439
1440    $sql .= join("\n", @metadata_joins)
1441            . (
1442                scalar @where
1443                              ? " WHERE " . join(" AND ",@where) 
1444                              : ""
1445              )
1446            . " ORDER BY "
1447            . ( $use_content_table ? "content" : "node" )
1448            . ".modified DESC";
1449    if ( $limit ) {
1450        croak "Bad argument $limit" unless $limit =~ /^\d+$/;
1451        $sql .= " LIMIT $limit";
1452    }
1453#print "\n\n$sql\n\n";
1454    my $nodesref = $dbh->selectall_arrayref($sql);
1455    my @finds = map { { name          => $_->[0],
1456                        version       => $_->[1],
1457                        last_modified => $_->[2] }
1458                    } @$nodesref;
1459    foreach my $find ( @finds ) {
1460        my %metadata;
1461        my $sth = $dbh->prepare( "SELECT metadata_type, metadata_value
1462                                  FROM node
1463                                  INNER JOIN metadata
1464                                        ON (id = node_id)
1465                                  WHERE name=?
1466                                  AND metadata.version=?" );
1467        $sth->execute( $find->{name}, $find->{version} );
1468        while ( my ($type, $value) = $self->charset_decode( $sth->fetchrow_array ) ) {
1469            if ( defined $metadata{$type} ) {
1470                push @{$metadata{$type}}, $value;
1471            } else {
1472                $metadata{$type} = [ $value ];
1473            }
1474        }
1475        $find->{metadata} = \%metadata;
1476    }
1477    return @finds;
1478}
1479
1480=item B<list_all_nodes>
1481
1482  my @nodes = $store->list_all_nodes();
1483  print "First node is $nodes[0]\n";
1484
1485  my @nodes = $store->list_all_nodes( with_details=> 1 );
1486  print "First node is ".$nodes[0]->{'name'}." at version ".$nodes[0]->{'version'}."\n";
1487
1488Returns a list containing the name of every existing node.  The list
1489won't be in any kind of order; do any sorting in your calling script.
1490
1491Optionally also returns the id, version and moderation flag.
1492
1493=cut
1494
1495sub list_all_nodes {
1496    my ($self,%args) = @_;
1497    my $dbh = $self->dbh;
1498        my @nodes;
1499
1500        if($args{with_details}) {
1501                my $sql = "SELECT id, name, version, moderate FROM node;";
1502                my $sth = $dbh->prepare( $sql );
1503                $sth->execute();
1504
1505                while(my @results = $sth->fetchrow_array) {
1506                        my %data;
1507                        @data{ qw( node_id name version moderate ) } = @results;
1508                        push @nodes, \%data;
1509                }
1510        } else {
1511                my $sql = "SELECT name FROM node;";
1512                my $raw_nodes = $dbh->selectall_arrayref($sql); 
1513                @nodes = ( map { $self->charset_decode( $_->[0] ) } (@$raw_nodes) );
1514        }
1515        return @nodes;
1516}
1517
1518=item B<list_node_all_versions>
1519
1520  my @all_versions = $store->list_node_all_versions(
1521      name => 'HomePage',
1522      with_content => 1,
1523      with_metadata => 0
1524  );
1525
1526Returns all the versions of a node, optionally including the content
1527and metadata, as an array of hashes (newest versions first).
1528
1529=cut
1530
1531sub list_node_all_versions {
1532    my ($self, %args) = @_;
1533
1534    my ($node_id,$name,$with_content,$with_metadata) = 
1535                @args{ qw( node_id name with_content with_metadata ) };
1536
1537    my $dbh = $self->dbh;
1538    my $sql;
1539
1540    # If they only gave us the node name, get the node id
1541    unless ($node_id) {
1542        $sql = "SELECT id FROM node WHERE name=" . $dbh->quote($name);
1543        $node_id = $dbh->selectrow_array($sql);
1544    }
1545
1546    # If they didn't tell us what they wanted / we couldn't find it,
1547    #  return an empty array
1548    return () unless($node_id);
1549
1550    # Build up our SQL
1551    $sql = "SELECT id, name, content.version, content.modified ";
1552    if ( $with_content ) {
1553        $sql .= ", content.text ";
1554    }
1555    if ( $with_metadata ) {
1556        $sql .= ", metadata_type, metadata_value ";
1557    }
1558    $sql .= " FROM node INNER JOIN content ON (id = content.node_id) ";
1559    if ( $with_metadata ) {
1560        $sql .= " LEFT OUTER JOIN metadata ON "
1561           . "(id = metadata.node_id AND content.version = metadata.version) ";
1562    }
1563    $sql .= " WHERE id = ? ORDER BY content.version DESC";
1564
1565    # Do the fetch
1566    my $sth = $dbh->prepare( $sql );
1567    $sth->execute( $node_id );
1568
1569    # Need to hold onto the last row by hash ref, so we don't trash
1570    #  it every time
1571    my %first_data;
1572    my $dataref = \%first_data;
1573
1574    # Haul out the data
1575    my @versions;
1576    while ( my @results = $sth->fetchrow_array ) {
1577        my %data = %$dataref;
1578
1579        # Is it the same version as last time?
1580        if ( %data && $data{'version'} != $results[2] ) {
1581            # New version
1582            push @versions, $dataref;
1583            %data = ();
1584        } else {
1585            # Same version as last time, must be more metadata
1586        }
1587
1588        # Grab the core data (will be the same on multi-row for metadata)
1589        @data{ qw( node_id name version last_modified ) } = @results;
1590
1591        my $i = 4;
1592        if ( $with_content ) {
1593            $data{'content'} = $results[$i];
1594            $i++;
1595        }
1596        if ( $with_metadata ) {
1597            my ($m_type,$m_value) = @results[$i,($i+1)];
1598            unless ( $data{'metadata'} ) { $data{'metadata'} = {}; }
1599
1600            if ( $m_type ) {
1601                # If we have existing data, then put it into an array
1602                if ( $data{'metadata'}->{$m_type} ) {
1603                    unless ( ref($data{'metadata'}->{$m_type}) eq "ARRAY" ) {
1604                        $data{'metadata'}->{$m_type} =
1605                                             [ $data{'metadata'}->{$m_type} ];
1606                    }
1607                    push @{$data{'metadata'}->{$m_type}}, $m_value;
1608                } else {
1609                    # Otherwise, just store it in a normal string
1610                    $data{'metadata'}->{$m_type} = $m_value;
1611                }
1612            }
1613        }
1614
1615        # Save where we've got to
1616        $dataref = \%data;
1617    }
1618
1619    # Handle final row saving
1620    if ( $dataref ) {
1621        push @versions, $dataref;
1622    }
1623
1624    # Return
1625    return @versions;
1626}
1627
1628=item B<list_nodes_by_metadata>
1629
1630  # All documentation nodes.
1631  my @nodes = $store->list_nodes_by_metadata(
1632      metadata_type  => "category",
1633      metadata_value => "documentation",
1634      ignore_case    => 1,   # optional but recommended (see below)
1635  );
1636
1637  # All pubs in Hammersmith.
1638  my @pubs = $store->list_nodes_by_metadata(
1639      metadata_type  => "category",
1640      metadata_value => "Pub",
1641  );
1642  my @hsm  = $store->list_nodes_by_metadata(
1643      metadata_type  => "category",
1644      metadata_value  => "Hammersmith",
1645  );
1646  my @results = my_l33t_method_for_ANDing_arrays( \@pubs, \@hsm );
1647
1648Returns a list containing the name of every node whose caller-supplied
1649metadata matches the criteria given in the parameters.
1650
1651By default, the case-sensitivity of both C<metadata_type> and
1652C<metadata_value> depends on your database - if it will return rows
1653with an attribute value of "Pubs" when you asked for "pubs", or not.
1654If you supply a true value to the C<ignore_case> parameter, then you
1655can be sure of its being case-insensitive.  This is recommended.
1656
1657If you don't supply any criteria then you'll get an empty list.
1658
1659This is a really really really simple way of finding things; if you
1660want to be more complicated then you'll need to call the method
1661multiple times and combine the results yourself, or write a plugin.
1662
1663=cut
1664
1665sub list_nodes_by_metadata {
1666    my ($self, %args) = @_;
1667    my ( $type, $value ) = @args{ qw( metadata_type metadata_value ) };
1668    return () unless $type;
1669
1670    my $dbh = $self->dbh;
1671    if ( $args{ignore_case} ) {
1672        $type  = lc( $type  );
1673        $value = lc( $value );
1674    }
1675    my $sql =
1676         $self->_get_list_by_metadata_sql( ignore_case => $args{ignore_case} );
1677    my $sth = $dbh->prepare( $sql );
1678    $sth->execute( $type, $self->charset_encode($value) );
1679    my @nodes;
1680    while ( my ($id, $node) = $sth->fetchrow_array ) {
1681        push @nodes, $node;
1682    }
1683    return @nodes;
1684}
1685
1686=item B<list_nodes_by_missing_metadata>
1687Returns nodes where either the metadata doesn't exist, or is blank
1688
1689Unlike list_nodes_by_metadata(), the metadata value is optional.
1690
1691  # All nodes missing documentation
1692  my @nodes = $store->list_nodes_by_missing_metadata(
1693      metadata_type  => "category",
1694      metadata_value => "documentation",
1695      ignore_case    => 1,   # optional but recommended (see below)
1696  );
1697
1698  # All nodes which don't have a latitude defined
1699  my @nodes = $store->list_nodes_by_missing_metadata(
1700      metadata_type  => "latitude"
1701  );
1702=cut
1703sub list_nodes_by_missing_metadata {
1704    my ($self, %args) = @_;
1705    my ( $type, $value ) = @args{ qw( metadata_type metadata_value ) };
1706    return () unless $type;
1707
1708    my $dbh = $self->dbh;
1709    if ( $args{ignore_case} ) {
1710        $type  = lc( $type  );
1711        $value = lc( $value );
1712    }
1713
1714        my @nodes;
1715
1716        # If the don't want to match by value, then we can do it with
1717        #  a LEFT OUTER JOIN, and either NULL or LENGTH() = 0
1718        if( ! $value ) {
1719                my $sql = $self->_get_list_by_missing_metadata_sql( 
1720                                                                                ignore_case => $args{ignore_case}
1721                      );
1722                my $sth = $dbh->prepare( $sql );
1723                $sth->execute( $type );
1724
1725                while ( my ($id, $node) = $sth->fetchrow_array ) {
1726                push @nodes, $node;
1727                }
1728    } else {
1729                # To find those without the value in this case would involve
1730                #  some seriously brain hurting SQL.
1731                # So, cheat - find those with, and return everything else
1732                my @with = $self->list_nodes_by_metadata(%args);
1733                my %with_hash;
1734                foreach my $node (@with) { $with_hash{$node} = 1; }
1735
1736                my @all_nodes = $self->list_all_nodes();
1737                foreach my $node (@all_nodes) {
1738                        unless($with_hash{$node}) {
1739                                push @nodes, $node;
1740                        }
1741                }
1742        }
1743
1744    return @nodes;
1745}
1746
1747=item B<_get_list_by_metadata_sql>
1748Return the SQL to do a match by metadata. Should expect the metadata type
1749as the first SQL parameter, and the metadata value as the second.
1750
1751If possible, should take account of $args{ignore_case}
1752=cut
1753sub _get_list_by_metadata_sql {
1754        # SQL 99 version
1755    #  Can be over-ridden by database-specific subclasses
1756    my ($self, %args) = @_;
1757    if ( $args{ignore_case} ) {
1758        return "SELECT node.id, node.name "
1759             . "FROM node "
1760             . "INNER JOIN metadata "
1761             . "   ON (node.id = metadata.node_id "
1762             . "       AND node.version=metadata.version) "
1763             . "WHERE ". $self->_get_lowercase_compare_sql("metadata.metadata_type")
1764             . " AND ". $self->_get_lowercase_compare_sql("metadata.metadata_value");
1765    } else {
1766        return "SELECT node.id, node.name "
1767             . "FROM node "
1768             . "INNER JOIN metadata "
1769             . "   ON (node.id = metadata.node_id "
1770             . "       AND node.version=metadata.version) "
1771             . "WHERE ". $self->_get_casesensitive_compare_sql("metadata.metadata_type")
1772             . " AND ". $self->_get_casesensitive_compare_sql("metadata.metadata_value");
1773    }
1774}
1775
1776=item B<_get_list_by_missing_metadata_sql>
1777Return the SQL to do a match by missing metadata. Should expect the metadata
1778type as the first SQL parameter.
1779
1780If possible, should take account of $args{ignore_case}
1781=cut
1782sub _get_list_by_missing_metadata_sql {
1783        # SQL 99 version
1784    #  Can be over-ridden by database-specific subclasses
1785    my ($self, %args) = @_;
1786
1787        my $sql = "";
1788    if ( $args{ignore_case} ) {
1789        $sql = "SELECT node.id, node.name "
1790             . "FROM node "
1791             . "LEFT OUTER JOIN metadata "
1792             . "   ON (node.id = metadata.node_id "
1793             . "       AND node.version=metadata.version "
1794             . "       AND ". $self->_get_lowercase_compare_sql("metadata.metadata_type")
1795                         . ")";
1796    } else {
1797        $sql = "SELECT node.id, node.name "
1798             . "FROM node "
1799             . "LEFT OUTER JOIN metadata "
1800             . "   ON (node.id = metadata.node_id "
1801             . "       AND node.version=metadata.version "
1802             . "       AND ". $self->_get_casesensitive_compare_sql("metadata.metadata_type")
1803             . ")";
1804    }
1805
1806        $sql .= "WHERE (metadata.metadata_value IS NULL OR LENGTH(metadata.metadata_value) = 0) ";
1807        return $sql;
1808}
1809
1810sub _get_lowercase_compare_sql {
1811        my ($self, $column) = @_;
1812        # SQL 99 version
1813    #  Can be over-ridden by database-specific subclasses
1814        return "lower($column) = ?";
1815}
1816sub _get_casesensitive_compare_sql {
1817        my ($self, $column) = @_;
1818        # SQL 99 version
1819    #  Can be over-ridden by database-specific subclasses
1820        return "$column = ?";
1821}
1822
1823sub _get_comparison_sql {
1824    my ($self, %args) = @_;
1825        # SQL 99 version
1826    #  Can be over-ridden by database-specific subclasses
1827    return "$args{thing1} = $args{thing2}";
1828}
1829
1830sub _get_node_exists_ignore_case_sql {
1831        # SQL 99 version
1832    #  Can be over-ridden by database-specific subclasses
1833    return "SELECT name FROM node WHERE name = ? ";
1834}
1835
1836=item B<list_unmoderated_nodes>
1837
1838  my @nodes = $wiki->list_unmoderated_nodes();
1839  my @nodes = $wiki->list_unmoderated_nodes(
1840                                                only_where_latest => 1
1841                                            );
1842
1843  $nodes[0]->{'name'}              # The name of the node
1844  $nodes[0]->{'node_id'}           # The id of the node
1845  $nodes[0]->{'version'}           # The version in need of moderation
1846  $nodes[0]->{'moderated_version'} # The newest moderated version
1847
1848  With only_where_latest set, return the id, name and version of all the
1849   nodes where the most recent version needs moderation.
1850  Otherwise, returns the id, name and version of all node versions that need
1851   to be moderated.
1852
1853=cut
1854
1855sub list_unmoderated_nodes {
1856        my ($self,%args) = @_;
1857
1858        my $only_where_lastest = $args{'only_where_latest'};
1859
1860        my $sql =
1861                 "SELECT "
1862                ."      id, name, "
1863                ."      node.version AS last_moderated_version, "
1864                ."      content.version AS version "
1865                ."FROM content "
1866                ."INNER JOIN node "
1867                ."      ON (id = node_id) "
1868                ."WHERE moderated = ? "
1869        ;
1870        if($only_where_lastest) {
1871                $sql .= "AND node.version = content.version ";
1872        }
1873        $sql .= "ORDER BY name, content.version ";
1874
1875        # Query
1876    my $dbh = $self->dbh;
1877    my $sth = $dbh->prepare( $sql );
1878    $sth->execute( "0" );
1879
1880        my @nodes;
1881        while(my @results = $sth->fetchrow_array) {
1882                my %data;
1883                @data{ qw( node_id name moderated_version version ) } = @results;
1884                push @nodes, \%data;
1885        }
1886
1887        return @nodes;
1888}
1889
1890=item B<list_last_version_before>
1891        List the last version of every node before a given date.
1892        If no version existed before that date, will return undef for version.
1893        Returns a hash of id, name, version and date
1894
1895        my @nv = $wiki->list_last_version_before('2007-01-02 10:34:11')
1896        foreach my $data (@nv) {
1897               
1898        }
1899=cut
1900sub list_last_version_before {
1901        my ($self, $date) = @_;
1902
1903        my $sql =
1904                 "SELECT "
1905                ."      id, name, "
1906                ."MAX(content.version) AS version, MAX(content.modified) AS modified "
1907                ."FROM node "
1908                ."LEFT OUTER JOIN content "
1909                ."      ON (id = node_id "
1910                ."      AND content.modified <= ?) "
1911                ."GROUP BY id, name "
1912                ."ORDER BY id "
1913        ;
1914
1915        # Query
1916    my $dbh = $self->dbh;
1917    my $sth = $dbh->prepare( $sql );
1918    $sth->execute( $date );
1919
1920        my @nodes;
1921        while(my @results = $sth->fetchrow_array) {
1922                my %data;
1923                @data{ qw( id name version modified ) } = @results;
1924                $data{'node_id'} = $data{'id'};
1925                unless($data{'version'}) { $data{'version'} = undef; }
1926                push @nodes, \%data;
1927        }
1928
1929        return @nodes;
1930}
1931
1932=item B<list_metadata_by_type>
1933        List all the currently defined values of the given type of metadata.
1934
1935        Will only work with the latest moderated version
1936
1937        # List all of the different metadata values with the type 'category'
1938        my @categories = $wiki->list_metadata_by_type('category');
1939=cut
1940sub list_metadata_by_type {
1941        my ($self, $type) = @_;
1942
1943        return 0 unless $type;
1944}
1945
1946
1947=item B<schema_current>
1948
1949  my ($code_version, $db_version) = $store->schema_current;
1950  if ($code_version == $db_version)
1951      # Do stuff
1952  } else {
1953      # Bail
1954  }
1955
1956=cut
1957
1958sub schema_current {
1959    my $self = shift;
1960    my $dbh = $self->dbh;
1961    my $sth;
1962    eval { $sth = $dbh->prepare("SELECT version FROM schema_info") };
1963    if ($@) {
1964        return ($SCHEMA_VER, 0);
1965    }
1966    eval { $sth->execute };
1967    if ($@) {
1968        return ($SCHEMA_VER, 0);
1969    }
1970    my $version;
1971    eval { $version = $sth->fetchrow_array };
1972    if ($@) {
1973        return ($SCHEMA_VER, 0);
1974    } else {
1975        return ($SCHEMA_VER, $version);
1976    }
1977}
1978
1979
1980=item B<dbh>
1981
1982  my $dbh = $store->dbh;
1983
1984Returns the database handle belonging to this storage backend instance.
1985
1986=cut
1987
1988sub dbh {
1989    my $self = shift;
1990    return $self->{_dbh};
1991}
1992
1993=item B<dbname>
1994
1995  my $dbname = $store->dbname;
1996
1997Returns the name of the database used for backend storage.
1998
1999=cut
2000
2001sub dbname {
2002    my $self = shift;
2003    return $self->{_dbname};
2004}
2005
2006=item B<dbuser>
2007
2008  my $dbuser = $store->dbuser;
2009
2010Returns the username used to connect to the database used for backend storage.
2011
2012=cut
2013
2014sub dbuser {
2015    my $self = shift;
2016    return $self->{_dbuser};
2017}
2018
2019=item B<dbpass>
2020
2021  my $dbpass = $store->dbpass;
2022
2023Returns the password used to connect to the database used for backend storage.
2024
2025=cut
2026
2027sub dbpass {
2028    my $self = shift;
2029    return $self->{_dbpass};
2030}
2031
2032=item B<dbhost>
2033
2034  my $dbhost = $store->dbhost;
2035
2036Returns the optional host used to connect to the database used for
2037backend storage.
2038
2039=cut
2040
2041sub dbhost {
2042    my $self = shift;
2043    return $self->{_dbhost};
2044}
2045
2046# Cleanup.
2047sub DESTROY {
2048    my $self = shift;
2049    return if $self->{_external_dbh};
2050    my $dbh = $self->dbh;
2051    $dbh->disconnect if $dbh;
2052}
2053
2054# decode a string of octets into perl's internal encoding, based on the
2055# charset parameter we were passed. Takes a list, returns a list.
2056sub charset_decode {
2057  my $self = shift;
2058  my @input = @_;
2059  if ($CAN_USE_ENCODE) {
2060    my @output;
2061    for (@input) {
2062      push( @output, Encode::decode( $self->{_charset}, $_ ) );
2063    }
2064    return @output;
2065  }
2066  return @input;
2067}
2068
2069# convert a perl string into a series of octets we can put into the database
2070# takes a list, returns a list
2071sub charset_encode {
2072  my $self = shift;
2073  my @input = @_;
2074  if ($CAN_USE_ENCODE) {
2075    my @output;
2076    for (@input) {
2077      push( @output, Encode::encode( $self->{_charset}, $_ ) );
2078    }
2079    return @output;
2080  }
2081  return @input;
2082}
2083
20841;
Note: See TracBrowser for help on using the repository browser.