From: Michael G Schwern Date: Fri, 14 Mar 2008 03:27:47 +0000 (+0000) Subject: Better emulation of add_constructor, unfortunately also slower. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=2e424e0ce593db821194d5039cbae94c3938720c;p=dbsrgits%2FDBIx-Class-Historic.git Better emulation of add_constructor, unfortunately also slower. --- diff --git a/lib/DBIx/Class/CDBICompat/Constructor.pm b/lib/DBIx/Class/CDBICompat/Constructor.pm index f44079b..190c223 100644 --- a/lib/DBIx/Class/CDBICompat/Constructor.pm +++ b/lib/DBIx/Class/CDBICompat/Constructor.pm @@ -1,22 +1,30 @@ package # hide from PAUSE DBIx::Class::CDBICompat::Constructor; +use base qw(DBIx::Class::CDBICompat::ImaDBI); + use strict; use warnings; +use Carp; + +__PACKAGE__->set_sql(Retrieve => <<''); +SELECT __ESSENTIAL__ +FROM __TABLE__ +WHERE %s + sub add_constructor { - my ($class, $meth, $sql) = @_; - $class = ref $class if ref $class; - no strict 'refs'; - - my %attrs; - $attrs{rows} = $1 if $sql =~ s/LIMIT\s+(.*)\s+$//i; - $attrs{order_by} = $1 if $sql =~ s/ORDER BY\s+(.*)//i; - - *{"${class}::${meth}"} = - sub { - my ($class, @args) = @_; - return $class->search_literal($sql, @args, \%attrs); + my ($class, $method, $fragment) = @_; + return croak("constructors needs a name") unless $method; + + no strict 'refs'; + my $meth = "$class\::$method"; + return carp("$method already exists in $class") + if *$meth{CODE}; + + *$meth = sub { + my $self = shift; + $self->sth_to_objects($self->sql_Retrieve($fragment), \@_); }; }