Re: Can we make might_have() relationships easier to use?

[prev] [thread] [next] [Date index for 2004/06/12]

Ed Sabol wrote:
>> Well, to start with, how about implementing a 'might_have' column group so
>> that $class->columns('might_have') would return just the columns imported by
>> might_have() relationships?

Tony replied:
> This is a possibility.

Ed Sabol asked:
>> Would you like me to take a shot at a patch for that? If so, which method in
>> Class::DBI::Relationship::MightHave do you think would be the best place to
>> do that? remap_arguments? methods? Or perhaps generic support for adding
>> relationship-related column groups should be implemented in
>> Class::DBI::Relationship?

Tony answered:
> Probably generic. Just another thing that would be added to the list of
> methods to call at setup.

Below is an updated version of my might_have patch which adds support for a
"MightHave" column group.

Did you prefer "might_have" for the column group name? After some thought, it
seemed "MightHave" was a more natural fit with both the existing column group
names and the MightHave package name.

If there's some aspect of the implementation here that you don't like, please
let me know. If you've already applied the previous patch, I can supply diffs
from that point if you prefer.

Here's a description of the changes since my previous might_have patch:

    Class::DBI::Relationship: Added two new methods: _add_column_groups()
    and column_groups.

    Class::DBI::Relationship::MightHave: Added column_groups() method.

    Class::DBI::ColumnGroup: Added two new methods: groups() and
    add_columns_to_group(). AFAICT, there was no introspective method to
    discover what column groups were defined. That seemed pretty useful to
    me, so I gratuitously added a simple groups() method which just returns
    the list of defined column groups. Then I added the
    add_columns_to_group() method which adds columns to a group which may or
    may not already exist. This was necessary to implement the MightHave
    column group. Since each subsequent might_have() call may import columns
    into the object, I needed the capability to add columns to a group
    incrementally.

    Class::DBI: Unrelated to anything might_have-related, I fixed a typo in
    the pod ("relies" not "replies").

diff -rNBub Class-DBI-0.96.orig/lib/Class/DBI/ColumnGrouper.pm Class-DBI-0.96/lib/Class/DBI/ColumnGrouper.pm
--- Class-DBI-0.96.orig/lib/Class/DBI/ColumnGrouper.pm	Sun Apr 25 11:33:36 2004
+++ Class-DBI-0.96/lib/Class/DBI/ColumnGrouper.pm	Sat Jun 12 04:08:16 2004
@@ -93,7 +93,7 @@
 
 	$colg->add_group(People => qw/star director producer/);
 
-This adds a list of columns as a column group.
+This defines a list of columns as a column group.
 
 =cut
 
@@ -113,10 +113,43 @@
 	return $self;
 }
 
+=head2 add_columns_to_group
+
+	$colg->add_columns_to_group(People => qw/cinematographer composer/);
+
+This adds a list of columns to a column group that may already exist.
+
+=cut
+
+sub add_columns_to_group {
+	my ($self, $group, @names) = @_;
+	my %colg = map { $_->name => 1 } $self->group_cols($group);
+	my @newnames = _unique(grep !exists($colg{$_}), @names);
+	my @cols = map $self->add_column($_), @newnames;
+	return unless @cols;
+	$_->add_group($group) foreach @cols;
+	$self->{_groups}->{$group} = []
+	  unless defined $self->{_groups}->{$group};
+	push @{ $self->{_groups}->{$group} }, @cols;
+}
+
+=head2 groups
+
+	my @group_names = $colg->groups();
+
+This returns a list of all defined column groups.
+
+=cut
+
+sub groups {
+	my $self = shift;
+	keys %{ $self->{_groups} };
+}
+
 =head2 group_cols / groups_for
 
-	my @colg = $cols->group_cols($group);
-	my @groups = $cols->groups_for(@cols);
+	my @colg = $colg->group_cols($group);
+	my @groups = $colg->groups_for(@cols);
 
 This returns a list of all columns which are in the given group, or the
 groups a given column is in.
diff -rNBub Class-DBI-0.96.orig/lib/Class/DBI/Relationship/MightHave.pm Class-DBI-0.96/lib/Class/DBI/Relationship/MightHave.pm
--- Class-DBI-0.96.orig/lib/Class/DBI/Relationship/MightHave.pm	Sun Apr 25 11:33:36 2004
+++ Class-DBI-0.96/lib/Class/DBI/Relationship/MightHave.pm	Sat Jun 12 03:04:40 2004
@@ -32,9 +32,30 @@
 	my ($class, $method) = ($self->class, $self->accessor);
 	return (
 		$method => $self->_object_accessor,
+		"add_$method" => $self->_method_add,
 		map { $_ => $self->_imported_accessor($_) } @{ $self->args->{import} });
 }
 
