1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
|
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.
The model must define the instance methods C<Schema> and C<Table>.
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 (ref $model and 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 CreateTableSQLStatements
Returns a list of SQL statements (as strings) to create tables for all of
the models added to the SchemaGenerator.
=cut
sub CreateTableSQLStatements {
my $self = shift;
# The sort here is to make it predictable, so that we can write tests.
return sort $self->_db_schema->sql($self->handle->dbh);
}
=for public_doc CreateTableSQLText
Returns a string containing a sequence of SQL statements to create tables for
all of the models added to the SchemaGenerator.
=cut
sub CreateTableSQLText {
my $self = shift;
return join "\n", map { "$_ ;\n" } $self->CreateTableSQLStatements;
}
=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 $schema = $model->Schema;
my $primary = "id"; # TODO allow override
my $primary_col = DBIx::DBSchema::Column->new({
name => $primary,
type => 'serial',
null => 'NOT NULL',
});
my @cols = ($primary_col);
# The sort here is to make it predictable, so that we can write tests.
for my $field (sort keys %$schema) {
# Skip foreign keys
next if defined $schema->{$field}->{'REFERENCES'} and defined $schema->{$field}->{'KEY'};
# TODO XXX FIXME
# In lieu of real reference support, make references just integers
$schema->{$field}{'TYPE'} = 'integer' if $schema->{$field}{'REFERENCES'};
push @cols, DBIx::DBSchema::Column->new({
name => $field,
type => $schema->{$field}{'TYPE'},
null => 'NULL',
default => $schema->{$field}{'DEFAULT'},
});
}
my $table = DBIx::DBSchema::Table->new({
name => $table_name,
primary_key => $primary,
columns => \@cols,
});
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;
|
