Initial
authorzby <zby@bd8105ee-0ff8-0310-8827-fb3f25b6796d>
Mon, 22 Sep 2008 17:10:13 +0000 (17:10 +0000)
committerzby <zby@bd8105ee-0ff8-0310-8827-fb3f25b6796d>
Mon, 22 Sep 2008 17:10:13 +0000 (17:10 +0000)
23 files changed:
Changes [new file with mode: 0644]
MANIFEST [new file with mode: 0644]
META.yml [new file with mode: 0644]
Makefile.PL [new file with mode: 0644]
README [new file with mode: 0644]
lib/DBIx/Class/ResultSet/RecursiveUpdate.pm [new file with mode: 0644]
t/00.load.t [new file with mode: 0644]
t/lib/DBSchema.pm [new file with mode: 0644]
t/lib/DBSchema/Result/Dvd.pm [new file with mode: 0644]
t/lib/DBSchema/Result/Dvdtag.pm [new file with mode: 0644]
t/lib/DBSchema/Result/LinerNotes.pm [new file with mode: 0644]
t/lib/DBSchema/Result/Role.pm [new file with mode: 0644]
t/lib/DBSchema/Result/Tag.pm [new file with mode: 0644]
t/lib/DBSchema/Result/User.pm [new file with mode: 0644]
t/lib/DBSchema/Result/UserRole.pm [new file with mode: 0644]
t/lib/MySchema.pm [new file with mode: 0644]
t/lib/MySchema/Test.pm [new file with mode: 0644]
t/lib/RunTests.pm [new file with mode: 0644]
t/pg.t [new file with mode: 0644]
t/pod-coverage.t [new file with mode: 0644]
t/pod.t [new file with mode: 0644]
t/sqlite.t [new file with mode: 0644]
t/var/dvdzbr.db [new file with mode: 0644]

