Initial commit of DBIx::Class (experimental Class::DBI-inspired ORM)

lib/DBIx/Class.pm

@@ -0,0 +1,5 @@
+package DBIx::Class;
+
+use base qw/DBIx::Class::CDBICompat DBIx::Class::Core/;
+
+1;

lib/DBIx/Class/CDBICompat.pm

@@ -0,0 +1,10 @@
+package DBIx::Class::CDBICompat;
+
+use strict;
+use warnings;
+
+use base qw/DBIx::Class::CDBICompat::AccessorMapping
+            DBIx::Class::CDBICompat::ColumnCase
+            DBIx::Class::CDBICompat::ColumnGroups/;
+
+1;

lib/DBIx/Class/CDBICompat/AccessorMapping.pm

@@ -0,0 +1,29 @@
+package DBIx::Class::CDBICompat::AccessorMapping;
+
+use strict;
+use warnings;
+
+use NEXT;
+
+sub _mk_column_accessors {
+  my ($class, @cols) = @_;
+  unless ($class->can('accessor_name') || $class->can('mutator_name')) {
+    return $class->NEXT::_mk_column_accessors(@cols);
+  }
+  foreach my $col (@cols) {
+    my $ro_meth = ($class->can('accessor_name')
+                    ? $class->accessor_name($col)
+                    : $col);
+    my $wo_meth = ($class->can('mutator_name')
+                    ? $class->mutator_name($col)
+                    : $col);
+    if ($ro_meth eq $wo_meth) {
+      $class->mk_accessors($col);
+    } else {
+      $class->mk_ro_accessors($ro_meth);
+      $class->mk_wo_accessors($wo_meth);
+    }
+  }
+}
+
+1;

lib/DBIx/Class/CDBICompat/ColumnCase.pm

@@ -0,0 +1,40 @@
+package DBIx::Class::CDBICompat::ColumnCase;
+
+use strict;
+use warnings;
+use NEXT;
+
+sub _register_column_group {
+  my ($class, $group, @cols) = @_;
+  return $class->NEXT::_register_column_group($group => map lc, @cols);
+}
+
+sub _register_columns {
+  my ($class, @cols) = @_;
+  return $class->NEXT::_register_columns(map lc, @cols);
+}
+
+sub get {
+  my ($class, $get, @rest) = @_;
+  return $class->NEXT::get(lc $get, @rest);
+}
+
+sub set {
+  my ($class, $set, @rest) = @_;
+  return $class->NEXT::set(lc $set, @rest);
+}
+
+sub find_column {
+  my ($class, $col) = @_;
+  return $class->NEXT::find_column(lc $col);
+}
+
+sub _mk_accessors {
+  my ($class, $type, @fields) = @_;
+  my %fields;
+  $fields{$_} = 1 for @fields,
+                    map lc, grep { !defined &{"${class}::${_}"} } @fields;
+  return $class->NEXT::_mk_accessors($type, keys %fields);
+}
+
+1;

lib/DBIx/Class/CDBICompat/ColumnGroups.pm

