| line | stmt | bran | cond | sub | pod | time | code | 
| 1 |  |  |  |  |  |  | package Wiki::Toolkit::Store::SQLite; | 
| 2 |  |  |  |  |  |  |  | 
| 3 | 3 |  |  | 3 |  | 2285 | use strict; | 
|  | 3 |  |  |  |  | 7 |  | 
|  | 3 |  |  |  |  | 106 |  | 
| 4 |  |  |  |  |  |  |  | 
| 5 | 3 |  |  | 3 |  | 19 | use vars qw( @ISA $VERSION ); | 
|  | 3 |  |  |  |  | 8 |  | 
|  | 3 |  |  |  |  | 170 |  | 
| 6 |  |  |  |  |  |  |  | 
| 7 | 3 |  |  | 3 |  | 1411 | use Wiki::Toolkit::Store::Database; | 
|  | 3 |  |  |  |  | 11 |  | 
|  | 3 |  |  |  |  | 105 |  | 
| 8 | 3 |  |  | 3 |  | 22 | use Carp qw/carp croak/; | 
|  | 3 |  |  |  |  | 7 |  | 
|  | 3 |  |  |  |  | 1646 |  | 
| 9 |  |  |  |  |  |  |  | 
| 10 |  |  |  |  |  |  | @ISA = qw( Wiki::Toolkit::Store::Database ); | 
| 11 |  |  |  |  |  |  | $VERSION = 0.06; | 
| 12 |  |  |  |  |  |  |  | 
| 13 |  |  |  |  |  |  | =head1 NAME | 
| 14 |  |  |  |  |  |  |  | 
| 15 |  |  |  |  |  |  | Wiki::Toolkit::Store::SQLite - SQLite storage backend for Wiki::Toolkit | 
| 16 |  |  |  |  |  |  |  | 
| 17 |  |  |  |  |  |  | =head1 SYNOPSIS | 
| 18 |  |  |  |  |  |  |  | 
| 19 |  |  |  |  |  |  | See Wiki::Toolkit::Store::Database | 
| 20 |  |  |  |  |  |  |  | 
| 21 |  |  |  |  |  |  | =cut | 
| 22 |  |  |  |  |  |  |  | 
| 23 |  |  |  |  |  |  | # Internal method to return the data source string required by DBI. | 
| 24 |  |  |  |  |  |  | sub _dsn { | 
| 25 | 0 |  |  | 0 |  | 0 | my ($self, $dbname) = @_; | 
| 26 | 0 |  |  |  |  | 0 | return "dbi:SQLite:dbname=$dbname"; | 
| 27 |  |  |  |  |  |  | } | 
| 28 |  |  |  |  |  |  |  | 
| 29 |  |  |  |  |  |  | =head1 METHODS | 
| 30 |  |  |  |  |  |  |  | 
| 31 |  |  |  |  |  |  | =over 4 | 
| 32 |  |  |  |  |  |  |  | 
| 33 |  |  |  |  |  |  | =item B | 
| 34 |  |  |  |  |  |  |  | 
| 35 |  |  |  |  |  |  | my $store = Wiki::Toolkit::Store::SQLite->new( dbname => "wiki" ); | 
| 36 |  |  |  |  |  |  |  | 
| 37 |  |  |  |  |  |  | The dbname parameter is mandatory. | 
| 38 |  |  |  |  |  |  |  | 
| 39 |  |  |  |  |  |  | =cut | 
| 40 |  |  |  |  |  |  |  | 
| 41 |  |  |  |  |  |  | sub new { | 
| 42 | 1 |  |  | 1 | 1 | 105 | my ($class, %args) = @_; | 
| 43 | 1 |  |  |  |  | 3 | my $self = {}; | 
| 44 | 1 |  |  |  |  | 4 | bless $self, $class; | 
| 45 | 1 |  |  |  |  | 6 | @args{qw(dbuser dbpass)} = ("", "");  # for the parent class _init | 
| 46 | 1 |  |  |  |  | 14 | return $self->_init(%args); | 
| 47 |  |  |  |  |  |  | } | 
| 48 |  |  |  |  |  |  |  | 
| 49 |  |  |  |  |  |  | =item B | 
| 50 |  |  |  |  |  |  |  | 
| 51 |  |  |  |  |  |  | $store->check_and_write_node( node     => $node, | 
| 52 |  |  |  |  |  |  | checksum => $checksum, | 
| 53 |  |  |  |  |  |  | %other_args ); | 
| 54 |  |  |  |  |  |  |  | 
| 55 |  |  |  |  |  |  | Locks the node, verifies the checksum, calls | 
| 56 |  |  |  |  |  |  | C with all supplied arguments, unlocks the | 
| 57 |  |  |  |  |  |  | node. Returns the version of the updated node on successful writing, 0 if | 
| 58 |  |  |  |  |  |  | checksum doesn't match, -1 if the change was not applied, croaks on error. | 
| 59 |  |  |  |  |  |  |  | 
| 60 |  |  |  |  |  |  | =back | 
| 61 |  |  |  |  |  |  |  | 
| 62 |  |  |  |  |  |  | =cut | 
| 63 |  |  |  |  |  |  |  | 
| 64 |  |  |  |  |  |  | sub check_and_write_node { | 
| 65 | 0 |  |  | 0 | 1 |  | my ($self, %args) = @_; | 
| 66 | 0 |  |  |  |  |  | my ($node, $checksum) = @args{qw( node checksum )}; | 
| 67 |  |  |  |  |  |  |  | 
| 68 | 0 |  |  |  |  |  | my $dbh = $self->{_dbh}; | 
| 69 | 0 |  |  |  |  |  | $dbh->begin_work; | 
| 70 |  |  |  |  |  |  |  | 
| 71 | 0 |  |  |  |  |  | my $ok = eval { | 
| 72 | 0 | 0 |  |  |  |  | $self->verify_checksum($node, $checksum) or return 0; | 
| 73 | 0 |  |  |  |  |  | $self->write_node_post_locking( %args ); | 
| 74 |  |  |  |  |  |  | }; | 
| 75 | 0 | 0 |  |  |  |  | if ($@) { | 
| 76 | 0 |  |  |  |  |  | my $error = $@; | 
| 77 | 0 |  |  |  |  |  | $dbh->rollback; | 
| 78 | 0 | 0 | 0 |  |  |  | if ( $error =~ /database is locked/ | 
| 79 |  |  |  |  |  |  | or $error =~ /DBI connect.+failed/ ) { | 
| 80 | 0 |  |  |  |  |  | return 0; | 
| 81 |  |  |  |  |  |  | } else { | 
| 82 | 0 |  |  |  |  |  | croak "Unhandled error: [$error]"; | 
| 83 |  |  |  |  |  |  | } | 
| 84 |  |  |  |  |  |  | } else { | 
| 85 | 0 |  |  |  |  |  | $dbh->commit; | 
| 86 | 0 |  |  |  |  |  | return $ok; | 
| 87 |  |  |  |  |  |  | } | 
| 88 |  |  |  |  |  |  | } | 
| 89 |  |  |  |  |  |  |  | 
| 90 |  |  |  |  |  |  | # Get the attributes for the database connection.  We set | 
| 91 |  |  |  |  |  |  | # sqlite_use_immediate_transaction to false because we use database locking | 
| 92 |  |  |  |  |  |  | # explicitly in check_and_write_node.  This is required for DBD::SQLite 1.38. | 
| 93 |  |  |  |  |  |  | sub _get_dbh_connect_attr { | 
| 94 | 0 |  |  | 0 |  |  | my $self = shift; | 
| 95 | 0 |  |  |  |  |  | my $attrs = $self->SUPER::_get_dbh_connect_attr; | 
| 96 |  |  |  |  |  |  | return { | 
| 97 | 0 |  |  |  |  |  | %$attrs, | 
| 98 |  |  |  |  |  |  | sqlite_use_immediate_transaction => 0 | 
| 99 |  |  |  |  |  |  | }; | 
| 100 |  |  |  |  |  |  | } | 
| 101 |  |  |  |  |  |  |  | 
| 102 |  |  |  |  |  |  | sub _get_lowercase_compare_sql { | 
| 103 | 0 |  |  | 0 |  |  | my ($self, $column) = @_; | 
| 104 | 0 |  |  |  |  |  | return "$column LIKE ?"; | 
| 105 |  |  |  |  |  |  | } | 
| 106 |  |  |  |  |  |  |  | 
| 107 |  |  |  |  |  |  | sub _get_comparison_sql { | 
| 108 | 0 |  |  | 0 |  |  | my ($self, %args) = @_; | 
| 109 | 0 | 0 |  |  |  |  | if ( $args{ignore_case} ) { | 
| 110 | 0 |  |  |  |  |  | return "$args{thing1} LIKE $args{thing2}"; | 
| 111 |  |  |  |  |  |  | } else { | 
| 112 | 0 |  |  |  |  |  | return "$args{thing1} = $args{thing2}"; | 
| 113 |  |  |  |  |  |  | } | 
| 114 |  |  |  |  |  |  | } | 
| 115 |  |  |  |  |  |  |  | 
| 116 |  |  |  |  |  |  | sub _get_node_exists_ignore_case_sql { | 
| 117 | 0 |  |  | 0 |  |  | return "SELECT name FROM node WHERE name LIKE ? "; | 
| 118 |  |  |  |  |  |  | } | 
| 119 |  |  |  |  |  |  |  | 
| 120 |  |  |  |  |  |  | 1; |