+sub _method_add {
+	my $self     = shift;
+	my $accessor = $self->accessor;
+	return sub {
+		my ($self, $data) = @_;
+		my $class = ref $self
+			or return $self->_croak("add_$accessor called as class method");
+		return $self->_croak("add_$accessor needs data")
+			unless ref $data eq "HASH";
+
+		return $self->_croak("add_$accessor called on an object that already has a $accessor")
+			if defined $self->$accessor();
+
+		my $meta = $class->meta_info(might_have => $accessor);
+		my $f_class = $meta->foreign_class;
+		$data->{$f_class->primary_column} = $self->id;
+		$f_class->create($data);
+	};
+}
+
 sub _object_accessor {
 	my $self = shift;
 	my ($class, $method) = ($self->class, $self->accessor);
@@ -64,4 +85,9 @@
 	};
 }
 
+sub column_groups {
+	my $self = shift;
+	return (MightHave => $self->args->{import});
+}
+
 1;
diff -rNBub Class-DBI-0.96.orig/lib/Class/DBI/Relationship.pm Class-DBI-0.96/lib/Class/DBI/Relationship.pm
--- Class-DBI-0.96.orig/lib/Class/DBI/Relationship.pm	Sun Apr 25 11:33:36 2004
+++ Class-DBI-0.96/lib/Class/DBI/Relationship.pm	Sat Jun 12 04:08:58 2004
@@ -13,6 +13,7 @@
 	$self->_set_up_class_data;
 	$self->_add_triggers;
 	$self->_add_methods;
+	$self->_add_column_groups;
 	$self;
 }
 
@@ -63,6 +64,17 @@
 	}
 }
 
+sub column_groups { () }
+
+sub _add_column_groups {
+	my $self   = shift;
+	my %groups = $self->column_groups or return;
+	my $class  = $self->class;
+	while (my($group,$columns) = each(%groups)) {
+	    $class->__grouper->add_columns_to_group($group => @$columns);
+	}
+}
+
 1;
 
 __END__
@@ -161,4 +173,18 @@
 Class::DBI class.  This method can be omitted if there are no methods
 to be set up.
 
+=head2 column_groups
+
+	sub column_groups { 
+		return (
+			group1 => [ ... ],
+			group2 => [ ... ],
+		);
+	}
+
+Subclasses may define a 'column_groups' method that returns a list of
+column groups and the columns to add to those groups in the calling
+Class::DBI class.  This method can be omitted if there are no column
+groups to be set up.
+
 =cut
diff -rNBub Class-DBI-0.96.orig/lib/Class/DBI.pm Class-DBI-0.96/lib/Class/DBI.pm
--- Class-DBI-0.96.orig/lib/Class/DBI.pm	Fri Apr 30 03:22:12 2004
+++ Class-DBI-0.96/lib/Class/DBI.pm	Sat Jun 12 04:13:29 2004
@@ -2410,6 +2410,10 @@
 	my $liner_notes_object = $cd->liner_notes;
 	my $notes = $cd->notes; # equivalent to $cd->liner_notes->notes;
 
+	$liner_notes_object = $cd->add_liner_notes({
+		notes => 'These are the liner notes.',
+	}); # equivalent to $cd->notes('These are the liner notes.');
+
 might_have() is similar to has_many() for relationships that can have
 at most one associated objects. For example, if you have a CD database
 to which you want to add liner notes information, you might not want
@@ -2427,9 +2431,24 @@
 you can just call $cd->notes and it will call the notes method on the
 correct LinerNotes object transparently for you.
 