@@ -0,0 +1,93 @@
+package DBIx::Class::CDBICompat::ColumnGroups;
+
+use strict;
+use warnings;
+use NEXT;
+
+use base qw/Class::Data::Inheritable/;
+
+__PACKAGE__->mk_classdata('_column_groups' => { });
+
+sub table {
+  shift->_table_name(@_);
+}
+
+sub columns {
+  my $proto = shift;
+  my $class = ref $proto || $proto;
+  my $group = shift || "All";
+  $class->_set_column_group($group => @_) if @_;
+  return $class->all_columns    if $group eq "All";
+  return $class->primary_column if $group eq "Primary";
+  return keys %{$class->_column_groups->{$group}};
+}
+
+sub _set_column_group {
+  my ($class, $group, @cols) = @_;
+  $class->_register_column_group($group => @cols);
+  $class->_register_columns(@cols);
+  $class->_mk_column_accessors(@cols);
+}
+
+sub _register_column_group {
+  my ($class, $group, @cols) = @_;
+  if ($group eq 'Primary') {
+    my %pri;
+    $pri{$_} = {} for @cols;
+    $class->_primaries(\%pri);
+  }
+
+  my $groups = { %{$class->_column_groups} };
+
+  if ($group eq 'All') {
+    unless ($class->_column_groups->{'Primary'}) {
+      $groups->{'Primary'}{$cols[0]} = {};
+      $class->_primaries({ $cols[0] => {} });
+    }
+    unless ($class->_column_groups->{'Essential'}) {
+      $groups->{'Essential'}{$cols[0]} = {};
+    }
+  }
+
+  $groups->{$group}{$_} ||= {} for @cols;
+  $class->_column_groups($groups);
+}
+
+sub all_columns { return keys %{$_[0]->_columns}; }
+
+sub primary_column {
+  my ($class) = @_;
+  my @pri = keys %{$class->_primaries};
+  return wantarray ? @pri : $pri[0];
+}
+
+sub find_column {
+  my ($class, $col) = @_;
+  return $col if $class->_columns->{$col};
+}
+
+sub __grouper {
+  my ($class) = @_;
+  return bless({ class => $class}, 'DBIx::Class::CDBICompat::ColumnGroups::GrouperShim');
+}
+
+sub _find_columns {
+  my ($class, @col) = @_;
+  return map { $class->find_column($_) } @col;
+}
+
+package DBIx::Class::CDBICompat::ColumnGroups::GrouperShim;
+
+sub groups_for {
+  my ($self, @cols) = @_;
+  my %groups;
+  foreach my $col (@cols) {
+    foreach my $group (keys %{$self->{class}->_column_groups}) {
+      $groups{$group} = 1 if $self->{class}->_column_groups->{$group}->{$col};
+    }
+  }
+  return keys %groups;
+}
+
+
+1;

lib/DBIx/Class/Core.pm

@@ -0,0 +1,8 @@
+package DBIx::Class::Core;
+
+use strict;
+use warnings;
+
+use base qw/DBIx::Class::Table DBIx::Class::SQL DBIx::Class::DB/;
+
+1;

lib/DBIx/Class/DB.pm

@@ -0,0 +1,29 @@
+package DBIx::Class::DB;
+
+use base qw/Class::Data::Inheritable/;
+
+__PACKAGE__->mk_classdata('_dbi_connect_info');
+__PACKAGE__->mk_classdata('_dbi_connect_package');
+__PACKAGE__->mk_classdata('_dbh');
+
+sub _get_dbh {
+  my ($class) = @_;
+  unless ((my $dbh = $class->_dbh) && $dbh->FETCH('Active') && $dbh->ping) {
+    $class->_populate_dbh;
+  }
+  return $class->_dbh;
+}
+
+sub _populate_dbh {
+  my ($class) = @_;
+  my @info = @{$class->_dbi_connect_info || []};
+  my $pkg = $class->_dbi_connect_package || $class;
+  $pkg->_dbh($class->_dbi_connect(@info));
+}
+
+sub _dbi_connect {
+  my ($class, @info) = @_;
+  return DBI->connect_cached(@info);
+}
+
+1;

lib/DBIx/Class/SQL.pm

