[Rt-commit] r2986 - in DBIx-SearchBuilder/trunk: . SearchBuilder t
glasser at bestpractical.com
glasser at bestpractical.com
Mon May 30 18:42:29 EDT 2005
Author: glasser
Date: Mon May 30 18:42:28 2005
New Revision: 2986
Added:
DBIx-SearchBuilder/trunk/SearchBuilder/SchemaGenerator.pm
DBIx-SearchBuilder/trunk/t/10schema.t
DBIx-SearchBuilder/trunk/t/testmodels.pl
Modified:
DBIx-SearchBuilder/trunk/ (props changed)
Log:
r33493 at tin-foil: glasser | 2005-05-30 17:44:22 -0400
Basic sketch of SchemaGenerator. Doesn't do columns yet
Added: DBIx-SearchBuilder/trunk/SearchBuilder/SchemaGenerator.pm
==============================================================================
--- (empty file)
+++ DBIx-SearchBuilder/trunk/SearchBuilder/SchemaGenerator.pm Mon May 30 18:42:28 2005
@@ -0,0 +1,261 @@
+use strict;
+use warnings;
+
+package DBIx::SearchBuilder::SchemaGenerator;
+
+use base qw(Class::Accessor);
+use DBIx::DBSchema;
+use Class::ReturnValue;
+
+# Public accessors
+__PACKAGE__->mk_accessors(qw(handle));
+# Internal accessors: do not use from outside class
+__PACKAGE__->mk_accessors(qw(_db_schema));
+
+=head2 new HANDLE
+
+Creates a new C<DBIx::SearchBuilder::SchemaGenerator> object. The single
+required argument is a C<DBIx::SearchBuilder::Handle>.
+
+=cut
+
+sub new {
+ my $class = shift;
+ my $handle = shift;
+ my $self = $class->SUPER::new();
+
+ $self->handle($handle);
+
+ my $schema = DBIx::DBSchema->new;
+ $self->_db_schema($schema);
+
+ return $self;
+}
+
+=for public_doc AddModel MODEL
+
+Adds a new model class to the SchemaGenerator. Model should either be an object
+of a subclass of C<DBIx::SearchBuilder::Record>, or the name of such a subclass; in the
+latter case, C<AddModel> will instantiate an object of the subclass.
+
+Returns true if the model was added successfully; returns a false C<Class::ReturnValue> error
+otherwise.
+
+=cut
+
+sub AddModel {
+ my $self = shift;
+ my $model = shift;
+
+ # $model could either be a (presumably unfilled) object of a subclass of
+ # DBIx::SearchBuilder::Record, or it could be the name of such a subclass.
+
+ unless (UNIVERSAL::isa($model, 'DBIx::SearchBuilder::Record')) {
+ my $new_model;
+ eval { $new_model = $model->new; };
+
+ if ($@) {
+ return $self->_error("Error making new object from $model: $@");
+ }
+
+ return $self->_error("Didn't get a DBIx::SearchBuilder::Record from $model, got $new_model")
+ unless UNIVERSAL::isa($new_model, 'DBIx::SearchBuilder::Record');
+
+ $model = $new_model;
+ }
+
+ my $table_obj = $self->_DBSchemaTableFromModel($model);
+
+ $self->_db_schema->addtable($table_obj);
+
+ 1;
+}
+
+=for public_doc CreateTableSQL
+
+Returns a SQL string to create tables for all of the models added
+to the SchemaGenerator.
+
+=cut
+
+sub CreateTableSQL {
+ my $self = shift;
+ return join "\n\n", map { "$_ ;" } $self->_db_schema->sql($self->handle->dbh);
+}
+
+=for private_doc _DBSchemaTableFromModel MODEL
+
+Takes an object of a subclass of DBIx::SearchBuilder::Record; returns a new
+C<DBIx::DBSchema::Table> object corresponding to the model.
+
+=cut
+
+sub _DBSchemaTableFromModel {
+ my $self = shift;
+ my $model = shift;
+
+ my $table_name = $model->Table;
+ my $desc = $model->TableDescription;
+
+ my $table = DBIx::DBSchema::Table->new( {
+ name => $table_name,
+ });
+
+ return $table;
+}
+
+=for private_doc _error STRING
+
+Takes in a string and returns it as a Class::ReturnValue error object.
+
+=cut
+
+sub _error {
+ my $self = shift;
+ my $message = shift;
+
+ my $ret = Class::ReturnValue->new;
+ $ret->as_error(errno => 1, message => $message);
+ return $ret->return_value;
+}
+
+
+1; # Magic true value required at end of module
+__END__
+
+=head1 NAME
+
+DBIx::SearchBuilder::SchemaGenerator - Generate table schemas from DBIx::SearchBuilder records
+
+=head1 SYNOPSIS
+
+ use DBIx::SearchBuilder::SchemaGenerator;
+
+
+=head1 DESCRIPTION
+
+=for author to fill in:
+ Write a full description of the module and its features here.
+ Use subsections (=head2, =head3) as appropriate.
+
+
+=head1 INTERFACE
+
+=for author to fill in:
+ Write a separate section listing the public components of the modules
+ interface. These normally consist of either subroutines that may be
+ exported, or methods that may be called on objects belonging to the
+ classes provided by the module.
+
+
+=head1 DIAGNOSTICS
+
+=for author to fill in:
+ List every single error and warning message that the module can
+ generate (even the ones that will "never happen"), with a full
+ explanation of each problem, one or more likely causes, and any
+ suggested remedies.
+
+=over
+
+=item C<< Error message here, perhaps with %s placeholders >>
+
+[Description of error here]
+
+=item C<< Another error message here >>
+
+[Description of error here]
+
+[Et cetera, et cetera]
+
+=back
+
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+=for author to fill in:
+ A full explanation of any configuration system(s) used by the
+ module, including the names and locations of any configuration
+ files, and the meaning of any environment variables or properties
+ that can be set. These descriptions must also include details of any
+ configuration language used.
+
+<MODULE NAME> requires no configuration files or environment variables.
+
+
+=head1 DEPENDENCIES
+
+=for author to fill in:
+ A list of all the other modules that this module relies upon,
+ including any restrictions on versions, and an indication whether
+ the module is part of the standard Perl distribution, part of the
+ module's distribution, or must be installed separately. ]
+
+None.
+
+
+=head1 INCOMPATIBILITIES
+
+=for author to fill in:
+ A list of any modules that this module cannot be used in conjunction
+ with. This may be due to name conflicts in the interface, or
+ competition for system or program resources, or due to internal
+ limitations of Perl (for example, many modules that use source code
+ filters are mutually incompatible).
+
+None reported.
+
+
+=head1 BUGS AND LIMITATIONS
+
+=for author to fill in:
+ A list of known problems with the module, together with some
+ indication Whether they are likely to be fixed in an upcoming
+ release. Also a list of restrictions on the features the module
+ does provide: data types that cannot be handled, performance issues
+ and the circumstances in which they may arise, practical
+ limitations on the size of data sets, special cases that are not
+ (yet) handled, etc.
+
+No bugs have been reported.
+
+Please report any bugs or feature requests to
+C<bug-<RT NAME>@rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org>.
+
+
+=head1 AUTHOR
+
+David Glasser C<< glasser at bestpractical.com >>
+
+
+=head1 LICENCE AND COPYRIGHT
+
+Copyright (c) <YEAR>, <AUTHOR> C<< <<EMAIL>> >>. 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.
Added: DBIx-SearchBuilder/trunk/t/10schema.t
==============================================================================
--- (empty file)
+++ DBIx-SearchBuilder/trunk/t/10schema.t Mon May 30 18:42:28 2005
@@ -0,0 +1,75 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use Test::More;
+
+use constant TESTS_PER_DRIVER => 10;
+our @AvailableDrivers;
+
+BEGIN {
+ require("t/utils.pl");
+ my $total = 3 + scalar(@AvailableDrivers) * TESTS_PER_DRIVER;
+
+ plan tests => $total;
+}
+
+BEGIN {
+ use_ok("DBIx::SearchBuilder::SchemaGenerator");
+ use_ok("DBIx::SearchBuilder::Handle");
+}
+
+require_ok("t/testmodels.pl");
+
+foreach my $d ( @AvailableDrivers ) {
+ SKIP: {
+ unless ($d eq 'Pg') {
+ skip "first goal is to work on Pg, not $d", TESTS_PER_DRIVER;
+ }
+
+ unless( should_test( $d ) ) {
+ skip "ENV is not defined for driver $d", TESTS_PER_DRIVER;
+ }
+
+ my $handle = get_handle( $d );
+ connect_handle( $handle );
+ isa_ok($handle, "DBIx::SearchBuilder::Handle::$d");
+ isa_ok($handle->dbh, 'DBI::db');
+
+ my $SG = DBIx::SearchBuilder::SchemaGenerator->new($handle);
+
+ isa_ok($SG, 'DBIx::SearchBuilder::SchemaGenerator');
+
+ isa_ok($SG->_db_schema, 'DBIx::DBSchema');
+
+ is($SG->CreateTableSQL, '', "no tables means no sql");
+
+ my $ret = $SG->AddModel('Sample::This::Does::Not::Exist');
+
+ ok($ret == 0, "couldn't add model from nonexistent class");
+
+ like($ret->error_message, qr/Error making new object from Sample::This::Does::Not::Exist/,
+ "couldn't add model from nonexistent class");
+
+ is($SG->CreateTableSQL, '', "no tables means no sql");
+
+ $ret = $SG->AddModel('Sample::Address');
+
+ ok($ret != 0, "added model from real class");
+
+ is_spaceless($SG->CreateTableSQL, <<END_SCHEMA, "got the right schema");
+ CREATE TABLE Addresses ( ) ;
+END_SCHEMA
+}}
+
+sub is_spaceless {
+ my $a = shift;
+ my $b = shift;
+
+ $a =~ s/^\s+//; $a =~ s/\s+$//; $a =~ s/\s+/ /g;
+ $b =~ s/^\s+//; $b =~ s/\s+$//; $b =~ s/\s+/ /g;
+
+ unshift @_, $b; unshift @_, $a;
+
+ goto &is;
+}
\ No newline at end of file
Added: DBIx-SearchBuilder/trunk/t/testmodels.pl
==============================================================================
--- (empty file)
+++ DBIx-SearchBuilder/trunk/t/testmodels.pl Mon May 30 18:42:28 2005
@@ -0,0 +1,19 @@
+package Sample::Address;
+
+use base qw/DBIx::SearchBuilder::Record/;
+
+# Class and instance method
+
+sub Table { "Addresses" }
+
+# Class and instance method
+
+sub TableDescription {
+ return {
+ Name => { TYPE => 'varchar', },
+ Phone => { TYPE => 'varchar', },
+# EmployeeId => { REFERENCES => 'Sample::Employee', },
+ }
+}
+
+1;
\ No newline at end of file
More information about the Rt-commit
mailing list