# Input/option accessors
__PACKAGE__->mk_accessors(qw/
ignore_index_names ignore_constraint_names ignore_view_sql
- ignore_proc_sql output_db source_schema target_schema
+ ignore_proc_sql output_db source_schema target_schema
case_insensitive no_batch_alters ignore_missing_methods producer_args
/);
unless ( $src_table ) {
## table is new
- ## add table(s) later.
+ ## add table(s) later.
push @{$self->tables_to_create}, $tar_table;
next;
}
table_renamed_from => 'rename_table',
);
my @diffs;
-
- if (!$self->no_batch_alters &&
- (my $batch_alter = $producer_class->can('batch_alter_table')) )
+
+ if (!$self->no_batch_alters &&
+ (my $batch_alter = $producer_class->can('batch_alter_table')) )
{
# Good - Producer supports batch altering of tables.
foreach my $table ( sort keys %{$self->table_diff_hash} ) {
push @diffs, $batch_alter->($tar_table,
{ map {
$func_map{$_} => $self->table_diff_hash->{$table}{$_}
- } keys %func_map
- },
+ } keys %func_map
+ },
$self->producer_args
);
}
push @diffs, map( {
if (@{ $flattened_diffs{$_} || [] }) {
my $meth = $producer_class->can($_);
-
- $meth ? map {
+
+ $meth ? map {
my $sql = $meth->( (ref $_ eq 'ARRAY' ? @$_ : $_), $self->producer_args );
- $sql ? ("$sql") : ();
+ $sql ? ("$sql") : ();
} @{ $flattened_diffs{$_} }
: $self->ignore_missing_methods
? "-- $producer_class cant $_"
$schema->add_table($_) for @tables;
- unshift @diffs,
+ unshift @diffs,
# Remove begin/commit here, since we wrap everything in one.
grep { $_ !~ /^(?:COMMIT|START(?: TRANSACTION)?|BEGIN(?: TRANSACTION)?)/ } $producer_class->can('produce')->($translator);
}
if (my @tables_to_drop = @{ $self->{tables_to_drop} || []} ) {
my $meth = $producer_class->can('drop_table');
-
+
push @diffs, $meth ? ( map { $meth->($_, $self->producer_args) } @tables_to_drop)
: $self->ignore_missing_methods
? "-- $producer_class cant drop_table"
unshift(@diffs, "-- Output database @{[$self->output_db]} is untested/unsupported!!!");
}
- my @return =
+ my @return =
map { $_ ? ( $_ =~ /;$/xms ? $_ : "$_;\n\n" ) : "\n" }
("-- Convert schema '$src_name' to '$tar_name':", @diffs);
next;
}
- # field exists, something changed. This is a bit complex. Parsers can
+ # field exists, something changed. This is a bit complex. Parsers can
# normalize types, but only some of them do, so compare the normalized and
# parsed types for each field to each other
if ( !$tar_table_field->equals($src_table_field, $self->case_insensitive) &&
- !$tar_table_field->equals($src_table_field->parsed_field, $self->case_insensitive) &&
- !$tar_table_field->parsed_field->equals($src_table_field, $self->case_insensitive) &&
+ !$tar_table_field->equals($src_table_field->parsed_field, $self->case_insensitive) &&
+ !$tar_table_field->parsed_field->equals($src_table_field, $self->case_insensitive) &&
!$tar_table_field->parsed_field->equals($src_table_field->parsed_field, $self->case_insensitive) ) {
# Some producers might need src field to diff against
=head1 DESCRIPTION
-Takes two input SQL::Translator::Schemas (or SQL files) and produces ALTER
+Takes two input SQL::Translator::Schemas (or SQL files) and produces ALTER
statments to make them the same
=head1 SNYOPSIS
=head1 PRODUCER FUNCTIONS
The following producer functions should be implemented for completeness. If
-any of them are needed for a given diff, but not found, an error will be
+any of them are needed for a given diff, but not found, an error will be
thrown.
=over
=item * C<batch_alter_table($table, $hash)> (optional)
-If the producer supports C<batch_alter_table>, it will be called with the
+If the producer supports C<batch_alter_table>, it will be called with the
table to alter and a hash, the keys of which will be the method names listed
-above; values will be arrays of fields or constraints to operate on. In the
+above; values will be arrays of fields or constraints to operate on. In the
case of the field functions that take two arguments this will appear as a hash.
I.e. the hash might look something like the following:
schema should be done here, so that a diff between a parsed SQL file and (say)
a parsed DBIx::Class::Schema object will be sane.
-(As an aside, DBIx::Class, for instance, uses the presence of a
+(As an aside, DBIx::Class, for instance, uses the presence of a
C<preprocess_schema> function on the producer to know that it can diff between
the previous SQL file and its own internal representation. Without this method
-on th producer it will diff the two SQL files which is slower, but known to
+on th producer it will diff the two SQL files which is slower, but known to
work better on old-style producers.)
=back
filters => [
DefaultExtra => {
# XXX - These should really be ordered
-
+
# Default widget for fields to basic text edit.
'field.widget' => 'text',
# idea:
# Default label (human formated name) for fields and tables
'field.label' => '=ucfirst($name)',
'table.label' => '=ucfirst($name)',
- },
+ },
],
) || die "SQLFairy error : ".SQL::Translator->error;
my $sql = $sqlt->translate || die "SQLFairy error : ".$sqlt->error;
}
],
indices => [
- {
+ {
fields => 'modifed',
},
]
=head1 AUTHORS
-Ken Youens-Clark, E<lt>kclark@cpan.org<gt>,
+Ken Youens-Clark, E<lt>kclark@cpan.org<gt>,
darren chamberlain E<lt>darren@cpan.orgE<gt>.
=head1 SEE ALSO
=head1 DESCRIPTION
-The grammar derived from the MySQL grammar. The input is expected to be
+The grammar derived from the MySQL grammar. The input is expected to be
something similar to the output of mdbtools (http://mdbtools.sourceforge.net/).
=cut
$GRAMMAR = q!
-{
+{
my ( %tables, $table_order, @table_comments );
}
#
# The "eofile" rule makes the parser fail if any "statement" rule
-# fails. Otherwise, the first successful match by a "statement"
+# fails. Otherwise, the first successful match by a "statement"
# won't cause the failure needed to know that the parse, as a whole,
# failed. -ky
#
{ @table_comments = () }
create : CREATE TABLE table_name '(' create_definition(s /,/) ')' ';'
- {
+ {
my $table_name = $item{'table_name'};
$tables{ $table_name }{'order'} = ++$table_order;
$tables{ $table_name }{'table_name'} = $table_name;
for my $definition ( @{ $item[5] } ) {
if ( $definition->{'supertype'} eq 'field' ) {
my $field_name = $definition->{'name'};
- $tables{ $table_name }{'fields'}{ $field_name } =
+ $tables{ $table_name }{'fields'}{ $field_name } =
{ %$definition, order => $i };
$i++;
-
+
if ( $definition->{'is_primary_key'} ) {
push @{ $tables{ $table_name }{'constraints'} },
{
;
}
-create_definition : constraint
+create_definition : constraint
| index
| field
| comment
| <error>
-comment : /^\s*--(.*)\n/
- {
+comment : /^\s*--(.*)\n/
+ {
my $comment = $1;
$return = $comment;
push @table_comments, $comment;
}
field : field_name data_type field_qualifier(s?) reference_definition(?)
- {
- $return = {
+ {
+ $return = {
supertype => 'field',
- name => $item{'field_name'},
+ name => $item{'field_name'},
data_type => $item{'data_type'}{'type'},
size => $item{'data_type'}{'size'},
constraints => $item{'reference_definition(?)'},
- }
+ }
}
| <error>
field_qualifier : not_null
- {
- $return = {
+ {
+ $return = {
null => $item{'not_null'},
- }
+ }
}
field_qualifier : default_val
- {
- $return = {
+ {
+ $return = {
default => $item{'default_val'},
- }
+ }
}
field_qualifier : auto_inc
- {
- $return = {
+ {
+ $return = {
is_auto_inc => $item{'auto_inc'},
- }
+ }
}
field_qualifier : primary_key
- {
- $return = {
+ {
+ $return = {
is_primary_key => $item{'primary_key'},
- }
+ }
}
field_qualifier : unsigned
- {
- $return = {
+ {
+ $return = {
is_unsigned => $item{'unsigned'},
- }
+ }
}
field_qualifier : /character set/i WORD
on_update : /on update/i reference_option
{ $item[2] }
-reference_option: /restrict/i |
- /cascade/i |
- /set null/i |
- /no action/i |
+reference_option: /restrict/i |
+ /cascade/i |
+ /set null/i |
+ /no action/i |
/set default/i
- { $item[1] }
+ { $item[1] }
index : normal_index
| fulltext_index
index_name : NAME
data_type : access_data_type parens_value_list(s?) type_qualifier(s?)
- {
- $return = {
+ {
+ $return = {
type => $item[1],
size => $item[2][0],
qualifiers => $item[3],
- }
+ }
}
access_data_type : /long integer/i { $return = 'Long Integer' }
}
}
-foreign_key_def_begin : /constraint/i /foreign key/i
+foreign_key_def_begin : /constraint/i /foreign key/i
{ $return = '' }
|
/constraint/i WORD /foreign key/i
{ $return = '' }
primary_key_def : primary_key index_name(?) '(' name_with_opt_paren(s /,/) ')'
- {
- $return = {
+ {
+ $return = {
supertype => 'constraint',
name => $item{'index_name(?)'}[0],
type => 'primary_key',
}
unique_key_def : UNIQUE KEY(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
- {
- $return = {
+ {
+ $return = {
supertype => 'constraint',
name => $item{'index_name(?)'}[0],
type => 'unique',
fields => $item[5],
- }
+ }
}
normal_index : KEY index_name(?) '(' name_with_opt_paren(s /,/) ')'
- {
- $return = {
+ {
+ $return = {
supertype => 'index',
type => 'normal',
name => $item{'index_name(?)'}[0],
fields => $item[4],
- }
+ }
}
fulltext_index : /fulltext/i KEY(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
- {
- $return = {
+ {
+ $return = {
supertype => 'index',
type => 'fulltext',
name => $item{'index_name(?)'}[0],
fields => $item[5],
- }
+ }
}
name_with_opt_paren : NAME parens_value_list(s?)
KEY : /key/i | /index/i
table_option : WORD /\s*=\s*/ WORD
- {
+ {
$return = { $item[1] => $item[3] };
}
VALUE : /[-+]?\.?\d+(?:[eE]\d+)?/
{ $item[1] }
- | /'.*?'/
- {
- # remove leading/trailing quotes
+ | /'.*?'/
+ {
+ # remove leading/trailing quotes
my $val = $item[1];
$val =~ s/^['"]|['"]$//g;
$return = $val;
warn Dumper( $result ) if $DEBUG;
my $schema = $translator->schema;
- my @tables = sort {
+ my @tables = sort {
$result->{ $a }->{'order'} <=> $result->{ $b }->{'order'}
} keys %{ $result };
for my $table_name ( @tables ) {
my $tdata = $result->{ $table_name };
- my $table = $schema->add_table(
+ my $table = $schema->add_table(
name => $tdata->{'table_name'},
) or die $schema->error;
$table->comments( $tdata->{'comments'} );
- my @fields = sort {
- $tdata->{'fields'}->{$a}->{'order'}
+ my @fields = sort {
+ $tdata->{'fields'}->{$a}->{'order'}
<=>
$tdata->{'fields'}->{$b}->{'order'}
} keys %{ $tdata->{'fields'} };
warn Dumper( $result ) if $DEBUG;
my $schema = $translator->schema;
- my @tables =
+ my @tables =
map { $_->[1] }
- sort { $a->[0] <=> $b->[0] }
+ sort { $a->[0] <=> $b->[0] }
map { [ $result->{'tables'}{ $_ }->{'order'}, $_ ] }
keys %{ $result->{'tables'} };
for my $table_name ( @tables ) {
my $tdata = $result->{'tables'}{ $table_name };
- my $table = $schema->add_table(
+ my $table = $schema->add_table(
name => $tdata->{'name'},
) or die $schema->error;
use DBI;
use SQL::Translator;
- my $dbh = DBI->connect('dsn', 'user', 'pass',
+ my $dbh = DBI->connect('dsn', 'user', 'pass',
{
RaiseError => 1,
FetchHashKeyName => 'NAME_lc',
=head1 DESCRIPTION
-This parser accepts an open database handle (or the arguments to create
-one) and queries the database directly for the information.
+This parser accepts an open database handle (or the arguments to create
+one) and queries the database directly for the information.
The following are acceptable arguments:
=item * dbh
-An open DBI database handle. NB: Be sure to create the database with the
-"FetchHashKeyName => 'NAME_lc'" option as all the DBI parsers expect
+An open DBI database handle. NB: Be sure to create the database with the
+"FetchHashKeyName => 'NAME_lc'" option as all the DBI parsers expect
lowercased column names.
=item * dsn
this is determined automatically by inspecting $dbh->{'Driver'}{'Name'}.
If a parser exists for your database, it will be used automatically;
if not, the code will fail automatically (and you can write the parser
-and contribute it to the project!).
+and contribute it to the project!).
Currently parsers exist for the following databases:
unless ( $dbh ) {
die 'No DSN' unless $dsn;
- $dbh = DBI->connect( $dsn, $db_user, $db_password,
+ $dbh = DBI->connect( $dsn, $db_user, $db_password,
{
FetchHashKeyName => 'NAME_lc',
LongReadLen => 3000,
LongTruncOk => 1,
RaiseError => 1,
- }
+ }
);
}
=head1 DESCRIPTION
-Uses DBI methods to determine schema structure. DBI, of course,
+Uses DBI methods to determine schema structure. DBI, of course,
delegates to DBD::DB2.
=cut
SQL
my $indsth = $dbh->prepare(<<SQL);
-SELECT i.INDSCHEMA,
- i.INDNAME,
- i.TABSCHEMA,
- i.TABNAME,
- i.UNIQUERULE,
- i.INDEXTYPE,
- ic.COLNAME
-FROM SYSCAT.INDEXES i
-JOIN SYSCAT.INDEXCOLUSE ic ON i.INDSCHEMA = ic.INDSCHEMA AND
- i.INDNAME = ic.INDNAME
-WHERE i.TABSCHEMA NOT LIKE 'SYS%' AND
+SELECT i.INDSCHEMA,
+ i.INDNAME,
+ i.TABSCHEMA,
+ i.TABNAME,
+ i.UNIQUERULE,
+ i.INDEXTYPE,
+ ic.COLNAME
+FROM SYSCAT.INDEXES i
+JOIN SYSCAT.INDEXCOLUSE ic ON i.INDSCHEMA = ic.INDSCHEMA AND
+ i.INDNAME = ic.INDNAME
+WHERE i.TABSCHEMA NOT LIKE 'SYS%' AND
i.INDEXTYPE <> 'P' AND
i.TABNAME = ?
SQL
my $trigsth = $dbh->prepare(<<SQL);
SELECT t.TRIGSCHEMA,
t.TRIGNAME,
- t.TABSCHEMA,
+ t.TABSCHEMA,
t.TRIGTIME,
t.TRIGEVENT,
t.GRANULARITY,
$colsth->execute($table_info->{TABNAME});
my $cols = $colsth->fetchall_hashref("COLNAME");
-
+
foreach my $c (values %{$cols}) {
print Dumper($c) if $DEBUG;
print $c->{COLNAME} if($DEBUG);
size => $c->{LENGTH},
) || die $table->error;
-
+
$f->is_nullable($c->{NULLS} eq 'Y');
}
my @fields = map { $_->{COLNAME} } (values %{$cons});
my $c = $cons->{$fields[0]};
-
+
print $c->{CONSTNAME} if($DEBUG);
my $con = $table->add_constraint(
name => $c->{CONSTNAME},
FOREIGN_KEY : UNIQUE
) || die $table->error;
-
+
$con->deferrable($c->{CHECKEXISTINGDATA} eq 'D');
-
+
$indsth->execute($table_info->{TABNAME});
my $inds = $indsth->fetchall_hashref("INDNAME");
print Dumper($inds) if($DEBUG);
type => $index->{UNIQUERULE} eq 'U' ?
UNIQUE : NORMAL
) || die $table->error;
-
-
+
+
}
$trigsth->execute($table_info->{TABNAME});
next if(!%$trigs);
foreach my $t (values %$trigs)
- {
+ {
print $t->{TRIGNAME} if($DEBUG);
my $trig = $schema->add_trigger(
name => $t->{TRIGNAME},
$t->{TRIGTIME} eq 'B' ? 'before':
'instead',
database_event => $t->{TRIGEVENT} eq 'I' ? 'insert'
- : $t->{TRIGEVENT} eq 'D' ? 'delete'
+ : $t->{TRIGEVENT} eq 'D' ? 'delete'
: 'update',
action => $t->{TEXT},
- on_table => $t->{TABNAME}
+ on_table => $t->{TABNAME}
) || die $schema->error;
-
+
# $trig->extra( reference => $def->{'reference'},
# condition => $def->{'condition'},
# granularity => $def->{'granularity'} );
=head1 ACKNOWLEDGEMENT
-Initial revision of this module came almost entirely from work done by
+Initial revision of this module came almost entirely from work done by
Todd Hepler E<lt>thepler@freeshell.orgE<gt>. My changes were
-quite minor (ensuring NAME_uc, changing a couple variable names,
+quite minor (ensuring NAME_uc, changing a couple variable names,
skipping tables with a $ in them).
Todd claimed his work to be an almost verbatim copy of
=head1 DESCRIPTION
-Uses DBI to query PostgreSQL system tables to determine schema structure.
+Uses DBI to query PostgreSQL system tables to determine schema structure.
=cut
WHERE a.attrelid=? AND attnum>0
AND a.atttypid=t.oid
ORDER BY a.attnum"
- );
+ );
my $index_select = $dbh->prepare(
"SELECT oid, c.relname, i.indkey, i.indnatts, i.indisunique,
AND c.relname = ?
ORDER BY 1;
/) or die "Can't prepare: $@";
-
+
$table_select->execute();
while ( my $tablehash = $table_select->fetchrow_hashref ) {
my $table_name = $$tablehash{'relname'};
- my $table_oid = $$tablehash{'oid'};
+ my $table_oid = $$tablehash{'oid'};
my $table = $schema->add_table(
name => $table_name,
#what is type? type => $table_info->{TABLE_TYPE},
while (my $columnhash = $column_select->fetchrow_hashref ) {
- #data_type seems to not be populated; perhaps there needs to
+ #data_type seems to not be populated; perhaps there needs to
#be a mapping of query output to reserved constants in sqlt?
my $col = $table->add_field(
my @column_names = $table->field_names();
while (my $indexhash = $index_select->fetchrow_hashref ) {
#don't deal with function indexes at the moment
- next if ($$indexhash{'indkey'} eq ''
+ next if ($$indexhash{'indkey'} eq ''
or !defined($$indexhash{'indkey'}) );
my $type;
fields => \@columns,
) || die $table->error;
}
-
+
$fk_select->execute('public',$table_name) or die "Can't execute: $@";
my $fkeys = $fk_select->fetchall_arrayref({});
$DEBUG and print Dumper $fkeys;
);
}
}
-
+
return 1;
}
=head1 AUTHOR
-Scott Cain E<lt>cain@cshl.eduE<gt>, previous author:
+Scott Cain E<lt>cain@cshl.eduE<gt>, previous author:
Paul Harrington E<lt>harringp@deshaw.comE<gt>.
=head1 SEE ALSO
->{columns};
foreach my $c (values %{$cols}) {
- my $is_auto_increment = $c->{TYPE_NAME} =~ s#(\(\))? identity##i;
+ my $is_auto_increment = $c->{TYPE_NAME} =~ s#(\(\))? identity##i;
my $f = $table->add_field(
name => $c->{COLUMN_NAME},
data_type => $c->{TYPE_NAME},
$f->is_nullable($c->{NULLABLE} == 1);
$f->is_auto_increment($is_auto_increment);
if ( defined $c->{COLUMN_DEF}) {
- $c->{COLUMN_DEF} =~ s#\('?(.*?)'?\)#$1#;
- $f->default_value($c->{COLUMN_DEF});
+ $c->{COLUMN_DEF} =~ s#\('?(.*?)'?\)#$1#;
+ $f->default_value($c->{COLUMN_DEF});
}
}
# add in foreign keys
$h = $dbh->selectall_hashref("sp_fkeys NULL,
\@fktable_name = '$table_info->{TABLE_NAME}'", 'FK_NAME');
- foreach my $fk ( values %{$h} ) {
- my $constraint = $table->add_constraint( name => $fk->{FK_NAME},
- fields => [$fk->{FKCOLUMN_NAME}],
- );
- $constraint->type("FOREIGN_KEY");
- $constraint->on_delete(
- $fk->{DELETE_RULE} == 0 ? "CASCADE" :
- $fk->{DELETE_RULE} == 1 ? "NO ACTION" : "SET_NULL"
- );
- $constraint->on_update(
- $fk->{UPDATE_RULE} == 0 ? "CASCADE" :
- $fk->{UPDATE_RULE} == 1 ? "NO ACTION" : "SET_NULL"
- );
- $constraint->reference_table($fk->{PKTABLE_NAME});
- }
+ foreach my $fk ( values %{$h} ) {
+ my $constraint = $table->add_constraint( name => $fk->{FK_NAME},
+ fields => [$fk->{FKCOLUMN_NAME}],
+ );
+ $constraint->type("FOREIGN_KEY");
+ $constraint->on_delete(
+ $fk->{DELETE_RULE} == 0 ? "CASCADE" :
+ $fk->{DELETE_RULE} == 1 ? "NO ACTION" : "SET_NULL"
+ );
+ $constraint->on_update(
+ $fk->{UPDATE_RULE} == 0 ? "CASCADE" :
+ $fk->{UPDATE_RULE} == 1 ? "NO ACTION" : "SET_NULL"
+ );
+ $constraint->reference_table($fk->{PKTABLE_NAME});
+ }
# add in any indexes ... how do we tell if the index has
# already been created as part of a primary key or other
}
}
} elsif ($table_info->{TABLE_TYPE} eq 'VIEW') {
- next if $table_info->{TABLE_NAME} eq 'sysconstraints'
- || $table_info->{TABLE_NAME} eq 'syssegments';
- next if !$stuff->{view}->{$table_info->{TABLE_NAME}}->{text};
+ next if $table_info->{TABLE_NAME} eq 'sysconstraints'
+ || $table_info->{TABLE_NAME} eq 'syssegments';
+ next if !$stuff->{view}->{$table_info->{TABLE_NAME}}->{text};
my $view = $schema->add_view(
name =>
$table_info->{TABLE_NAME},
}
foreach my $p (values %{$stuff->{procedures}}) {
- next if !$p->{text};
+ next if !$p->{text};
my $proc = $schema->add_procedure(
name => $p->{name},
owner => $p->{PROCEDURE_OWNER},
Queries the "sqlite_master" table for schema definition. The schema
is held in this table simply as CREATE statements for the database
objects, so it really just builds up a string of all these and passes
-the result to the regular SQLite parser. Therefore there is no gain
-(at least in performance) to using this module over simply dumping the
+the result to the regular SQLite parser. Therefore there is no gain
+(at least in performance) to using this module over simply dumping the
schema to a text file and parsing that.
=cut
#
# If directed, look at every field's values to guess size and type.
#
- unless (
+ unless (
defined $args->{'scan_fields'} &&
$args->{'scan_fields'} == 0
) {
for(
my $iR = $ws->{'MinRow'} == 0 ? 1 : $ws->{'MinRow'};
- defined $ws->{'MaxRow'} && $iR <= $ws->{'MaxRow'};
+ defined $ws->{'MaxRow'} && $iR <= $ws->{'MaxRow'};
$iR++
) {
- for (
+ for (
my $iC = $ws->{'MinCol'};
- defined $ws->{'MaxCol'} && $iC <= $ws->{'MaxCol'};
+ defined $ws->{'MaxCol'} && $iC <= $ws->{'MaxCol'};
$iC++
) {
my $field = $field_names[ $iC ];
if ( $data =~ /^-?\d+$/ ) {
$type = 'integer';
}
- elsif (
- $data =~ /^-?[,\d]+\.[\d+]?$/
+ elsif (
+ $data =~ /^-?[,\d]+\.[\d+]?$/
||
- $data =~ /^-?[,\d]+?\.\d+$/
+ $data =~ /^-?[,\d]+?\.\d+$/
||
- $data =~ /^-?\.\d+$/
+ $data =~ /^-?\.\d+$/
) {
$type = 'float';
- my ( $w, $d ) =
- map { s/,//g; length $_ || 1 }
+ my ( $w, $d ) =
+ map { s/,//g; length $_ || 1 }
split( /\./, $data )
;
$size = [ $w + $d, $d ];
for my $field ( keys %field_info ) {
my $size = $field_info{ $field }{'size'} || [ 1 ];
- my $data_type =
- $field_info{ $field }{'char'} ? 'char' :
+ my $data_type =
+ $field_info{ $field }{'char'} ? 'char' :
$field_info{ $field }{'float'} ? 'float' :
$field_info{ $field }{'integer'} ? 'integer' : 'char';
CREATE [TEMPORARY] TABLE [IF NOT EXISTS] tbl_name [(create_definition,...)]
[table_options] [select_statement]
-
+
or
-
+
CREATE [TEMPORARY] TABLE [IF NOT EXISTS] tbl_name LIKE old_table_name;
-
+
create_definition:
col_name type [NOT NULL | NULL] [DEFAULT default_value] [AUTO_INCREMENT]
[PRIMARY KEY] [reference_definition]
or [CONSTRAINT symbol] FOREIGN KEY [index_name] (index_col_name,...)
[reference_definition]
or CHECK (expr)
-
+
type:
TINYINT[(length)] [UNSIGNED] [ZEROFILL]
or SMALLINT[(length)] [UNSIGNED] [ZEROFILL]
or LONGTEXT
or ENUM(value1,value2,value3,...)
or SET(value1,value2,value3,...)
-
+
index_col_name:
col_name [(length)]
-
+
reference_definition:
REFERENCES tbl_name [(index_col_name,...)]
[MATCH FULL | MATCH PARTIAL]
[ON DELETE reference_option]
[ON UPDATE reference_option]
-
+
reference_option:
RESTRICT | CASCADE | SET NULL | NO ACTION | SET DEFAULT
-
+
table_options:
TYPE = {BDB | HEAP | ISAM | InnoDB | MERGE | MRG_MYISAM | MYISAM }
or ENGINE = {BDB | HEAP | ISAM | InnoDB | MERGE | MRG_MYISAM | MYISAM }
$GRAMMAR = << 'END_OF_GRAMMAR';
-{
+{
my ( $database_name, %tables, $table_order, @table_comments, %views,
$view_order, %procedures, $proc_order );
my $delimiter = ';';
#
# The "eofile" rule makes the parser fail if any "statement" rule
-# fails. Otherwise, the first successful match by a "statement"
+# fails. Otherwise, the first successful match by a "statement"
# won't cause the failure needed to know that the parse, as a whole,
# failed. -ky
#
-startrule : statement(s) eofile {
- {
- database_name => $database_name,
- tables => \%tables,
- views => \%views,
+startrule : statement(s) eofile {
+ {
+ database_name => $database_name,
+ tables => \%tables,
+ views => \%views,
procedures => \%procedures,
- }
+ }
}
eofile : /^\Z/
{ @table_comments = () }
string :
- # MySQL strings, unlike common SQL strings, can be double-quoted or
- # single-quoted, and you can escape the delmiters by doubling (but only the
+ # MySQL strings, unlike common SQL strings, can be double-quoted or
+ # single-quoted, and you can escape the delmiters by doubling (but only the
# delimiter) or by backslashing.
/'(\\.|''|[^\\\'])*'/ |
my $table_name = $item{'table_name'};
die "Cannot ALTER table '$table_name'; it does not exist"
unless $tables{ $table_name };
- for my $definition ( @{ $item[4] } ) {
+ for my $definition ( @{ $item[4] } ) {
$definition->{'extra'}->{'alter'} = 1;
push @{ $tables{ $table_name }{'constraints'} }, $definition;
}
{ @table_comments = () }
create : CREATE TEMPORARY(?) TABLE opt_if_not_exists(?) table_name '(' create_definition(s /,/) /(,\s*)?\)/ table_option(s?) "$delimiter"
- {
+ {
my $table_name = $item{'table_name'};
$tables{ $table_name }{'order'} = ++$table_order;
$tables{ $table_name }{'table_name'} = $table_name;
for my $definition ( @{ $item[7] } ) {
if ( $definition->{'supertype'} eq 'field' ) {
my $field_name = $definition->{'name'};
- $tables{ $table_name }{'fields'}{ $field_name } =
+ $tables{ $table_name }{'fields'}{ $field_name } =
{ %$definition, order => $i };
$i++;
-
+
if ( $definition->{'is_primary_key'} ) {
push @{ $tables{ $table_name }{'constraints'} },
{
my $func_name = $item[3];
my $owner = '';
my $sql = "$item[1] $item[2] $item[3] $item[4]";
-
+
$procedures{ $func_name }{'order'} = ++$proc_order;
$procedures{ $func_name }{'name'} = $func_name;
$procedures{ $func_name }{'owner'} = $owner;
my $view_name = $item[5];
my $sql = join(q{ }, grep { defined and length } $item[1], $item[2]->[0], $item[3]->[0])
. " $item[4] $item[5] $item[6]";
-
+
# Hack to strip database from function calls in SQL
$sql =~ s#`\w+`\.(`\w+`\()##g;
-
+
$views{ $view_name }{'order'} = ++$view_order;
$views{ $view_name }{'name'} = $view_name;
$views{ $view_name }{'sql'} = $sql;
not_delimiter : /.*?(?=$delimiter)/is
-create_definition : constraint
+create_definition : constraint
| index
| field
| comment
| <error>
-comment : /^\s*(?:#|-{2}).*\n/
- {
+comment : /^\s*(?:#|-{2}).*\n/
+ {
my $comment = $item[1];
$comment =~ s/^\s*(#|--)\s*//;
$comment =~ s/\s*$//;
$comment =~ s/^\s*|\s*$//g;
$return = $comment;
}
-
-field_comment : /^\s*(?:#|-{2}).*\n/
- {
+
+field_comment : /^\s*(?:#|-{2}).*\n/
+ {
my $comment = $item[1];
$comment =~ s/^\s*(#|--)\s*//;
$comment =~ s/\s*$//;
blank : /\s*/
field : field_comment(s?) field_name data_type field_qualifier(s?) field_comment2(?) reference_definition(?) on_update(?) field_comment(s?)
- {
+ {
my %qualifiers = map { %$_ } @{ $item{'field_qualifier(s?)'} || [] };
if ( my @type_quals = @{ $item{'data_type'}{'qualifiers'} || [] } ) {
$qualifiers{ $_ } = 1 for @type_quals;
}
- my $null = defined $qualifiers{'not_null'}
+ my $null = defined $qualifiers{'not_null'}
? $qualifiers{'not_null'} : 1;
delete $qualifiers{'not_null'};
my @comments = ( @{ $item[1] }, @{ $item[5] }, @{ $item[8] } );
- $return = {
+ $return = {
supertype => 'field',
- name => $item{'field_name'},
+ name => $item{'field_name'},
data_type => $item{'data_type'}{'type'},
size => $item{'data_type'}{'size'},
list => $item{'data_type'}{'list'},
constraints => $item{'reference_definition(?)'},
comments => [ @comments ],
%qualifiers,
- }
+ }
}
| <error>
field_qualifier : not_null
- {
- $return = {
+ {
+ $return = {
null => $item{'not_null'},
- }
+ }
}
field_qualifier : default_val
- {
- $return = {
+ {
+ $return = {
default => $item{'default_val'},
- }
+ }
}
field_qualifier : auto_inc
- {
- $return = {
+ {
+ $return = {
is_auto_inc => $item{'auto_inc'},
- }
+ }
}
field_qualifier : primary_key
- {
- $return = {
+ {
+ $return = {
is_primary_key => $item{'primary_key'},
- }
+ }
}
field_qualifier : unsigned
- {
- $return = {
+ {
+ $return = {
is_unsigned => $item{'unsigned'},
- }
+ }
}
-field_qualifier : /character set/i WORD
+field_qualifier : /character set/i WORD
{
$return = {
'CHARACTER SET' => $item[2],
on_delete : /on delete/i reference_option
{ $item[2] }
-on_update :
+on_update :
/on update/i 'CURRENT_TIMESTAMP'
{ $item[2] }
|
/on update/i reference_option
{ $item[2] }
-reference_option: /restrict/i |
- /cascade/i |
- /set null/i |
- /no action/i |
+reference_option: /restrict/i |
+ /cascade/i |
+ /set null/i |
+ /no action/i |
/set default/i
- { $item[1] }
+ { $item[1] }
index : normal_index
| fulltext_index
index_name : NAME
data_type : WORD parens_value_list(s?) type_qualifier(s?)
- {
+ {
my $type = $item[1];
my $size; # field size, applicable only to non-set fields
my $list; # set list, applicable only to sets (duh)
}
- $return = {
+ $return = {
type => $type,
size => $size,
list => $list,
qualifiers => $item[3],
- }
+ }
}
parens_field_list : '(' field_name(s /,/) ')'
create_index : /create/i /index/i
-not_null : /not/i /null/i
+not_null : /not/i /null/i
{ $return = 0 }
|
/null/i
unsigned : /unsigned/i { $return = 0 }
-default_val :
+default_val :
/default/i 'CURRENT_TIMESTAMP'
{
$return = \$item[2];
{ $return = '' }
primary_key_def : primary_key index_name_not_using(?) index_type(?) '(' name_with_opt_paren(s /,/) ')' index_type(?)
- {
- $return = {
+ {
+ $return = {
supertype => 'constraint',
name => $item[2][0],
type => 'primary_key',
}
unique_key_def : UNIQUE KEY(?) index_name_not_using(?) index_type(?) '(' name_with_opt_paren(s /,/) ')' index_type(?)
- {
- $return = {
+ {
+ $return = {
supertype => 'constraint',
name => $item[3][0],
type => 'unique',
fields => $item[6],
options => $item[4][0] || $item[8][0],
- }
+ }
}
normal_index : KEY index_name_not_using(?) index_type(?) '(' name_with_opt_paren(s /,/) ')' index_type(?)
- {
- $return = {
+ {
+ $return = {
supertype => 'index',
type => 'normal',
name => $item[2][0],
index_type : /using (btree|hash|rtree)/i { $return = uc $1 }
fulltext_index : /fulltext/i KEY(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
- {
- $return = {
+ {
+ $return = {
supertype => 'index',
type => 'fulltext',
name => $item{'index_name(?)'}[0],
fields => $item[5],
- }
+ }
}
spatial_index : /spatial/i KEY(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
- {
- $return = {
+ {
+ $return = {
supertype => 'index',
type => 'spatial',
name => $item{'index_name(?)'}[0],
fields => $item[5],
- }
+ }
}
name_with_opt_paren : NAME parens_value_list(s?)
$return = { comment => $comment };
}
| /(default )?(charset|character set)/i /\s*=?\s*/ WORD
- {
+ {
$return = { 'CHARACTER SET' => $item[3] };
}
| /collate/i WORD
$return = { 'COLLATE' => $item[2] }
}
| /union/i /\s*=\s*/ '(' table_name(s /,/) ')'
- {
+ {
$return = { $item[1] => $item[4] };
}
| WORD /\s*=\s*/ MAYBE_QUOTED_WORD
{ $item[2] }
NAME: QUOTED_NAME
- | /\w+/
+ | /\w+/
VALUE : /[-+]?\.?\d+(?:[eE]\d+)?/
{ $item[1] }
- | /'.*?'/
- {
- # remove leading/trailing quotes
+ | /'.*?'/
+ {
+ # remove leading/trailing quotes
my $val = $item[1];
$val =~ s/^['"]|['"]$//g;
$return = $val;
CURRENT_TIMESTAMP : /current_timestamp(\(\))?/i
| /now\(\)/i
{ 'CURRENT_TIMESTAMP' }
-
+
END_OF_GRAMMAR
# -------------------------------------------------------------------
return $translator->error("Error instantiating Parse::RecDescent ".
"instance: Bad grammer");
}
-
+
# Preprocess for MySQL-specific and not-before-version comments
# from mysqldump
my $parser_version = parse_mysql_version(
$translator->parser_args->{mysql_parser_version}, 'mysql'
) || DEFAULT_PARSER_VERSION;
- while ( $data =~
- s#/\*!(\d{5})?(.*?)\*/#($1 && $1 > $parser_version ? '' : $2)#es
+ while ( $data =~
+ s#/\*!(\d{5})?(.*?)\*/#($1 && $1 > $parser_version ? '' : $2)#es
) {
# do nothing; is there a better way to write this? -- ky
}
my $schema = $translator->schema;
$schema->name($result->{'database_name'}) if $result->{'database_name'};
- my @tables = sort {
- $result->{'tables'}{ $a }{'order'}
- <=>
+ my @tables = sort {
+ $result->{'tables'}{ $a }{'order'}
+ <=>
$result->{'tables'}{ $b }{'order'}
} keys %{ $result->{'tables'} };
for my $table_name ( @tables ) {
my $tdata = $result->{tables}{ $table_name };
- my $table = $schema->add_table(
+ my $table = $schema->add_table(
name => $tdata->{'table_name'},
) or die $schema->error;
$table->comments( $tdata->{'comments'} );
- my @fields = sort {
- $tdata->{'fields'}->{$a}->{'order'}
+ my @fields = sort {
+ $tdata->{'fields'}->{$a}->{'order'}
<=>
$tdata->{'fields'}->{$b}->{'order'}
} keys %{ $tdata->{'fields'} };
reference_table => $cdata->{'reference_table'},
reference_fields => $cdata->{'reference_fields'},
match_type => $cdata->{'match_type'} || '',
- on_delete => $cdata->{'on_delete'}
+ on_delete => $cdata->{'on_delete'}
|| $cdata->{'on_delete_do'},
- on_update => $cdata->{'on_update'}
+ on_update => $cdata->{'on_update'}
|| $cdata->{'on_update_do'},
) or die $table->error;
}
- # After the constrains and PK/idxs have been created,
+ # After the constrains and PK/idxs have been created,
# we normalize fields
normalize_field($_) for $table->get_fields;
}
-
- my @procedures = sort {
- $result->{procedures}->{ $a }->{'order'}
- <=>
+
+ my @procedures = sort {
+ $result->{procedures}->{ $a }->{'order'}
+ <=>
$result->{procedures}->{ $b }->{'order'}
} keys %{ $result->{procedures} };
sql => $result->{procedures}->{$proc_name}->{sql},
);
}
- my @views = sort {
- $result->{views}->{ $a }->{'order'}
- <=>
+ my @views = sort {
+ $result->{views}->{ $a }->{'order'}
+ <=>
$result->{views}->{ $b }->{'order'}
} keys %{ $result->{views} };
return 1;
}
-# Takes a field, and returns
+# Takes a field, and returns
sub normalize_field {
my ($field) = @_;
my ($size, $type, $list, $changed) = @_;
-
+
$size = $field->size;
$type = $field->data_type;
$list = $field->extra->{list} || [];
}
elsif ( lc $type =~ /(float|double|decimal|numeric|real|fixed|dec)/ ) {
my $old_size = (ref $size || '') eq 'ARRAY' ? $size : [];
- $changed = @$old_size != 2
- || $old_size->[0] != 8
+ $changed = @$old_size != 2
+ || $old_size->[0] != 8
|| $old_size->[1] != 2;
$size = [8,2];
}
CREATE [GLOBAL TEMPORARY] TABLE [schema.]table (tbl_defs,...)
[ON COMMIT {DELETE|PRESERVE} ROWS]
[storage_options | CLUSTER cluster_name (col1, col2,... )
- | ORGANIZATION {HEAP [storage_options]
+ | ORGANIZATION {HEAP [storage_options]
| INDEX idx_organized_tbl_clause}]
[LOB_storage_clause][varray_clause][nested_storage_clause]
partitioning_options
CONSTRAINT constrnt_name REFERENCES [schema.]table[(column)]
[ON DELETE {CASCADE|SET NULL}] constrnt_state
-constrnt_state
+constrnt_state
[[NOT] DEFERRABLE] [INITIALLY {IMMEDIATE|DEFERRED}]
[RELY | NORELY] [USING INDEX using_index_clause]
[ENABLE|DISABLE] [VALIDATE|NOVALIDATE]
[EXCEPTIONS INTO [schema.]table]
-Note that probably not all of the above syntax is supported, but the grammar
+Note that probably not all of the above syntax is supported, but the grammar
was altered to better handle the syntax created by DDL::Oracle.
=cut
#
# The "eofile" rule makes the parser fail if any "statement" rule
-# fails. Otherwise, the first successful match by a "statement"
+# fails. Otherwise, the first successful match by a "statement"
# won't cause the failure needed to know that the parse, as a whole,
# failed. -ky
#
-startrule : statement(s) eofile
- {
+startrule : statement(s) eofile
+ {
$return = {
tables => \%tables,
indices => \%indices,
eofile : /^\Z/
statement : remark
- | run
+ | run
| prompt
| create
| table_comment
for my $definition ( @{ $item[4] } ) {
if ( $definition->{'type'} eq 'field' ) {
my $field_name = $definition->{'name'};
- $tables{ $table_name }{'fields'}{ $field_name } =
+ $tables{ $table_name }{'fields'}{ $field_name } =
{ %$definition, order => $i };
$i++;
-
+
for my $constraint ( @{ $definition->{'constraints'} || [] } ) {
$constraint->{'fields'} = [ $field_name ];
- push @{ $tables{ $table_name }{'constraints'} },
+ push @{ $tables{ $table_name }{'constraints'} },
$constraint;
}
}
}
index_expr: parens_word_list
- { $item[1] }
- | '(' WORD parens_word_list ')'
- {
- my $arg_list = join(",", @{$item[3]});
- $return = "$item[2]($arg_list)";
- }
+ { $item[1] }
+ | '(' WORD parens_word_list ')'
+ {
+ my $arg_list = join(",", @{$item[3]});
+ $return = "$item[2]($arg_list)";
+ }
create : /create/i /or replace/i /procedure/i table_name not_end m#^/$#im
- {
- @table_comments = ();
+ {
+ @table_comments = ();
my $proc_name = $item[4];
# Hack to strip owner from procedure name
$proc_name =~ s#.*\.##;
my $owner = '';
my $sql = "$item[1] $item[2] $item[3] $item[4] $item[5]";
-
+
$procedures{ $proc_name }{'order'} = ++$proc_order;
$procedures{ $proc_name }{'name'} = $proc_name;
$procedures{ $proc_name }{'owner'} = $owner;
$procedures{ $proc_name }{'sql'} = $sql;
- }
+ }
not_end: m#.*?(?=^/$)#ism
create : /create/i /or replace/i /force/i /view/i table_name not_delimiter ';'
- {
- @table_comments = ();
+ {
+ @table_comments = ();
my $view_name = $item[5];
# Hack to strip owner from view name
$view_name =~ s#.*\.##;
my $sql = "$item[1] $item[2] $item[3] $item[4] $item[5] $item[6] $item[7]";
-
+
$views{ $view_name }{'order'} = ++$view_order;
$views{ $view_name }{'name'} = $view_name;
$views{ $view_name }{'sql'} = $sql;
- }
+ }
not_delimiter: /.*?(?=;)/is
{ @table_comments = () }
create_index : /create/i UNIQUE(?) /index/i
- { $return = @{$item[2]} }
+ { $return = @{$item[2]} }
index_name : NAME '.' NAME
{ $item[3] }
- | NAME
+ | NAME
{ $item[1] }
global_temporary: /global/i /temporary/i
table_name : NAME '.' NAME
{ $item[3] }
- | NAME
+ | NAME
{ $item[1] }
create_definition : table_constraint
$return = $comment;
}
-comment : /\/\*/ /[^\*]+/ /\*\//
+comment : /\/\*/ /[^\*]+/ /\*\//
{
my $comment = $item[2];
$comment =~ s/^\s*|\s*$//g;
{
my $table_name = $item[4]->{'table'};
my $field_name = $item[4]->{'field'};
- push @{ $tables{ $table_name }{'fields'}{ $field_name }{'comments'} },
+ push @{ $tables{ $table_name }{'fields'}{ $field_name }{'comments'} },
$item{'comment_phrase'};
}
column_name : NAME '.' NAME
{ $return = { table => $item[1], field => $item[3] } }
-comment_phrase : /'.*?'/
- {
+comment_phrase : /'.*?'/
+ {
my $val = $item[1];
$val =~ s/^'|'$//g;
$return = $val;
my @comments = ( @{ $item[1] }, @{ $item[5] } );
- $return = {
+ $return = {
type => 'field',
- name => $item{'field_name'},
+ name => $item{'field_name'},
data_type => $item{'data_type'}{'type'},
size => $item{'data_type'}{'size'},
null => $null,
is_primary_key => $is_pk,
constraints => [ @constraints ],
comments => [ @comments ],
- }
+ }
}
| <error>
field_name : NAME
data_type : ora_data_type data_size(?)
- {
- $return = {
+ {
+ $return = {
type => $item[1],
size => $item[2][0] || '',
- }
+ }
}
-
+
data_size : '(' VALUE(s /,/) data_size_modifier(?) ')'
- { $item[2] }
+ { $item[2] }
data_size_modifier: /byte/i
- | /char/i
+ | /char/i
column_constraint : constraint_name(?) column_constraint_type constraint_state(s?)
{
reference_fields => $desc->{'reference_fields'},
# match_type => $desc->{'match_type'},
# on_update => $desc->{'on_update'},
- }
+ }
}
constraint_name : /constraint/i NAME { $item[2] }
column_constraint_type : /not\s+null/i { $return = { type => 'not_null' } }
| /unique/i
{ $return = { type => 'unique' } }
- | /primary\s+key/i
+ | /primary\s+key/i
{ $return = { type => 'primary_key' } }
| /check/i check_expression
- {
- $return = {
- type => 'check',
- expression => $item[2],
+ {
+ $return = {
+ type => 'check',
+ expression => $item[2],
};
}
- | /references/i table_name parens_word_list(?) on_delete(?)
+ | /references/i table_name parens_word_list(?) on_delete(?)
{
$return = {
type => 'foreign_key',
RPAREN : ')'
check_condition_text : /.+\s+in\s+\([^)]+\)/i
- | /[^)]+/
+ | /[^)]+/
-check_expression : LPAREN check_condition_text RPAREN
- { $return = join( ' ', map { $_ || () }
- $item[1], $item[2], $item[3], $item[4][0] )
+check_expression : LPAREN check_condition_text RPAREN
+ { $return = join( ' ', map { $_ || () }
+ $item[1], $item[2], $item[3], $item[4][0] )
}
constraint_state : deferrable { $return = { type => $item[1] } }
| deferred { $return = { type => $item[1] } }
| /(no)?rely/i { $return = { type => $item[1] } }
-# | /using/i /index/i using_index_clause
+# | /using/i /index/i using_index_clause
# { $return = { type => 'using_index', index => $item[3] } }
| /(dis|en)able/i { $return = { type => $item[1] } }
| /(no)?validate/i { $return = { type => $item[1] } }
- | /exceptions/i /into/i table_name
+ | /exceptions/i /into/i table_name
{ $return = { type => 'exceptions_into', table => $item[3] } }
-deferrable : /not/i /deferrable/i
+deferrable : /not/i /deferrable/i
{ $return = 'not_deferrable' }
- | /deferrable/i
+ | /deferrable/i
{ $return = 'deferrable' }
deferred : /initially/i /(deferred|immediate)/i { $item[2] }
|
/n?char/i { $return = 'character' }
|
- /n?dec/i { $return = 'decimal' }
- |
+ /n?dec/i { $return = 'decimal' }
+ |
/number/i { $return = 'number' }
|
/integer/i { $return = 'integer' }
field_meta : default_val
| column_constraint
-default_val : /default/i /(?:')?[\w\d.-]*(?:')?/
- {
+default_val : /default/i /(?:')?[\w\d.-]*(?:')?/
+ {
my $val = $item[2];
- $val =~ s/'//g if defined $val;
+ $val =~ s/'//g if defined $val;
$return = {
supertype => 'constraint',
type => 'default',
on_delete => $desc->{'on_delete'} || $desc->{'on_delete_do'},
on_update => $desc->{'on_update'} || $desc->{'on_update_do'},
comments => [ @comments ],
- }
+ }
}
table_constraint_type : /primary key/i '(' NAME(s /,/) ')'
- {
+ {
$return = {
type => 'primary_key',
fields => $item[3],
}
}
|
- /unique/i '(' NAME(s /,/) ')'
- {
+ /unique/i '(' NAME(s /,/) ')'
+ {
$return = {
type => 'unique',
fields => $item[3],
my $schema = $translator->schema;
my $indices = $result->{'indices'};
my $constraints = $result->{'constraints'};
- my @tables = sort {
- $result->{'tables'}{ $a }{'order'}
- <=>
+ my @tables = sort {
+ $result->{'tables'}{ $a }{'order'}
+ <=>
$result->{'tables'}{ $b }{'order'}
} keys %{ $result->{'tables'} };
for my $table_name ( @tables ) {
my $tdata = $result->{'tables'}{ $table_name };
next unless $tdata->{'table_name'};
- my $table = $schema->add_table(
+ my $table = $schema->add_table(
name => $tdata->{'table_name'},
comments => $tdata->{'comments'},
) or die $schema->error;
$table->options( $tdata->{'table_options'} );
- my @fields = sort {
- $tdata->{'fields'}->{$a}->{'order'}
+ my @fields = sort {
+ $tdata->{'fields'}->{$a}->{'order'}
<=>
$tdata->{'fields'}->{$b}->{'order'}
} keys %{ $tdata->{'fields'} };
}
push @{ $tdata->{'indices'} }, @{ $indices->{ $table_name } || [] };
- push @{ $tdata->{'constraints'} },
+ push @{ $tdata->{'constraints'} },
@{ $constraints->{ $table_name } || [] };
for my $idata ( @{ $tdata->{'indices'} || [] } ) {
reference_table => $cdata->{'reference_table'},
reference_fields => $cdata->{'reference_fields'},
match_type => $cdata->{'match_type'} || '',
- on_delete => $cdata->{'on_delete'}
+ on_delete => $cdata->{'on_delete'}
|| $cdata->{'on_delete_do'},
- on_update => $cdata->{'on_update'}
+ on_update => $cdata->{'on_update'}
|| $cdata->{'on_update_do'},
) or die $table->error;
}
}
-
- my @procedures = sort {
+
+ my @procedures = sort {
$result->{procedures}->{ $a }->{'order'} <=> $result->{procedures}->{ $b }->{'order'}
} keys %{ $result->{procedures} };
foreach my $proc_name (@procedures) {
- $schema->add_procedure(
- name => $proc_name,
- owner => $result->{procedures}->{$proc_name}->{owner},
- sql => $result->{procedures}->{$proc_name}->{sql},
- );
+ $schema->add_procedure(
+ name => $proc_name,
+ owner => $result->{procedures}->{$proc_name}->{owner},
+ sql => $result->{procedures}->{$proc_name}->{sql},
+ );
}
- my @views = sort {
+ my @views = sort {
$result->{views}->{ $a }->{'order'} <=> $result->{views}->{ $b }->{'order'}
} keys %{ $result->{views} };
foreach my $view_name (keys %{ $result->{views} }) {
- $schema->add_view(
- name => $view_name,
- sql => $result->{views}->{$view_name}->{sql},
- );
+ $schema->add_view(
+ name => $view_name,
+ sql => $result->{views}->{$view_name}->{sql},
+ );
}
return 1;
=head1 DESCRIPTION
-The grammar was started from the MySQL parsers. Here is the description
+The grammar was started from the MySQL parsers. Here is the description
from PostgreSQL:
Table:
(http://www.postgresql.org/docs/view.php?version=7.3&idoc=1&file=sql-createtable.html)
CREATE [ [ LOCAL ] { TEMPORARY | TEMP } ] TABLE table_name (
- { column_name data_type [ DEFAULT default_expr ]
+ { column_name data_type [ DEFAULT default_expr ]
[ column_constraint [, ... ] ]
| table_constraint } [, ... ]
)
[ INHERITS ( parent_table [, ... ] ) ]
[ WITH OIDS | WITHOUT OIDS ]
-
+
where column_constraint is:
-
+
[ CONSTRAINT constraint_name ]
{ NOT NULL | NULL | UNIQUE | PRIMARY KEY |
CHECK (expression) |
REFERENCES reftable [ ( refcolumn ) ] [ MATCH FULL | MATCH PARTIAL ]
[ ON DELETE action ] [ ON UPDATE action ] }
- [ DEFERRABLE | NOT DEFERRABLE ]
+ [ DEFERRABLE | NOT DEFERRABLE ]
[ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
-
+
and table_constraint is:
-
+
[ CONSTRAINT constraint_name ]
{ UNIQUE ( column_name [, ... ] ) |
PRIMARY KEY ( column_name [, ... ] ) |
CHECK ( expression ) |
- FOREIGN KEY ( column_name [, ... ] )
+ FOREIGN KEY ( column_name [, ... ] )
REFERENCES reftable [ ( refcolumn [, ... ] ) ]
- [ MATCH FULL | MATCH PARTIAL ]
+ [ MATCH FULL | MATCH PARTIAL ]
[ ON DELETE action ] [ ON UPDATE action ] }
- [ DEFERRABLE | NOT DEFERRABLE ]
+ [ DEFERRABLE | NOT DEFERRABLE ]
[ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
Index:
RENAME TO new_table
ALTER TABLE table
ADD table_constraint_definition
- ALTER TABLE [ ONLY ] table
+ ALTER TABLE [ ONLY ] table
DROP CONSTRAINT constraint { RESTRICT | CASCADE }
ALTER TABLE table
- OWNER TO new_owner
+ OWNER TO new_owner
View table:
#
# The "eofile" rule makes the parser fail if any "statement" rule
-# fails. Otherwise, the first successful match by a "statement"
+# fails. Otherwise, the first successful match by a "statement"
# won't cause the failure needed to know that the parse, as a whole,
# failed. -ky
#
startrule : statement(s) eofile { { tables => \%tables, views => \@views } }
eofile : /^\Z/
-
+
statement : create
| comment_on_table
drop : /drop/i /[^;]*/ ';'
string :
- /'(\\.|''|[^\\\'])*'/
+ /'(\\.|''|[^\\\'])*'/
nonstring : /[^;\'"]+/
for my $definition ( @{ $item[6] } ) {
if ( $definition->{'supertype'} eq 'field' ) {
my $field_name = $definition->{'name'};
- $tables{ $table_name }{'fields'}{ $field_name } =
+ $tables{ $table_name }{'fields'}{ $field_name } =
{ %$definition, order => $field_order++ };
-
+
for my $constraint ( @{ $definition->{'constraints'} || [] } ) {
$constraint->{'fields'} = [ $field_name ];
push @{ $tables{ $table_name }{'constraints'} },
}
for my $option ( @{ $item[8] } ) {
- $tables{ $table_name }{'table_options(s?)'}{ $option->{'type'} } =
+ $tables{ $table_name }{'table_options(s?)'}{ $option->{'type'} } =
$option;
}
| table_constraint
| <error>
-comment : /^\s*(?:#|-{2})(.*)\n/
- {
+comment : /^\s*(?:#|-{2})(.*)\n/
+ {
my $comment = $item[1];
$comment =~ s/^\s*(#|-*)\s*//;
$comment =~ s/\s*$//;
my $table_name = $item[4]->{'table'};
my $field_name = $item[4]->{'field'};
if ($tables{ $table_name }{'fields'}{ $field_name } ) {
- push @{ $tables{ $table_name }{'fields'}{ $field_name }{'comments'} },
+ push @{ $tables{ $table_name }{'fields'}{ $field_name }{'comments'} },
$item{'comment_phrase'};
}
else {
{ $return = $item[1] }
-xxxcomment_phrase : /'.*?'|NULL/
- {
+xxxcomment_phrase : /'.*?'|NULL/
+ {
my $val = $item[1] || '';
$val =~ s/^'|'$//g;
$return = $val;
$return = {
supertype => 'field',
- name => $item{'field_name'},
+ name => $item{'field_name'},
data_type => $item{'data_type'}{'type'},
size => $item{'data_type'}{'size'},
is_nullable => $is_nullable,
comments => [ @comments ],
is_primary_key => $is_pk || 0,
is_auto_increment => $item{'data_type'}{'is_auto_increment'},
- }
+ }
}
| <error>
-field_comment : /^\s*(?:#|-{2})(.*)\n/
- {
+field_comment : /^\s*(?:#|-{2})(.*)\n/
+ {
my $comment = $item[1];
$comment =~ s/^\s*(#|-*)\s*//;
$comment =~ s/\s*$//;
match_type => $desc->{'match_type'},
on_delete => $desc->{'on_delete'} || $desc->{'on_delete_do'},
on_update => $desc->{'on_update'} || $desc->{'on_update_do'},
- }
+ }
}
constraint_name : /constraint/i name_with_opt_quotes { $item[2] }
/unique/i
{ $return = { type => 'unique' } }
|
- /primary key/i
+ /primary key/i
{ $return = { type => 'primary_key' } }
|
- /check/i '(' /[^)]+/ ')'
+ /check/i '(' /[^)]+/ ')'
{ $return = { type => 'check', expression => $item[3] } }
|
/references/i table_id parens_word_list(?) match_type(?) key_action(s?)
$return = "$item[2] $item[3]"
}
-view_target_spec :
+view_target_spec :
schema_qualification : name_with_opt_quotes '.'
index_name : name_with_opt_quotes
data_type : pg_data_type parens_value_list(?)
- {
+ {
my $data_type = $item[1];
#
pg_data_type :
/(bigint|int8)/i
- {
- $return = {
+ {
+ $return = {
type => 'integer',
size => 20,
};
}
|
/(smallint|int2)/i
- {
+ {
$return = {
- type => 'integer',
+ type => 'integer',
size => 5,
};
}
}
|
/(integer|int4?)/i # interval must come before this
- {
+ {
$return = {
- type => 'integer',
+ type => 'integer',
size => 10,
};
}
- |
+ |
/(real|float4)/i
- {
+ {
$return = {
- type => 'real',
+ type => 'real',
size => 10,
};
}
|
/(double precision|float8?)/i
- {
+ {
$return = {
- type => 'float',
+ type => 'float',
size => 20,
- };
+ };
}
|
/(bigserial|serial8)/i
- {
- $return = {
- type => 'integer',
- size => 20,
+ {
+ $return = {
+ type => 'integer',
+ size => 20,
is_auto_increment => 1,
};
}
|
/serial4?/i
- {
- $return = {
+ {
+ $return = {
type => 'integer',
- size => 11,
+ size => 11,
is_auto_increment => 1,
};
}
|
/(bit varying|varbit)/i
- {
+ {
$return = { type => 'varbit' };
}
|
/character varying/i
- {
+ {
$return = { type => 'varchar' };
}
|
/char(acter)?/i
- {
+ {
$return = { type => 'char' };
}
|
/bool(ean)?/i
- {
+ {
$return = { type => 'boolean' };
}
|
/bytea/i
- {
+ {
$return = { type => 'bytea' };
}
|
/(timestamptz|timestamp)(?:\(\d\))?( with(?:out)? time zone)?/i
- {
+ {
$return = { type => 'timestamp' . ($2||'') };
}
|
/text/i
- {
- $return = {
+ {
+ $return = {
type => 'text',
size => 64_000,
};
}
|
/(bit|box|cidr|circle|date|inet|line|lseg|macaddr|money|numeric|decimal|path|point|polygon|timetz|time|varchar)/i
- {
+ {
$return = { type => $item[1] };
}
on_delete => $desc->{'on_delete'} || $desc->{'on_delete_do'},
on_update => $desc->{'on_update'} || $desc->{'on_update_do'},
comments => [ @comments ],
- }
+ }
}
-table_constraint_type : /primary key/i '(' name_with_opt_quotes(s /,/) ')'
- {
+table_constraint_type : /primary key/i '(' name_with_opt_quotes(s /,/) ')'
+ {
$return = {
type => 'primary_key',
fields => $item[3],
}
}
|
- /unique/i '(' name_with_opt_quotes(s /,/) ')'
- {
+ /unique/i '(' name_with_opt_quotes(s /,/) ')'
+ {
$return = {
type => 'unique',
fields => $item[3],
}
}
|
- /check/i '(' /[^)]+/ ')'
+ /check/i '(' /[^)]+/ ')'
{
$return = {
type => 'check',
$on_delete = $action->{'action'} if $action->{'type'} eq 'delete';
$on_update = $action->{'action'} if $action->{'type'} eq 'update';
}
-
+
$return = {
supertype => 'constraint',
type => 'foreign_key',
}
}
-deferrable : not(?) /deferrable/i
- {
+deferrable : not(?) /deferrable/i
+ {
$return = ( $item[1] =~ /not/i ) ? 0 : 1;
}
match_type : /match/i /partial|full|simple/i { $item[2] }
-key_action : key_delete
+key_action : key_delete
|
key_update
key_delete : /on delete/i key_mutation
- {
- $return = {
+ {
+ $return = {
type => 'delete',
action => $item[2],
};
}
key_update : /on update/i key_mutation
- {
- $return = {
+ {
+ $return = {
type => 'update',
action => $item[2],
};
|
/set default/i { $return = 'set default' }
-alter : alter_table table_id add_column field ';'
- {
+alter : alter_table table_id add_column field ';'
+ {
my $field_def = $item[4];
$tables{ $item[2]->{'table_name'} }{'fields'}{ $field_def->{'name'} } = {
%$field_def, order => $field_order++
1;
}
-alter : alter_table table_id ADD table_constraint ';'
- {
+alter : alter_table table_id ADD table_constraint ';'
+ {
my $table_name = $item[2]->{'table_name'};
my $constraint = $item[4];
push @{ $tables{ $table_name }{'constraints'} }, $constraint;
1;
}
-alter : alter_table table_id drop_column NAME restrict_or_cascade(?) ';'
+alter : alter_table table_id drop_column NAME restrict_or_cascade(?) ';'
{
$tables{ $item[2]->{'table_name'} }{'fields'}{ $item[4] }{'drop'} = 1;
1;
}
-alter : alter_table table_id alter_column NAME alter_default_val ';'
+alter : alter_table table_id alter_column NAME alter_default_val ';'
{
- $tables{ $item[2]->{'table_name'} }{'fields'}{ $item[4] }{'default'} =
+ $tables{ $item[2]->{'table_name'} }{'fields'}{ $item[4] }{'default'} =
$item[5]->{'value'};
1;
}
alter : alter_table table_id /rename/i /to/i NAME ';'
{ 1 }
-alter : alter_table table_id alter_column NAME SET /statistics/i INTEGER ';'
+alter : alter_table table_id alter_column NAME SET /statistics/i INTEGER ';'
{ 1 }
alter : alter_table table_id alter_column NAME SET /storage/i storage_type ';'
or_replace : /or replace/i
-alter_default_val : SET default_val
- {
- $return = { value => $item[2]->{'value'} }
+alter_default_val : SET default_val
+ {
+ $return = { value => $item[2]->{'value'} }
+ }
+ | DROP DEFAULT
+ {
+ $return = { value => undef }
}
- | DROP DEFAULT
- {
- $return = { value => undef }
- }
#
-# This is a little tricky to get right, at least WRT to making the
+# This is a little tricky to get right, at least WRT to making the
# tests pass. The problem is that the constraints are stored just as
# a list (no name access), and the tests expect the constraints in a
-# particular order. I'm going to leave the rule but disable the code
+# particular order. I'm going to leave the rule but disable the code
# for now. - ky
#
alter : alter_table table_id alter_column NAME alter_nullable ';'
# my $field_name = $item[4];
# my $is_nullable = $item[5]->{'is_nullable'};
#
-# $tables{ $table_name }{'fields'}{ $field_name }{'is_nullable'} =
+# $tables{ $table_name }{'fields'}{ $field_name }{'is_nullable'} =
# $is_nullable;
#
# if ( $is_nullable ) {
# };
# }
# else {
-# for my $i (
-# 0 .. $#{ $tables{ $table_name }{'constraints'} || [] }
+# for my $i (
+# 0 .. $#{ $tables{ $table_name }{'constraints'} || [] }
# ) {
# my $c = $tables{ $table_name }{'constraints'}[ $i ] or next;
# my $fields = join( '', @{ $c->{'fields'} || [] } ) or next;
1;
}
-alter_nullable : SET not_null
- {
- $return = { is_nullable => 0 }
+alter_nullable : SET not_null
+ {
+ $return = { is_nullable => 0 }
}
| DROP not_null
- {
- $return = { is_nullable => 1 }
+ {
+ $return = { is_nullable => 1 }
}
not_null : /not/i /null/i
alter_table : ALTER TABLE ONLY(?)
-alter_sequence : ALTER SEQUENCE
+alter_sequence : ALTER SEQUENCE
drop_column : DROP COLUMN(?)
rename_column : /rename/i COLUMN(?)
-restrict_or_cascade : /restrict/i |
+restrict_or_cascade : /restrict/i |
/cascade/i
# Handle functions that can be called
-select : SELECT select_function ';'
+select : SELECT select_function ';'
{ 1 }
# Read the setval function but don't do anything with it because this parser
# isn't handling sequences
-select_function : schema_qualification(?) /setval/i '(' VALUE /,/ VALUE /,/ /(true|false)/i ')'
+select_function : schema_qualification(?) /setval/i '(' VALUE /,/ VALUE /,/ /(true|false)/i ')'
{ 1 }
# Skipping all COPY commands
create_index : CREATE /index/i
default_val : DEFAULT /(\d+|'[^']*'|\w+\(.*\))|\w+/
- {
+ {
my $val = defined $item[2] ? $item[2] : '';
- $val =~ s/^'|'$//g;
+ $val =~ s/^'|'$//g;
$return = {
supertype => 'constraint',
type => 'default',
}
}
| /null/i
- {
+ {
$return = {
supertype => 'constraint',
type => 'default',
key : /key/i | /index/i
table_option : /inherits/i '(' name_with_opt_quotes(s /,/) ')'
- {
+ {
$return = { type => 'inherits', table_name => $item[3] }
}
|
warn Dumper($result) if $DEBUG;
my $schema = $translator->schema;
- my @tables = sort {
+ my @tables = sort {
( $result->{tables}{ $a }{'order'} || 0 ) <=> ( $result->{tables}{ $b }{'order'} || 0 )
} keys %{ $result->{tables} };
for my $table_name ( @tables ) {
my $tdata = $result->{tables}{ $table_name };
- my $table = $schema->add_table(
+ my $table = $schema->add_table(
#schema => $tdata->{'schema_name'},
name => $tdata->{'table_name'},
) or die "Couldn't create table '$table_name': " . $schema->error;
$table->comments( $tdata->{'comments'} );
- my @fields = sort {
- $tdata->{'fields'}{ $a }{'order'}
+ my @fields = sort {
+ $tdata->{'fields'}{ $a }{'order'}
<=>
$tdata->{'fields'}{ $b }{'order'}
} keys %{ $tdata->{'fields'} };
on_update => $cdata->{'on_update'} || $cdata->{'on_update_do'},
expression => $cdata->{'expression'},
) or die "Can't add constraint of type '" .
- $cdata->{'type'} . "' to table '" . $table->name .
+ $cdata->{'type'} . "' to table '" . $table->name .
"': " . $table->error;
}
}
# -------------------------------------------------------------------
# Rescue the drowning and tie your shoestrings.
-# Henry David Thoreau
+# Henry David Thoreau
# -------------------------------------------------------------------
=pod
=head1 DESCRIPTION
-This is a grammar for parsing CREATE statements for SQLite as
+This is a grammar for parsing CREATE statements for SQLite as
described here:
http://www.sqlite.org/lang.html
CREATE INDEX
sql-statement ::=
- CREATE [TEMP | TEMPORARY] [UNIQUE] INDEX index-name
+ CREATE [TEMP | TEMPORARY] [UNIQUE] INDEX index-name
ON [database-name .] table-name ( column-name [, column-name]* )
[ ON CONFLICT conflict-algorithm ]
trigger-action
database-event ::=
- DELETE |
- INSERT |
- UPDATE |
+ DELETE |
+ INSERT |
+ UPDATE |
UPDATE OF column-list
trigger-action ::=
- [ FOR EACH ROW | FOR EACH STATEMENT ] [ WHEN expression ]
- BEGIN
+ [ FOR EACH ROW | FOR EACH STATEMENT ] [ WHEN expression ]
+ BEGIN
trigger-step ; [ trigger-step ; ]*
END
trigger-step ::=
- update-statement | insert-statement |
+ update-statement | insert-statement |
delete-statement | select-statement
CREATE VIEW
$GRAMMAR = q!
-{
+{
my ( %tables, $table_order, @table_comments, @views, @triggers );
}
#
# The "eofile" rule makes the parser fail if any "statement" rule
-# fails. Otherwise, the first successful match by a "statement"
+# fails. Otherwise, the first successful match by a "statement"
# won't cause the failure needed to know that the parse, as a whole,
# failed. -ky
#
-startrule : statement(s) eofile {
+startrule : statement(s) eofile {
$return = {
- tables => \%tables,
+ tables => \%tables,
views => \@views,
triggers => \@triggers,
}
$return = $comment;
}
-comment : /\/\*/ /[^\*]+/ /\*\//
+comment : /\/\*/ /[^\*]+/ /\*\//
{
my $comment = $item[2];
$comment =~ s/^\s*|\s*$//g;
my $db_name = $item[7]->{'db_name'} || '';
my $table_name = $item[7]->{'name'};
- my $index = {
+ my $index = {
name => $item[5],
fields => $item[8],
on_conflict => $item[9][0],
}
}
-definition : constraint_def | column_def
+definition : constraint_def | column_def
column_def: comment(s?) NAME type(?) column_constraint_def(s?)
{
$return = {
type => 'primary_key',
sort_order => $item[2][0],
- on_conflict => $item[2][0],
+ on_conflict => $item[2][0],
}
}
|
{
$return = {
type => 'unique',
- on_conflict => $item[2][0],
+ on_conflict => $item[2][0],
}
}
|
$return = {
type => 'check',
expression => $item[3],
- on_conflict => $item[5][0],
+ on_conflict => $item[5][0],
}
}
|
{ $return = { reference_table => $1, reference_fields => $2 } }
table_name : qualified_name
-
-qualified_name : NAME
+
+qualified_name : NAME
{ $return = { name => $item[1] } }
-qualified_name : /(\w+)\.(\w+)/
+qualified_name : /(\w+)\.(\w+)/
{ $return = { db_name => $1, name => $2 } }
field_name : NAME
when : WHEN expr { $item[2] }
string :
- /'(\\.|''|[^\\\'])*'/
+ /'(\\.|''|[^\\\'])*'/
nonstring : /[^;\'"]+/
trigger_step : /(select|delete|insert|update)/i statement_body(s?) SEMICOLON
{
$return = join( ' ', $item[1], join ' ', @{ $item[2] || [] } )
- }
+ }
before_or_after : /(before|after)/i { $return = lc $1 }
#
# Create View
#
-create : CREATE TEMPORARY(?) VIEW view_name AS select_statement
+create : CREATE TEMPORARY(?) VIEW view_name AS select_statement
{
push @views, {
name => $item[4]->{'name'},
- sql => $item[6],
+ sql => $item[6],
is_temporary => $item[2][0] ? 1 : 0,
}
}
VALUE : /[-+]?\.?\d+(?:[eE]\d+)?/
{ $item[1] }
- | /'.*?'/
- {
- # remove leading/trailing quotes
+ | /'.*?'/
+ {
+ # remove leading/trailing quotes
my $val = $item[1];
$val =~ s/^['"]|['"]$//g;
$return = $val;
warn Dumper( $result ) if $DEBUG;
my $schema = $translator->schema;
- my @tables =
+ my @tables =
map { $_->[1] }
- sort { $a->[0] <=> $b->[0] }
+ sort { $a->[0] <=> $b->[0] }
map { [ $result->{'tables'}{ $_ }->{'order'}, $_ ] }
keys %{ $result->{'tables'} };
for my $table_name ( @tables ) {
my $tdata = $result->{'tables'}{ $table_name };
- my $table = $schema->add_table(
+ my $table = $schema->add_table(
name => $tdata->{'name'},
) or die $schema->error;
reference_table => $cdata->{'reference_table'},
reference_fields => $cdata->{'reference_fields'},
match_type => $cdata->{'match_type'} || '',
- on_delete => $cdata->{'on_delete'}
+ on_delete => $cdata->{'on_delete'}
|| $cdata->{'on_delete_do'},
- on_update => $cdata->{'on_update'}
+ on_update => $cdata->{'on_update'}
|| $cdata->{'on_update_do'},
) or die $table->error;
}
$GRAMMAR = q{
-{
+{
my ( %tables, @table_comments, $table_order );
}
| exec
| <error>
-use : /use/i WORD GO
+use : /use/i WORD GO
{ @table_comments = () }
setuser : /setuser/i NAME GO
exec_statement : /exec/i /[^\n]+/
comment : comment_start comment_middle comment_end
- {
+ {
my $comment = $item[2];
$comment =~ s/^\s*|\s*$//mg;
$comment =~ s/^\**\s*//mg;
# Create table.
#
create_table : /create/i /table/i ident '(' create_def(s /,/) ')' lock(?) on_system(?) GO
- {
+ {
my $table_owner = $item[3]{'owner'};
my $table_name = $item[3]{'name'};
for my $def ( @{ $item[5] } ) {
if ( $def->{'supertype'} eq 'field' ) {
my $field_name = $def->{'name'};
- $tables{ $table_name }{'fields'}{ $field_name } =
+ $tables{ $table_name }{'fields'}{ $field_name } =
{ %$def, order => $i };
$i++;
-
+
if ( $def->{'is_primary_key'} ) {
push @{ $tables{ $table_name }{'constraints'} }, {
type => 'primary_key',
}
}
-create_constraint : /create/i constraint
+create_constraint : /create/i constraint
{
@table_comments = ();
push @{ $tables{ $item[2]{'table'} }{'constraints'} }, $item[2];
blank : /\s*/
-field : field_name data_type nullable(?)
- {
- $return = {
+field : field_name data_type nullable(?)
+ {
+ $return = {
supertype => 'field',
- name => $item{'field_name'},
+ name => $item{'field_name'},
data_type => $item{'data_type'}{'type'},
size => $item{'data_type'}{'size'},
- nullable => $item[3][0],
-# default => $item{'default_val'}[0],
-# is_auto_inc => $item{'auto_inc'}[0],
-# is_primary_key => $item{'primary_key'}[0],
- }
+ nullable => $item[3][0],
+# default => $item{'default_val'}[0],
+# is_auto_inc => $item{'auto_inc'}[0],
+# is_primary_key => $item{'primary_key'}[0],
+ }
}
constraint : primary_key_constraint
table_name : WORD
-data_type : WORD field_size(?)
- {
- $return = {
- type => $item[1],
+data_type : WORD field_size(?)
+ {
+ $return = {
+ type => $item[1],
size => $item[2][0]
- }
+ }
}
lock : /lock/i /datarows/i
| /null/i
{ $return = 1 }
-default_val : /default/i /(?:')?[\w\d.-]*(?:')?/
+default_val : /default/i /(?:')?[\w\d.-]*(?:')?/
{ $item[2]=~s/'//g; $return=$item[2] }
auto_inc : /auto_increment/i { 1 }
-primary_key_constraint : /primary/i /key/i index_name(?) parens_field_list
- {
- $return = {
+primary_key_constraint : /primary/i /key/i index_name(?) parens_field_list
+ {
+ $return = {
supertype => 'constraint',
name => $item{'index_name'}[0],
type => 'primary_key',
fields => $item[4],
- }
+ }
}
unique_constraint : /unique/i clustered(?) INDEX(?) index_name(?) on_table(?) parens_field_list
- {
- $return = {
+ {
+ $return = {
supertype => 'constraint',
type => 'unique',
clustered => $item[2][0],
name => $item[4][0],
table => $item[5][0],
fields => $item[6],
- }
+ }
}
clustered : /clustered/i
{ $return = 1 }
index : clustered(?) INDEX index_name(?) on_table(?) parens_field_list
- {
- $return = {
+ {
+ $return = {
supertype => 'index',
type => 'normal',
clustered => $item[1][0],
name => $item[3][0],
table => $item[4][0],
fields => $item[5],
- }
+ }
}
parens_field_list : '(' field_name(s /,/) ')'
warn Dumper( $result ) if $DEBUG;
my $schema = $translator->schema;
- my @tables = sort {
+ my @tables = sort {
$result->{ $a }->{'order'} <=> $result->{ $b }->{'order'}
} keys %{ $result };
for my $table_name ( @tables ) {
my $tdata = $result->{ $table_name };
- my $table = $schema->add_table( name => $tdata->{'name'} )
+ my $table = $schema->add_table( name => $tdata->{'name'} )
or die "Can't create table '$table_name': ", $schema->error;
$table->comments( $tdata->{'comments'} );
- my @fields = sort {
- $tdata->{'fields'}->{$a}->{'order'}
+ my @fields = sort {
+ $tdata->{'fields'}->{$a}->{'order'}
<=>
$tdata->{'fields'}->{$b}->{'order'}
} keys %{ $tdata->{'fields'} };
$table->add_index( %data ) or die $table->error;
}
-
+
#
# Comments
#
#
# Tables
#
- my @tables =
+ my @tables =
map { $data->{'tables'}{ $_->[1] } }
sort { $a->[0] <=> $b->[0] }
map { [ $data->{'tables'}{ $_ }{'order'} || 0, $_ ] }
;
for my $tdata ( @tables ) {
-
+
my $table = $schema->add_table(
map {
$tdata->{$_} ? ($_ => $tdata->{$_}) : ()
} (qw/name extra options/)
) or die $schema->error;
- my @fields =
+ my @fields =
map { $tdata->{'fields'}{ $_->[1] } }
sort { $a->[0] <=> $b->[0] }
map { [ $tdata->{'fields'}{ $_ }{'order'}, $_ ] }
for my $fdata ( @fields ) {
$table->add_field( %$fdata ) or die $table->error;
- $table->primary_key( $fdata->{'name'} )
+ $table->primary_key( $fdata->{'name'} )
if $fdata->{'is_primary_key'};
}
#
# Views
#
- my @views =
+ my @views =
map { $data->{'views'}{ $_->[1] } }
sort { $a->[0] <=> $b->[0] }
map { [ $data->{'views'}{ $_ }{'order'}, $_ ] }
#
# Triggers
#
- my @triggers =
+ my @triggers =
map { $data->{'triggers'}{ $_->[1] } }
sort { $a->[0] <=> $b->[0] }
map { [ $data->{'triggers'}{ $_ }{'order'}, $_ ] }
#
# Procedures
#
- my @procedures =
+ my @procedures =
map { $data->{'procedures'}{ $_->[1] } }
sort { $a->[0] <=> $b->[0] }
map { [ $data->{'procedures'}{ $_ }{'order'}, $_ ] }
=head1 DESCRIPTION
-Parses arbitrarily delimited text files. See the
+Parses arbitrarily delimited text files. See the
Text::RecordParser manpage for arguments on how to parse the file
(e.g., C<field_separator>, C<record_separator>). Other arguments
include:
=item * trim_fields
-A shortcut to sending filters to Text::RecordParser, will create
+A shortcut to sending filters to Text::RecordParser, will create
callbacks that trim leading and trailing spaces from fields and headers.
True by default.
=back
-Field names will automatically be normalized by
+Field names will automatically be normalized by
C<SQL::Translator::Utils::normalize_name>.
=cut
header_filter => \&normalize_name,
);
- $parser->field_filter( sub { $_ = shift || ''; s/^\s+|\s+$//g; $_ } )
+ $parser->field_filter( sub { $_ = shift || ''; s/^\s+|\s+$//g; $_ } )
unless defined $args->{'trim_fields'} && $args->{'trim_fields'} == 0;
my $schema = $tr->schema;
#
# If directed, look at every field's values to guess size and type.
#
- unless (
+ unless (
defined $args->{'scan_fields'} &&
$args->{'scan_fields'} == 0
) {
if ( $data =~ /^-?\d+$/ ) {
$type = 'integer';
}
- elsif (
- $data =~ /^-?[,\d]+\.[\d+]?$/
+ elsif (
+ $data =~ /^-?[,\d]+\.[\d+]?$/
||
- $data =~ /^-?[,\d]+?\.\d+$/
+ $data =~ /^-?[,\d]+?\.\d+$/
||
- $data =~ /^-?\.\d+$/
+ $data =~ /^-?\.\d+$/
) {
$type = 'float';
- my ( $w, $d ) =
+ my ( $w, $d ) =
map { s/,//g; length $_ || 1 } split( /\./, $data );
$size = [ $w + $d, $d ];
}
for my $field ( keys %field_info ) {
my $size = $field_info{ $field }{'size'} || [ 1 ];
- my $data_type =
- $field_info{ $field }{'char'} ? 'char' :
+ my $data_type =
+ $field_info{ $field }{'char'} ? 'char' :
$field_info{ $field }{'float'} ? 'float' :
$field_info{ $field }{'integer'} ? 'integer' : 'char';
Producer modules designed to be used with SQL::Translator need to
implement a single function, called B<produce>. B<produce> will be
-called with the SQL::Translator object from which it is expected to
-retrieve the SQL::Translator::Schema object which has been populated
+called with the SQL::Translator object from which it is expected to
+retrieve the SQL::Translator::Schema object which has been populated
by the parser. It is expected to return a string.
=head1 METHODS
my $header = header_comment( __PACKAGE__, "# " );
my $parser_type = ( split /::/, $t->parser_type )[-1];
my $from = $CDBI_auto_pkgs{$parser_type} || '';
- my $dsn = $args->{'dsn'} || sprintf( 'dbi:%s:_',
- $CDBI_auto_pkgs{ $parser_type }
- ? $CDBI_auto_pkgs{ $parser_type } : $parser_type
+ my $dsn = $args->{'dsn'} || sprintf( 'dbi:%s:_',
+ $CDBI_auto_pkgs{ $parser_type }
+ ? $CDBI_auto_pkgs{ $parser_type } : $parser_type
);
my $sep = '# ' . '-' x 67;
{
next unless $field->is_foreign_key;
- next unless (
+ next unless (
$field->foreign_key_reference->reference_table eq
$table_name
- ||
- $field->foreign_key_reference->reference_table eq $link
+ ||
+ $field->foreign_key_reference->reference_table eq $link
);
push @lk_fields,
my $table_name = $table->name;
my $field_name = $field->name;
# my $fk_method = $t->format_fk_name( $table_name, $field_name );
- my $fk_method = join('::', $table_pkg_name,
+ my $fk_method = join('::', $table_pkg_name,
$t->format_fk_name( $table_name, $field_name )
);
my $fk = $field->foreign_key_reference;
else {
my $table = $schema->get_table( $pkg->{'table'} );
my @field_names = map { $_->name } $table->get_fields;
-
+
push @create, join("\n",
$pkg_name."->table('".$pkg->{'table'}."');\n",
$pkg_name."->columns(All => qw/".
DEFAULTS KEY RENAME YEAR
DEFINITION LABEL REPEAT YEARS
DELETE LANGUAGE RESET
-DESCRIPTOR LC_CTYPE RESIGNAL
+DESCRIPTOR LC_CTYPE RESIGNAL
/;
#------------------------------------------------------------------------------
push @index_defs, create_index($index);
}
- }
+ }
my (@view_defs);
foreach my $view ( $schema->get_views )
{
if(length($name) > $length) ## Maximum table name length is 18
{
warn "Table name $name is longer than $length characters, truncated" if $WARN;
-# if(grep {$_ eq substr($name, 0, $length) }
+# if(grep {$_ eq substr($name, 0, $length) }
# values(%{$objnames{$type}}))
# {
# die "Got multiple matching table names when truncated";
{
my ($table, $options) = @_;
- my $table_name = check_name($table->name, 'tables', 128);
+ my $table_name = check_name($table->name, 'tables', 128);
# this limit is 18 in older DB2s ! (<= 8)
my (@field_defs, @comments);
sub create_field
{
my ($field) = @_;
-
+
my $field_name = check_name($field->name, 'fields', 30);
# use Data::Dumper;
# print Dumper(\%dt_translate);
my $size = $field->size();
my $field_def = "$field_name $data_type";
- $field_def .= $field->is_auto_increment ?
+ $field_def .= $field->is_auto_increment ?
' GENERATED BY DEFAULT AS IDENTITY (START WITH 1, INCREMENT BY 1)' : '';
$field_def .= $data_type =~ /(CHAR|CLOB|NUMERIC|DECIMAL)/i ? "(${size})" : '';
$field_def .= !$field->is_nullable ? ' NOT NULL':'';
# $field_def .= $field->is_primary_key ? ' PRIMARY KEY':'';
- $field_def .= !defined $field->default_value ? '' :
+ $field_def .= !defined $field->default_value ? '' :
$field->default_value =~ /current( |_)timestamp/i ||
- $field->default_value =~ /\Qnow()\E/i ?
+ $field->default_value =~ /\Qnow()\E/i ?
' DEFAULT CURRENT TIMESTAMP' : defined $field->default_value ?
- (" DEFAULT " . ($data_type =~ /(INT|DOUBLE)/i ?
+ (" DEFAULT " . ($data_type =~ /(INT|DOUBLE)/i ?
$field->default_value : "'" . $field->default_value . "'")
) : '';
}
return \@con_defs, \@fks;
-
+
}
sub create_view
my $out = sprintf('CREATE TRIGGER %s %s %s ON %s %s %s MODE DB2SQL %s',
$trigger->name,
$trigger->perform_action_when || 'AFTER',
- $db_events =~ /update_on/i ?
+ $db_events =~ /update_on/i ?
('UPDATE OF '. join(', ', $trigger->fields)) :
$db_events || 'UPDATE',
$trigger->table->name,
$trigger->action );
return $out;
-
+
}
sub alter_field
use SQL::Translator;
- my $t = SQL::Translator->new(
- from => 'MySQL',
+ my $t = SQL::Translator->new(
+ from => 'MySQL',
to => 'GraphViz',
producer_args => {
# All args are optional
skip_fields => $args->{'skip_fields'},
);
- my $g = $schema->as_graph_pm;
+ my $g = $schema->as_graph_pm;
my $d = Graph::Traversal::DFS->new( $g, next_alphabetic => 1 );
$d->preorder;
- @table_names = $d->dfs;
+ @table_names = $d->dfs;
}
else {
@table_names = map { $_->name } $schema->get_tables;
# Layout the image.
#
my $font
- = $font_size eq 'small' ? gdTinyFont
- : $font_size eq 'medium' ? gdSmallFont
- : $font_size eq 'large' ? gdLargeFont
+ = $font_size eq 'small' ? gdTinyFont
+ : $font_size eq 'medium' ? gdSmallFont
+ : $font_size eq 'large' ? gdLargeFont
: gdGiantFont;
my $num_tables = scalar @table_names;
$num_columns ||= .5;
my $no_per_col = sprintf( "%.0f", $num_tables/$num_columns + .5 );
- my @shapes;
+ my @shapes;
my ( $max_x, $max_y ); # the furthest x and y used
my $orig_y = 40; # used to reset y for each column
my ( $x, $y ) = (30,$orig_y); # where to start
}
my $top = $y;
- push @shapes,
+ push @shapes,
[ 'string', $font, $this_col_x, $y, $table_name, 'black' ];
$y += $font->height + 2;
my $below_table_name = $y;
$y += 2;
- my $this_max_x =
+ my $this_max_x =
$this_col_x + ($font->width * length($table_name));
debug("Processing table '$table_name'");
my $desc = $f->data_type;
$desc .= '('.$f->size.')' if $f->size &&
$f->data_type =~ /^(VAR)?CHAR2?$/i;
-
+
my $nlen = length $name;
my $dlen = length $desc;
$max_name = $nlen if $nlen > $max_name;
fld_name => $orig_name,
};
- push @imap_coords, [
+ push @imap_coords, [
$imap_url."#$table_name-$orig_name",
$this_col_x, $y - $font->height, $length, $y_link,
];
$this_max_x += 5;
$table_x{ $table_name } = $this_max_x + 5;
- push @shapes, [ 'line', $this_col_x - 5, $below_table_name,
+ push @shapes, [ 'line', $this_col_x - 5, $below_table_name,
$this_max_x, $below_table_name, 'black' ];
my @bounds = ( $this_col_x - 5, $top - 5, $this_max_x, $y + 5 );
if ( $add_color ) {
- unshift @shapes, [
- 'filledRectangle',
+ unshift @shapes, [
+ 'filledRectangle',
$bounds[0], $bounds[1],
$this_max_x, $below_table_name,
- 'khaki'
+ 'khaki'
];
unshift @shapes, [ 'filledRectangle', @bounds, 'white' ];
}
- push @imap_coords, [
+ push @imap_coords, [
$imap_url."#$table_name",
$bounds[0], $bounds[1], $this_max_x, $below_table_name,
];
push @shapes, [ 'rectangle', @bounds, 'black' ];
$max_x = $this_max_x if $this_max_x > $max_x;
$y += 25;
-
+
if ( ++$no_this_col == $no_per_col ) {# if we've filled up this column
$cur_col++; # up the column number
$no_this_col = 0; # reset the number of tables
if ( $natural_join ) {
for my $field_name ( keys %nj_registry ) {
my @positions;
- my @table_names =
+ my @table_names =
@{ $nj_registry{ $field_name } || [] } or next;
next if scalar @table_names == 1;
}
else {
for my $pair ( @fk_registry ) {
- push @position_bunches, [
+ push @position_bunches, [
$coords{$pair->[0][0]}{ $pair->[0][1] }{'coords'},
$coords{$pair->[1][0]}{ $pair->[1][1] }{'coords'},
];
my $diff = 0;
if ( $x1 == $x2 ) {
while ( $horz_taken{ $x1 + $diff } ) {
- $diff = $side1 eq 'left' ? $diff - 2 : $diff + 2;
+ $diff = $side1 eq 'left' ? $diff - 2 : $diff + 2;
}
$horz_taken{ $x1 + $diff } = 1;
}
if ( $side2 eq 'left' ) {
$end = $x2 - $offset + $diff;
- }
+ }
else {
$end = $col2_right + $diff;
- }
+ }
- push @shapes,
+ push @shapes,
[ 'line', $x1, $y1, $start, $y1, 'cadetblue' ];
- push @shapes,
+ push @shapes,
[ 'line', $start, $y1, $end, $y2, 'cadetblue' ];
- push @shapes,
+ push @shapes,
[ 'line', $end, $y2, $x2, $y2, 'cadetblue' ];
if ( $is_directed ) {
||
$side1 eq 'left' && $side2 eq 'left'
) {
- push @shapes, [
- 'line', $x2 - 3, $y2 - 3, $x2, $y2, 'cadetblue'
+ push @shapes, [
+ 'line', $x2 - 3, $y2 - 3, $x2, $y2, 'cadetblue'
];
- push @shapes, [
- 'line', $x2 - 3, $y2 + 3, $x2, $y2, 'cadetblue'
+ push @shapes, [
+ 'line', $x2 - 3, $y2 + 3, $x2, $y2, 'cadetblue'
];
- push @shapes, [
- 'line', $x2 - 3, $y2 - 3, $x2 - 3, $y2 +3,
- 'cadetblue'
+ push @shapes, [
+ 'line', $x2 - 3, $y2 - 3, $x2 - 3, $y2 +3,
+ 'cadetblue'
];
}
else {
- push @shapes, [
- 'line', $x2 + 3, $y2 - 3, $x2, $y2, 'cadetblue'
+ push @shapes, [
+ 'line', $x2 + 3, $y2 - 3, $x2, $y2, 'cadetblue'
];
- push @shapes, [
- 'line', $x2 + 3, $y2 + 3, $x2, $y2, 'cadetblue'
+ push @shapes, [
+ 'line', $x2 + 3, $y2 + 3, $x2, $y2, 'cadetblue'
];
- push @shapes, [
- 'line', $x2 + 3, $y2 - 3, $x2 + 3, $y2 +3,
- 'cadetblue'
+ push @shapes, [
+ 'line', $x2 + 3, $y2 - 3, $x2 + 3, $y2 +3,
+ 'cadetblue'
];
}
}
#
my $large_font = gdLargeFont;
my $title_len = $large_font->width * length $title;
- push @shapes, [
- 'string', $large_font, $max_x/2 - $title_len/2, 10, $title, 'black'
+ push @shapes, [
+ 'string', $large_font, $max_x/2 - $title_len/2, 10, $title, 'black'
];
if ( %legend ) {
$max_y += 5;
- push @shapes, [
+ push @shapes, [
'string', $font, $x, $max_y - $font->height - 4, 'Legend', 'black'
];
$max_y += $font->height + 4;
my $longest;
for my $len ( map { length $_ } values %legend ) {
- $longest = $len if $len > $longest;
+ $longest = $len if $len > $longest;
}
$longest += 2;
while ( my ( $key, $shape ) = each %legend ) {
my $space = $longest - length $shape;
- push @shapes, [
- 'string', $font, $x, $max_y - $font->height - 4,
+ push @shapes, [
+ 'string', $font, $x, $max_y - $font->height - 4,
join( '', $shape, ' ' x $space, $key ), 'black'
];
my $sig = 'Created by SQL::Translator ' . $t->version;
my $sig_len = $font->width * length $sig;
- push @shapes, [
- 'string', $font, $max_x - $sig_len, $max_y - $font->height - 4,
+ push @shapes, [
+ 'string', $font, $max_x - $sig_len, $max_y - $font->height - 4,
$sig, 'black'
];
for my $rec ( @imap_coords ) {
my $href = shift @$rec;
print $fh q[<area coords="].join(',', @$rec).qq[" href="$href">\n];
- }
+ }
print $fh qq[</body></html>];
close $fh;
}
my $t = shift;
my $args = $t->producer_args;
my $schema = $t->schema;
- my $add_truncate = $args->{'add_truncate'} || 0;
+ my $add_truncate = $args->{'add_truncate'} || 0;
my $skip = $args->{'skip'} || '';
my $skiplike = $args->{'skiplike'} || '';
my $db_user = $args->{'db_user'} || 'db_user';
my $db_pass = $args->{'db_password'} || 'db_pass';
my $parser_name = $t->parser_type;
- my %skip = map { $_, 1 } map { s/^\s+|\s+$//; $_ }
+ my %skip = map { $_, 1 } map { s/^\s+|\s+$//; $_ }
split (/,/, $skip);
my $sqlt_version = $t->version;
- if ( $parser_name =~ /Parser::(\w+)$/ ) {
- $parser_name = $1
+ if ( $parser_name =~ /Parser::(\w+)$/ ) {
+ $parser_name = $1
}
my %type_to_dbd = (
my $template = Template->new;
my $template_text = template();
my $out;
- $template->process(
- \$template_text,
- {
+ $template->process(
+ \$template_text,
+ {
translator => $t,
schema => $schema,
db_user => $db_user,
perl => $Config{'startperl'},
skip => \%skip,
skiplike => $skiplike,
- },
- \$out
+ },
+ \$out
) or die $template->error;
return $out;
use Getopt::Long;
use File::Spec::Functions 'catfile';
-my ( $help, $add_truncate, $skip, $skiplike, $no_comments,
+my ( $help, $add_truncate, $skip, $skiplike, $no_comments,
$takelike, $mysql_loadfile );
GetOptions(
'add-truncate' => \$add_truncate,
types => types,
fields => field_names,
});
-END
+END
-%]
my $db = DBI->connect(
- '[% dsn %]',
- '[% db_user %]',
- '[% db_pass %]',
+ '[% dsn %]',
+ '[% db_user %]',
+ '[% db_pass %]',
{ RaiseError => 1 }
);
my %skip = map { $_, 1 } map { s/^\s+|\s+$//; $_ } split (/,/, $skip);
my ( $out_fh, $outfile );
if ( $mysql_loadfile ) {
$outfile = catfile( cwd(), "$table_name.txt" );
- open $out_fh, ">$outfile" or
+ open $out_fh, ">$outfile" or
die "Can't write LOAD FILE to '$table_name': $!\n";
}
$val = defined $val ? $val : $mysql_loadfile ? '\N' : 'NULL';
}
push @vals, $val;
- }
+ }
if ( $mysql_loadfile ) {
print $out_fh join("\t", @vals), "\n";
}
else {
print "INSERT INTO $table_name (".
- join(', ', @{ $table->{'fields'} }) .
+ join(', ', @{ $table->{'fields'} }) .
') VALUES (', join(', ', @vals), ");\n";
}
}
Or like so:
- cluster => [
+ cluster => [
{ name => 'cluster1', tables => [ 'table1', 'table2' ] },
{ name => 'cluster2', tables => [ 'table3', 'table4' ] },
]
=item * output_type (DEFAULT: 'png')
-This determines which
+This determines which
L<output method|GraphViz/as_canon,_as_text,_as_gif_etc._methods>
will be invoked to generate the graph: C<png> translates to
C<as_png>, C<ps> to C<as_ps> and so on.
=item * fontname
-This sets the global font name (or full path to font file) for
+This sets the global font name (or full path to font file) for
node, edge, and graph labels
=item * fontsize
);
# join_pk_only/skip_fields implies natural_join
- $args->{natural_join} = 1
+ $args->{natural_join} = 1
if ($args->{join_pk_only} or scalar keys %skip_fields);
# usually we do not want direction when using natural join
push @fmt_indexes, join (' ',
'*',
$args->{show_index_names}
- ? $index->name . ':'
+ ? $index->name . ':'
: ()
,
join (', ', $index->fields),
import CGI::Pretty;
CGI::Pretty->new }
: do { require CGI;
- import CGI;
+ import CGI;
CGI->new };
my ($table, @table_names);
$q->hr;
}
- @table_names = grep { length $_->name } $schema->get_tables;
+ @table_names = grep { length $_->name } $schema->get_tables;
if ($linktable) {
# Generate top menu, with links to full table information
$count = sprintf "%d table%s", $count, $count == 1 ? '' : 's';
# Leading table of links
- push @html,
+ push @html,
$q->comment("Table listing ($count)"),
$q->a({ -name => 'top' }),
$q->start_table({ -width => '100%', -class => 'LinkTable'}),
for my $table (@table_names) {
my $table_name = $table->name;
- push @html,
+ push @html,
$q->comment("Start link to table '$table_name'"),
$q->Tr({ -class => 'LinkTableRow' },
$q->td({ -class => 'LinkTableCell' },
$q->start_table({ -border => 1 }),
$q->Tr(
$q->th({ -class => 'FieldHeader' },
- [
- 'Field Name',
- 'Data Type',
- 'Size',
- 'Default Value',
- 'Other',
- 'Foreign Key'
+ [
+ 'Field Name',
+ 'Data Type',
+ 'Size',
+ 'Default Value',
+ 'Other',
+ 'Foreign Key'
]
- )
+ )
);
my $i = 0;
$name = qq[<a name="$table_name-$name">$name</a>];
my $data_type = $field->data_type || '';
my $size = defined $field->size ? $field->size : '';
- my $default = defined $field->default_value
+ my $default = defined $field->default_value
? $field->default_value : '';
my $comment = $field->comments || '';
my $fk = '';
my $c = $field->foreign_key_reference;
my $ref_table = $c->reference_table || '';
my $ref_field = ($c->reference_fields)[0] || '';
- $fk =
+ $fk =
qq[<a href="#$ref_table-$ref_field">$ref_table.$ref_field</a>];
}
# Indices
#
if ( my @indices = $table->get_indices ) {
- push @html,
+ push @html,
$q->h3('Indices'),
$q->start_table({ -border => 1 }),
$q->Tr({ -class => 'IndexRow' },
- $q->th([ 'Name', 'Fields' ])
+ $q->th([ 'Name', 'Fields' ])
);
for my $index ( @indices ) {
#
# Constraints
#
- my @constraints =
+ my @constraints =
grep { $_->type ne PRIMARY_KEY } $table->get_constraints;
if ( @constraints ) {
- push @html,
+ push @html,
$q->h3('Constraints'),
$q->start_table({ -border => 1 }),
$q->Tr({ -class => 'IndexRow' },
- $q->th([ 'Type', 'Fields' ])
+ $q->th([ 'Type', 'Fields' ])
);
for my $c ( @constraints ) {
$s =~ s/([\&\_\$\{\#])/\\$1/g;
return $s;
}
-
+
1;
# -------------------------------------------------------------------
=head1 AUTHOR
-Chris Mungall
+Chris Mungall
=head1 SEE ALSO
=head1 DESCRIPTION
This module will produce text output of the schema suitable for MySQL.
-There are still some issues to be worked out with syntax differences
+There are still some issues to be worked out with syntax differences
between MySQL versions 3 and 4 ("SET foreign_key_checks," character sets
for fields, etc.).
-=head1 ARGUMENTS
+=head1 ARGUMENTS
-This producer takes a single optional producer_arg C<mysql_version>, which
+This producer takes a single optional producer_arg C<mysql_version>, which
provides the desired version for the target database. By default MySQL v3 is
assumed, and statements pertaining to any features introduced in later versions
(e.g. CREATE VIEW) are not produced.
-Valid version specifiers for C<mysql_version> are listed L<here|SQL::Translator::Utils/parse_mysql_version>
+Valid version specifiers for C<mysql_version> are listed L<here|SQL::Translator::Utils/parse_mysql_version>
=head2 Table Types
use Data::Dumper;
use SQL::Translator::Schema::Constants;
-use SQL::Translator::Utils qw(debug header_comment
+use SQL::Translator::Utils qw(debug header_comment
truncate_id_uniquely parse_mysql_version);
#
# Now just to find if there is already an Engine or Type option...
# and lets normalize it to ENGINE since:
#
- # The ENGINE table option specifies the storage engine for the table.
+ # The ENGINE table option specifies the storage engine for the table.
# TYPE is a synonym, but ENGINE is the preferred option name.
#
- # We have to use the hash directly here since otherwise there is no way
+ # We have to use the hash directly here since otherwise there is no way
# to remove options.
my $options = ( $table->{options} ||= []);
OPT_NAME: for ( @$opt_name[1..$#$opt_name] ) {
for my $idx ( 0..$#{$options} ) {
my ($key, $value) = %{ $options->[$idx] };
-
+
if (uc $key eq $_) {
$options->[$idx] = { $opt_name->[0] => $value };
last OPT_NAME;
my ($key, $value) = %{ $options->[$idx] };
next unless uc $key eq $opt_name;
-
+
# make sure case is right on option name
delete $options->[$idx]{$key};
return $options->[$idx]{$opt_name} = $value || $extra_type;
}
-
+
if ($extra_type) {
push @$options, { $opt_name => $extra_type };
return $extra_type;
# constraints. We do this first as we need InnoDB at both ends.
#
foreach my $table ( $schema->get_tables ) {
-
+
$extra_to_options->($table, 'mysql_table_type', ['ENGINE', 'TYPE'] );
$extra_to_options->($table, 'mysql_charset', 'CHARACTER SET' );
$extra_to_options->($table, 'mysql_collate', 'COLLATE' );
# Give the constraint a name if it doesn't have one, so it doens't feel
# left out
$c_name = $table->name . '_fk' unless length $c_name;
-
+
$c->name( next_unused_name($c_name) );
for my $meth (qw/table reference_table/) {
debug("PKG: Beginning production\n");
%used_names = ();
- my $create = '';
+ my $create = '';
$create .= header_comment unless ($no_comments);
# \todo Don't set if MySQL 3.x is set on command line
my @create = "SET foreign_key_checks=0";
# Generate sql
#
my @table_defs =();
-
+
for my $table ( $schema->get_tables ) {
# print $table->name, "\n";
- push @table_defs, create_table($table,
+ push @table_defs, create_table($table,
{ add_drop_table => $add_drop_table,
show_warnings => $show_warnings,
no_comments => $no_comments,
for my $c ( @constraints ) {
my $constr = create_constraint($c, $options);
push @constraint_defs, $constr if($constr);
-
+
unless ( $indexed_fields{ ($c->fields())[0] } || $c->type ne FOREIGN_KEY ) {
push @index_defs, "INDEX ($qf" . ($c->fields())[0] . "$qf)";
$indexed_fields{ ($c->fields())[0] } = 1;
}
}
- $create .= join(",\n", map { " $_" }
+ $create .= join(",\n", map { " $_" }
@field_defs, @index_defs, @constraint_defs
);
return "$qt$table_name$qt";
}
-sub generate_table_options
+sub generate_table_options
{
my ($table, $options) = @_;
my $create;
if ( lc($data_type) eq 'enum' || lc($data_type) eq 'set') {
$field_def .= '(' . $commalist . ')';
}
- elsif (
- defined $size[0] && $size[0] > 0
- &&
- ! grep lc($data_type) eq $_, @no_length_attr
+ elsif (
+ defined $size[0] && $size[0] > 0
+ &&
+ ! grep lc($data_type) eq $_, @no_length_attr
) {
$field_def .= '(' . join( ', ', @size ) . ')';
}
my $qf = $options->{quote_field_names} || '';
my $table_name = quote_table_name($index->table->name, $qt);
- return join( ' ',
+ return join( ' ',
'ALTER TABLE',
$table_name,
'DROP',
}
elsif ( $c->type eq UNIQUE ) {
return
- 'UNIQUE '.
+ 'UNIQUE '.
(defined $c->name ? $qf.truncate_id_uniquely( $c->name, $options->{max_id_length} || $DEFAULT_MAX_ID_LENGTH ).$qf.' ' : '').
'(' . $qf . join("$qf, $qf", @fields). $qf . ')';
}
my $table = $c->table;
my $c_name = truncate_id_uniquely( $c->name, $options->{max_id_length} || $DEFAULT_MAX_ID_LENGTH );
- my $def = join(' ',
- map { $_ || () }
- 'CONSTRAINT',
- $qf . $c_name . $qf,
+ my $def = join(' ',
+ map { $_ || () }
+ 'CONSTRAINT',
+ $qf . $c_name . $qf,
'FOREIGN KEY'
);
}
else {
warn "FK constraint on " . $table->name . '.' .
- join('', @fields) . " has no reference fields\n"
+ join('', @fields) . " has no reference fields\n"
if $options->{show_warnings};
}
if ( $c->match_type ) {
- $def .= ' MATCH ' .
+ $def .= ' MATCH ' .
( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
}
}
sub drop_field
-{
+{
my ($old_field, $options) = @_;
my $qf = $options->{quote_field_names} || '';
my $qt = $options->{quote_table_names} || '';
my $table_name = quote_table_name($old_field->table->name, $qt);
-
+
my $out = sprintf('ALTER TABLE %s DROP COLUMN %s',
$table_name,
$qf . $old_field->name . $qf);
return $out;
-
+
}
sub batch_alter_table {
my ($table, $diff_hash, $options) = @_;
- # InnoDB has an issue with dropping and re-adding a FK constraint under the
+ # InnoDB has an issue with dropping and re-adding a FK constraint under the
# name in a single alter statment, see: http://bugs.mysql.com/bug.php?id=13741
#
# We have to work round this.
my %fks_to_alter;
my %fks_to_drop = map {
- $_->type eq FOREIGN_KEY
- ? ( $_->name => $_ )
+ $_->type eq FOREIGN_KEY
+ ? ( $_->name => $_ )
: ( )
} @{$diff_hash->{alter_drop_constraint} };
my $table_name = quote_table_name($table->name, $qt);
- my $re = $renamed_from
+ my $re = $renamed_from
? qr/^ALTER TABLE (?:\Q$table_name\E|\Q$renamed_from\E) /
: qr/^ALTER TABLE \Q$table_name\E /;
my $qf = 1 if $translator->quote_field_names;
if ( $translator->parser_type =~ /mysql/i ) {
- $create .=
+ $create .=
"-- We assume that default NLS_DATE_FORMAT has been changed\n".
"-- but we set it here anyway to be self-consistent.\n"
unless $no_comments;
- $create .=
+ $create .=
"ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS';\n\n";
}
- for my $table ( $schema->get_tables ) {
+ for my $table ( $schema->get_tables ) {
my ( $table_def, $fk_def, $trigger_def, $index_def, $constraint_def ) = create_table(
$table,
{
my ( $key, $value ) = each %$opt;
if ( ref $value eq 'ARRAY' ) {
push @table_options, "$key\n(\n". join ("\n",
- map { " $_->[0]\t$_->[1]" }
+ map { " $_->[0]\t$_->[1]" }
map { [ each %$_ ] }
@$value
)."\n)";
}
if ( $c->match_type ) {
- $def .= ' MATCH ' .
+ $def .= ' MATCH ' .
( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
}
my ( $key, $value ) = each %$opt;
if ( ref $value eq 'ARRAY' ) {
push @table_options, "$key\n(\n". join ("\n",
- map { " $_->[0]\t$_->[1]" }
+ map { " $_->[0]\t$_->[1]" }
map { [ each %$_ ] }
@$value
)."\n)";
? "\n".join("\n", @index_options) : '';
if ( $index_type eq PRIMARY_KEY ) {
- $index_name = $index_name ? mk_name( $index_name )
+ $index_name = $index_name ? mk_name( $index_name )
: mk_name( $table_name, 'pk' );
$index_name = quote($index_name, $qf);
push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
'(' . join( ', ', @fields ) . ')';
}
elsif ( $index_type eq NORMAL ) {
- $index_name = $index_name ? mk_name( $index_name )
+ $index_name = $index_name ? mk_name( $index_name )
: mk_name( $table_name, $index_name || 'i' );
$index_name = quote($index_name, $qf);
- push @index_defs,
+ push @index_defs,
"CREATE INDEX $index_name on $table_name_q (".
- join( ', ', @fields ).
+ join( ', ', @fields ).
")$index_options";
}
elsif ( $index_type eq UNIQUE ) {
- $index_name = $index_name ? mk_name( $index_name )
+ $index_name = $index_name ? mk_name( $index_name )
: mk_name( $table_name, $index_name || 'i' );
$index_name = quote($index_name, $qf);
- push @index_defs,
+ push @index_defs,
"CREATE UNIQUE INDEX $index_name on $table_name_q (".
- join( ', ', @fields ).
- ")$index_options";
+ join( ', ', @fields ).
+ ")$index_options";
}
else {
warn "Unknown index type ($index_type) on table $table_name.\n"
}
}
- my $table_options = @table_options
+ my $table_options = @table_options
? "\n".join("\n", @table_options) : '';
push @create, "CREATE TABLE $table_name_q (\n" .
join( ",\n", map { " $_" } @field_defs,
$data_type = 'varchar2';
}
elsif ( $data_type eq 'set' ) {
- # XXX add a CHECK constraint maybe
+ # XXX add a CHECK constraint maybe
# (trickier and slower, than enum :)
$data_type = 'varchar2';
}
}
#
- # Fixes ORA-02329: column of datatype LOB cannot be
+ # Fixes ORA-02329: column of datatype LOB cannot be
# unique or a primary key
#
if ( $data_type eq 'clob' && $field->is_primary_key ) {
#
# Fixes ORA-00906: missing right parenthesis
- # if size is 0 or undefined
+ # if size is 0 or undefined
#
for (qw/varchar2/) {
if ( $data_type =~ /^($_)$/i ) {
my $default = $field->default_value;
if ( defined $default ) {
#
- # Wherein we try to catch a string being used as
+ # Wherein we try to catch a string being used as
# a default value for a numerical field. If "true/false,"
# then sub "1/0," otherwise just test the truthity of the
# argument and use that (naive?).
$default = $$default;
} elsif (ref $default) {
$default = 'NULL';
- } elsif (
- $data_type =~ /^number$/i &&
+ } elsif (
+ $data_type =~ /^number$/i &&
$default !~ /^-?\d+$/ &&
$default !~ m/null/i
) {
} else {
$default = $default ? "'1'" : "'0'";
}
- } elsif (
+ } elsif (
$data_type =~ /date/ && (
- $default eq 'current_timestamp'
+ $default eq 'current_timestamp'
||
- $default eq 'now()'
+ $default eq 'now()'
)
) {
$default = 'SYSDATE';
} else {
$default = $default =~ m/null/i ? 'NULL' : "'$default'"
- }
+ }
$field_def .= " DEFAULT $default",
}
if ( lc $field->data_type eq 'timestamp' ) {
my $base_name = $table_name . "_". $field_name;
my $trig_name = quote(mk_name( $base_name, 'ts' ), $qt);
- my $trigger =
+ my $trigger =
"CREATE OR REPLACE TRIGGER $trig_name\n".
"BEFORE INSERT OR UPDATE ON $table_name_q\n".
"FOR EACH ROW WHEN (new.$field_name_q IS NULL)\n".
if ( my $comment = $field->comments ) {
$comment =~ s/'/''/g;
- push @field_comments,
+ push @field_comments,
"COMMENT ON COLUMN $table_name_q.$field_name_q is\n '" .
$comment . "';" unless $options->{no_comments};
}
my ($view, $options) = @_;
my $qt = $options->{quote_table_names};
my $view_name = quote($view->name,$qt);
-
+
my @create;
push @create, qq[DROP VIEW $view_name]
if $options->{add_drop_view};
# -------------------------------------------------------------------
sub mk_name {
- my $basename = shift || '';
- my $type = shift || '';
+ my $basename = shift || '';
+ my $type = shift || '';
$type = '' if $type =~ /^\d/;
- my $scope = shift || '';
+ my $scope = shift || '';
my $critical = shift || '';
my $basename_orig = $basename;
- my $max_name = $type
- ? $max_id_length - (length($type) + 1)
+ my $max_name = $type
+ ? $max_id_length - (length($type) + 1)
: $max_id_length;
- $basename = substr( $basename, 0, $max_name )
+ $basename = substr( $basename, 0, $max_name )
if length( $basename ) > $max_name;
my $name = $type ? "${type}_$basename" : $basename;
=head1 DESCRIPTION
-Creates a POD description of each table, field, index, and constraint.
-A good starting point for text documentation of a schema. You can
-easily convert the output to HTML or text using "perldoc" or other
+Creates a POD description of each table, field, index, and constraint.
+A good starting point for text documentation of a schema. You can
+easily convert the output to HTML or text using "perldoc" or other
interesting formats using Pod::POM or Template::Toolkit's POD plugin.
=cut
$pod .= "=head3 INDICES\n\n";
for my $index ( @indices ) {
$pod .= "=head4 " . $index->type . "\n\n=over 4\n\n";
- $pod .= "=item * Fields = " .
+ $pod .= "=item * Fields = " .
join(', ', $index->fields ) . "\n\n";
$pod .= "=back\n\n";
}
$pod .= "=head3 CONSTRAINTS\n\n";
for my $c ( @constraints ) {
$pod .= "=head4 " . $c->type . "\n\n=over 4\n\n";
- $pod .= "=item * Fields = " .
+ $pod .= "=item * Fields = " .
join(', ', $c->fields ) . "\n\n";
if ( $c->type eq FOREIGN_KEY ) {
- $pod .= "=item * Reference Table = L</" .
+ $pod .= "=item * Reference Table = L</" .
$c->reference_table . ">\n\n";
- $pod .= "=item * Reference Fields = " .
- join(', ', map {"L</$_>"} $c->reference_fields ) .
+ $pod .= "=item * Reference Fields = " .
+ join(', ', map {"L</$_>"} $c->reference_fields ) .
"\n\n";
}
Now handles PostGIS Geometry and Geography data types on table definitions.
Does not yet support PostGIS Views.
-
+
=cut
use strict;
$max_id_length = 62;
}
my %reserved = map { $_, 1 } qw[
- ALL ANALYSE ANALYZE AND ANY AS ASC
+ ALL ANALYSE ANALYZE AND ANY AS ASC
BETWEEN BINARY BOTH
CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
- CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
+ CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
DEFAULT DEFERRABLE DESC DISTINCT DO
ELSE END EXCEPT
- FALSE FOR FOREIGN FREEZE FROM FULL
- GROUP HAVING
- ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL
- JOIN LEADING LEFT LIKE LIMIT
+ FALSE FOR FOREIGN FREEZE FROM FULL
+ GROUP HAVING
+ ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL
+ JOIN LEADING LEFT LIKE LIMIT
NATURAL NEW NOT NOTNULL NULL
OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
- PRIMARY PUBLIC REFERENCES RIGHT
- SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
+ PRIMARY PUBLIC REFERENCES RIGHT
+ SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
UNION UNIQUE USER USING VERBOSE WHEN WHERE
];
my $qt = $translator->quote_table_names ? q{"} : q{};
my $qf = $translator->quote_field_names ? q{"} : q{};
-
+
my @output;
push @output, header_comment unless ($no_comments);
my %type_defs;
for my $table ( $schema->get_tables ) {
- my ($table_def, $fks) = create_table($table, {
+ my ($table_def, $fks) = create_table($table, {
quote_table_names => $qt,
quote_field_names => $qf,
no_comments => $no_comments,
# -------------------------------------------------------------------
sub mk_name {
- my $basename = shift || '';
- my $type = shift || '';
- my $scope = shift || '';
+ my $basename = shift || '';
+ my $type = shift || '';
+ my $scope = shift || '';
my $critical = shift || '';
my $basename_orig = $basename;
# my $max_id_length = 62;
- my $max_name = $type
- ? $max_id_length - (length($type) + 1)
+ my $max_name = $type
+ ? $max_id_length - (length($type) + 1)
: $max_id_length;
- $basename = substr( $basename, 0, $max_name )
+ $basename = substr( $basename, 0, $max_name )
if length( $basename ) > $max_name;
my $name = $type ? "${type}_$basename" : $basename;
if ( my $prev = $scope->{ $name } ) {
my $name_orig = $name;
$name .= sprintf( "%02d", ++$prev );
- substr($name, $max_id_length - 3) = "00"
+ substr($name, $max_id_length - 3) = "00"
if length( $name ) > $max_id_length;
warn "The name '$name_orig' has been changed to ",
sub is_geometry
{
- my $field = shift;
- return 1 if $field->data_type eq 'geometry';
+ my $field = shift;
+ return 1 if $field->data_type eq 'geometry';
}
sub is_geography
return 1 if $field->data_type eq 'geography';
}
-sub create_table
+sub create_table
{
my ($table, $options) = @_;
# my $idx_name_default;
for my $index ( $table->get_indices ) {
my ($idef, $constraints) = create_index($index,
- {
+ {
quote_field_names => $qf,
quote_table_names => $qt,
table_name => $table_name,
#
my $c_name_default;
for my $c ( $table->get_constraints ) {
- my ($cdefs, $fks) = create_constraint($c,
- {
+ my ($cdefs, $fks) = create_constraint($c,
+ {
quote_field_names => $qf,
quote_table_names => $qt,
table_name => $table_name,
if(exists $table->{extra}{temporary}) {
$temporary = $table->{extra}{temporary} ? "TEMPORARY " : "";
- }
+ }
my $create_statement;
$create_statement = join("\n", @comments);
$create_statement .= ( $create_statement =~ /;$/ ? "\n" : q{} )
. join(";\n", @index_defs);
- #
- # Geometry
- #
- if(grep { is_geometry($_) } $table->get_fields){
+ #
+ # Geometry
+ #
+ if(grep { is_geometry($_) } $table->get_fields){
$create_statement .= ";";
my @geometry_columns;
foreach my $col ($table->get_fields) { push(@geometry_columns,$col) if is_geometry($col); }
- $create_statement .= "\n".join("\n", map{ drop_geometry_column($_) } @geometry_columns) if $options->{add_drop_table};
- $create_statement .= "\n".join("\n", map{ add_geometry_column($_) } @geometry_columns);
- }
+ $create_statement .= "\n".join("\n", map{ drop_geometry_column($_) } @geometry_columns) if $options->{add_drop_table};
+ $create_statement .= "\n".join("\n", map{ add_geometry_column($_) } @geometry_columns);
+ }
return $create_statement, \@fks;
}
return $create;
}
-{
+{
my %field_name_scope;
$field_name_scope{$table_name} ||= {};
my $field_name = $field->name;
- my $field_comments = $field->comments
- ? "-- " . $field->comments . "\n "
+ my $field_comments = $field->comments
+ ? "-- " . $field->comments . "\n "
: '';
my $field_def = $field_comments.qq[$qf$field_name$qf];
}
#
- # Default value
+ # Default value
#
SQL::Translator::Producer->_apply_default_value(
$field,
#
$field_def .= ' NOT NULL' unless $field->is_nullable;
- #
- # Geometry constraints
- #
- if(is_geometry($field)){
- foreach ( create_geometry_constraints($field) ) {
- my ($cdefs, $fks) = create_constraint($_,
- {
- quote_field_names => $qf,
- quote_table_names => $qt,
- table_name => $table_name,
- });
- push @$constraint_defs, @$cdefs;
- push @$fks, @$fks;
- }
+ #
+ # Geometry constraints
+ #
+ if(is_geometry($field)){
+ foreach ( create_geometry_constraints($field) ) {
+ my ($cdefs, $fks) = create_constraint($_,
+ {
+ quote_field_names => $qf,
+ quote_table_names => $qt,
+ table_name => $table_name,
+ });
+ push @$constraint_defs, @$cdefs;
+ push @$fks, @$fks;
+ }
}
-
+
return $field_def;
}
}
sub create_geometry_constraints{
- my $field = shift;
-
- my @constraints;
- push @constraints, SQL::Translator::Schema::Constraint->new(
- name => "enforce_dims_".$field->name,
- expression => "(ST_NDims($field) = ".$field->{extra}{dimensions}.")",
- table => $field->table,
- type => CHECK_C,
- );
-
- push @constraints, SQL::Translator::Schema::Constraint->new(
- name => "enforce_srid_".$field->name,
- expression => "(ST_SRID($field) = ".$field->{extra}{srid}.")",
- table => $field->table,
- type => CHECK_C,
- );
- push @constraints, SQL::Translator::Schema::Constraint->new(
- name => "enforce_geotype_".$field->name,
- expression => "(GeometryType($field) = '".$field->{extra}{geometry_type}."'::text OR $field IS NULL)",
- table => $field->table,
- type => CHECK_C,
- );
-
- return @constraints;
+ my $field = shift;
+
+ my @constraints;
+ push @constraints, SQL::Translator::Schema::Constraint->new(
+ name => "enforce_dims_".$field->name,
+ expression => "(ST_NDims($field) = ".$field->{extra}{dimensions}.")",
+ table => $field->table,
+ type => CHECK_C,
+ );
+
+ push @constraints, SQL::Translator::Schema::Constraint->new(
+ name => "enforce_srid_".$field->name,
+ expression => "(ST_SRID($field) = ".$field->{extra}{srid}.")",
+ table => $field->table,
+ type => CHECK_C,
+ );
+ push @constraints, SQL::Translator::Schema::Constraint->new(
+ name => "enforce_geotype_".$field->name,
+ expression => "(GeometryType($field) = '".$field->{extra}{geometry_type}."'::text OR $field IS NULL)",
+ table => $field->table,
+ type => CHECK_C,
+ );
+
+ return @constraints;
}
sub create_index
push @constraint_defs, "${def_start}UNIQUE " .$field_names;
}
elsif ( $type eq NORMAL ) {
- $index_def =
+ $index_def =
"CREATE INDEX ${qf}${name}${qf} on ${qt}${table_name}${qt} ".$field_names
- ;
+ ;
}
else {
warn "Unknown index type ($type) on table $table_name.\n"
}
if ( $c->match_type ) {
- $def .= ' MATCH ' .
+ $def .= ' MATCH ' .
( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
}
# my $len = 0;
# $len = ($len < length($_)) ? length($_) : $len for (@$list);
# my $chk_name = mk_name( $table_name.'_'.$field_name, 'chk' );
-# push @$constraint_defs,
+# push @$constraint_defs,
# qq[CONSTRAINT "$chk_name" CHECK ($qf$field_name$qf ].
# qq[IN ($commalist))];
$data_type = 'character varying';
);
if ( $data_type !~ /$type_with_size/ ) {
- @size = ();
+ @size = ();
}
if (defined $size[0] && $size[0] > 0 && $data_type =~ /^time/i ) {
{
my ($from_field, $to_field) = @_;
- die "Can't alter field in another table"
+ die "Can't alter field in another table"
if($from_field->table->name ne $to_field->table->name);
my @out;
-
+
# drop geometry column and constraints
push @out, drop_geometry_column($from_field) if is_geometry($from_field);
push @out, drop_geometry_constraints($from_field) if is_geometry($from_field);
$from_field->name,
$to_field->name) if($from_field->name ne $to_field->name);
-
push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s SET NOT NULL',
$to_field->table->name,
$to_field->name) if(!$to_field->is_nullable and
my $old_default = $from_field->default_value;
my $new_default = $to_field->default_value;
my $default_value = $to_field->default_value;
-
+
# fixes bug where output like this was created:
# ALTER TABLE users ALTER COLUMN column SET DEFAULT ThisIsUnescaped;
if(ref $default_value eq "SCALAR" ) {
$default_value =~ s/'/''/xsmg;
$default_value = q(') . $default_value . q(');
}
-
+
push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s SET DEFAULT %s',
$to_field->table->name,
$to_field->name,
if ( defined $new_default &&
(!defined $old_default || $old_default ne $new_default) );
- # fixes bug where removing the DEFAULT statement of a column
- # would result in no change
-
- push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s DROP DEFAULT',
+ # fixes bug where removing the DEFAULT statement of a column
+ # would result in no change
+
+ push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s DROP DEFAULT',
$to_field->table->name,
$to_field->name)
if ( !defined $new_default && defined $old_default );
-
- # add geometry column and contraints
- push @out, add_geometry_column($to_field) if is_geometry($to_field);
- push @out, add_geometry_constraints($to_field) if is_geometry($to_field);
-
+
+ # add geometry column and contraints
+ push @out, add_geometry_column($to_field) if is_geometry($to_field);
+ push @out, add_geometry_constraints($to_field) if is_geometry($to_field);
+
return wantarray ? @out : join(";\n", @out);
}
$qt . $old_field->table->name . $qt,
$qf . $old_field->name . $qf);
$out .= "\n".drop_geometry_column($old_field) if is_geometry($old_field);
- return $out;
+ return $out;
}
sub add_geometry_column{
- my ($field,$options) = @_;
-
- my $out = sprintf("INSERT INTO geometry_columns VALUES ('%s','%s','%s','%s','%s','%s','%s')",
- '',
- $field->table->schema->name,
- $options->{table} ? $options->{table} : $field->table->name,
- $field->name,
- $field->{extra}{dimensions},
- $field->{extra}{srid},
- $field->{extra}{geometry_type});
+ my ($field,$options) = @_;
+
+ my $out = sprintf("INSERT INTO geometry_columns VALUES ('%s','%s','%s','%s','%s','%s','%s')",
+ '',
+ $field->table->schema->name,
+ $options->{table} ? $options->{table} : $field->table->name,
+ $field->name,
+ $field->{extra}{dimensions},
+ $field->{extra}{srid},
+ $field->{extra}{geometry_type});
return $out;
}
sub drop_geometry_column
{
- my $field = shift;
-
- my $out = sprintf("DELETE FROM geometry_columns WHERE f_table_schema = '%s' AND f_table_name = '%s' AND f_geometry_column = '%s'",
- $field->table->schema->name,
- $field->table->name,
- $field->name);
+ my $field = shift;
+
+ my $out = sprintf("DELETE FROM geometry_columns WHERE f_table_schema = '%s' AND f_table_name = '%s' AND f_geometry_column = '%s'",
+ $field->table->schema->name,
+ $field->table->name,
+ $field->name);
return $out;
}
sub add_geometry_constraints{
- my $field = shift;
-
- my @constraints = create_geometry_constraints($field);
+ my $field = shift;
+
+ my @constraints = create_geometry_constraints($field);
+
+ my $out = join("\n", map { alter_create_constraint($_); } @constraints);
- my $out = join("\n", map { alter_create_constraint($_); } @constraints);
-
- return $out;
+ return $out;
}
sub drop_geometry_constraints{
- my $field = shift;
-
- my @constraints = create_geometry_constraints($field);
-
- my $out = join("\n", map { alter_drop_constraint($_); } @constraints);
-
- return $out;
+ my $field = shift;
+
+ my @constraints = create_geometry_constraints($field);
+
+ my $out = join("\n", map { alter_drop_constraint($_); } @constraints);
+
+ return $out;
}
sub alter_table {
my $qt = $options->{quote_table_names} || '';
$options->{alter_table_action} = "RENAME TO $qt$new_table$qt";
- my @geometry_changes;
- push @geometry_changes, map { drop_geometry_column($_); } grep { is_geometry($_) } $old_table->get_fields;
- push @geometry_changes, map { add_geometry_column($_, { table => $new_table }); } grep { is_geometry($_) } $old_table->get_fields;
-
+ my @geometry_changes;
+ push @geometry_changes, map { drop_geometry_column($_); } grep { is_geometry($_) } $old_table->get_fields;
+ push @geometry_changes, map { add_geometry_column($_, { table => $new_table }); } grep { is_geometry($_) } $old_table->get_fields;
+
$options->{geometry_changes} = join ("\n",@geometry_changes) if scalar(@geometry_changes);
-
+
return alter_table($old_table, $options);
}
my ($index, $options) = @_;
my $qt = $options->{quote_table_names} || '';
my ($defs, $fks) = create_constraint(@_);
-
+
# return if there are no constraint definitions so we don't run
# into output like this:
# ALTER TABLE users ADD ;
-
+
return unless(@{$defs} || @{$fks});
return $index->type eq FOREIGN_KEY ? join(q{}, @{$fks})
: join( ' ', 'ALTER TABLE', $qt.$index->table->name.$qt,
my ($table, $options) = @_;
my $qt = $options->{quote_table_names} || '';
my $out = "DROP TABLE $qt$table$qt CASCADE";
-
+
my @geometry_drops = map { drop_geometry_column($_); } grep { is_geometry($_) } $table->get_fields;
$out .= "\n".join("\n",@geometry_drops) if scalar(@geometry_drops);
if ( my $prev = $scope->{ $name } ) {
my $name_orig = $name;
$name .= sprintf( "%02d", ++$prev );
- substr($name, $max_id_length - 3) = "00"
+ substr($name, $max_id_length - 3) = "00"
if length( $name ) > $max_id_length;
warn "The name '$name_orig' has been changed to ",
push @field_defs, create_field($field);
}
- if (
- scalar @pk_fields > 1
- ||
- ( @pk_fields && !grep /INTEGER PRIMARY KEY/, @field_defs )
+ if (
+ scalar @pk_fields > 1
+ ||
+ ( @pk_fields && !grep /INTEGER PRIMARY KEY/, @field_defs )
) {
push @field_defs, 'PRIMARY KEY (' . join(', ', @pk_fields ) . ')';
}
if ($c->type eq "FOREIGN KEY") {
push @field_defs, create_foreignkey($c);
}
- next unless $c->type eq UNIQUE;
+ next unless $c->type eq UNIQUE;
push @constraint_defs, create_constraint($c);
}
my $field_name = $field->name;
debug("PKG: Looking at field '$field_name'\n");
- my $field_comments = $field->comments
- ? "-- " . $field->comments . "\n "
+ my $field_comments = $field->comments
+ ? "-- " . $field->comments . "\n "
: '';
my $field_def = $field_comments.$field_name;
}
# if ( $data_type =~ /timestamp/i ) {
-# push @trigger_defs,
+# push @trigger_defs,
# "CREATE TRIGGER ts_${table_name} ".
# "after insert on $table_name\n".
# "begin\n".
my $pk = $field->table->primary_key;
my @pk_fields = $pk ? $pk->fields : ();
- if (
- $field->is_primary_key &&
+ if (
+ $field->is_primary_key &&
scalar @pk_fields == 1 &&
(
$data_type =~ /int(eger)?$/i
# $pk_set = 1;
}
- $field_def .= sprintf " %s%s", $data_type,
+ $field_def .= sprintf " %s%s", $data_type,
( !$field->is_auto_increment && $size ) ? "($size)" : '';
# Null?
my $name = $index->name;
$name = mk_name($name);
- my $type = $index->type eq 'UNIQUE' ? "UNIQUE " : '';
+ my $type = $index->type eq 'UNIQUE' ? "UNIQUE " : '';
# strip any field size qualifiers as SQLite doesn't like these
my @fields = map { s/\(\d+\)$//; $_ } $index->fields;
(my $index_table_name = $index->table->name) =~ s/^.+?\.//; # table name may not specify schema
warn "removing schema name from '" . $index->table->name . "' to make '$index_table_name'\n" if $WARN;
- my $index_def =
+ my $index_def =
"CREATE ${type}INDEX $name ON " . $index_table_name .
' (' . join( ', ', @fields ) . ')';
(my $index_table_name = $c->table->name) =~ s/^.+?\.//; # table name may not specify schema
warn "removing schema name from '" . $c->table->name . "' to make '$index_table_name'\n" if $WARN;
- my $c_def =
+ my $c_def =
"CREATE UNIQUE INDEX $name ON " . $index_table_name .
' (' . join( ', ', @fields ) . ')';
@{$diffs->{alter_field}} == 0 &&
@{$diffs->{drop_field}} == 0
) {
-# return join("\n", map {
- return map {
+# return join("\n", map {
+ return map {
my $meth = __PACKAGE__->can($_) or die __PACKAGE__ . " cant $_";
map { my $sql = $meth->(ref $_ eq 'ARRAY' ? @$_ : $_); $sql ? ("$sql") : () } @{ $diffs->{$_} }
-
- } grep { @{$diffs->{$_}} }
+
+ } grep { @{$diffs->{$_}} }
qw/rename_table
alter_drop_constraint
alter_drop_index
my @sql;
my $old_table = $renaming ? $diffs->{rename_table}[0][0] : $table;
-
+
do {
local $table->{name} = $table_name . '_temp_alter';
# We only want the table - dont care about indexes on tmp table
bit => 'bit',
tinyint => 'smallint',
float => 'double precision',
- serial => 'numeric',
+ serial => 'numeric',
boolean => 'varchar',
char => 'char',
long => 'varchar',
);
my %reserved = map { $_, 1 } qw[
- ALL ANALYSE ANALYZE AND ANY AS ASC
+ ALL ANALYSE ANALYZE AND ANY AS ASC
BETWEEN BINARY BOTH
CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
- CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
+ CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
DEFAULT DEFERRABLE DESC DISTINCT DO
ELSE END EXCEPT
- FALSE FOR FOREIGN FREEZE FROM FULL
- GROUP HAVING
- ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL
- JOIN LEADING LEFT LIKE LIMIT
+ FALSE FOR FOREIGN FREEZE FROM FULL
+ GROUP HAVING
+ ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL
+ JOIN LEADING LEFT LIKE LIMIT
NATURAL NEW NOT NOTNULL NULL
OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
- PRIMARY PUBLIC REFERENCES RIGHT
- SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
+ PRIMARY PUBLIC REFERENCES RIGHT
+ SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
UNION UNIQUE USER USING VERBOSE WHEN WHERE
];
my %field_name_scope;
for my $field ( $table->get_fields ) {
my $field_name = mk_name(
- $field->name, '', \%field_name_scope, undef,1
+ $field->name, '', \%field_name_scope, undef,1
);
my $field_name_ur = unreserve( $field_name, $table_name );
my $field_def = qq["$field_name_ur"];
my $seq_name;
if ( $data_type eq 'enum' ) {
- my $check_name = mk_name(
+ my $check_name = mk_name(
$table_name.'_'.$field_name, 'chk' ,undef, 1
);
- push @constraint_defs,
+ push @constraint_defs,
"CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
$data_type .= 'character varying';
}
$size = '255';
}
elsif (
- $data_type eq 'varchar' &&
+ $data_type eq 'varchar' &&
$orig_data_type eq 'boolean'
) {
$size = '6';
if ( $type eq PRIMARY_KEY ) {
$name ||= mk_name( $table_name, 'pk', undef,1 );
- push @constraint_defs,
+ push @constraint_defs,
"CONSTRAINT $name PRIMARY KEY ".
'(' . join( ', ', @fields ) . ')';
}
elsif ( $type eq FOREIGN_KEY ) {
$name ||= mk_name( $table_name, 'fk', undef,1 );
- push @constraint_defs,
+ push @constraint_defs,
"CONSTRAINT $name FOREIGN KEY".
' (' . join( ', ', @fields ) . ') REFERENCES '.
$constraint->reference_table.
' (' . join( ', ', @rfields ) . ')';
}
elsif ( $type eq UNIQUE ) {
- $name ||= mk_name(
- $table_name,
+ $name ||= mk_name(
+ $table_name,
$name || ++$c_name_default,undef, 1
);
- push @constraint_defs,
+ push @constraint_defs,
"CONSTRAINT $name UNIQUE " .
'(' . join( ', ', @fields ) . ')';
}
# Indices
#
for my $index ( $table->get_indices ) {
- push @index_defs,
+ push @index_defs,
'CREATE INDEX ' . $index->name .
" ON $table_name (".
join( ', ', $index->fields ) . ");";
}
my $create_statement;
- $create_statement = qq[DROP TABLE $table_name_ur;\n]
+ $create_statement = qq[DROP TABLE $table_name_ur;\n]
if $add_drop_table;
$create_statement .= qq[CREATE TABLE $table_name_ur (\n].
- join( ",\n",
- map { " $_" } @field_defs, @constraint_defs
+ join( ",\n",
+ map { " $_" } @field_defs, @constraint_defs
).
"\n);"
;
- $output .= join( "\n\n",
+ $output .= join( "\n\n",
@comments,
- $create_statement,
- @index_defs,
+ $create_statement,
+ @index_defs,
''
);
}
my (@comments, $procedure_name);
$procedure_name = $procedure->name();
- push @comments,
+ push @comments,
"--\n-- Procedure: $procedure_name\n--" unless $no_comments;
# text of procedure already has the 'create procedure' stuff
# -------------------------------------------------------------------
sub mk_name {
- my $basename = shift || '';
- my $type = shift || '';
- my $scope = shift || '';
+ my $basename = shift || '';
+ my $type = shift || '';
+ my $scope = shift || '';
my $critical = shift || '';
my $basename_orig = $basename;
- my $max_name = $type
- ? $max_id_length - (length($type) + 1)
+ my $max_name = $type
+ ? $max_id_length - (length($type) + 1)
: $max_id_length;
- $basename = substr( $basename, 0, $max_name )
+ $basename = substr( $basename, 0, $max_name )
if length( $basename ) > $max_name;
my $name = $type ? "${type}_$basename" : $basename;
if ( my $prev = $scope->{ $name } ) {
my $name_orig = $name;
$name .= sprintf( "%02d", ++$prev );
- substr($name, $max_id_length - 3) = "00"
+ substr($name, $max_id_length - 3) = "00"
if length( $name ) > $max_id_length;
warn "The name '$name_orig' has been changed to ",
$scope->{ $name_orig }++;
}
- $name = substr( $name, 0, $max_id_length )
+ $name = substr( $name, 0, $max_id_length )
if ((length( $name ) > $max_id_length) && $critical);
$scope->{ $name }++;
return $name;
my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
# also trap fields that don't begin with a letter
- return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
+ return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
if ( $schema_obj_name ) {
++$unreserve{"$schema_obj_name.$name"};
WARNING: This method is Experimental so may change!
Called with the L<SQL::Translator::Schema> object and should return one (it
-doesn't have to be the same one) that will become the C<schema> varibale used
+doesn't have to be the same one) that will become the C<schema> varibale used
in the template.
Gets called from tt_default_vars.
%$pargs, # Allow any TT opts to be passed in the producer_args
) || die "Failed to initialize Template object: ".Template->error;
- for my $tbl ( sort {$a->order <=> $b->order} $scma->get_tables ) {
- my $outtmp;
+ for my $tbl ( sort {$a->order <=> $b->order} $scma->get_tables ) {
+ my $outtmp;
$tt->process( $file, {
translator => $Translator,
schema => $scma,
table => $tbl,
- }, \$outtmp )
- or die "Error processing template '$file' for table '".$tbl->name
- ."': ".$tt->error;
+ }, \$outtmp )
+ or die "Error processing template '$file' for table '".$tbl->name
+ ."': ".$tt->error;
$out .= $outtmp;
# Write out the file...
- write_file( table_file($tbl), $outtmp ) if $pargs->{mk_files};
+ write_file( table_file($tbl), $outtmp ) if $pargs->{mk_files};
}
return $out;
# Write the src given to the file given, handling the on_exists arg.
sub write_file {
- my ($file, $src) = @_;
+ my ($file, $src) = @_;
my $pargs = $Translator->producer_args;
my $root = $pargs->{mk_files_base};
}
my ($dir) = $file =~ m!^(.*)/!; # Want greedy, eveything before the last /
- if ( $dir and not -d $dir and $pargs->{mk_file_dir} ) { mkpath($dir); }
+ if ( $dir and not -d $dir and $pargs->{mk_file_dir} ) { mkpath($dir); }
debug "Writing to $file\n";
- open( FILE, ">$file") or die "Error opening file $file : $!\n";
- print FILE $src;
- close(FILE);
+ open( FILE, ">$file") or die "Error opening file $file : $!\n";
+ print FILE $src;
+ close(FILE);
}
# Reads file and inserts code between the insert comments and returns the new
=head1 DESCRIPTION
-Previous versions of SQL::Translator included an XML producer, but the
-namespace has since been further subdivided. Therefore, this module is
+Previous versions of SQL::Translator included an XML producer, but the
+namespace has since been further subdivided. Therefore, this module is
now just just an alias to the XML::SQLFairy producer.
=head1 SEE ALSO
return Dump({
schema => {
- tables => {
+ tables => {
map { ($_->name => view_table($_)) }
$schema->get_tables,
},
- views => {
+ views => {
map { ($_->name => view_view($_)) }
$schema->get_views,
},
- triggers => {
+ triggers => {
map { ($_->name => view_trigger($_)) }
$schema->get_triggers,
},
- procedures => {
- map { ($_->name => view_procedure($_)) }
+ procedures => {
+ map { ($_->name => view_procedure($_)) }
$schema->get_procedures,
},
},
'indices' => [
map { view_index($_) } $table->get_indices
],
- 'fields' => {
+ 'fields' => {
map { ($_->name => view_field($_)) }
- $table->get_fields
+ $table->get_fields
},
keys %{$table->extra} ? ('extra' => { $table->extra } ) : (),
};
my $self = shift;
my $g = Graph::Directed->new;
-
- for my $table ( $self->get_tables ) {
+
+ for my $table ( $self->get_tables ) {
my $tname = $table->name;
$g->add_vertex( $tname );
-
+
for my $field ( $table->get_fields ) {
if ( $field->is_foreign_key ) {
my $fktable = $field->foreign_key_reference->reference_table;
Add a table object. Returns the new SQL::Translator::Schema::Table object.
The "name" parameter is required. If you try to create a table with the
-same name as an existing table, you will get an error and the table will
+same name as an existing table, you will get an error and the table will
not be created.
my $t1 = $schema->add_table( name => 'foo' ) or die $schema->error;
Add a trigger object. Returns the new SQL::Translator::Schema::Trigger object.
The "name" parameter is required. If you try to create a trigger with the
-same name as an existing trigger, you will get an error and the trigger will
+same name as an existing trigger, you will get an error and the trigger will
not be created.
my $t1 = $schema->add_trigger( name => 'foo' );
Add a view object. Returns the new SQL::Translator::Schema::View object.
The "name" parameter is required. If you try to create a view with the
-same name as an existing view, you will get an error and the view will
+same name as an existing view, you will get an error and the view will
not be created.
my $v1 = $schema->add_view( name => 'foo' );
my $table_name = shift or return $self->error('No table name');
my $case_insensitive = shift;
if ( $case_insensitive ) {
- $table_name = uc($table_name);
- foreach my $table ( keys %{$self->{tables}} ) {
- return $self->{tables}{$table} if $table_name eq uc($table);
- }
- return $self->error(qq[Table "$table_name" does not exist]);
+ $table_name = uc($table_name);
+ foreach my $table ( keys %{$self->{tables}} ) {
+ return $self->{tables}{$table} if $table_name eq uc($table);
+ }
+ return $self->error(qq[Table "$table_name" does not exist]);
}
return $self->error(qq[Table "$table_name" does not exist])
unless exists $self->{'tables'}{$table_name};
=item * join_pk_only
-A True or False argument which determins whether or not to perform
+A True or False argument which determins whether or not to perform
the joins from primary keys to fields of the same name in other tables
=item * skip_fields
require Exporter;
$VERSION = '1.59';
-@EXPORT = qw[
+@EXPORT = qw[
CHECK_C
FOREIGN_KEY
FULL_TEXT
# ----------------------------------------------------------------------
__PACKAGE__->_attributes( qw/
- table name type fields reference_fields reference_table
+ table name type fields reference_fields reference_table
match_type on_delete on_update expression deferrable
/);
# Override to remove empty arrays from args.
# t/14postgres-parser breaks without this.
sub init {
-
+
=pod
=head2 new
=cut
my $self = shift;
-
+
if ( my $arg = shift ) {
# check arg here?
$self->{'expression'} = $arg;
return $self->error('Only one field allowed for foreign key')
if scalar @fields > 1;
- my $ref_table_name = $self->reference_table or
+ my $ref_table_name = $self->reference_table or
return $self->error('No reference table');
my $ref_table = $schema->get_table( $ref_table_name ) or
for my $ref_field ( @ref_fields ) {
next if $ref_table->get_field( $ref_field );
return $self->error(
- "Constraint from field(s) ",
+ "Constraint from field(s) ",
join(', ', map {qq['$table_name.$_']} @fields),
" to non-existent field '$ref_table_name.$ref_field'"
);
}
}
elsif ( $type eq CHECK_C ) {
- return $self->error('No expression for CHECK') unless
+ return $self->error('No expression for CHECK') unless
$self->expression;
}
=cut
my ( $self, $arg ) = @_;
-
+
if ( $arg ) {
$arg = lc $arg;
return $self->error("Invalid match type: $arg")
=head2 options
-Gets or adds to the constraints's options (e.g., "INITIALLY IMMEDIATE").
+Gets or adds to the constraints's options (e.g., "INITIALLY IMMEDIATE").
Returns an array or array reference.
$constraint->options('NORELY');
=cut
my $self = shift;
-
+
if ( my $arg = shift ) {
# validate $arg?
$self->{'on_delete'} = $arg;
=cut
my $self = shift;
-
+
if ( my $arg = shift ) {
# validate $arg?
$self->{'on_update'} = $arg;
unless ( ref $self->{'reference_fields'} ) {
my $table = $self->table or return $self->error('No table');
my $schema = $table->schema or return $self->error('No schema');
- if ( my $ref_table_name = $self->reference_table ) {
+ if ( my $ref_table_name = $self->reference_table ) {
my $ref_table = $schema->get_table( $ref_table_name ) or
return $self->error("Can't find table '$ref_table_name'");
- if ( my $constraint = $ref_table->primary_key ) {
+ if ( my $constraint = $ref_table->primary_key ) {
$self->{'reference_fields'} = [ $constraint->fields ];
}
else {
}
if ( ref $self->{'reference_fields'} ) {
- return wantarray
- ? @{ $self->{'reference_fields'} }
+ return wantarray
+ ? @{ $self->{'reference_fields'} }
: $self->{'reference_fields'};
}
else {
if ( $type ) {
$type = uc $type;
$type =~ s/_/ /g;
- return $self->error("Invalid constraint type: $type")
+ return $self->error("Invalid constraint type: $type")
unless $VALID_CONSTRAINT_TYPE{ $type };
$self->{'type'} = $type;
}
my $other = shift;
my $case_insensitive = shift;
my $ignore_constraint_names = shift;
-
+
return 0 unless $self->SUPER::equals($other);
return 0 unless $self->type eq $other->type;
unless ($ignore_constraint_names) {
return 0 unless $self->deferrable eq $other->deferrable;
#return 0 unless $self->is_valid eq $other->is_valid;
return 0 unless $case_insensitive ? uc($self->table->name) eq uc($other->table->name)
- : $self->table->name eq $other->table->name;
+ : $self->table->name eq $other->table->name;
return 0 unless $self->expression eq $other->expression;
-
+
# Check fields, regardless of order
- my %otherFields = (); # create a hash of the other fields
+ my %otherFields = (); # create a hash of the other fields
foreach my $otherField ($other->fields) {
- $otherField = uc($otherField) if $case_insensitive;
- $otherFields{$otherField} = 1;
+ $otherField = uc($otherField) if $case_insensitive;
+ $otherFields{$otherField} = 1;
}
foreach my $selfField ($self->fields) { # check for self fields in hash
- $selfField = uc($selfField) if $case_insensitive;
- return 0 unless $otherFields{$selfField};
- delete $otherFields{$selfField};
+ $selfField = uc($selfField) if $case_insensitive;
+ return 0 unless $otherFields{$selfField};
+ delete $otherFields{$selfField};
}
# Check all other fields were accounted for
return 0 unless keys %otherFields == 0;
# Check reference fields, regardless of order
- my %otherRefFields = (); # create a hash of the other reference fields
+ my %otherRefFields = (); # create a hash of the other reference fields
foreach my $otherRefField ($other->reference_fields) {
- $otherRefField = uc($otherRefField) if $case_insensitive;
- $otherRefFields{$otherRefField} = 1;
+ $otherRefField = uc($otherRefField) if $case_insensitive;
+ $otherRefFields{$otherRefField} = 1;
}
foreach my $selfRefField ($self->reference_fields) { # check for self reference fields in hash
- $selfRefField = uc($selfRefField) if $case_insensitive;
- return 0 unless $otherRefFields{$selfRefField};
- delete $otherRefFields{$selfRefField};
+ $selfRefField = uc($selfRefField) if $case_insensitive;
+ return 0 unless $otherRefFields{$selfRefField};
+ delete $otherRefFields{$selfRefField};
}
# Check all other reference fields were accounted for
return 0 unless keys %otherRefFields == 0;
=head2 comments
-Get or set the comments on a field. May be called several times to
+Get or set the comments on a field. May be called several times to
set and it will accumulate the comments. Called in an array context,
returns each comment individually; called in a scalar context, returns
all the comments joined on newlines.
}
if ( @{ $self->{'comments'} || [] } ) {
- return wantarray
+ return wantarray
? @{ $self->{'comments'} || [] }
: join( "\n", @{ $self->{'comments'} || [] } );
}
=head2 default_value
Get or set the field's default value. Will return undef if not defined
-and could return the empty string (it's a valid default value), so don't
+and could return the empty string (it's a valid default value), so don't
assume an error like other methods.
my $default = $field->default_value('foo');
unless ( defined $self->{'is_auto_increment'} ) {
if ( my $table = $self->table ) {
if ( my $schema = $table->schema ) {
- if (
+ if (
$schema->database eq 'PostgreSQL' &&
$self->data_type eq 'serial'
) {
=head2 is_nullable
-Get or set whether the field can be null. If not defined, then
+Get or set whether the field can be null. If not defined, then
returns "1" (assumes the field can be null). The argument is evaluated
by Perl for True or False, so the following are eqivalent:
$self->{'is_nullable'} = $arg ? 1 : 0;
}
- if (
- defined $self->{'is_nullable'} &&
+ if (
+ defined $self->{'is_nullable'} &&
$self->{'is_nullable'} == 1 &&
$self->is_primary_key
) {
=cut
my $self = shift;
-
+
unless ( defined $self->{'is_unique'} ) {
if ( my $table = $self->table ) {
for my $c ( $table->get_constraints ) {
# ----------------------------------------------------------------------
sub schema {
-=head2 schema
+=head2 schema
Shortcut to get the fields schema ($field->table->schema) or undef if it
doesn't have one.
$self->{'size'} = \@new if @new; # only set if all OK
}
- return wantarray
+ return wantarray
? @{ $self->{'size'} || [0] }
: join( ',', @{ $self->{'size'} || [0] } )
;
sub parsed_field {
-=head2
+=head2
Returns the field exactly as the parser found it
my $self = shift;
my $other = shift;
my $case_insensitive = shift;
-
+
return 0 unless $self->SUPER::equals($other);
return 0 unless $case_insensitive ? uc($self->name) eq uc($other->name) : $self->name eq $other->name;
# build package objects
#
foreach my $table ($self->translator->schema->get_tables){
- die __PACKAGE__." table ".$table->name." doesn't have a primary key!" unless $table->primary_key;
- die __PACKAGE__." table ".$table->name." can't have a composite primary key!" if ($table->primary_key->fields)[1];
+ die __PACKAGE__." table ".$table->name." doesn't have a primary key!" unless $table->primary_key;
+ die __PACKAGE__." table ".$table->name." can't have a composite primary key!" if ($table->primary_key->fields)[1];
- my $node = Node->new();
+ my $node = Node->new();
- $self->node_push($table->name => $node);
+ $self->node_push($table->name => $node);
- if ($table->is_trivial_link) { $node->is_trivial_link(1); }
- else { $node->is_trivial_link(0); }
+ if ($table->is_trivial_link) { $node->is_trivial_link(1); }
+ else { $node->is_trivial_link(0); }
- $node->order($self->order_incr());
- $node->name( $self->translator->format_package_name($table->name) );
- $node->table( $table );
- $node->primary_key( ($table->primary_key->fields)[0] );
+ $node->order($self->order_incr());
+ $node->name( $self->translator->format_package_name($table->name) );
+ $node->table( $table );
+ $node->primary_key( ($table->primary_key->fields)[0] );
- # Primary key may have a differenct accessor method name
- $node->primary_key_accessor(
- defined($self->translator->format_pk_name)
- ? $self->translator->format_pk_name->( $node->name, $node->primary_key )
- : undef
- );
+ # Primary key may have a differenct accessor method name
+ $node->primary_key_accessor(
+ defined($self->translator->format_pk_name)
+ ? $self->translator->format_pk_name->( $node->name, $node->primary_key )
+ : undef
+ );
}
foreach my $node ($self->node_values){
- foreach my $field ($node->table->get_fields){
- if (!$field->is_foreign_key && !$field->is_primary_key) { $node->data_fields->{$field->name} = 1; }
- elsif($field->is_foreign_key) {
- my $that = $self->node($field->foreign_key_reference->reference_table);
+ foreach my $field ($node->table->get_fields){
+ if (!$field->is_foreign_key && !$field->is_primary_key) { $node->data_fields->{$field->name} = 1; }
+ elsif($field->is_foreign_key) {
+ my $that = $self->node($field->foreign_key_reference->reference_table);
- #this means we have an incomplete schema
- next unless $that;
+ #this means we have an incomplete schema
+ next unless $that;
- my $edge = Edge->new(
- type => 'import',
- thisnode => $node,
- thisfield => $field,
- thatnode => $that,
- #can you believe this sh*t just to get a field obj?
- thatfield => $self->translator->schema->get_table($field->foreign_key_reference->reference_table)->get_field(($field->foreign_key_reference->reference_fields)[0])
- );
+ my $edge = Edge->new(
+ type => 'import',
+ thisnode => $node,
+ thisfield => $field,
+ thatnode => $that,
+ #can you believe this sh*t just to get a field obj?
+ thatfield => $self->translator->schema->get_table($field->foreign_key_reference->reference_table)->get_field(($field->foreign_key_reference->reference_fields)[0])
+ );
- $node->edgecount($that->name, $node->edgecount($that->name)+1);
+ $node->edgecount($that->name, $node->edgecount($that->name)+1);
- $node->has($that->name, $node->has($that->name)+1);
- $that->many($node->name, $that->many($node->name)+1);
+ $node->has($that->name, $node->has($that->name)+1);
+ $that->many($node->name, $that->many($node->name)+1);
- $that->edgecount($node->name, $that->edgecount($node->name)+1);
+ $that->edgecount($node->name, $that->edgecount($node->name)+1);
#warn "\t" . $node->name . "\t" . $node->edgecount($that->name);
- $node->push_edges( $edge );
- $that->push_edges( $edge->flip );
+ $node->push_edges( $edge );
+ $that->push_edges( $edge->flip );
}
- }
+ }
#warn Dumper($node->edgecount());
#warn "*****";
#
#foreach linknode
foreach my $lnode (sort $self->node_values){
- next if $lnode->table->is_data;
- foreach my $inode1 (sort $self->node_values){
- #linknode can't link to itself
- next if $inode1 eq $lnode;
-
- my @inode1_imports = grep { $_->type eq 'import' and $_->thatnode eq $inode1 } $lnode->edges;
- next unless @inode1_imports;
-
- foreach my $inode2 (sort $self->node_values){
- #linknode can't link to itself
- next if $inode2 eq $lnode;
-
- #identify tables that import keys to linknode
- my %i = map {$_->thatnode->name => 1} grep { $_->type eq 'import'} $lnode->edges;
-
- if(scalar(keys %i) == 1) {
- } else {
- last if $inode1 eq $inode2;
- }
-
- my @inode2_imports = grep { $_->type eq 'import' and $_->thatnode eq $inode2 } $lnode->edges;
- next unless @inode2_imports;
-
- my $cedge = CompoundEdge->new();
- $cedge->via($lnode);
-
- #warn join ' ', map {$_->thisfield->name} map {$_->flip} $lnode->edges;
- #warn join ' ', map {$_->thisfield->name} $lnode->edges;
- #warn join ' ', map {$_->thisfield->name} map {$_->flip} grep {$_->type eq 'import'} $lnode->edges;
- #warn join ' ', map {$_->thatfield->name} map {$_->flip} grep {$_->type eq 'import'} $lnode->edges;
- $cedge->push_edges(
- map {$_->flip}
- grep {$_->type eq 'import'
- and
- ($_->thatnode eq $inode1 or $_->thatnode eq $inode2)
- } $lnode->edges
- );
-
- if(scalar(@inode1_imports) == 1 and scalar(@inode2_imports) == 1){
- $cedge->type('one2one');
-
- $inode1->via($inode2->name,$inode1->via($inode2->name)+1);
- $inode2->via($inode1->name,$inode2->via($inode1->name)+1);
- }
- elsif(scalar(@inode1_imports) > 1 and scalar(@inode2_imports) == 1){
- $cedge->type('many2one');
-
- $inode1->via($inode2->name,$inode1->via($inode2->name)+1);
- $inode2->via($inode1->name,$inode2->via($inode1->name)+1);
- }
- elsif(scalar(@inode1_imports) == 1 and scalar(@inode2_imports) > 1){
- #handled above
- }
- elsif(scalar(@inode1_imports) > 1 and scalar(@inode2_imports) > 1){
- $cedge->type('many2many');
-
- $inode1->via($inode2->name,$inode1->via($inode2->name)+1);
- $inode2->via($inode1->name,$inode2->via($inode1->name)+1);
- }
+ next if $lnode->table->is_data;
+ foreach my $inode1 (sort $self->node_values){
+ #linknode can't link to itself
+ next if $inode1 eq $lnode;
+
+ my @inode1_imports = grep { $_->type eq 'import' and $_->thatnode eq $inode1 } $lnode->edges;
+ next unless @inode1_imports;
+
+ foreach my $inode2 (sort $self->node_values){
+ #linknode can't link to itself
+ next if $inode2 eq $lnode;
+
+ #identify tables that import keys to linknode
+ my %i = map {$_->thatnode->name => 1} grep { $_->type eq 'import'} $lnode->edges;
+
+ if(scalar(keys %i) == 1) {
+ } else {
+ last if $inode1 eq $inode2;
+ }
+
+ my @inode2_imports = grep { $_->type eq 'import' and $_->thatnode eq $inode2 } $lnode->edges;
+ next unless @inode2_imports;
+
+ my $cedge = CompoundEdge->new();
+ $cedge->via($lnode);
+
+ #warn join ' ', map {$_->thisfield->name} map {$_->flip} $lnode->edges;
+ #warn join ' ', map {$_->thisfield->name} $lnode->edges;
+ #warn join ' ', map {$_->thisfield->name} map {$_->flip} grep {$_->type eq 'import'} $lnode->edges;
+ #warn join ' ', map {$_->thatfield->name} map {$_->flip} grep {$_->type eq 'import'} $lnode->edges;
+ $cedge->push_edges(
+ map {$_->flip}
+ grep {$_->type eq 'import'
+ and
+ ($_->thatnode eq $inode1 or $_->thatnode eq $inode2)
+ } $lnode->edges
+ );
+
+ if(scalar(@inode1_imports) == 1 and scalar(@inode2_imports) == 1){
+ $cedge->type('one2one');
+
+ $inode1->via($inode2->name,$inode1->via($inode2->name)+1);
+ $inode2->via($inode1->name,$inode2->via($inode1->name)+1);
+ }
+ elsif(scalar(@inode1_imports) > 1 and scalar(@inode2_imports) == 1){
+ $cedge->type('many2one');
+
+ $inode1->via($inode2->name,$inode1->via($inode2->name)+1);
+ $inode2->via($inode1->name,$inode2->via($inode1->name)+1);
+ }
+ elsif(scalar(@inode1_imports) == 1 and scalar(@inode2_imports) > 1){
+ #handled above
+ }
+ elsif(scalar(@inode1_imports) > 1 and scalar(@inode2_imports) > 1){
+ $cedge->type('many2many');
+
+ $inode1->via($inode2->name,$inode1->via($inode2->name)+1);
+ $inode2->via($inode1->name,$inode2->via($inode1->name)+1);
+ }
#warn Dumper($cedge);
- $inode1->push_compoundedges($cedge);
- $inode2->push_compoundedges($cedge) unless $inode1 eq $inode2;
+ $inode1->push_compoundedges($cedge);
+ $inode2->push_compoundedges($cedge) unless $inode1 eq $inode2;
# if($inode1->name ne $inode2->name){
# my $flipped_cedge = $cedge;
# foreach my $flipped_cedge_edge ($flipped_cedge->edges){
# warn "\t". Dumper $flipped_cedge_edge->flip;
# }
# }
- }
- }
+ }
+ }
}
my $graph = $self; #hack
use Class::MakeMethods::Template::Hash (
new => ['new'],
object => [
- 'via' => {class => 'SQL::Translator::Schema::Graph::Node'},
- ],
+ 'via' => {class => 'SQL::Translator::Schema::Graph::Node'},
+ ],
'array_of_objects -class SQL::Translator::Schema::Graph::Edge' => [ qw( edges ) ],
);
scalar => [ qw( type ) ],
array => [ qw( traversals ) ],
object => [
- 'thisfield' => {class => 'SQL::Translator::Schema::Field'}, #FIXME
- 'thatfield' => {class => 'SQL::Translator::Schema::Field'}, #FIXME
- 'thisnode' => {class => 'SQL::Translator::Schema::Graph::Node'},
- 'thatnode' => {class => 'SQL::Translator::Schema::Graph::Node'},
+ 'thisfield' => {class => 'SQL::Translator::Schema::Field'}, #FIXME
+ 'thatfield' => {class => 'SQL::Translator::Schema::Field'}, #FIXME
+ 'thisnode' => {class => 'SQL::Translator::Schema::Graph::Node'},
+ 'thatnode' => {class => 'SQL::Translator::Schema::Graph::Node'},
- ],
+ ],
);
sub flip {
#warn "self thatfield: ".$self->thatfield->name;
return SQL::Translator::Schema::Graph::Edge->new( thisfield => $self->thatfield,
- thatfield => $self->thisfield,
- thisnode => $self->thatnode,
- thatnode => $self->thisnode,
- type => $self->type eq 'import' ? 'export' : 'import'
- );
+ thatfield => $self->thisfield,
+ thisnode => $self->thatnode,
+ thatnode => $self->thisnode,
+ type => $self->type eq 'import' ? 'export' : 'import'
+ );
}
1;
if ( $type ) {
$type = uc $type;
- return $self->error("Invalid index type: $type")
+ return $self->error("Invalid index type: $type")
unless $VALID_INDEX_TYPE{ $type };
$self->{'type'} = $type;
}
my $other = shift;
my $case_insensitive = shift;
my $ignore_index_names = shift;
-
+
return 0 unless $self->SUPER::equals($other);
unless ($ignore_index_names) {
}
#return 0 unless $self->is_valid eq $other->is_valid;
return 0 unless $self->type eq $other->type;
-
+
# Check fields, regardless of order
- my %otherFields = (); # create a hash of the other fields
+ my %otherFields = (); # create a hash of the other fields
foreach my $otherField ($other->fields) {
- $otherField = uc($otherField) if $case_insensitive;
- $otherFields{$otherField} = 1;
+ $otherField = uc($otherField) if $case_insensitive;
+ $otherFields{$otherField} = 1;
}
foreach my $selfField ($self->fields) { # check for self fields in hash
- $selfField = uc($selfField) if $case_insensitive;
- return 0 unless $otherFields{$selfField};
- delete $otherFields{$selfField};
+ $selfField = uc($selfField) if $case_insensitive;
+ return 0 unless $otherFields{$selfField};
+ delete $otherFields{$selfField};
}
# Check all other fields were accounted for
return 0 unless keys %otherFields == 0;
=head1 DESCSIPTION
Base class for Schema objects. Sub classes L<Class::Base> and adds the following
-extra functionality.
+extra functionality.
=cut
package SQL::Translator::Schema::Table;
use base qw/SQL::Translator::Schema::Object/;
-
+
__PACKAGE__->_attributes( qw/schema name/ );
sub name { ... }
Then we can construct it with
- my $table = SQL::Translator::Schema::Table->new(
+ my $table = SQL::Translator::Schema::Table->new(
schema => $schema,
name => 'foo',
);
__PACKAGE__->mk_classdata("__attributes");
# Define any global attributes here
-__PACKAGE__->__attributes([qw/extra/]);
+__PACKAGE__->__attributes([qw/extra/]);
# Set the classes attribute names. Multiple calls are cumulative.
# We need to be careful to create a new ref so that all classes don't end up
# Call accessors for any args in hashref passed
sub init {
my ( $self, $config ) = @_;
-
+
for my $arg ( $self->_attributes ) {
next unless defined $config->{$arg};
- defined $self->$arg( $config->{$arg} ) or return;
+ defined $self->$arg( $config->{$arg} ) or return;
}
return $self;
Returns a hash or a hashref.
$field->extra( qualifier => 'ZEROFILL' );
-
+
$qualifier = $field->extra('qualifier');
-
+
%extra = $field->extra;
$extra = $field->extra;
-
+
=cut
my $self = shift;
@_ = %{$_[0]} if ref $_[0] eq "HASH";
my $extra = $self->{'extra'} ||= {};
- if (@_==1) {
+ if (@_==1) {
return exists($extra->{$_[0]}) ? $extra->{$_[0]} : undef ;
}
elsif (@_) {
$extra->{$key} = $value;
}
}
-
+
return wantarray ? %$extra : $extra;
}
certain extra attributes only.
# remove all extra attributes
- $field->remove_extra();
-
+ $field->remove_extra();
+
# remove timezone and locale attributes only
$field->remove_extra(qw/timezone locale/);
my $self = shift;
my $other = shift;
-
+
return 0 unless $other;
return 1 if overload::StrVal($self) eq overload::StrVal($other);
return 0 unless $other->isa( __PACKAGE__ );
# ----------------------------------------------------------------------
sub _compare_objects {
- my $self = shift;
- my $obj1 = shift;
- my $obj2 = shift;
- my $result = (ref_compare($obj1, $obj2) == 0);
-# if ( !$result ) {
-# use Carp qw(cluck);
-# cluck("How did I get here?");
-# use Data::Dumper;
-# $Data::Dumper::Maxdepth = 1;
-# print "obj1: ", Dumper($obj1), "\n";
-# print "obj2: ", Dumper($obj2), "\n";
-# }
- return $result;
+ my $self = shift;
+ my $obj1 = shift;
+ my $obj2 = shift;
+ my $result = (ref_compare($obj1, $obj2) == 0);
+# if ( !$result ) {
+# use Carp qw(cluck);
+# cluck("How did I get here?");
+# use Data::Dumper;
+# $Data::Dumper::Maxdepth = 1;
+# print "obj1: ", Dumper($obj1), "\n";
+# print "obj2: ", Dumper($obj2), "\n";
+# }
+ return $result;
}
#=============================================================================
=head1 AUTHOR
-Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>,
+Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>,
Mark Addison E<lt>mark.addison@itn.co.ukE<gt>.
=cut
}
if ( @{ $self->{'comments'} || [] } ) {
- return wantarray
+ return wantarray
? @{ $self->{'comments'} || [] }
: join( "\n", @{ $self->{'comments'} || [] } );
}
my $other = shift;
my $case_insensitive = shift;
my $ignore_sql = shift;
-
+
return 0 unless $self->SUPER::equals($other);
return 0 unless $case_insensitive ? uc($self->name) eq uc($other->name) : $self->name eq $other->name;
-
+
unless ($ignore_sql) {
my $selfSql = $self->sql;
my $otherSql = $other->sql;
$otherSql =~ s/\s+/ /sg;
return 0 unless $selfSql eq $otherSql;
}
-
+
return 0 unless $self->_compare_objects(scalar $self->parameters, scalar $other->parameters);
# return 0 unless $self->comments eq $other->comments;
# return 0 unless $case_insensitive ? uc($self->owner) eq uc($other->owner) : $self->owner eq $other->owner;
Object constructor.
- my $table = SQL::Translator::Schema::Table->new(
+ my $table = SQL::Translator::Schema::Table->new(
schema => $schema,
name => 'foo',
);
=head2 add_constraint
-Add a constraint to the table. Returns the newly created
+Add a constraint to the table. Returns the newly created
C<SQL::Translator::Schema::Constraint> object.
my $c1 = $table->add_constraint(
else {
my %args = @_;
$args{'table'} = $self;
- $constraint = $constraint_class->new( \%args ) or
+ $constraint = $constraint_class->new( \%args ) or
return $self->error( $constraint_class->error );
}
if ( $pk && $constraint->type eq PRIMARY_KEY ) {
$self->primary_key( $constraint->fields );
$pk->name($constraint->name) if $constraint->name;
- my %extra = $constraint->extra;
+ my %extra = $constraint->extra;
$pk->extra(%extra) if keys %extra;
$constraint = $pk;
$ok = 0;
}
}
#
- # See if another constraint of the same type
+ # See if another constraint of the same type
# covers the same fields. -- This doesn't work! ky
#
# elsif ( $constraint->type ne CHECK_C ) {
# my @field_names = $constraint->fields;
-# for my $c (
-# grep { $_->type eq $constraint->type }
-# $self->get_constraints
+# for my $c (
+# grep { $_->type eq $constraint->type }
+# $self->get_constraints
# ) {
# my %fields = map { $_, 1 } $c->fields;
# for my $field_name ( @field_names ) {
# if ( $fields{ $field_name } ) {
# $constraint = $c;
-# $ok = 0;
+# $ok = 0;
# last;
# }
# }
$constraint_name = shift;
}
- if ( ! grep { $_->name eq $constraint_name } @ { $self->{'constraints'} } ) {
+ if ( ! grep { $_->name eq $constraint_name } @ { $self->{'constraints'} } ) {
return $self->error(qq[Can't drop constraint: "$constraint_name" doesn't exist]);
}
else {
my %args = @_;
$args{'table'} = $self;
- $index = $index_class->new( \%args ) or return
+ $index = $index_class->new( \%args ) or return
$self->error( $index_class->error );
}
foreach my $ex_index ($self->get_indices) {
$index_name = shift;
}
- if ( ! grep { $_->name eq $index_name } @{ $self->{'indices'} }) {
+ if ( ! grep { $_->name eq $index_name } @{ $self->{'indices'} }) {
return $self->error(qq[Can't drop index: "$index_name" doesn't exist]);
}
=head2 add_field
Add an field to the table. Returns the newly created
-C<SQL::Translator::Schema::Field> object. The "name" parameter is
-required. If you try to create a field with the same name as an
+C<SQL::Translator::Schema::Field> object. The "name" parameter is
+required. If you try to create a field with the same name as an
existing field, you will get an error and the field will not be created.
my $f1 = $table->add_field(
size => 11,
);
- my $f2 = SQL::Translator::Schema::Field->new(
- name => 'name',
+ my $f2 = SQL::Translator::Schema::Field->new(
+ name => 'name',
table => $table,
);
$f2 = $table->add_field( $field2 ) or die $table->error;
else {
my %args = @_;
$args{'table'} = $self;
- $field = $field_class->new( \%args ) or return
+ $field = $field_class->new( \%args ) or return
$self->error( $field_class->error );
}
# We know we have a name as the Field->new above errors if none given.
my $field_name = $field->name;
- if ( exists $self->{'fields'}{ $field_name } ) {
+ if ( exists $self->{'fields'}{ $field_name } ) {
return $self->error(qq[Can't create field: "$field_name" exists]);
}
else {
=head2 drop_field
-Remove a field from the table. Returns the field object if the field was
-found and removed, an error otherwise. The single parameter can be either
+Remove a field from the table. Returns the field object if the field was
+found and removed, an error otherwise. The single parameter can be either
a field name or an C<SQL::Translator::Schema::Field> object.
$table->drop_field('myfield');
=head2 comments
-Get or set the comments on a table. May be called several times to
+Get or set the comments on a table. May be called several times to
set and it will accumulate the comments. Called in an array context,
returns each comment individually; called in a scalar context, returns
all the comments joined on newlines.
}
if ( @{ $self->{'comments'} || [] } ) {
- return wantarray
+ return wantarray
? @{ $self->{'comments'} }
: join( "\n", @{ $self->{'comments'} } )
;
- }
+ }
else {
return wantarray ? () : undef;
}
my $self = shift;
if ( ref $self->{'constraints'} ) {
- return wantarray
+ return wantarray
? @{ $self->{'constraints'} } : $self->{'constraints'};
}
else {
my $self = shift;
if ( ref $self->{'indices'} ) {
- return wantarray
- ? @{ $self->{'indices'} }
+ return wantarray
+ ? @{ $self->{'indices'} }
: $self->{'indices'};
}
else {
my $field_name = shift or return $self->error('No field name');
my $case_insensitive = shift;
if ( $case_insensitive ) {
- $field_name = uc($field_name);
- foreach my $field ( keys %{$self->{fields}} ) {
- return $self->{fields}{$field} if $field_name eq uc($field);
- }
- return $self->error(qq[Field "$field_name" does not exist]);
+ $field_name = uc($field_name);
+ foreach my $field ( keys %{$self->{fields}} ) {
+ return $self->{fields}{$field} if $field_name eq uc($field);
+ }
+ return $self->error(qq[Field "$field_name" does not exist]);
}
return $self->error( qq[Field "$field_name" does not exist] ) unless
exists $self->{'fields'}{ $field_name };
=cut
my $self = shift;
- my @fields =
+ my @fields =
map { $_->[1] }
sort { $a->[0] <=> $b->[0] }
map { [ $_->order, $_ ] }
return $self->error('No name') unless $self->name;
return $self->error('No fields') unless $self->get_fields;
- for my $object (
- $self->get_fields, $self->get_indices, $self->get_constraints
+ for my $object (
+ $self->get_fields, $self->get_indices, $self->get_constraints
) {
return $object->error unless $object->is_valid;
}
my %fk = ();
foreach my $field ( $self->get_fields ) {
- next unless $field->is_foreign_key;
- $fk{$field->foreign_key_reference->reference_table}++;
- }
+ next unless $field->is_foreign_key;
+ $fk{$field->foreign_key_reference->reference_table}++;
+ }
foreach my $referenced (keys %fk){
- if($fk{$referenced} > 1){
- $self->{'is_trivial_link'} = 0;
- last;
- }
+ if($fk{$referenced} > 1){
+ $self->{'is_trivial_link'} = 0;
+ last;
+ }
}
return $self->{'is_trivial_link'};
$self->{'can_link'}{ $table1->name }{ $table2->name } =
[ 'one2one', $fk{ $table2->name }, $fk{ $table1->name } ];
- # non-trivial traversal. one way to link table2,
+ # non-trivial traversal. one way to link table2,
# many ways to link table1
}
elsif ( scalar( @{ $fk{ $table1->name } } > 1 )
$self->{'can_link'}{ $table2->name }{ $table1->name } =
[ 'one2many', $fk{ $table2->name }, $fk{ $table1->name } ];
- # non-trivial traversal. one way to link table1,
+ # non-trivial traversal. one way to link table1,
# many ways to link table2
}
elsif ( scalar( @{ $fk{ $table1->name } } == 1 )
$self->{'can_link'}{ $table2->name }{ $table1->name } =
[ 'many2many', $fk{ $table2->name }, $fk{ $table1->name } ];
- # one of the tables didn't export a key
+ # one of the tables didn't export a key
# to this table, no linking possible
}
else {
my $constraint;
if ( @$fields ) {
for my $f ( @$fields ) {
- return $self->error(qq[Invalid field "$f"]) unless
+ return $self->error(qq[Invalid field "$f"]) unless
$self->get_field($f);
}
$has_pk = 1;
$c->fields( @{ $c->fields }, @$fields );
$constraint = $c;
- }
+ }
}
unless ( $has_pk ) {
=cut
my $self = shift;
- my @fields =
+ my @fields =
map { $_->name }
sort { $a->order <=> $b->order }
values %{ $self->{'fields'} || {} };
my $self = shift;
my $other = shift;
my $case_insensitive = shift;
-
+
return 0 unless $self->SUPER::equals($other);
return 0 unless $case_insensitive ? uc($self->name) eq uc($other->name) : $self->name eq $other->name;
return 0 unless $self->_compare_objects(scalar $self->options, scalar $other->options);
# Go through our fields
my %checkedFields;
foreach my $field ( $self->get_fields ) {
- my $otherField = $other->get_field($field->name, $case_insensitive);
- return 0 unless $field->equals($otherField, $case_insensitive);
- $checkedFields{$field->name} = 1;
+ my $otherField = $other->get_field($field->name, $case_insensitive);
+ return 0 unless $field->equals($otherField, $case_insensitive);
+ $checkedFields{$field->name} = 1;
}
# Go through the other table's fields
foreach my $otherField ( $other->get_fields ) {
- next if $checkedFields{$otherField->name};
- return 0;
+ next if $checkedFields{$otherField->name};
+ return 0;
}
# Constraints
my %checkedConstraints;
CONSTRAINT:
foreach my $constraint ( $self->get_constraints ) {
- foreach my $otherConstraint ( $other->get_constraints ) {
- if ( $constraint->equals($otherConstraint, $case_insensitive) ) {
- $checkedConstraints{$otherConstraint} = 1;
- next CONSTRAINT;
- }
- }
- return 0;
+ foreach my $otherConstraint ( $other->get_constraints ) {
+ if ( $constraint->equals($otherConstraint, $case_insensitive) ) {
+ $checkedConstraints{$otherConstraint} = 1;
+ next CONSTRAINT;
+ }
+ }
+ return 0;
}
# Go through the other table's constraints
CONSTRAINT2:
foreach my $otherConstraint ( $other->get_constraints ) {
- next if $checkedFields{$otherConstraint};
- foreach my $constraint ( $self->get_constraints ) {
- if ( $otherConstraint->equals($constraint, $case_insensitive) ) {
- next CONSTRAINT2;
- }
- }
- return 0;
+ next if $checkedFields{$otherConstraint};
+ foreach my $constraint ( $self->get_constraints ) {
+ if ( $otherConstraint->equals($constraint, $case_insensitive) ) {
+ next CONSTRAINT2;
+ }
+ }
+ return 0;
}
# Indices
my %checkedIndices;
INDEX:
foreach my $index ( $self->get_indices ) {
- foreach my $otherIndex ( $other->get_indices ) {
- if ( $index->equals($otherIndex, $case_insensitive) ) {
- $checkedIndices{$otherIndex} = 1;
- next INDEX;
- }
- }
- return 0;
+ foreach my $otherIndex ( $other->get_indices ) {
+ if ( $index->equals($otherIndex, $case_insensitive) ) {
+ $checkedIndices{$otherIndex} = 1;
+ next INDEX;
+ }
+ }
+ return 0;
}
# Go through the other table's indices
INDEX2:
foreach my $otherIndex ( $other->get_indices ) {
- next if $checkedIndices{$otherIndex};
- foreach my $index ( $self->get_indices ) {
- if ( $otherIndex->equals($index, $case_insensitive) ) {
- next INDEX2;
- }
- }
- return 0;
+ next if $checkedIndices{$otherIndex};
+ foreach my $index ( $self->get_indices ) {
+ if ( $otherIndex->equals($index, $case_insensitive) ) {
+ next INDEX2;
+ }
+ }
+ return 0;
}
- return 1;
+ return 1;
}
# ----------------------------------------------------------------------
=head1 LOOKUP METHODS
-The following are a set of shortcut methods for getting commonly used lists of
-fields and constraints. They all return lists or array refs of Field or
+The following are a set of shortcut methods for getting commonly used lists of
+fields and constraints. They all return lists or array refs of Field or
Constraint objects.
=over 4
# ----------------------------------------------------------------------
__PACKAGE__->_attributes( qw/
- name schema perform_action_when database_events database_event
+ name schema perform_action_when database_events database_event
fields table on_table action order
/);
=head2 perform_action_when
-Gets or sets whether the event happens "before" or "after" the
+Gets or sets whether the event happens "before" or "after" the
C<database_event>.
$trigger->perform_action_when('after');
=cut
my $self = shift;
-
+
if ( my $arg = shift ) {
$arg = lc $arg;
$arg =~ s/\s+/ /g;
$self->{'perform_action_when'} = $arg;
}
else {
- return
+ return
$self->error("Invalid argument '$arg' to perform_action_when");
}
}
Obsolete please use database_events!
=cut
-
+
my $self = shift;
return $self->database_events( @_ );
}
-
+
# ----------------------------------------------------------------------
sub database_events {
@args = map { s/\s+/ /g; lc $_ } @args;
my %valid = map { $_, 1 } qw[ insert update update_on delete ];
my @invalid = grep { !defined $valid{ $_ } } @args;
-
+
if ( @invalid ) {
return $self->error(
sprintf("Invalid events '%s' in database_events",
$self->{'database_events'} = [ @args ];
}
- return wantarray
+ return wantarray
? @{ $self->{'database_events'} || [] }
: $self->{'database_events'};
}
my ($self, $arg) = @_;
if ( @_ == 2 ) {
$self->error("Table attribute of a ".__PACKAGE__.
- " must be a SQL::Translator::Schema::Table")
+ " must be a SQL::Translator::Schema::Table")
unless ref $arg and $arg->isa('SQL::Translator::Schema::Table');
$self->{table} = $arg;
}
my $self = shift;
- for my $attr (
- qw[ name perform_action_when database_events on_table action ]
+ for my $attr (
+ qw[ name perform_action_when database_events on_table action ]
) {
return $self->error("Invalid: missing '$attr'") unless $self->$attr();
}
-
- return $self->error("Missing fields for UPDATE ON") if
+
+ return $self->error("Missing fields for UPDATE ON") if
$self->database_event eq 'update_on' && !$self->fields;
return 1;
Compare two arrays.
=cut
-
+
my ($first, $second) = @_;
no warnings; # silence spurious -w undef complaints
my $self = shift;
my $other = shift;
my $case_insensitive = shift;
-
+
return 0 unless $self->SUPER::equals($other);
my %names;
- for my $name ( $self->name, $other->name ) {
+ for my $name ( $self->name, $other->name ) {
$name = lc $name if $case_insensitive;
$names{ $name }++;
}
return $self->error('perform_action_when differs');
}
- if (
- !compare_arrays( [$self->database_events], [$other->database_events] )
+ if (
+ !compare_arrays( [$self->database_events], [$other->database_events] )
) {
return $self->error('database_events differ');
}
return $self->error('action differs');
}
- if (
+ if (
!$self->_compare_objects( scalar $self->extra, scalar $other->extra )
) {
return $self->error('extras differ');
my $other = shift;
my $case_insensitive = shift;
my $ignore_sql = shift;
-
+
return 0 unless $self->SUPER::equals($other);
return 0 unless $case_insensitive ? uc($self->name) eq uc($other->name) : $self->name eq $other->name;
#return 0 unless $self->is_valid eq $other->is_valid;
-
+
unless ($ignore_sql) {
my $selfSql = $self->sql;
my $otherSql = $other->sql;
$otherSql =~ s/\s+/ /sg;
return 0 unless $selfSql eq $otherSql;
}
-
+
my $selfFields = join(":", $self->fields);
my $otherFields = join(":", $other->fields);
return 0 unless $case_insensitive ? uc($selfFields) eq uc($otherFields) : $selfFields eq $otherFields;
# This processes string-like arguments.
#
else {
- return [
+ return [
map { s/^\s+|\s+$//g; $_ }
map { split /,/ }
grep { defined && length } @$list
my @vers;
- # X.Y.Z style
+ # X.Y.Z style
if ( $v =~ / ^ (\d+) \. (\d{1,3}) (?: \. (\d{1,3}) )? $ /x ) {
push @vers, $1, $2, $3;
}
- # XYYZZ (mysql) style
+ # XYYZZ (mysql) style
elsif ( $v =~ / ^ (\d) (\d{2}) (\d{2}) $ /x ) {
push @vers, $1, $2, $3;
}
- # XX.YYYZZZ (perl) style or simply X
+ # XX.YYYZZZ (perl) style or simply X
elsif ( $v =~ / ^ (\d+) (?: \. (\d{3}) (\d{3}) )? $ /x ) {
push @vers, $1, $2, $3;
}
my @vers;
- # X.Y.Z style
+ # X.Y.Z style
if ( $v =~ / ^ (\d+) \. (\d{1,3}) (?: \. (\d{1,3}) )? $ /x ) {
push @vers, $1, $2, $3;
}
- # XX.YYYZZZ (perl) style or simply X
+ # XX.YYYZZZ (perl) style or simply X
elsif ( $v =~ / ^ (\d+) (?: \. (\d{3}) (\d{3}) )? $ /x ) {
push @vers, $1, $2, $3;
}
=head2 parse_mysql_version
-Used by both L<Parser::MySQL|SQL::Translator::Parser::MySQL> and
+Used by both L<Parser::MySQL|SQL::Translator::Parser::MySQL> and
L<Producer::MySQL|SQL::Translator::Producer::MySQL> in order to provide a
consistent format for both C<< parser_args->{mysql_parser_version} >> and
C<< producer_args->{mysql_version} >> respectively. Takes any of the following
my ($hashref, $object_type) = @_;
if ( !exists $ATTRIBUTES{ $object_type } ) {
- die "Can't add default attribs for unknown Schema "
+ die "Can't add default attribs for unknown Schema "
. "object type '$object_type'.";
}
- for my $attr (
+ for my $attr (
grep { !exists $hashref->{ $_ } }
- keys %{ $ATTRIBUTES{ $object_type } }
+ keys %{ $ATTRIBUTES{ $object_type } }
) {
$hashref->{ $attr } = $ATTRIBUTES{ $object_type }{ $attr }
}
is_deeply( [$obj->options], $test->{options},
"$t_name options are '".join(",",@{$test->{options}})."'" );
-
+
is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" );
}
is_deeply( [$obj->options], $test->{options},
"$t_name options are '".join(",",@{$test->{options}})."'" );
-
+
is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" );
}
"$t_name on_table is '$test->{on_table}'" );
is( $obj->action, $test->{action}, "$t_name action is '$test->{action}'" );
-
+
is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" );
}
is_deeply( [$obj->fields], $test->{fields},
"$t_name fields are '".join(",",@{$test->{fields}})."'" );
-
+
is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" );
}
is_deeply( [$obj->parameters], $test->{parameters},
"$t_name parameters are '".join(",",@{$test->{parameters}})."'" );
- is( $obj->comments, $test->{comments},
+ is( $obj->comments, $test->{comments},
"$t_name comments is '$test->{comments}'" );
is( $obj->owner, $test->{owner}, "$t_name owner is '$test->{owner}'" );
-
+
is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" );
}
# Fields
if ( $arg{fields} ) {
my @fldnames = map {$_->{name}} @{$arg{fields}};
- is_deeply(
+ is_deeply(
[ map {$_->name} $obj->get_fields ],
[ @fldnames ],
"${t_name} field names are ".join(", ",@fldnames)
my $meth = "get_$plural";
my @objects = $obj->$meth;
is( scalar(@objects), scalar(@tests),
- "${t_name}$obj_name has " . scalar(@tests) . " $plural"
+ "${t_name}$obj_name has " . scalar(@tests) . " $plural"
);
for my $object (@objects) {
is( $obj->database, $test->{database},
"$t_name database is '$test->{database}'" );
-
+
is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" );
is( $obj->is_valid, $test->{is_valid},
=head1 AUTHOR
-Mark D. Addison E<lt>mark.addison@itn.co.ukE<gt>,
+Mark D. Addison E<lt>mark.addison@itn.co.ukE<gt>,
Darren Chamberlain <darren@cpan.org>.
Thanks to Ken Y. Clark for the original table and field test code taken from
projects / dbsrgits/SQL-Translator.git / commitdiff