@@ -0,0 +1,41 @@
+package DBIx::Class::SQL;
+
+use strict;
+use warnings;
+
+use base qw/Class::Data::Inheritable/;
+
+use constant COLS => 0;
+use constant FROM => 1;
+use constant COND => 2;
+
+__PACKAGE__->mk_classdata('_sql_statements',
+  {
+    'select' =>
+      sub { "SELECT ".join(', ', @$_[COLS])." FROM $_[FROM] WHERE $_[COND]"; },
+    'update' =>
+      sub { "UPDATE $_[FROM] SET ".join(', ', map { "$_ = ?" } @$_[COLS]).
+              " WHERE $_[COND]"; },
+    'insert' =>
+      sub { "INSERT INTO $_[FROM] (".join(', ', @$_[COLS]).") VALUES (".
+              join(', ', map { '?' } @$_[COLS]).")"; },
+    'delete' =>
+      sub { "DELETE FROM $_[FROM] WHERE $_[COND]"; },
+  } );
+
+sub _get_sql {
+  my ($class, $name, $cols, $from, $cond) = @_;
+  return $class->_sql_statements->{$name}->($cols, $from, $cond);
+}
+
+sub _sql_to_sth {
+  my ($class, $sql) = @_;
+  return $class->_get_dbh->prepare($sql);
+}
+
+sub _get_sth {
+  my $class = shift;
+  return $class->_sql_to_sth($class->_get_sql(@_));
+}
+
+1;

lib/DBIx/Class/Table.pm

@@ -0,0 +1,98 @@
+package DBIx::Class::Table;
+
+use strict;
+use warnings;
+
+use base qw/Class::Data::Inheritable Class::Accessor DBIx::Class::SQL/;
+
+__PACKAGE__->mk_classdata('_columns' => {});
+
+__PACKAGE__->mk_classdata('_primaries' => {});
+
+__PACKAGE__->mk_classdata('_table_name');
+
+sub new {
+  my ($class, $attrs) = @_;
+  $class = ref $class if ref $class;
+  my $new = bless({ _column_data => { } }, $class);
+  if ($attrs) {
+    die "Attrs must be a hashref" unless ref($attrs) eq 'HASH';
+    while (my ($k, $v) = each %{$attrs}) {
+      $new->set_column($k => $v);
+    }
+  }
+}
+
+sub insert {
+  my ($self) = @_;
+  return if $self->{_in_database};
+  my $sth = $self->_get_sth('insert', [ keys %{$self->{_column_data}} ],
+                              $self->_table_name, undef);
+  $sth->execute(values %{$self->{_column_data}});
+  $self->{_in_database} = 1;
+  return $self;
+}
+
+sub create {
+  my ($class, $attrs) = @_;
+  return $class->new($attrs)->insert;
+}
+
+sub update {
+  my ($self) = @_;
+  die "Not in database" unless $self->{_in_database};
+  my @to_update = keys %{$self->{_dirty_columns} || {}};
+  my $sth = $self->_get_sth('update', \@to_update,
+                              $self->_table_name, $self->_ident_cond);
+  $sth->execute( (map { $self->{_column_data}{$_} } @to_update),
+                  $self->_ident_values );
+  $self->{_dirty_columns} = {};
+  return $self;
+}
+
+sub delete {
+  my ($self) = @_;
+  my $sth = $self->_get_sth('delete', undef,
+                              $self->_table_name, $self->_ident_cond);
+  $sth->execute($self->_ident_values);
+  delete $self->{_in_database};
+  return $self;
+}
+
+sub get {
+  my ($self, $column) = @_;
+  die "No such column '${column}'" unless $self->_columns->{$column};
+  return $self->{_column_data}{$column};
+}
+
+sub set {
+  my ($self, $column, $value) = @_;
+  die "No such column '${column}'" unless $self->_columns->{$column};
+  die "set_column called for ${column} without value" if @_ < 3;
+  $self->{_dirty_columns}{$column} = 1;
+  return $self->{_column_data}{$column} = $value;
+}
+
+sub _ident_cond {
+  my ($class) = @_;
+  return join(" AND ", map { "$_ = ?" } keys %{$class->_primaries});
+}
+
+sub _ident_values {
+  my ($self) = @_;
+  return (map { $self->{_column_data}{$_} } keys %{$self->_primaries});
+}
+
+sub _register_columns {
+  my ($class, @cols) = @_;
+  my $names = { %{$class->_columns} };
+  $names->{$_} ||= {} for @cols;
+  $class->_columns($names); 
+}
+
+sub _mk_column_accessors {
+  my ($class, @cols) = @_;
+  $class->mk_accessors(@cols);
+}
+
+1;