Added support for temp columns and ->make_read_only

diff --git a/lib/DBIx/Class/CDBICompat.pm b/lib/DBIx/Class/CDBICompat.pm
index a054a47..78cfc07 100644 (file)
--- a/lib/DBIx/Class/CDBICompat.pm
+++ b/lib/DBIx/Class/CDBICompat.pm
@@ -5,6 +5,7 @@ use warnings;
 
 use base qw/DBIx::Class::CDBICompat::Constraints
             DBIx::Class::CDBICompat::Triggers
+            DBIx::Class::CDBICompat::ReadOnly
             DBIx::Class::CDBICompat::GetSet
             DBIx::Class::CDBICompat::LiveObjectIndex
             DBIx::Class::CDBICompat::AttributeAPI
@@ -17,6 +18,7 @@ use base qw/DBIx::Class::CDBICompat::Constraints
             DBIx::Class::CDBICompat::HasA
             DBIx::Class::CDBICompat::LazyLoading
             DBIx::Class::CDBICompat::AutoUpdate
+            DBIx::Class::CDBICompat::TempColumns
             DBIx::Class::CDBICompat::ColumnGroups
             DBIx::Class::CDBICompat::ImaDBI/;
 

diff --git a/lib/DBIx/Class/CDBICompat/ReadOnly.pm b/lib/DBIx/Class/CDBICompat/ReadOnly.pm
new file mode 100644 (file)
index 0000000..fe1d902
--- /dev/null
+++ b/lib/DBIx/Class/CDBICompat/ReadOnly.pm
@@ -0,0 +1,13 @@
+package DBIx::Class::CDBICompat::ReadOnly;
+
+use strict;
+use warnings;
+
+sub make_read_only {
+  my $proto = shift;
+  $proto->add_trigger("before_$_" => sub { shift->throw("$proto is read only") })
+    foreach qw/create delete update/;
+  return $proto;
+}
+
+1;

diff --git a/lib/DBIx/Class/CDBICompat/TempColumns.pm b/lib/DBIx/Class/CDBICompat/TempColumns.pm
new file mode 100644 (file)
index 0000000..64d6d20
--- /dev/null
+++ b/lib/DBIx/Class/CDBICompat/TempColumns.pm
@@ -0,0 +1,64 @@
+package DBIx::Class::CDBICompat::TempColumns;
+
+use strict;
+use warnings;
+use base qw/Class::Data::Inheritable/;
+
+__PACKAGE__->mk_classdata('_temp_columns' => { });
+
+sub _add_column_group {
+  my ($class, $group, @cols) = @_;
+  if ($group eq 'TEMP') {
+    $class->_register_column_group($group => @cols);
+    $class->mk_group_accessors('temp' => @cols);
+    my %tmp = %{$class->_temp_columns};
+    $tmp{$_} = 1 for @cols;
+    $class->_temp_columns(\%tmp);
+  } else {
+    return $class->NEXT::ACTUAL::_add_column_group($group, @cols);
+  }
+}
+
+sub new {
+  my ($class, $attrs, @rest) = @_;
+  my %temp;
+  foreach my $key (keys %$attrs) {
+    $temp{$key} = delete $attrs->{$key} if $class->_temp_columns->{$key};
+  }
+  my $new = $class->NEXT::ACTUAL::new($attrs, @rest);
+  foreach my $key (keys %temp) {
+    $new->set_temp($key, $temp{$key});
+  }
+  return $new;
+}
+
+
+sub find_column {
+  my ($class, $col, @rest) = @_;
+  return $col if $class->_temp_columns->{$col};
+  return $class->NEXT::ACTUAL::find_column($col, @rest);
+}
+
+sub get_temp {
+  my ($self, $column) = @_;
+  $self->throw( "Can't fetch data as class method" ) unless ref $self;
+  $self->throw( "No such TEMP column '${column}'" ) unless $self->_temp_columns->{$column} ;
+  return $self->{_temp_column_data}{$column}
+    if exists $self->{_temp_column_data}{$column};
+  return undef;
+}
+
+sub set_temp {
+  my ($self, $column, $value) = @_;
+  $self->throw( "No such TEMP column '${column}'" )
+    unless $self->_temp_columns->{$column};
+  $self->throw( "set_temp called for ${column} without value" )
+    if @_ < 3;
+  return $self->{_temp_column_data}{$column} = $value;
+}
+
+sub has_real_column {
+  return 1 if shift->_columns->{shift};
+}
+
+1;

diff --git a/t/cdbi-t/15-accessor.t b/t/cdbi-t/15-accessor.t
index 35cf44d..2f7c85c 100644 (file)
--- a/t/cdbi-t/15-accessor.t
+++ b/t/cdbi-t/15-accessor.t
@@ -3,7 +3,7 @@ use Test::More;
 
 BEGIN {
        eval "use DBD::SQLite";
-       plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 55);
+       plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 53);
 }
 
 INIT {
@@ -127,7 +127,7 @@ eval {
 }
 
 SKIP: {    # have non persistent accessor?
-        skip "Compat layer doesn't handle TEMP columns yet", 11;
+        #skip "Compat layer doesn't handle TEMP columns yet", 11;
        Film->columns(TEMP => qw/nonpersistent/);
        ok(Film->find_column('nonpersistent'), "nonpersistent is a column");
        ok(!Film->has_real_column('nonpersistent'), " - but it's not real");
@@ -148,7 +148,7 @@ SKIP: {    # have non persistent accessor?
 }
 
 SKIP: {    # was bug with TEMP and no Essential
-        skip "Compat layer doesn't have TEMP columns yet", 5;
+        #skip "Compat layer doesn't have TEMP columns yet", 5;
        is_deeply(
                Actor->columns('Essential'),
                Actor->columns('Primary'),
@@ -162,7 +162,7 @@ SKIP: {    # was bug with TEMP and no Essential
 }
 
 SKIP: {
-        skip "Compat layer doesn't handle read-only objects yet", 10;
+        #skip "Compat layer doesn't handle read-only objects yet", 10;
        Film->autoupdate(1);
        my $naked = Film->create({ title => 'Naked' });
        my $sandl = Film->create({ title => 'Secrets and Lies' });
@@ -190,6 +190,3 @@ SKIP: {
        like $@, qr/read only/, "Or create new films";
        $SIG{__WARN__} = sub { };
 }
-
-SKIP: { skip "Lost a test adding skips somewhere, sorry", 2 }
-