diff --git a/Changes b/Changes
new file mode 100644 (file)
index 0000000..f845cd9
--- /dev/null
+++ b/Changes
@@ -0,0 +1,5 @@
+Revision history for DBIx-Class-RecursivePUT
+
+0.0.1  Wed Jun 18 13:09:28 2008
+       Initial release.
+
diff --git a/MANIFEST b/MANIFEST
new file mode 100644 (file)
index 0000000..d205cfc
--- /dev/null
+++ b/MANIFEST
@@ -0,0 +1,23 @@
+Changes
+MANIFEST
+Makefile.PL
+README
+lib/DBIx/Class/ResultSet/RecursiveUpdate.pm
+t/00.load.t
+t/pod-coverage.t
+t/pod.t
+t/lib/MySchema/Test.pm
+t/lib/DBSchema.pm
+t/lib/RunTests.pm
+t/lib/DBSchema/Result/User.pm
+t/lib/DBSchema/Result/Dvd.pm
+t/lib/DBSchema/Result/Tag.pm
+t/lib/DBSchema/Result/LinerNotes.pm
+t/lib/DBSchema/Result/Dvdtag.pm
+t/lib/DBSchema/Result/UserRole.pm
+t/lib/DBSchema/Result/Role.pm
+t/lib/MySchema.pm
+t/var/dvdzbr.db
+t/pg.t
+t/sqlite.t
+META.yml                                 Module meta-data (added by MakeMaker)
diff --git a/META.yml b/META.yml
new file mode 100644 (file)
index 0000000..cd56128
--- /dev/null
+++ b/META.yml
@@ -0,0 +1,16 @@
+--- #YAML:1.0
+name:                DBIx-Class-ResultSet-RecursiveUpdate
+version:             0.0.1
+abstract:            like update_or_create - but recursive 
+license:             ~
+author:              
+    - Zbigniew Lukasiak <zby@cpan.org>
+generated_by:        ExtUtils::MakeMaker version 6.40
+distribution_type:   module
+requires:     
+    DBIx::Class:                   0
+    Test::More:                    0
+    version:                       0
+meta-spec:
+    url:     http://module-build.sourceforge.net/META-spec-v1.3.html
+    version: 1.3
diff --git a/Makefile.PL b/Makefile.PL
new file mode 100644 (file)
index 0000000..ca2968a
--- /dev/null
@@ -0,0 +1,18 @@
+use strict;
+use warnings;
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+    NAME                => 'DBIx::Class::ResultSet::RecursiveUpdate',
+    AUTHOR              => 'Zbigniew Lukasiak <zby@cpan.org>',
+    VERSION_FROM        => 'lib/DBIx/Class/ResultSet/RecursiveUpdate.pm',
+    ABSTRACT_FROM       => 'lib/DBIx/Class/ResultSet/RecursiveUpdate.pm',
+    PL_FILES            => {},
+    PREREQ_PM => {
+        'Test::More' => 0,
+        'version'    => 0,
+        'DBIx::Class' => 0,
+    },
+    dist                => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', },
+    clean               => { FILES => 'DBIx-Class-ResultSet-RecursiveUpdate-*' },
+);
diff --git a/README b/README
new file mode 100644 (file)
index 0000000..7802081
--- /dev/null
+++ b/README
@@ -0,0 +1,38 @@
+DBIx-Class-RecursiveUpdate version 0.0.1
+
+[ REPLACE THIS...
+
+  The README is used to introduce the module and provide instructions on
+  how to install the module, any machine dependencies it may have (for
+  example C compilers and installed libraries) and any other information
+  that should be understood before the module is installed.
+
+  A README file is required for CPAN modules since CPAN extracts the
+  README file from a module distribution so that people browsing the
+  archive can use it get an idea of the modules uses. It is usually a
+  good idea to provide version information here so that people can
+  decide whether fixes for the module are worth downloading.
+]
+
+
+INSTALLATION
+
+To install this module, run the following commands:
+
+       perl Makefile.PL
+       make
+       make test
+       make install
+
+
+DEPENDENCIES
+
+None.
+
+
+COPYRIGHT AND LICENCE
+
+Copyright (C) 2008, Zbigniew Lukasiak
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
diff --git a/lib/DBIx/Class/ResultSet/RecursiveUpdate.pm b/lib/DBIx/Class/ResultSet/RecursiveUpdate.pm
new file mode 100644 (file)
index 0000000..5934bc4
--- /dev/null
@@ -0,0 +1,284 @@
+package DBIx::Class::ResultSet::RecursiveUpdate;
+
+use version; $VERSION = qv('0.0.1');
+
+use warnings;
+use strict;
+use Carp;
+
+use base qw(DBIx::Class::ResultSet);
+
+sub recursive_update { 
+    my( $self, $updates ) = @_;
+    my $object;
+    # this is a workaround for a bug in the svn version 4794 
+    if ( ref $self->{cond} eq 'ARRAY' and ref $self->{cond}[0] eq 'SCALAR' ){
+        $self->{cond} = {};
+        $object = $self->new( {} );
+    }
+    else {
+        $object = $self->find( $updates, { key => 'primary' } ) || $self->new( {} );
+    }
+
+    for my $name ( keys %$updates ){ if($object->can($name)){
+            my $value = $updates->{$name};
+            # updating relations that that should be done before the row is inserted into the database
+            # like belongs_to
+            if( $object->result_source->has_relationship($name) 
+                    and 
+                ref $value
+            ){
+                my $info = $object->result_source->relationship_info( $name );
+                if( $info and not $info->{attrs}{accessor} eq 'multi'
+                        and 
+                    _master_relation_cond( $object, $info->{cond}, _get_pk_for_related( $object, $name ) )
+                ){
+                    my $related_result = $object->related_resultset( $name );
+                    $DB::single = 1;
+                    my $sub_object = $related_result->recursive_update( $value );
+                    $object->set_from_related( $name, $sub_object );
+                }
+            }
+            # columns and other accessors
+            elsif( $object->result_source->has_column($name) 
+                    or 
+                !$object->can( 'set_' . $name ) 
+            ) {
+                $object->$name($value);
+            }
+        }
+        #warn Dumper($object->{_column_data}); use Data::Dumper;
+    }
+    _delete_empty_auto_increment($object);
+    $object->update_or_insert;
+
+    # updating relations that can be done only after the row is inserted into the database
+    # like has_many and many_to_many
+    for my $name ( keys %$updates ){
+        my $value = $updates->{$name};
+        # many to many case
+        if($object->can($name) and 
+            !$object->result_source->has_relationship($name) and 
+            $object->can( 'set_' . $name )
+        ) {
+                my ( $pk ) = _get_pk_for_related( $object, $name );
+                my @values = @{$updates->{$name}};
+                my @rows;
+                my $result_source = $object->$name->result_source;
+                @rows = $result_source->resultset->search({ $pk => [ @values ] } ) if @values; 
+                my $set_meth = 'set_' . $name;
+                $object->$set_meth( \@rows );
+        }
+        elsif( $object->result_source->has_relationship($name) ){
+            my $info = $object->result_source->relationship_info( $name );
+            # has many case
+            if( ref $updates->{$name} eq 'ARRAY' ){
+                for my $sub_updates ( @{$updates->{$name}} ) {
+                    my $sub_object = $object->search_related( $name )->recursive_update( $sub_updates );
+                }
+            }
+            # might_have and has_one case
+            elsif ( ! _master_relation_cond( $object, $info->{cond}, _get_pk_for_related( $object, $name ) ) ){
+                my $sub_object = $object->search_related( $name )->recursive_update( $value );
+                #$object->set_from_related( $name, $sub_object );
+            }
+        }
+    }
+    return $object;
+}
+
+sub _delete_empty_auto_increment {
+    my ( $object ) = @_;
+    for my $col ( keys %{$object->{_column_data}}){
+        if( $object->result_source->column_info( $col )->{is_auto_increment} 
+                and 
+            ( ! defined $object->{_column_data}{$col} or $object->{_column_data}{$col} eq '' )
+        ){
+            delete $object->{_column_data}{$col}
+        }
+    }
+}
+
+sub _get_pk_for_related {
+    my ( $object, $relation ) = @_;
+
+    my $rs = $object->result_source->resultset;
+    my $result_source = _get_related_source( $rs, $relation );
+    return $result_source->primary_columns;
+}
+
+sub _get_related_source {
+    my ( $rs, $name ) = @_;
+    if( $rs->result_source->has_relationship( $name ) ){
+        return $rs->result_source->related_source( $name );
+    }
+    # many to many case
+    my $row = $rs->new({});
+    if ( $row->can( $name ) and $row->can( 'add_to_' . $name ) and $row->can( 'set_' . $name ) ){
+        my $r = $row->$name;
+        return $r->result_source;
+    }
+    return;
+}
+
+sub _master_relation_cond {
+    my ( $object, $cond, @foreign_ids ) = @_;
+    my $foreign_ids_re = join '|', @foreign_ids;
+    if ( ref $cond eq 'HASH' ){
+        for my $f_key ( keys %{$cond} ) {
+            # might_have is not master
+            my $col = $cond->{$f_key};
+            $col =~ s/self\.//;
+            if( $object->column_info( $col )->{is_auto_increment} ){
+                return 0;
+            }
+            if( $f_key =~ /^foreign\.$foreign_ids_re/ ){
+                return 1;
+            }
+        }
+    }elsif ( ref $cond eq 'ARRAY' ){
+        for my $new_cond ( @$cond ) {
+            return 1 if _master_relation_cond( $object, $new_cond, @foreign_ids );
+        }
+    }
+    return;
+}
+
+# Module implementation here
+
+
+1; # Magic true value required at end of module
+__END__
+
+=head1 NAME
+
+DBIx::Class::ResultSet::RecursiveUpdate - like update_or_create - but recursive 
+
+
+=head1 VERSION
+
+This document describes DBIx::Class::ResultSet::RecursiveUpdate version 0.0.1
+
+
+=head1 SYNOPSIS
+
+   __PACKAGE__->load_namespaces( default_resultset_class => '+DBIx::Class::ResultSet::RecursiveUpdate' );
+
+in the Schema file (see t/lib/DBSchema.pm).  Or appriopriate 'use base' in the ResultSet classes. 
+
+Then:
+
+=for author to fill in:
+
+    my $user = $user_rs->recursive_update( { 
+        id => 1, 
+        owned_dvds => [ 
+        { 
+          id => undef, 
+          title => 'One Flew Over the Cuckoo's Nest' 
+        } 
+        ] 
+      }
+    );
+
+  
+=head1 DESCRIPTION
+
+=for author to fill in:
+    You can feed the ->create method with a recursive datastructure and have the related records
+    created.  Unfortunately you cannot do a similar thing with update_or_create - this module
+    tries to fill that void. 
+    It is a base class for ResultSets providing just one method: recursive_update
+    which works just like update_or_create but can recursively update or create
+    data objects composed of multiple rows. All rows need to be identified by primary keys
+    - so you need to provide them in the update structure (unless they can be deduced from 
+    the parent row - for example when you have a belongs_to relationship).  
+    When creating new rows in a table with auto_increment primary keys you need to 
+    put 'undef' for the key value - this is then removed
+    and a correct INSERT statement is generated.  
+
+    For a description how to set up base classes for ResultSets see load_namespaces
+    in DBIx::Class::Schema.
+
+=head1 INTERFACE 
+
+=for author to fill in:
+
+=head1 METHODS
+
+=head2 recursive_update
+
+The only method here.
+
+=head1 DIAGNOSTICS
+
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+=for author to fill in:
+DBIx::Class::RecursiveUpdate requires no configuration files or environment variables.
+
+
+=head1 DEPENDENCIES
+
+=for author to fill in:
+
+    DBIx::Class
+
+None.
+
+
+=head1 INCOMPATIBILITIES
+
+=for author to fill in:
+
+None reported.
+
+
+=head1 BUGS AND LIMITATIONS
+
+=for author to fill in:
+
+No bugs have been reported.
+
+Please report any bugs or feature requests to
+C<bug-dbix-class-recursiveput@rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org>.
+
+
+=head1 AUTHOR
+
+Zbigniew Lukasiak  C<< <zby@cpan.org> >>
+Influenced by code by Pedro Melo.
+
+=head1 LICENCE AND COPYRIGHT
+
+Copyright (c) 2008, Zbigniew Lukasiak C<< <zby@cpan.org> >>. All rights reserved.
+
+This module is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself. See L<perlartistic>.
+
+
+=head1 DISCLAIMER OF WARRANTY
+
+BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
+FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
+PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
+EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
+ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
+YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
+NECESSARY SERVICING, REPAIR, OR CORRECTION.
+
+IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
+REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE
+LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,
+OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
+THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
+RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
+FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
+SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGES.
diff --git a/t/00.load.t b/t/00.load.t
new file mode 100644 (file)
index 0000000..b63e069
--- /dev/null
@@ -0,0 +1,7 @@
+use Test::More tests => 1;
+
+BEGIN {
+use_ok( 'DBIx::Class::ResultSet::RecursiveUpdate' );
+}
+
+diag( "Testing DBIx::Class::ResultSet::RecursiveUpdate $DBIx::Class::ResultSet::RecursiveUpdate::VERSION" );
diff --git a/t/lib/DBSchema.pm b/t/lib/DBSchema.pm
new file mode 100644 (file)
index 0000000..e729155
--- /dev/null
@@ -0,0 +1,54 @@
+package DBSchema;
+
+# Created by DBIx::Class::Schema::Loader v0.03000 @ 2006-10-02 08:24:09
+
+use strict;
+use warnings;
+
+use base 'DBIx::Class::Schema';
+use DateTime;
+
+__PACKAGE__->load_namespaces( default_resultset_class => '+DBIx::Class::ResultSet::RecursiveUpdate' );
+
+sub get_test_schema {
+    my ( $dsn, $user, $pass ) = @_;
+    $dsn ||= 'dbi:SQLite:dbname=t/var/dvdzbr.db';
+    warn "testing $dsn";
+    my $schema = __PACKAGE__->connect( $dsn, $user, $pass, {} );
+    $schema->deploy({ add_drop_table => 1, });
+    $schema->populate('User', [
+        [ qw/username name password / ],
+        [ 'jgda', 'Jonas Alves', ''],
+        [ 'isa' , 'Isa', '', ],
+        [ 'zby' , 'Zbyszek Lukasiak', ''],
+        ]
+    );
+    $schema->populate('Tag', [
+        [ qw/name file / ],
+        [ 'comedy', '' ],
+        [ 'dramat', '' ],
+        [ 'australian', '' ],
+        ]
+    );
+    $schema->populate('Dvd', [
+        [ qw/name imdb_id owner current_borrower creation_date alter_date / ],
+        [ 'Picnick under the Hanging Rock', 123, 1, 3, '2003-01-16 23:12:01', undef ],
+        [ 'The Deerhunter', 1234, 1, 1, undef, undef ],
+        [ 'Rejs', 1235, 3, 1, undef, undef ],
+        [ 'Seksmisja', 1236, 3, 1, undef, undef ],
+        ]
+    ); 
+    $schema->populate( 'Dvdtag', [
+        [ qw/ dvd tag / ],
+        [ 1, 2 ],
+        [ 1, 3 ],
+        [ 3, 1 ],
+        [ 4, 1 ],
+        ]
+    );
+    return $schema;
+}
+    
+    
+1;
+
diff --git a/t/lib/DBSchema/Result/Dvd.pm b/t/lib/DBSchema/Result/Dvd.pm
new file mode 100644 (file)
index 0000000..d87147c
--- /dev/null
@@ -0,0 +1,56 @@
+package DBSchema::Result::Dvd;
+
+# Created by DBIx::Class::Schema::Loader v0.03000 @ 2006-10-02 08:24:09
+
+use strict;
+use warnings;
+
+use base 'DBIx::Class';
+use overload '""' => sub {$_[0]->name}, fallback => 1;
+
+use lib '../../DBIx-Class-HTML-FormFu/lib/';
+__PACKAGE__->load_components('Core');
+__PACKAGE__->table('dvd');
+__PACKAGE__->add_columns(
+  'id' => {
+    data_type => 'integer',
+    is_auto_increment => 1
+  },
+  'name' => {
+    data_type => 'varchar',
+    size      => 100,
+    is_nullable => 1,
+  },
+  'imdb_id' => {
+    data_type => 'varchar',
+    size      => 100,
+    is_nullable => 1,
+  },
+  'owner' => { data_type => 'integer' },
+  'current_borrower' => { 
+    data_type => 'integer', 
+    is_nullable => 1,
+  },
+
+  'creation_date' => { 
+    data_type => 'datetime',
+    is_nullable => 1,
+  },
+  'alter_date' => { 
+    data_type => 'datetime',
+    is_nullable => 1,
+  },
+);
+__PACKAGE__->set_primary_key('id');
+__PACKAGE__->belongs_to('owner', 'User', { id => 'owner' });
+__PACKAGE__->belongs_to('current_borrower', 'User', { id => 'current_borrower' });
+__PACKAGE__->has_many('dvdtags', 'Dvdtag', { 'foreign.dvd' => 'self.id' });
+__PACKAGE__->many_to_many('tags', 'dvdtags' => 'tag');
+__PACKAGE__->might_have(
+    liner_notes => 'DBSchema::Result::LinerNotes', undef,
+    { proxy => [ qw/notes/ ] },
+);
+
+
+1;
+
diff --git a/t/lib/DBSchema/Result/Dvdtag.pm b/t/lib/DBSchema/Result/Dvdtag.pm
new file mode 100644 (file)
index 0000000..77521bc
--- /dev/null
@@ -0,0 +1,21 @@
+package DBSchema::Result::Dvdtag;
+
+# Created by DBIx::Class::Schema::Loader v0.03000 @ 2006-10-02 08:24:09
+
+use strict;
+use warnings;
+
+use base 'DBIx::Class';
+
+__PACKAGE__->load_components("PK::Auto", "Core");
+__PACKAGE__->table("dvdtag");
+__PACKAGE__->add_columns(
+    "dvd" => { data_type => 'integer' },
+    "tag" => { data_type => 'integer' },
+);
+__PACKAGE__->set_primary_key("dvd", "tag");
+__PACKAGE__->belongs_to("dvd", "Dvd", { id => "dvd" });
+__PACKAGE__->belongs_to("tag", "Tag", { id => "tag" });
+
+1;
+
diff --git a/t/lib/DBSchema/Result/LinerNotes.pm b/t/lib/DBSchema/Result/LinerNotes.pm
new file mode 100644 (file)
index 0000000..b7c8d6e
--- /dev/null
@@ -0,0 +1,21 @@
+package # hide from PAUSE 
+    DBSchema::Result::LinerNotes;
+
+use base qw/DBIx::Class::Core/;
+
+__PACKAGE__->table('liner_notes');
+__PACKAGE__->add_columns(
+  'liner_id' => {
+    data_type => 'integer',
+  },
+  'notes' => {
+    data_type => 'varchar',
+    size      => 100,
+  },
+);
+__PACKAGE__->set_primary_key('liner_id');
+__PACKAGE__->belongs_to(
+  'dvd', 'DBSchema::Result::Dvd', 'liner_id'
+);
+
+1;
diff --git a/t/lib/DBSchema/Result/Role.pm b/t/lib/DBSchema/Result/Role.pm
new file mode 100644 (file)
index 0000000..c393d25
--- /dev/null
@@ -0,0 +1,28 @@
+package DBSchema::Result::Role;
+
+# Created by DBIx::Class::Schema::Loader v0.03000 @ 2006-10-02 08:24:09
+
+use strict;
+use warnings;
+
+use base 'DBIx::Class';
+use overload '""' => sub {$_[0]->id}, fallback => 1;
+
+__PACKAGE__->load_components("PK::Auto", "Core");
+__PACKAGE__->table("role");
+__PACKAGE__->add_columns(
+    "id" => {
+        data_type => 'integer',
+        is_auto_increment => 1,
+    },
+    "role" => {
+        data_type => 'varchar',
+        size      => '100',
+      }
+  );
+__PACKAGE__->set_primary_key("id");
+__PACKAGE__->has_many("user_roles", "UserRole", { "foreign.role" => "self.id" });
+__PACKAGE__->many_to_many('users', 'user_roles' => 'user');
+
+1;
+
diff --git a/t/lib/DBSchema/Result/Tag.pm b/t/lib/DBSchema/Result/Tag.pm
new file mode 100644 (file)
index 0000000..5ec084c
--- /dev/null
@@ -0,0 +1,34 @@
+package DBSchema::Result::Tag;
+
+# Created by DBIx::Class::Schema::Loader v0.03000 @ 2006-10-02 08:24:09
+
+use strict;
+use warnings;
+
+use base 'DBIx::Class';
+use overload '""' => sub {$_[0]->name}, fallback => 1;
+
+__PACKAGE__->load_components("PK::Auto", "Core");
+__PACKAGE__->table("tag");
+__PACKAGE__->add_columns(
+    "id" => {
+    data_type => 'integer',
+    is_auto_increment => 1
+  },
+  'name' => {
+    data_type => 'varchar',
+    size      => 100,
+    is_nullable => 1,
+  },
+  'file' => {
+    data_type => 'text',
+    is_nullable => 1,
+  }
+);
+    
+__PACKAGE__->set_primary_key("id");
+__PACKAGE__->has_many("dvdtags", "Dvdtag", { "foreign.tag" => "self.id" });
+__PACKAGE__->many_to_many('dvds', 'dvdtags' => 'dvd');
+
+1;
+
diff --git a/t/lib/DBSchema/Result/User.pm b/t/lib/DBSchema/Result/User.pm
new file mode 100644 (file)
index 0000000..b8f53a5
--- /dev/null
@@ -0,0 +1,42 @@
+package DBSchema::Result::User;
+
+# Created by DBIx::Class::Schema::Loader v0.03000 @ 2006-10-02 08:24:09
+
+use strict;
+use warnings;
+
+use base 'DBIx::Class';
+#use overload '""' => sub {$_[0]->name}, fallback => 1;
+
+__PACKAGE__->load_components('Core');
+__PACKAGE__->table("usr");
+__PACKAGE__->add_columns(
+    "id" => {
+        data_type => 'integer',
+        is_auto_increment => 1,
+    },
+    "username" => {
+        data_type => 'varchar',
+        size      => '100',
+    },
+    "password" => {
+        data_type => 'varchar',
+        size      => '100',
+    },
+    "name" => {
+        data_type => 'varchar',
+        size      => '100',
+      },
+  );
+__PACKAGE__->set_primary_key("id");
+__PACKAGE__->has_many("user_roles", "UserRole", { "foreign.user" => "self.id" });
+__PACKAGE__->has_many("owned_dvds", "Dvd", { "foreign.owner" => "self.id" });
+__PACKAGE__->has_many(
+  "borrowed_dvds",
+  "Dvd",
+  { "foreign.current_borrower" => "self.id" },
+);
+__PACKAGE__->many_to_many('roles', 'user_roles' => 'role');
+
+1;
+
diff --git a/t/lib/DBSchema/Result/UserRole.pm b/t/lib/DBSchema/Result/UserRole.pm
new file mode 100644 (file)
index 0000000..ef858c7
--- /dev/null
@@ -0,0 +1,21 @@
+package DBSchema::Result::UserRole;
+
+# Created by DBIx::Class::Schema::Loader v0.03000 @ 2006-10-02 08:24:09
+
+use strict;
+use warnings;
+
+use base 'DBIx::Class';
+
+__PACKAGE__->load_components("PK::Auto", "Core");
+__PACKAGE__->table("user_role");
+__PACKAGE__->add_columns(
+    "user" => { data_type => 'integer' } , 
+    "role" => { data_type => 'integer' }
+);
+__PACKAGE__->set_primary_key("user", "role");
+__PACKAGE__->belongs_to("user", "User", { id => "user" });
+__PACKAGE__->belongs_to("role", "Role", { id => "role" });
+
+1;
+
diff --git a/t/lib/MySchema.pm b/t/lib/MySchema.pm
new file mode 100644 (file)
index 0000000..98a6792
--- /dev/null
@@ -0,0 +1,10 @@
+package MySchema;
+use strict;
+use warnings;
+
+use base 'DBIx::Class::Schema';
+
+__PACKAGE__->load_classes;
+
+1;
+
diff --git a/t/lib/MySchema/Test.pm b/t/lib/MySchema/Test.pm
new file mode 100644 (file)
index 0000000..6fb60ad
--- /dev/null
@@ -0,0 +1,32 @@
+package MySchema::Test;
+use strict;
+use warnings;
+
+use base 'DBIx::Class';
+
+__PACKAGE__->load_components(qw/ 
+    InflateColumn::DateTime PK::Auto Core 
+/);
+
+__PACKAGE__->table("test");
+
+__PACKAGE__->add_columns(
+    hidden_col     => { data_type => "INTEGER" },
+    text_col       => { data_type => "TEXT" },
+    password_col   => { data_type => "TEXT" },
+    checkbox_col   => {
+        data_type => "TEXT",
+        default_value => 0,
+        is_nullable   => 0,
+    },
+    select_col     => { data_type => "TEXT" },
+    radio_col      => { data_type => "TEXT" },
+    radiogroup_col => { data_type => "TEXT" },
+    date_col       => { data_type => "DATE" },
+    not_in_form    => { data_type => "TEXT" },
+);
+
+__PACKAGE__->set_primary_key("hidden_col");
+
+1;
+
diff --git a/t/lib/RunTests.pm b/t/lib/RunTests.pm
new file mode 100644 (file)
index 0000000..e38d1f1
--- /dev/null
@@ -0,0 +1,104 @@
+# -*- perl -*-
+package RunTests;
+use Exporter 'import'; # gives you Exporter's import() method directly
+@EXPORT = qw(run_tests);
+use strict;
+use Test::More; 
+
+
+sub run_tests{
+    my $schema = shift;
+    
+    my $dvd_rs = $schema->resultset( 'Dvd' );
+    my $owner = $schema->resultset( 'User' )->first;
+    my $initial_user_count = $schema->resultset( 'User' )->count;
+   
+    # creating new records
+    
+    my $updates = {
+            id => undef,
+            aaaa => undef,
+            tags => [ '2', '3' ], 
+            name => 'Test name',
+    #        'creation_date.year' => 2002,
+    #        'creation_date.month' => 1,
+    #        'creation_date.day' => 3,
+    #        'creation_date.hour' => 4,
+    #        'creation_date.minute' => 33,
+    #        'creation_date.pm' => 1,
+            owner => $owner->id,
+            current_borrower => {
+                name => 'temp name',
+                username => 'temp name',
+                password => 'temp name',
+            },
+            liner_notes => {
+                
+                notes => 'test note',
+            }
+    };
+    
+    my $dvd = $dvd_rs->recursive_update( $updates );
+   
+    is ( $schema->resultset( 'User' )->count, $initial_user_count + 1, "One new user created" );
+    is ( $dvd->name, 'Test name', 'Dvd name set' );
+    is_deeply ( [ map {$_->id} $dvd->tags ], [ '2', '3' ], 'Tags set' );
+    #my $value = $dvd->creation_date;
+    #is( "$value", '2002-01-03T16:33:00', 'Date set');
+    is ( $dvd->owner->id, $owner->id, 'Owner set' );
+    
+    is ( $dvd->current_borrower->name, 'temp name', 'Related record created' );
+    is ( $dvd->liner_notes->notes, 'test note', 'might_have record created' );
+    
+    # changing existing records
+    
+    $updates = {
+            id => $dvd->id,
+            aaaa => undef,
+            name => 'Test name',
+            tags => [ ], 
+            'owner' => $owner->id,
+            current_borrower => {
+                username => 'new name a',
+                name => 'new name a',
+                password => 'new password a',
+            }
+    };
+    $dvd = $dvd_rs->recursive_update( $updates );
+    
+    is ( $schema->resultset( 'User' )->count, $initial_user_count + 1, "No new user created" );
+    is ( $dvd->name, 'Test name', 'Dvd name set' );
+    is ( $dvd->owner->id, $owner->id, 'Owner set' );
+    is ( $dvd->current_borrower->name, 'new name a', 'Related record modified' );
+    is ( $dvd->tags->count, 0, 'Tags deleted' );
+
+    # repeatable
+    
+    $updates = {
+        id => undef,
+        name  => 'temp name',
+        username => 'temp username',
+        password => 'temp username',
+        owned_dvds =>[
+        {
+            'id' => undef,
+            'name' => 'temp name 1',
+            'tags' => [ 1, 2 ],
+        },
+        {
+            'id' => undef,
+            'name' => 'temp name 2',
+            'tags' => [ 2, 3 ],
+        }
+        ]
+    };
+    
+    my $user_rs = $schema->resultset( 'User' );
+    my $user = $user_rs->recursive_update( $updates );
+    my %owned_dvds = map { $_->name => $_ } $user->owned_dvds;
+    is( scalar keys %owned_dvds, 2, 'Has many relations created' );
+    ok( $owned_dvds{'temp name 1'}, 'Name in a has_many related record saved' );
+    my @tags = $owned_dvds{'temp name 1'}->tags;
+    is( scalar @tags, 2, 'Tags in has_many related record saved' );
+    ok( $owned_dvds{'temp name 2'}, 'Second name in a has_many related record saved' );
+}    
diff --git a/t/pg.t b/t/pg.t
new file mode 100644 (file)
index 0000000..8765d41
--- /dev/null
+++ b/t/pg.t
@@ -0,0 +1,18 @@
+# -*- perl -*-
+
+use lib 't/lib';
+use DBSchema;
+use RunTests;
+use Test::More;
+
+my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/};
+
+plan skip_all => 'Set $ENV{DBICTEST_PG_DSN}, _USER and _PASS to run this test'
+ . ' (note: creates and tables!)' unless ($dsn && $user);
+
+plan tests => 15;
+
+my $schema = DBSchema::get_test_schema( $dsn, $user, $pass );
+
+run_tests( $schema );
+
diff --git a/t/pod-coverage.t b/t/pod-coverage.t
new file mode 100644 (file)
index 0000000..703f91d
--- /dev/null
@@ -0,0 +1,6 @@
+#!perl -T
+
+use Test::More;
+eval "use Test::Pod::Coverage 1.04";
+plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@;
+all_pod_coverage_ok();
diff --git a/t/pod.t b/t/pod.t
new file mode 100644 (file)
index 0000000..976d7cd
--- /dev/null
+++ b/t/pod.t
@@ -0,0 +1,6 @@
+#!perl -T
+
+use Test::More;
+eval "use Test::Pod 1.14";
+plan skip_all => "Test::Pod 1.14 required for testing POD" if $@;
+all_pod_files_ok();
diff --git a/t/sqlite.t b/t/sqlite.t
new file mode 100644 (file)
index 0000000..835ecd1
--- /dev/null
@@ -0,0 +1,11 @@
+# -*- perl -*-
+
+use lib 't/lib';
+use DBSchema;
+use RunTests;
+use Test::More;
+plan tests => 15;
+
+my $schema = DBSchema::get_test_schema();
+run_tests( $schema );
+
diff --git a/t/var/dvdzbr.db b/t/var/dvdzbr.db
new file mode 100644 (file)
index 0000000..c464946
Binary files /dev/null and b/t/var/dvdzbr.db differ
This page took 0.051528 seconds and 4 git commands to generate.