Hi Merijn,
does the attached patch looks good for you?
I decided to deal differently with lockMode, because I don't want
silently drop lock support ...
Jens
Index: lib/DBD/File.pm
===================================================================
--- lib/DBD/File.pm (Revision 15389)
+++ lib/DBD/File.pm (Arbeitskopie)
@@ -624,6 +624,8 @@
{
my ($className, $data, $attrs, $flags) = @_;
+ # open_file must be called before inherited new is invoked
+ # because column name mapping is initialized in constructor ...
my ($tblnm, $meta) = $className->get_table_meta ($data->{Database},
$attrs->{table}, 1) or
croak "Cannot find appropriate file for table '$attrs->{table}'";
$className->open_file ($meta, $attrs, $flags);
Index: lib/DBI/DBD/SqlEngine.pm
===================================================================
--- lib/DBI/DBD/SqlEngine.pm (Revision 15389)
+++ lib/DBI/DBD/SqlEngine.pm (Arbeitskopie)
@@ -1293,6 +1293,17 @@
};
$self->{command} eq "DROP" and $flags->{dropMode} = 1;
+ # because column name mapping is initialized in constructor ...
+ # and therefore specific opening operations might be done before
+ # reaching DBI::DBD::SqlEngine::Table->new(), we need to intercept
+ # ReadOnly here
+ my $write_op = $createMode || $lockMode || $flags->{dropMode};
+ if( $write_op ) {
+ my ( $tblnm, $table_meta ) = $class->get_table_meta( $data->{Database},
$table, 1 )
+ or croak "Cannot find appropriate file for table '$table'";
+ $table_meta->{readonly} and croak "Table '$table' is marked readonly -
" . $self->{command} . " command forbidden";
+ }
+
return $class->new( $data, { table => $table }, $flags );
} # open_table
@@ -1450,8 +1461,6 @@
$flags->{createMode} && $data->{sql_stmt}{table_defs}
and $meta->{table_defs} = $data->{sql_stmt}{table_defs};
- my $columns = {};
- my $array = [];
my $tbl = {
%{$attrs},
meta => $meta,
Index: lib/DBI/SQL/Nano.pm
===================================================================
--- lib/DBI/SQL/Nano.pm (Revision 15387)
+++ lib/DBI/SQL/Nano.pm (Arbeitskopie)
@@ -31,7 +31,7 @@
$VERSION = sprintf( "1.%06d", q$Revision$ =~ /(\d+)/o );
$versions->{nano_version} = $VERSION;
- if ( $ENV{DBI_SQL_NANO} || !eval { require SQL::Statement;
$SQL::Statement::VERSION ge '1.28' } )
+ if ( $ENV{DBI_SQL_NANO} || !eval { require SQL::Statement;
$SQL::Statement::VERSION ge '1.400' } )
{
@DBI::SQL::Nano::Statement::ISA = qw(DBI::SQL::Nano::Statement_);
@DBI::SQL::Nano::Table::ISA = qw(DBI::SQL::Nano::Table_);
Index: t/49dbd_file.t
===================================================================
--- t/49dbd_file.t (Revision 15389)
+++ t/49dbd_file.t (Arbeitskopie)
@@ -150,8 +150,61 @@
$dbh->errstr and diag $dbh->errstr;
}
+# ==================== ReadOnly tests =============================
+ok ($dbh = DBI->connect ("dbi:File:", undef, undef, {
+ f_ext => ".txt",
+ f_dir => $dir,
+ f_schema => undef,
+ f_encoding => $encoding,
+ f_lock => 0,
+
+ sql_meta => {
+ $tbl => {
+ col_names => [qw(txt)],
+ }
+ },
+
+ RaiseError => 0,
+ PrintError => 0,
+ ReadOnly => 1,
+ }), "ReadOnly connect with driver attributes in hash");
+
+ok ($sth = $dbh->prepare ("select * from $tbl"), "Prepare select * from $tbl");
+$rowidx = 0;
+SKIP: {
+ $using_dbd_gofer and skip "method intrusion didn't work with proxying", 1;
+ ok ($sth->execute, "execute on $tbl");
+ $dbh->errstr and diag $dbh->errstr;
+ }
+
+ok ($sth = $dbh->prepare ("insert into $tbl (txt) values (?)"), "prepare
'insert into $tbl'");
+is ($sth->execute ("Perl rules"), undef, "insert failed intensionally");
+diag $dbh->errstr;
+
+ok ($sth = $dbh->prepare ("delete from $tbl"), "prepare 'delete from $tbl'");
+is ($sth->execute (), undef, "delete failed intensionally");
+diag $dbh->errstr;
+
+is ($dbh->do ("drop table $tbl"), undef, "table drop failed intensionally");
+diag $dbh->errstr;
+is (-f $tbl_file, 1, "Test table not removed");
+
+# ==================== ReadWrite again tests =============================
+ok ($dbh = DBI->connect ("dbi:File:", undef, undef, {
+ f_ext => ".txt",
+ f_dir => $dir,
+ f_schema => undef,
+ f_encoding => $encoding,
+ f_lock => 0,
+
+ RaiseError => 0,
+ PrintError => 0,
+ }), "ReadWrite for drop connect with driver attributes in hash");
+
+# XXX add a truncate test
+
ok ($dbh->do ("drop table $tbl"), "table drop");
-is (-s "$tbl.txt", undef, "Test table removed");
+is (-s $tbl_file, undef, "Test table removed"); # -s => size test
done_testing ();
