r51759 - in /trunk/liborlite-perl: Changes MANIFEST META.yml debian/changelog lib/ORLite.pm t/03_fk.t t/07_pk.t t/08_prune.pl t/11_cleanup.t t/12_xs.t t/13_array_basics.t t/14_array_fk.t t/15_array_xs.t t/16_array_create.t t/lib/Test.pm
gregoa at users.alioth.debian.org
gregoa at users.alioth.debian.org
Fri Jan 29 21:38:25 UTC 2010
Author: gregoa
Date: Fri Jan 29 21:38:20 2010
New Revision: 51759
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=51759
Log:
* New upstream release 1.39.
Added:
trunk/liborlite-perl/t/12_xs.t
- copied unchanged from r51758, branches/upstream/liborlite-perl/current/t/12_xs.t
trunk/liborlite-perl/t/13_array_basics.t
- copied unchanged from r51758, branches/upstream/liborlite-perl/current/t/13_array_basics.t
trunk/liborlite-perl/t/14_array_fk.t
- copied unchanged from r51758, branches/upstream/liborlite-perl/current/t/14_array_fk.t
trunk/liborlite-perl/t/15_array_xs.t
- copied unchanged from r51758, branches/upstream/liborlite-perl/current/t/15_array_xs.t
trunk/liborlite-perl/t/16_array_create.t
- copied unchanged from r51758, branches/upstream/liborlite-perl/current/t/16_array_create.t
Modified:
trunk/liborlite-perl/Changes
trunk/liborlite-perl/MANIFEST
trunk/liborlite-perl/META.yml
trunk/liborlite-perl/debian/changelog
trunk/liborlite-perl/lib/ORLite.pm
trunk/liborlite-perl/t/03_fk.t
trunk/liborlite-perl/t/07_pk.t
trunk/liborlite-perl/t/08_prune.pl
trunk/liborlite-perl/t/11_cleanup.t
trunk/liborlite-perl/t/lib/Test.pm
Modified: trunk/liborlite-perl/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/liborlite-perl/Changes?rev=51759&op=diff
==============================================================================
--- trunk/liborlite-perl/Changes (original)
+++ trunk/liborlite-perl/Changes Fri Jan 29 21:38:20 2010
@@ -1,4 +1,25 @@
Changes for Perl extension ORLite
+
+1.39 Fri 29 Jan 2010
+ - Typo in the tests, they now run >= instead of > 1.05
+
+1.38 Thu 28 Jan 2010
+ - When using array => 1 on classes that we can create, add a ->set
+ method for setting parameters in the object safely.
+
+1.37 Thu 28 Jan 2010
+ - Adding experimental support for the array => 1 option.
+
+1.36 Wed 27 Jan 2010
+ - Rolled back the Template::Tiny conversion as it ended up slowing
+ down the code generation too much. I shall struggle on under the
+ old method.
+
+1.35 Wed 27 Jan 2010
+ - Adding experimental support for accelerated XS accessors
+ using Class::XSAccessor. ORLite itself will not introduce a
+ dependency on this module, consumers of this feature will need
+ to do it themselves.
1.34 Tue 26 Jan 2010
- Major Change: Moved code generation from raw string appending to
Modified: trunk/liborlite-perl/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/liborlite-perl/MANIFEST?rev=51759&op=diff
==============================================================================
--- trunk/liborlite-perl/MANIFEST (original)
+++ trunk/liborlite-perl/MANIFEST Fri Jan 29 21:38:20 2010
@@ -31,6 +31,11 @@
t/10_cleanup.sql
t/10_cleanup.t
t/11_cleanup.t
+t/12_xs.t
+t/13_array_basics.t
+t/14_array_fk.t
+t/15_array_xs.t
+t/16_array_create.t
t/97_meta.t
t/98_pod.t
t/99_pmv.t
Modified: trunk/liborlite-perl/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/liborlite-perl/META.yml?rev=51759&op=diff
==============================================================================
--- trunk/liborlite-perl/META.yml (original)
+++ trunk/liborlite-perl/META.yml Fri Jan 29 21:38:20 2010
@@ -29,10 +29,9 @@
File::Spec: 0.80
File::Temp: 0.20
Params::Util: 0.33
- Template::Tiny: 0.09
perl: 5.6.0
resources:
ChangeLog: http://fisheye2.atlassian.com/changelog/cpan/trunk/ORLite
license: http://dev.perl.org/licenses/
repository: http://svn.ali.as/cpan/trunk/ORLite
-version: 1.34
+version: 1.39
Modified: trunk/liborlite-perl/debian/changelog
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/liborlite-perl/debian/changelog?rev=51759&op=diff
==============================================================================
--- trunk/liborlite-perl/debian/changelog (original)
+++ trunk/liborlite-perl/debian/changelog Fri Jan 29 21:38:20 2010
@@ -1,9 +1,13 @@
-liborlite-perl (1.34-1) unstable; urgency=low
+liborlite-perl (1.39-1) UNRELEASED; urgency=low
- * New upstream release
+ [ Jonathan Yu ]
+ * New upstream release 1.34
* Refresh POD spelling patch
- -- Jonathan Yu <jawnsy at cpan.org> Tue, 26 Jan 2010 21:19:39 -0500
+ [ gregor herrmann ]
+ * New upstream release 1.39.
+
+ -- gregor herrmann <gregoa at debian.org> Fri, 29 Jan 2010 22:36:55 +0100
liborlite-perl (1.33-1) unstable; urgency=low
Modified: trunk/liborlite-perl/lib/ORLite.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/liborlite-perl/lib/ORLite.pm?rev=51759&op=diff
==============================================================================
--- trunk/liborlite-perl/lib/ORLite.pm (original)
+++ trunk/liborlite-perl/lib/ORLite.pm Fri Jan 29 21:38:20 2010
@@ -4,19 +4,18 @@
use 5.006;
use strict;
-use Carp ();
-use File::Spec 0.80 ();
-use File::Temp 0.20 ();
-use File::Path 2.04 ();
-use File::Basename 0 ();
-use Params::Util 0.33 ();
-use Template::Tiny 0.09 ();
-use DBI 1.607 ();
-use DBD::SQLite 1.27 ();
+use Carp ();
+use File::Spec 0.80 ();
+use File::Temp 0.20 ();
+use File::Path 2.04 ();
+use File::Basename 0 ();
+use Params::Util 0.33 ();
+use DBI 1.607 ();
+use DBD::SQLite 1.27 ();
use vars qw{$VERSION};
BEGIN {
- $VERSION = '1.34';
+ $VERSION = '1.39';
}
# Support for the 'prune' option
@@ -46,26 +45,16 @@
pop @_;
}
- # Handle param formatting
+ # Check params and apply defaults
my %params;
if ( defined Params::Util::_STRING($_[1]) ) {
# Support the short form "use ORLite 'db.sqlite'"
- %params = (
- file => $_[1],
- readonly => undef, # Automatic
- package => undef, # Automatic
- tables => 1,
- );
+ %params = ( file => $_[1] );
} elsif ( Params::Util::_HASHLIKE($_[1]) ) {
%params = %{ $_[1] };
} else {
Carp::croak("Missing, empty or invalid params HASH");
}
-
- # Check params and apply defaults
- $params{orlite} = $VERSION;
- $params{file} = File::Spec->rel2abs($params{file});
- $params{dsn} = "dbi:SQLite:$params{file}";
unless ( defined $params{create} ) {
$params{create} = 0;
}
@@ -85,6 +74,12 @@
unless ( defined $params{cleanup} ) {
$params{cleanup} = '';
}
+ unless ( defined $params{array} ) {
+ $params{array} = 0;
+ }
+ unless ( defined $params{xsaccessor} ) {
+ $params{xsaccessor} = 0;
+ }
unless ( defined $params{tables} ) {
$params{tables} = 1;
}
@@ -96,17 +91,29 @@
}
# Connect to the database
- my $created = ! -f $params{file};
+ my $file = File::Spec->rel2abs($params{file});
+ my $created = ! -f $params{file};
if ( $created ) {
# Create the parent directory
- my $dir = File::Basename::dirname($params{file});
+ my $dir = File::Basename::dirname($file);
unless ( -d $dir ) {
my @dirs = File::Path::mkpath( $dir, { verbose => 0 } );
$class->prune(@dirs) if $params{prune};
}
- $class->prune($params{file}) if $params{prune};
- }
- my $dbh = DBI->connect( $params{dsn}, undef, undef, {
+ $class->prune($file) if $params{prune};
+ }
+ my $pkg = $params{package};
+ my $readonly = $params{readonly};
+ my $cleanup = $params{cleanup};
+ my $xsaccessor = $params{xsaccessor};
+ my $array = $params{array};
+ my $xsclass = $array ? 'Class::XSAccessor::Array' : 'Class::XSAccessor';
+ my $l = $array ? '[' : '{';
+ my $r = $array ? ']' : '}';
+ my $slice = $array ? '{}' : '{ Slice => {} }';
+ my $rowref = $array ? 'arrayref' : 'hashref';
+ my $dsn = "dbi:SQLite:$file";
+ my $dbh = DBI->connect( $dsn, undef, undef, {
PrintError => 0,
RaiseError => 1,
} );
@@ -122,57 +129,235 @@
Carp::croak("Schema user_version mismatch (got $user_version, wanted $params{user_version})");
}
+ # Generate the support package code
+ my $code = <<"END_PERL";
+package $pkg;
+
+use strict;
+use Carp ();
+use DBI 1.607 ();
+use DBD::SQLite 1.27 ();
+
+my \$DBH = undef;
+
+sub orlite { '$VERSION' }
+
+sub sqlite { '$file' }
+
+sub dsn { '$dsn' }
+
+sub dbh {
+ \$DBH or \$_[0]->connect;
+}
+
+sub connect {
+ DBI->connect( \$_[0]->dsn, undef, undef, {
+ PrintError => 0,
+ RaiseError => 1,
+ } );
+}
+
+sub prepare {
+ shift->dbh->prepare(\@_);
+}
+
+sub do {
+ shift->dbh->do(\@_);
+}
+
+sub selectall_arrayref {
+ shift->dbh->selectall_arrayref(\@_);
+}
+
+sub selectall_hashref {
+ shift->dbh->selectall_hashref(\@_);
+}
+
+sub selectcol_arrayref {
+ shift->dbh->selectcol_arrayref(\@_);
+}
+
+sub selectrow_array {
+ shift->dbh->selectrow_array(\@_);
+}
+
+sub selectrow_arrayref {
+ shift->dbh->selectrow_arrayref(\@_);
+}
+
+sub selectrow_hashref {
+ shift->dbh->selectrow_hashref(\@_);
+}
+
+sub pragma {
+ \$_[0]->do("pragma \$_[1] = \$_[2]") if \@_ > 2;
+ \$_[0]->selectrow_arrayref("pragma \$_[1]")->[0];
+}
+
+sub iterate {
+ my \$class = shift;
+ my \$call = pop;
+ my \$sth = \$class->prepare(shift);
+ \$sth->execute(\@_);
+ while ( \$_ = \$sth->fetchrow_arrayref ) {
+ \$call->() or last;
+ }
+ \$sth->finish;
+}
+
+sub begin {
+ \$DBH or
+ \$DBH = \$_[0]->connect;
+ \$DBH->begin_work;
+}
+
+sub rollback {
+ \$DBH or return 1;
+ \$DBH->rollback;
+ \$DBH->disconnect;
+ undef \$DBH;
+ return 1;
+}
+
+sub rollback_begin {
+ if ( \$DBH ) {
+ \$DBH->rollback;
+ \$DBH->begin_work;
+ } else {
+ \$_[0]->begin;
+ }
+ return 1;
+}
+
+END_PERL
+
+ # If you are a read-write database, we even allow you
+ # to commit your transactions.
+ $code .= <<"END_PERL" unless $readonly;
+sub commit {
+ \$DBH or return 1;
+ \$DBH->commit;
+ \$DBH->disconnect;
+ undef \$DBH;
+ return 1;
+}
+
+sub commit_begin {
+ if ( \$DBH ) {
+ \$DBH->commit;
+ \$DBH->begin_work;
+ } else {
+ \$_[0]->begin;
+ }
+ return 1;
+}
+
+END_PERL
+
+ # Cleanup and shutdown operations
+ if ( $cleanup ) {
+ $code .= <<"END_PERL";
+END {
+ if ( \$DBH ) {
+ \$DBH->rollback;
+ \$DBH->do('$cleanup');
+ \$DBH->disconnect;
+ undef \$DBH;
+ } else {
+ $pkg->do('$cleanup');
+ }
+}
+
+END_PERL
+ } else {
+ $code .= <<"END_PERL";
+END {
+ $pkg->rollback if \$DBH;
+}
+
+END_PERL
+ }
+
# Optionally generate the table classes
if ( $params{tables} ) {
- # Capture the raw schema information
- my $tables = $params{tables} = $dbh->selectall_arrayref(
+ # Capture the raw schema table information
+ my $tables = $dbh->selectall_arrayref(
'select * from sqlite_master where name not like ? and type = ?',
{ Slice => {} }, 'sqlite_%', 'table',
);
+ my %tindex = map { $_->{name} => $_ } @$tables;
+
+ # Capture the raw schema column information
foreach my $table ( @$tables ) {
- $table->{columns} = $dbh->selectall_arrayref(
+ # What will be the class for this table
+ $table->{class} = ucfirst lc $table->{name};
+ $table->{class} =~ s/_([a-z])/uc($1)/ge;
+ $table->{class} = "${pkg}::$table->{class}";
+
+ # Load the column data
+ my $columns = $table->{columns} = $dbh->selectall_arrayref(
"pragma table_info('$table->{name}')",
{ Slice => {} },
);
+
+ # Generate the object keys for the columns
+ if ( $array ) {
+ foreach my $i ( 0 .. $#$columns ) {
+ $columns->[$i]->{xs} = $i;
+ $columns->[$i]->{key} = "[$i]";
+ }
+ } else {
+ foreach my $c ( @$columns ) {
+ $c->{xs} = "'$c->{name}'";
+ $c->{key} = "{$c->{name}}";
+ }
+ }
+
+ # Generate the primary key list
+ $table->{pk} = [ grep { $_->{pk} } @$columns ];
+ $table->{pks} = scalar @{$table->{pk}};
+ $table->{create} = !! ( $table->{pks} and ! $readonly );
+
+ # Generate the main SQL fragments
+ $table->{sql_cols} = join ', ', map { '"' . $_->{name} . '"' } @$columns;
+ $table->{sql_vals} = join ', ', ('?') x scalar @$columns;
+ $table->{sql_select} = "select $table->{sql_cols} from $table->{name}";
+ $table->{sql_count} = "select count(*) from $table->{name}";
+ $table->{sql_insert} =
+ "insert into $table->{name} " .
+ "( $table->{sql_cols} ) " .
+ "values ( $table->{sql_vals} )";
+ $table->{sql_where} = join ' and ',
+ map { "$_->{name} = ?" } @{$table->{pk}};
+
+ # Generate the new Perl fragments
+ $table->{pl_new} = join "\n", map {
+ $array ? "\t\t\$attr{$_->{name}},"
+ : "\t\t$_->{name} => \$attr{$_->{name}},"
+ } @$columns;
+
+ $table->{pl_insert} = join "\n", map {
+ "\t\t\$self->$_->{key},"
+ } @$columns;
+
+ if ( $table->{pks} == 1 ) {
+ $table->{pl_fill} = "\t\$self->$table->{pk}->[0]->{key} " .
+ "= \$dbh->func('last_insert_rowid') " .
+ "unless \$self->$table->{pk}->[0]->{key};";
+ } else {
+ $table->{pl_fill} = '';
+ }
+
+ $table->{pl_where} = join "\n", map {
+ "\t\t\$self->$_->{key},"
+ } @{$table->{pk}};
}
- # Generate the main additional table level metadata
- my %tindex = map { $_->{name} => $_ } @$tables;
- foreach my $table ( @$tables ) {
- my @columns = @{ $table->{columns} };
- my @names = map { $_->{name} } @columns;
- $table->{cindex} = map { $_->{name} => $_ } @columns;
-
- # Discover the primary key
- @{$table->{pk}} = map($_->{name}, grep { $_->{pk} } @columns);
- $table->{pks} = scalar(@{$table->{pk}});
-
- # Will this table be read-write?
- $table->{readwrite} = !! ( $table->{pks} and ! $params{readonly} );
-
- # What will be the class for this table
- $table->{class} = ucfirst lc $table->{name};
- $table->{class} =~ s/_([a-z])/uc($1)/ge;
- $table->{class} = "$params{package}::$table->{class}";
-
- # Generate various SQL fragments
- $table->{sql_create} = $table->{sql};
- $table->{sql_cols} = join ', ', map { '"' . $_ . '"' } @names;
- $table->{sql_vals} = join ', ', ('?') x scalar @columns;
- $table->{sql_select} = "select $table->{sql_cols} from $table->{name}";
- $table->{sql_count} = "select count(*) from $table->{name}";
- $table->{sql_insert} = join ' ',
- "insert into $table->{name}" .
- "( $table->{sql_cols} )" .
- " values ( $table->{sql_vals} )";
- $table->{sql_where_pk} = join(' and ', map("$_ = ?", @{$table->{pk}}))
- }
-
- # Generate the foreign key metadata once all the basic table data is complete
+ # Generate the foreign key metadata
foreach my $table ( @$tables ) {
# Locate the foreign keys
my %fk = ();
- my @fk_sql = $table->{sql_create} =~ /[(,]\s*(.+?REFERENCES.+?)\s*[,)]/g;
+ my @fk_sql = $table->{sql} =~ /[(,]\s*(.+?REFERENCES.+?)\s*[,)]/g;
# Extract the details
foreach ( @fk_sql ) {
@@ -181,288 +366,226 @@
}
$fk{"$1"} = [ "$2", $tindex{"$2"}, "$3" ];
}
- foreach ( @{ $table->{columns} } ) {
+ foreach ( @{$table->{columns}} ) {
$_->{fk} = $fk{$_->{name}};
}
+
+ # One final code fragment we need the fk for
+ $table->{pl_accessor} = join "\n",
+ map { "\t\t$_->{name} => $_->{xs}," }
+ grep { ! $_->{fk} } @{$table->{columns}};
}
# Generate the per-table code
- foreach my $table ( grep { $_->{readwrite} } @$tables ) {
+ foreach my $table ( @$tables ) {
+ my @columns = @{$table->{columns}};
+
+ # Generate the elements in all packages
+ $code .= <<"END_PERL";
+package $table->{class};
+
+sub base { '$pkg' }
+
+sub table { '$table->{name}' }
+
+sub select {
+ my \$class = shift;
+ my \$sql = '$table->{sql_select} ';
+ \$sql .= shift if \@_;
+ my \$rows = $pkg->selectall_arrayref( \$sql, $slice, \@_ );
+ bless \$_, '$table->{class}' foreach \@\$rows;
+ wantarray ? \@\$rows : \$rows;
+}
+
+sub count {
+ my \$class = shift;
+ my \$sql = '$table->{sql_count} ';
+ \$sql .= shift if \@_;
+ $pkg->selectrow_array( \$sql, {}, \@_ );
+}
+
+END_PERL
+
+ # Handle different versions, because arrayref acts funny
+ if ( $array ) {
+ $code .= <<"END_PERL";
+sub iterate {
+ my \$class = shift;
+ my \$call = pop;
+ my \$sql = '$table->{sql_select} ';
+ \$sql .= shift if \@_;
+ my \$sth = $pkg->prepare(\$sql);
+ \$sth->execute(\@_);
+ while ( \$_ = \$sth->fetchrow_arrayref ) {
+ \$_ = bless [ \@\$_ ], '$table->{class}';
+ \$call->() or last;
+ }
+ \$sth->finish;
+}
+
+END_PERL
+ } else {
+ $code .= <<"END_PERL";
+sub iterate {
+ my \$class = shift;
+ my \$call = pop;
+ my \$sql = '$table->{sql_select} ';
+ \$sql .= shift if \@_;
+ my \$sth = $pkg->prepare(\$sql);
+ \$sth->execute(\@_);
+ while ( \$_ = \$sth->fetchrow_hashref ) {
+ bless \$_, '$table->{class}';
+ \$call->() or last;
+ }
+ \$sth->finish;
+}
+
+END_PERL
+ }
+
+ # Add the primary key based single object loader
+ if ( $table->{pks} ) {
+ if ( $array ) {
+ $code .= <<"END_PERL";
+sub load {
+ my \$class = shift;
+ my \@row = $pkg->selectrow_array(
+ '$table->{sql_select} where $table->{sql_where}',
+ undef, \@_,
+ );
+ unless ( \@row ) {
+ Carp::croak("$table->{class} row does not exist");
+ }
+ bless \\\@row, '$table->{class}';
+}
+
+END_PERL
+ } else {
+ $code .= <<"END_PERL";
+sub load {
+ my \$class = shift;
+ my \$row = $pkg->selectrow_hashref(
+ '$table->{sql_select} where $table->{sql_where}',
+ undef, \@_,
+ );
+ unless ( \$row ) {
+ Carp::croak("$table->{class} row does not exist");
+ }
+ bless \$row, '$table->{class}';
+}
+
+END_PERL
+ }
+ }
+
# Generate the elements for tables with primary keys
- my @names = map { $_->{name} } @{ $table->{columns} };
- $table->{nattr} = join "\n", map { "\t\t$_ => \$attr{$_}," } @names;
- $table->{iattr} = join "\n", map { "\t\t\$self->{$_}," } @names;
- $table->{fill_pk} = scalar @{$table->{pk}} == 1
- ? "\t\$self->{$table->{pk}->[0]} = \$dbh->func('last_insert_rowid') unless \$self->{$table->{pk}->[0]};"
- : q{};
- $table->{where_pk} = join(' and ', map("$_ = ?", @{$table->{pk}}));
- $table->{where_pk_attr} = join("\n", map("\t\t\$self->{$_},", @{$table->{pk}}));
+ if ( $table->{create} ) {
+ $code .= <<"END_PERL";
+sub new {
+ my \$class = shift;
+ my \%attr = \@_;
+ bless $l
+$table->{pl_new}
+ $r, \$class;
+}
+
+sub create {
+ shift->new(\@_)->insert;
+}
+
+sub insert {
+ my \$self = shift;
+ my \$dbh = $pkg->dbh;
+ \$dbh->do( '$table->{sql_insert}', {},
+$table->{pl_insert}
+ );
+$table->{pl_fill}
+ return \$self;
+}
+
+sub delete {
+ my \$self = shift;
+ return $pkg->do(
+ 'delete from $table->{name} where $table->{sql_where}',
+ {},
+$table->{pl_where}
+ ) if ref \$self;
+ Carp::croak("Must use truncate to delete all rows") unless \@_;
+ return $pkg->do(
+ 'delete from $table->{name} ' . shift,
+ {}, \@_,
+ );
+}
+
+sub truncate {
+ $pkg->do('delete from $table->{name}');
+}
+
+END_PERL
+
+ if ( $table->{create} and $array ) {
+ # Add an additional set method to avoid having
+ # the user have to enter manual positions.
+ $code .= <<"END_PERL";
+sub set {
+ my \$self = shift;
+ my \$i = {
+$table->{pl_accessor}
+ }->{\$_[0]};
+ die "Bad name '\$_[0]'" unless defined \$i;
+ \$self->[\$i] = \$_[1];
+}
+
+END_PERL
}
+ }
+
+ # Generate the boring accessors
+ if ( $xsaccessor ) {
+ my $type = $table->{create} ? 'accessors' : 'getters';
+ $code .= <<"END_PERL";
+use $xsclass 1.05 {
+ getters => {
+$table->{pl_accessor}
+ },
+};
+
+END_PERL
+ } else {
+ $code .= join "\n\n", map { <<"END_PERL" } grep { ! $_->{fk} } @columns;
+sub $_->{name} {
+ \$_[0]->$_->{key};
+}
+END_PERL
+ }
+
+ # Generate the foreign key accessors
+ $code .= join "\n\n", map { <<"END_PERL" } grep { $_->{fk} } @columns;
+sub $_->{name} {
+ ($_->{fk}->[1]->{class}\->select('where $_->{fk}->[1]->{pk}->[0]->{name} = ?', \$_[0]->$_->{key}))[0];
+}
+END_PERL
+ }
}
$dbh->disconnect;
- # Generate as a template.
- my $code2 = Template::Tiny->new->process( \<<'END_PERL', \%params );
-package [% package %];
-
-use strict;
-use Carp ();
-use DBI 1.607 ();
-use DBD::SQLite 1.27 ();
-
-my $DBH = undef;
-
-sub orlite { '[% orlite %]' }
-
-sub sqlite { '[% file %]' }
-
-sub dsn { 'dbi:SQLite:[% file %]' }
-
-sub dbh {
- $DBH or $_[0]->connect;
-}
-
-sub connect {
- DBI->connect( $_[0]->dsn, undef, undef, {
- PrintError => 0,
- RaiseError => 1,
- } );
-}
-
-sub prepare {
- shift->dbh->prepare(@_);
-}
-
-sub do {
- shift->dbh->do(@_);
-}
-
-sub selectall_arrayref {
- shift->dbh->selectall_arrayref(@_);
-}
-
-sub selectall_hashref {
- shift->dbh->selectall_hashref(@_);
-}
-
-sub selectcol_arrayref {
- shift->dbh->selectcol_arrayref(@_);
-}
-
-sub selectrow_array {
- shift->dbh->selectrow_array(@_);
-}
-
-sub selectrow_arrayref {
- shift->dbh->selectrow_arrayref(@_);
-}
-
-sub selectrow_hashref {
- shift->dbh->selectrow_hashref(@_);
-}
-
-sub pragma {
- $_[0]->do("pragma $_[1] = $_[2]") if @_ > 2;
- $_[0]->selectrow_arrayref("pragma $_[1]")->[0];
-}
-
-sub iterate {
- my $class = shift;
- my $call = pop;
- my $sth = $class->prepare(shift);
- $sth->execute(@_);
- while ( $_ = $sth->fetchrow_arrayref ) {
- $call->() or last;
- }
- $sth->finish;
-}
-
-sub begin {
- $DBH or
- $DBH = $_[0]->connect;
- $DBH->begin_work;
-}
-
-sub rollback {
- $DBH or return 1;
- $DBH->rollback;
- $DBH->disconnect;
- undef $DBH;
- return 1;
-}
-
-sub rollback_begin {
- if ( $DBH ) {
- $DBH->rollback;
- $DBH->begin_work;
- } else {
- $_[0]->begin;
- }
- return 1;
-}
-[% UNLESS readonly %]
-sub commit {
- $DBH or return 1;
- $DBH->commit;
- $DBH->disconnect;
- undef $DBH;
- return 1;
-}
-
-sub commit_begin {
- if ( $DBH ) {
- $DBH->commit;
- $DBH->begin_work;
- } else {
- $_[0]->begin;
- }
- return 1;
-}
-[% END %]
-[%- IF cleanup %]
-END {
- if ( $DBH ) {
- $DBH->rollback;
- $DBH->do('[% cleanup %]');
- $DBH->disconnect;
- undef $DBH;
- } else {
- [% package %]->do('[% cleanup %]');
- }
-}
-[%- ELSE %]
-END {
- [% package %]->rollback if $DBH;
-}
-[%- END %]
-[% FOREACH table IN tables %]
-package [% table.class %];
-
-sub base { '[% package %]' }
-
-sub table { '[% table.name %]' }
-
-sub select {
- my $class = shift;
- my $sql = '[% table.sql_select %] ';
- $sql .= shift if @_;
- my $rows = [% package %]->selectall_arrayref( $sql, { Slice => {} }, @_ );
- bless( $_, '[% table.class %]' ) foreach @$rows;
- wantarray ? @$rows : $rows;
-}
-
-sub count {
- my $class = shift;
- my $sql = '[% table.sql_count %] ';
- $sql .= shift if @_;
- [% package %]->selectrow_array( $sql, {}, @_ );
-}
-
-sub iterate {
- my $class = shift;
- my $call = pop;
- my $sql = '[% table.sql_select %] ';
- $sql .= shift if @_;
- my $sth = [% package %]->prepare( $sql );
- $sth->execute( @_ );
- while ( $_ = $sth->fetchrow_hashref ) {
- bless( $_, '[% table.class %]' );
- $call->() or last;
- }
- $sth->finish;
-}
-[% IF table.pks %]
-sub load {
- my $class = shift;
- my $row = [% package %]->selectrow_hashref(
- '[% table.sql_select %] where [% table.sql_where_pk %]',
- undef, @_,
- );
- unless ( $row ) {
- Carp::croak("[% table.class %] row does not exist");
- }
- bless( $row, '[% table.class %]' );
-}
-[% END %]
-[%- IF table.readwrite %]
-sub new {
- my $class = shift;
- my %attr = @_;
- bless {
-[% table.nattr %]
- }, $class;
-}
-
-sub create {
- shift->new(@_)->insert;
-}
-
-sub insert {
- my $self = shift;
- my $dbh = [% package %]->dbh;
- $dbh->do( '[% table.sql_insert %]', {},
-[% table.iattr %]
- );
-[% table.fill_pk %]
- return $self;
-}
-
-sub delete {
- my $self = shift;
- return [% package %]->do(
- 'delete from [% table.name %] where [% table.where_pk %]',
- {},
-[% table.where_pk_attr %]
- ) if ref $self;
- Carp::croak("Must use truncate to delete all rows") unless @_;
- return [% package %]->do(
- 'delete from [% table.name %] ' . shift,
- {}, @_,
- );
-}
-
-sub truncate {
- [% package %]->do( 'delete from [% table.name %]', {} );
-}
-[% END %]
-[%- FOREACH column IN table.columns %]
-sub [% column.name %] {
-[%- IF column.fk %]
- ([% column.fk.1.class %]->select('where [% column.fk.1.pk.0 %] = ?', $_[0]->{[% column.name %]}))[0];
-[%- ELSE %]
- $_[0]->{[% column.name %]};
-[%- END %]
-}
-[% END %]
-[%- END %]
-[%- IF append %]
-[%- IF tables %]
-package [% package %];
-[% END %]
-[% append %]
-[% END %]
-1;
-END_PERL
-
- # Comparative testing
-# if ( $ENV{HARNESS_ACTIVE} ) {
-# require Test::LongString;
-# Test::LongString::is_string(
-# $code2 => $code,
-# "Templated code matches string-append code",
-# );
-# }
+ # Add any custom code to the end
+ if ( defined $params{append} ) {
+ $code .= "\npackage $pkg;\n" if $params{tables};
+ $code .= "\n$params{append}";
+ }
+ $code .= "\n\n1;\n";
# Compile the code
local $@;
if ( $^P and $^V >= 5.008009 ) {
local $^P = $^P | 0x800;
- eval $code2;
+ eval $code;
die $@ if $@;
} elsif ( $DEBUG ) {
- dval($code2);
+ dval($code);
} else {
- eval $code2;
+ eval $code;
die $@ if $@;
}
Modified: trunk/liborlite-perl/t/03_fk.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/liborlite-perl/t/03_fk.t?rev=51759&op=diff
==============================================================================
--- trunk/liborlite-perl/t/03_fk.t (original)
+++ trunk/liborlite-perl/t/03_fk.t Fri Jan 29 21:38:20 2010
@@ -48,5 +48,3 @@
is( $t2[0]->col1, 1, '->col1 ok' );
isa_ok( $t2[0]->col2, 'Foo::Bar::TableOne' );
-
-1;
Modified: trunk/liborlite-perl/t/07_pk.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/liborlite-perl/t/07_pk.t?rev=51759&op=diff
==============================================================================
--- trunk/liborlite-perl/t/07_pk.t (original)
+++ trunk/liborlite-perl/t/07_pk.t Fri Jan 29 21:38:20 2010
@@ -44,5 +44,3 @@
is( scalar(@t1), 2, 'Got 2 table_one objects' );
@t1 = Foo::Bar::TableOne->select('where col1 = ? and col2 = ?', 1, 2);
is( $t1[0]->col3, 'b', 'Got line with col3 = b');
-
-1;
Modified: trunk/liborlite-perl/t/08_prune.pl
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/liborlite-perl/t/08_prune.pl?rev=51759&op=diff
==============================================================================
--- trunk/liborlite-perl/t/08_prune.pl (original)
+++ trunk/liborlite-perl/t/08_prune.pl Fri Jan 29 21:38:20 2010
@@ -4,7 +4,7 @@
use strict;
-our $VERSION = '1.34';
+our $VERSION = '1.39';
unless ( $ORLite::VERSION eq $VERSION ) {
die('Failed to load correct ORLite version');
Modified: trunk/liborlite-perl/t/11_cleanup.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/liborlite-perl/t/11_cleanup.t?rev=51759&op=diff
==============================================================================
--- trunk/liborlite-perl/t/11_cleanup.t (original)
+++ trunk/liborlite-perl/t/11_cleanup.t Fri Jan 29 21:38:20 2010
@@ -7,7 +7,7 @@
$^W = 1;
}
-use Test::More tests => 3;
+use Test::More tests => 4;
use File::Spec::Functions ':ALL';
use t::lib::Test;
@@ -40,5 +40,6 @@
# Run the tests
ok( Foo::Bar->can('orlite'), 'Created the ORLite class' );
+ok( Foo::Bar->begin, 'Created the transaction' );
+ok( ! Foo::Bar->dbh->{AutoCommit}, '->{AutoCommit} is off' );
-ok( Foo::Bar->begin, 'Created the transaction' );
Modified: trunk/liborlite-perl/t/lib/Test.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/liborlite-perl/t/lib/Test.pm?rev=51759&op=diff
==============================================================================
--- trunk/liborlite-perl/t/lib/Test.pm (original)
+++ trunk/liborlite-perl/t/lib/Test.pm Fri Jan 29 21:38:20 2010
@@ -9,7 +9,7 @@
use vars qw{$VERSION @ISA @EXPORT};
BEGIN {
- $VERSION = '1.34';
+ $VERSION = '1.39';
@ISA = 'Exporter';
@EXPORT = qw{ test_db connect_ok create_ok };
}
More information about the Pkg-perl-cvs-commits
mailing list