File Coverage

blib/lib/DBIx/SearchBuilder/SchemaGenerator.pm
Criterion Covered Total %
statement 15 58 25.8
branch 0 10 0.0
condition 0 6 0.0
subroutine 5 11 45.4
pod 1 4 25.0
total 21 89 23.6


line stmt bran cond sub pod time code
1 1     1   144621 use strict;
  1         13  
  1         31  
2 1     1   5 use warnings;
  1         3  
  1         50  
3              
4             package DBIx::SearchBuilder::SchemaGenerator;
5              
6 1     1   6 use base qw(Class::Accessor);
  1         2  
  1         629  
7 1     1   1986 use DBIx::DBSchema;
  1         3  
  1         23  
8 1     1   445 use Class::ReturnValue;
  1         12834  
  1         689  
9              
10             # Public accessors
11             __PACKAGE__->mk_accessors(qw(handle));
12             # Internal accessors: do not use from outside class
13             __PACKAGE__->mk_accessors(qw(_db_schema));
14              
15             =head2 new HANDLE
16              
17             Creates a new C object. The single
18             required argument is a C.
19              
20             =cut
21              
22             sub new {
23 0     0 1   my $class = shift;
24 0           my $handle = shift;
25 0           my $self = $class->SUPER::new();
26              
27 0           $self->handle($handle);
28              
29 0           my $schema = DBIx::DBSchema->new;
30 0           $self->_db_schema($schema);
31              
32 0           return $self;
33             }
34              
35             =for public_doc AddModel MODEL
36              
37             Adds a new model class to the SchemaGenerator. Model should either be an object
38             of a subclass of C, or the name of such a subclass; in the
39             latter case, C will instantiate an object of the subclass.
40              
41             The model must define the instance methods C and C.
42              
43             Returns true if the model was added successfully; returns a false C error
44             otherwise.
45              
46             =cut
47              
48             sub AddModel {
49 0     0 0   my $self = shift;
50 0           my $model = shift;
51              
52             # $model could either be a (presumably unfilled) object of a subclass of
53             # DBIx::SearchBuilder::Record, or it could be the name of such a subclass.
54              
55 0 0 0       unless (ref $model and UNIVERSAL::isa($model, 'DBIx::SearchBuilder::Record')) {
56 0           my $new_model;
57 0           eval { $new_model = $model->new; };
  0            
58              
59 0 0         if ($@) {
60 0           return $self->_error("Error making new object from $model: $@");
61             }
62              
63 0 0         return $self->_error("Didn't get a DBIx::SearchBuilder::Record from $model, got $new_model")
64             unless UNIVERSAL::isa($new_model, 'DBIx::SearchBuilder::Record');
65              
66 0           $model = $new_model;
67             }
68              
69 0           my $table_obj = $self->_DBSchemaTableFromModel($model);
70              
71 0           $self->_db_schema->addtable($table_obj);
72              
73 0           1;
74             }
75              
76             =for public_doc CreateTableSQLStatements
77              
78             Returns a list of SQL statements (as strings) to create tables for all of
79             the models added to the SchemaGenerator.
80              
81             =cut
82              
83             sub CreateTableSQLStatements {
84 0     0 0   my $self = shift;
85             # The sort here is to make it predictable, so that we can write tests.
86 0           return sort $self->_db_schema->sql($self->handle->dbh);
87             }
88              
89             =for public_doc CreateTableSQLText
90              
91             Returns a string containing a sequence of SQL statements to create tables for
92             all of the models added to the SchemaGenerator.
93              
94             =cut
95              
96             sub CreateTableSQLText {
97 0     0 0   my $self = shift;
98              
99 0           return join "\n", map { "$_ ;\n" } $self->CreateTableSQLStatements;
  0            
100             }
101              
102             =for private_doc _DBSchemaTableFromModel MODEL
103              
104             Takes an object of a subclass of DBIx::SearchBuilder::Record; returns a new
105             C object corresponding to the model.
106              
107             =cut
108              
109             sub _DBSchemaTableFromModel {
110 0     0     my $self = shift;
111 0           my $model = shift;
112              
113 0           my $table_name = $model->Table;
114 0           my $schema = $model->Schema;
115              
116 0           my $primary = "id"; # TODO allow override
117 0           my $primary_col = DBIx::DBSchema::Column->new({
118             name => $primary,
119             type => 'serial',
120             null => 'NOT NULL',
121             });
122              
123 0           my @cols = ($primary_col);
124              
125             # The sort here is to make it predictable, so that we can write tests.
126 0           for my $field (sort keys %$schema) {
127             # Skip foreign keys
128              
129 0 0 0       next if defined $schema->{$field}->{'REFERENCES'} and defined $schema->{$field}->{'KEY'};
130              
131             # TODO XXX FIXME
132             # In lieu of real reference support, make references just integers
133 0 0         $schema->{$field}{'TYPE'} = 'integer' if $schema->{$field}{'REFERENCES'};
134              
135             push @cols, DBIx::DBSchema::Column->new({
136             name => $field,
137             type => $schema->{$field}{'TYPE'},
138             null => 'NULL',
139 0           default => $schema->{$field}{'DEFAULT'},
140             });
141             }
142              
143 0           my $table = DBIx::DBSchema::Table->new({
144             name => $table_name,
145             primary_key => $primary,
146             columns => \@cols,
147             });
148              
149 0           return $table;
150             }
151              
152             =for private_doc _error STRING
153              
154             Takes in a string and returns it as a Class::ReturnValue error object.
155              
156             =cut
157              
158             sub _error {
159 0     0     my $self = shift;
160 0           my $message = shift;
161              
162 0           my $ret = Class::ReturnValue->new;
163 0           $ret->as_error(errno => 1, message => $message);
164 0           return $ret->return_value;
165             }
166              
167              
168             1; # Magic true value required at end of module
169              
170             __END__