-Making sure you don't have namespace clashes is up to you, as is correctly
-creating the objects, but I may make these simpler in later versions.
-(Particularly if someone asks for them!)
+If a LinerNotes object doesn't already exist, then one will be created upon
+calling $cd->notes with an appropriate value, taking care of the primary
+key linking automatically. In addition might_have() creates another method
+(analogous to has_many()'s add_to_* method) which allows a new associated
+object to be constructed by specifying all of the object's values in one
+call. This method is primarily useful if the underlying table has column
+constraints that would otherwise prevent object creation. The name of this
+method is the same as the accessor method with "add_" prepended.
+
+The add_liner_notes example above is exactly equivalent to:
+
+	my $liner_notes_object = LinerNotes->create({
+		cd    => $cd,
+		notes => 'These are the liner notes.',
+	});
+
+Making sure you don't have namespace clashes is up to you, but I may this
+in later versions. (Particularly if someone asks for it!)
 
 =head2 Notes
 
@@ -2849,7 +2868,7 @@
 go out of scope, they will be destroyed normally, and a future retrieve
 will instantiate an entirely new object.
 
-The ability to perform this magic for you replies on your perl having
+The ability to perform this magic for you relies on your perl having
 access to the Scalar::Util::weaken function. Although this is part of
 the core perl distribution, some vendors do not compile support for it.
 To find out if your perl has support for it, you can run this on the
diff -rNBub Class-DBI-0.96.orig/t/01-columns.t Class-DBI-0.96/t/01-columns.t
--- Class-DBI-0.96.orig/t/01-columns.t	Sun Apr 25 11:33:36 2004
+++ Class-DBI-0.96/t/01-columns.t	Sat Jun 12 04:09:45 2004
@@ -1,5 +1,5 @@
 use strict;
-use Test::More tests => 35;
+use Test::More tests => 42;
 
 #-----------------------------------------------------------------------
 # Make sure that we can set up columns properly
@@ -92,6 +92,8 @@
 ok(State->can('_set_Snowfall_accessor'), ' with alias');
 
 {
+	is_deeply [ sort State->__grouper->groups() ], [ qw/Essential Other Primary Weather/ ], "column groups = (Essential,Other,Primary,Weather)";
+
 	eval { my @grps = State->__grouper->groups_for("Huh"); };
 	ok $@, "Huh not in groups";
 
@@ -102,6 +104,23 @@
 }
 
 {
+	my($snowcol) = State->_find_columns(qw/snowfall/);
+	my @snowgroups = State->__grouper->groups_for($snowcol);
+	is @snowgroups, 1, "Snowfall in 1 group";
+	is $snowgroups[0], 'Weather', " - Weather";
+	my @colg = State->__grouper->group_cols('Other');
+	my %colh = map { $_->name => $_ } @colg;
+	State->__grouper->add_columns_to_group(Other => qw/Snowfall/);
+	@snowgroups = sort State->__grouper->groups_for($snowcol);
+	is @snowgroups, 2, "Snowfall now in 2 groups";
+	is $snowgroups[0], 'Other',   " - Other";
+	is $snowgroups[1], 'Weather', " - Weather";
+	State->__grouper->add_columns_to_group(Other => qw/Snowfall/);
+	State->__grouper->add_columns_to_group(Other => qw/Snowfall Snowfall/);
+	is @snowgroups, 2, "Snowfall still in 2 groups";
+}
+
+{
 	local $SIG{__WARN__} = sub { };
 	eval { Class::DBI->retrieve(1) };
 	like $@, qr/Can't retrieve unless primary columns are defined/, "Need primary key for retrieve";
diff -rNBub Class-DBI-0.96.orig/t/14-might_have.t Class-DBI-0.96/t/14-might_have.t
--- Class-DBI-0.96.orig/t/14-might_have.t	Sat Nov  1 11:53:55 2003
+++ Class-DBI-0.96/t/14-might_have.t	Sat Jun 12 02:21:40 2004
@@ -3,15 +3,17 @@
 
 BEGIN {
 	eval "use DBD::SQLite";
-	plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 18);
+	plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 44);
 }
 
 INIT {
 	use lib 't/testlib';
 	use Film;
 	use Blurb;
+	use Soundtrack;
 	Film->CONSTRUCT;
 	Blurb->CONSTRUCT;
+	Soundtrack->CONSTRUCT;
 }
 
 is(Blurb->primary_column, "title", "Primary key of Blurb = title");
@@ -21,6 +23,9 @@
 is $@, "", "No problem retrieving non-existent Blurb";
 
 Film->might_have(info => Blurb => qw/blurb/);
+is_deeply [ Film->columns('MightHave') ], [ qw/blurb/ ], "MightHave column group = (blurb)";
+Film->might_have(soundtrack => Soundtrack => qw/composer conductor orchestra/);
+is_deeply [ sort Film->columns('MightHave') ], [ qw/blurb composer conductor orchestra/ ], "MightHave column group = (blurb,composer,conductor,orchestra)";
 
 {
 	ok my $bt = Film->retrieve('Bad Taste'), "Get Film";
@@ -59,7 +64,67 @@
 		isa_ok $blurb => "Blurb";
 		$bt->delete;
 		$blurb = Blurb->retrieve('Bad Taste');
-		is $blurb, undef, "Blurb has gone";
+		is $blurb, undef, "Blurb is gone";
+	}
+		
+}
+
+Film->make_bad_taste;
+
+{
+	my $bt = Film->retrieve('Bad Taste');
+	is $bt->soundtrack, undef, "Bad taste has no soundtrack yet";
+	eval { $bt->composer('John Williams') };
+	isnt $@, '', "Test failure to insert nulls";
+	$bt->delete;
+}
+
+Film->make_bad_taste;
+
+{
+	my $bt = Film->retrieve('Bad Taste');
+	is $bt->soundtrack, undef, "Bad taste has no soundtrack yet";
+	eval { $bt->add_soundtrack() };
+	like $@, qr/^add_.* needs data/, "Test failure when no arg provided";
+	eval { $bt->add_soundtrack('blah') };
+	like $@, qr/^add_.* needs data/, "Test failure when no hash provided";
+	my $st = eval { $bt->add_soundtrack({ 'composer' => 'John Williams', 'conductor' => 'John Williams', 'orchestra' => 'London Symphony Orchestra' }) };
+	is $@, '', "No problems calling add_* method";
+	eval { $bt->update };
+	is $@, '', "No problems updating after using add_* method";
+	isa_ok $st, "Soundtrack";
+	is $bt->orchestra, $st->orchestra, "Orchestra is the same as fetching the long way";
+
+	is $bt->composer, "John Williams", "Added soundtrack composer";
+	is $bt->conductor, "John Williams", "Added soundtrack conductor";
+	is $bt->orchestra, "London Symphony Orchestra", "Added soundtrack orchestra";
+	eval { $bt->add_soundtrack({ 'composer' => 'Howard Shore', 'conductor' => 'Howard Shore', 'orchestra' => 'New Zealand Symphony Orchestra' }) };
+	like $@, qr/^add_.* called on an object that already has a soundtrack/, "Test failure on multiple add_* calls";
+}
+
+{
+	my $bt = Film->retrieve('Bad Taste');
+	my $soundtrack = $bt->soundtrack;
+	isa_ok $soundtrack, 'Soundtrack';
+
+	is $bt->composer, 'John Williams', "Retrieved composer OK";
+	ok $bt->composer("Howard Shore"), "We can set the composer";
+	ok $bt->conductor("Howard Shore"), "We can set the conductor";
+	ok $bt->orchestra("New Zealand Symphony"), "We can set the orchestra";
+	eval { $bt->update };
+	is $@, '', "No problems updating when do have";
+
+	is $bt->composer, 'Howard Shore', "Updated composer OK";
+	is $bt->conductor, 'Howard Shore', "Updated conductor OK";
+	is $bt->orchestra, 'New Zealand Symphony', "Updated orchestra OK";
+
+	# cascade delete?
+	{
+		my $soundtrack = Soundtrack->retrieve('Bad Taste');
+		isa_ok $soundtrack => "Soundtrack";
+		$bt->delete;
+		$soundtrack = Soundtrack->retrieve('Bad Taste');
+		is $soundtrack, undef, "Soundtrack is gone";
 	}
 		
 }
diff -rNBub Class-DBI-0.96.orig/t/testlib/Blurb.pm Class-DBI-0.96/t/testlib/Blurb.pm
--- Class-DBI-0.96.orig/t/testlib/Blurb.pm	Sun Apr 25 11:33:36 2004
+++ Class-DBI-0.96/t/testlib/Blurb.pm	Sun Jun  6 18:13:35 2004
@@ -21,7 +21,7 @@
 	$class->db_Main->do(
 		qq{
      CREATE TABLE Blurbs (
-        title                   VARCHAR(255) PRIMARY KEY,
+        title                   VARCHAR(255) NOT NULL PRIMARY KEY,
         blurb                   VARCHAR(255) NOT NULL
     )
   }
diff -rNBub Class-DBI-0.96.orig/t/testlib/Soundtrack.pm Class-DBI-0.96/t/testlib/Soundtrack.pm
--- Class-DBI-0.96.orig/t/testlib/Soundtrack.pm	Wed Dec 31 19:00:00 1969
+++ Class-DBI-0.96/t/testlib/Soundtrack.pm	Sun Jun  6 18:13:38 2004
@@ -0,0 +1,31 @@
+package Soundtrack;
+
+BEGIN { unshift @INC, './t/testlib'; }
+
+use strict;
+use base 'CDBase';
+
+__PACKAGE__->table('Soundtrack');
+__PACKAGE__->columns('Primary', 'Title');
+__PACKAGE__->columns('Soundtrack', qw/composer conductor orchestra/);
+
+sub CONSTRUCT {
+	my $class = shift;
+	$class->create_soundtrack_table;
+}
+
+sub create_soundtrack_table {
+	my $class = shift;
+	$class->db_Main->do(
+		qq{
+     CREATE TABLE Soundtrack (
+        title                   VARCHAR(255) NOT NULL PRIMARY KEY,
+        composer                VARCHAR(255) NOT NULL,
+        conductor               VARCHAR(255) NOT NULL,
+        orchestra               VARCHAR(255) NOT NULL
+    )
+  }
+	);
+}
+
+1;