tests) for this to the SQLF XML parser.
package SQL::Translator::Parser::XML::SQLFairy;
# -------------------------------------------------------------------
-# $Id: SQLFairy.pm,v 1.11 2004-08-20 11:01:48 grommit Exp $
+# $Id: SQLFairy.pm,v 1.12 2004-11-05 15:03:09 grommit Exp $
# -------------------------------------------------------------------
# Copyright (C) 2003 Mark Addison <mark.addison@itn.co.uk>,
#
use strict;
use vars qw[ $DEBUG $VERSION @EXPORT_OK ];
-$VERSION = sprintf "%d.%02d", q$Revision: 1.11 $ =~ /(\d+)\.(\d+)/;
+$VERSION = sprintf "%d.%02d", q$Revision: 1.12 $ =~ /(\d+)\.(\d+)/;
$DEBUG = 0 unless defined $DEBUG;
use Data::Dumper;
debug "Adding table:".$xp->findvalue('sqlf:name',$tblnode);
my $table = $schema->add_table(
- get_tagfields($xp, $tblnode, "sqlf:" => qw/name order/)
+ get_tagfields($xp, $tblnode, "sqlf:" => qw/name order extra/)
) or die $schema->error;
#
foreach (@nodes) {
my %data = get_tagfields($xp, $_, "sqlf:",
qw/name type table fields reference_fields reference_table
- match_type on_delete_do on_update_do/
+ match_type on_delete_do on_update_do extra/
);
$table->add_constraint( %data ) or die $table->error;
}
@nodes = $xp->findnodes('sqlf:indices/sqlf:index',$tblnode);
foreach (@nodes) {
my %data = get_tagfields($xp, $_, "sqlf:",
- qw/name type fields options/);
+ qw/name type fields options extra/);
$table->add_index( %data ) or die $table->error;
}
);
foreach (@nodes) {
my %data = get_tagfields($xp, $_, "sqlf:",
- qw/name sql fields order/
+ qw/name sql fields order extra/
);
$schema->add_view( %data ) or die $schema->error;
}
'/sqlf:schema/sqlf:trigger|/sqlf:schema/sqlf:triggers/sqlf:trigger'
);
foreach (@nodes) {
- my %data = get_tagfields($xp, $_, "sqlf:",
- qw/name perform_action_when database_event fields on_table action order/
- );
+ my %data = get_tagfields($xp, $_, "sqlf:", qw/
+ name perform_action_when database_event fields on_table action order
+ extra
+ /);
$schema->add_trigger( %data ) or die $schema->error;
}
);
foreach (@nodes) {
my %data = get_tagfields($xp, $_, "sqlf:",
- qw/name sql parameters owner comments order/
+ qw/name sql parameters owner comments order extra/
);
$schema->add_procedure( %data ) or die $schema->error;
}
package SQL::Translator::Schema::Field;
# ----------------------------------------------------------------------
-# $Id: Field.pm,v 1.21 2004-11-05 13:19:31 grommit Exp $
+# $Id: Field.pm,v 1.22 2004-11-05 15:03:10 grommit Exp $
# ----------------------------------------------------------------------
# Copyright (C) 2002-4 SQLFairy Authors
#
use vars qw($VERSION $TABLE_COUNT $VIEW_COUNT);
-$VERSION = sprintf "%d.%02d", q$Revision: 1.21 $ =~ /(\d+)\.(\d+)/;
+$VERSION = sprintf "%d.%02d", q$Revision: 1.22 $ =~ /(\d+)\.(\d+)/;
# Stringify to our name, being careful not to pass any args through so we don't
# accidentally set it to undef. We also have to tweak bool so the object is
__PACKAGE__->_attributes( qw/
table name data_type size is_primary_key is_nullable
- is_auto_increment default_value comments extra is_foreign_key
+ is_auto_increment default_value comments is_foreign_key
is_unique order
/);
}
# ----------------------------------------------------------------------
-sub extra {
-
=pod
=head2 extra
=cut
- my $self = shift;
- my $args = ref $_[0] eq 'HASH' ? shift : { @_ };
-
- while ( my ( $key, $value ) = each %$args ) {
- $self->{'extra'}{ $key } = $value;
- }
-
- return %{ $self->{'extra'} || {} };
-}
# ----------------------------------------------------------------------
sub foreign_key_reference {
package SQL::Translator::Schema::Object;
# ----------------------------------------------------------------------
-# $Id: Object.pm,v 1.2 2004-11-05 13:19:31 grommit Exp $
+# $Id: Object.pm,v 1.3 2004-11-05 15:03:10 grommit Exp $
# ----------------------------------------------------------------------
# Copyright (C) 2002-4 SQLFairy Authors
#
use vars qw[ $VERSION ];
-$VERSION = sprintf "%d.%02d", q$Revision: 1.2 $ =~ /(\d+)\.(\d+)/;
+$VERSION = sprintf "%d.%02d", q$Revision: 1.3 $ =~ /(\d+)\.(\d+)/;
=head1 Construction
__PACKAGE__->mk_classdata("__attributes");
-__PACKAGE__->__attributes([]);
+
+# Define any global attributes here
+__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
return $self;
}
+# ----------------------------------------------------------------------
+sub extra {
+
+=pod
+
+=head1 Global Attributes
+
+The following attributes are defined here, therefore all schema objects will
+have them.
+
+=head2 extra
+
+Get or set the objects "extra" attibutes (e.g., "ZEROFILL" for MySQL fields).
+Accepts a hash(ref) of name/value pairs to store; returns a hash.
+
+ $field->extra( qualifier => 'ZEROFILL' );
+ my %extra = $field->extra;
+
+=cut
+
+ my $self = shift;
+ my $args = ref $_[0] eq 'HASH' ? shift : { @_ };
+
+ while ( my ( $key, $value ) = each %$args ) {
+ $self->{'extra'}{ $key } = $value;
+ }
+
+ return %{ $self->{'extra'} || {} };
+}
#=============================================================================
package SQL::Translator::Schema::Table;
# ----------------------------------------------------------------------
-# $Id: Table.pm,v 1.28 2004-11-05 13:19:31 grommit Exp $
+# $Id: Table.pm,v 1.29 2004-11-05 15:03:10 grommit Exp $
# ----------------------------------------------------------------------
# Copyright (C) 2002-4 SQLFairy Authors
#
use vars qw( $VERSION $FIELD_ORDER );
-$VERSION = sprintf "%d.%02d", q$Revision: 1.28 $ =~ /(\d+)\.(\d+)/;
+$VERSION = sprintf "%d.%02d", q$Revision: 1.29 $ =~ /(\d+)\.(\d+)/;
# Stringify to our name, being careful not to pass any args through so we don't
my %args = @_;
$args{'table'} = $self;
$constraint = $constraint_class->new( \%args ) or
- return $self->error( $constraint_class->error );
+ return $self->error( $constraint_class->error );
}
#
my $pk = $self->primary_key;
if ( $pk && $constraint->type eq PRIMARY_KEY ) {
$self->primary_key( $constraint->fields );
+ $pk->name($constraint->name) if $constraint->name;
+ my %extra = $constraint->extra;
+ $pk->extra(%extra) if keys %extra;
$constraint = $pk;
$ok = 0;
}
package Test::SQL::Translator;
# ----------------------------------------------------------------------
-# $Id: Translator.pm,v 1.6 2004-07-08 17:29:56 grommit Exp $
+# $Id: Translator.pm,v 1.7 2004-11-05 15:03:10 grommit Exp $
# ----------------------------------------------------------------------
# Copyright (C) 2003 The SQLFairy Authors
#
use base qw(Exporter);
use vars qw($VERSION @EXPORT @EXPORT_OK);
-$VERSION = sprintf "%d.%02d", q$Revision: 1.6 $ =~ /(\d+)\.(\d+)/;
+$VERSION = sprintf "%d.%02d", q$Revision: 1.7 $ =~ /(\d+)\.(\d+)/;
@EXPORT = qw(
schema_ok
table_ok
on_update => '',
reference_fields => [],
reference_table => '',
+ extra => {},
};
$ATTRIBUTES{'index'} = {
fields => [],
name => "",
options => [],
type => NORMAL,
+ extra => {},
};
$ATTRIBUTES{'view'} = {
name => "",
sql => "",
fields => [],
is_valid => 1,
+ extra => {},
};
$ATTRIBUTES{'trigger'} = {
name => '',
on_table => undef,
action => undef,
is_valid => 1,
+ extra => {},
};
$ATTRIBUTES{'procedure'} = {
name => '',
parameters => [],
owner => '',
comments => '',
+ extra => {},
};
$ATTRIBUTES{table} = {
comments => undef,
constraints => undef,
indices => undef,
is_valid => 1,
+ extra => {},
};
$ATTRIBUTES{schema} = {
name => '',
triggers => undef, # [] when set
views => undef, # [] when set
is_valid => 1,
+ extra => {},
};
is_deeply( [$obj->options], $test->{options},
"$t_name options are '".join(",",@{$test->{options}})."'" );
+
+ is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" );
}
sub index_ok {
is_deeply( [$obj->options], $test->{options},
"$t_name options are '".join(",",@{$test->{options}})."'" );
+
+ is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" );
}
sub trigger_ok {
"$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" );
}
sub view_ok {
is_deeply( [$obj->fields], $test->{fields},
"$t_name fields are '".join(",",@{$test->{fields}})."'" );
+
+ is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" );
}
sub procedure_ok {
"$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" );
}
sub table_ok {
is_deeply( [$obj->options], $test->{options},
"$t_name options are '".join(",",@{$test->{options}})."'" );
+ is_deeply( { $obj->extra }, $test->{extra}, "$t_name extra" );
+
# Fields
if ( $arg{fields} ) {
my @fldnames = map {$_->{name}} @{$arg{fields}};
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},
"$t_name is ".($test->{is_valid} ? '' : 'not ').'valid' );
#=============================================================================
BEGIN {
- maybe_plan(142, 'SQL::Translator::Parser::XML::SQLFairy');
+ maybe_plan(150, 'SQL::Translator::Parser::XML::SQLFairy');
}
my $testschema = "$Bin/data/xml/schema.xml";
tables => [
{
name => "Basic",
+ extra => {
+ foo => "bar",
+ hello => "world",
+ bar => "baz",
+ },
fields => [
{
name => "id",
{
type => PRIMARY_KEY,
fields => ["id"],
+ extra => {
+ foo => "bar",
+ hello => "world",
+ bar => "baz",
+ },
},
{
name => 'emailuniqueindex',
{
name => "titleindex",
fields => ["title"],
+ extra => {
+ foo => "bar",
+ hello => "world",
+ bar => "baz",
+ },
},
],
} # end table Basic
name => 'email_list',
sql => "SELECT email FROM Basic WHERE email IS NOT NULL",
fields => ['email'],
+ extra => {
+ foo => "bar",
+ hello => "world",
+ bar => "baz",
+ },
},
],
database_event => 'insert',
on_table => 'foo',
action => 'update modified=timestamp();',
+ extra => {
+ foo => "bar",
+ hello => "world",
+ bar => "baz",
+ },
},
],
parameters => ['foo', 'bar'],
owner => 'Nomar',
comments => 'Go Sox!',
+ extra => {
+ foo => "bar",
+ hello => "world",
+ bar => "baz",
+ },
},
],
#=============================================================================
BEGIN {
- maybe_plan(321,
+ maybe_plan(335,
'SQL::Translator::Parser::XML::XMI::SQLFairy',
'SQL::Translator::Producer::MySQL');
}
-->
<schema xmlns="http://sqlfairy.sourceforge.net/sqlfairy.xml">
-
+
<tables>
<table order="1" name="Basic">
<fields>
</fields>
<indices>
- <index name="titleindex" fields="title" type="NORMAL" />
+ <index name="titleindex" fields="title" type="NORMAL">
+ <extra foo="bar" hello="world" bar="baz" />
+ </index>
</indices>
<constraints>
<constraint name="" type="PRIMARY KEY" fields="id"
reference_table="" options="" deferrable="1" match_type=""
- expression="" on_update="" on_delete="" />
+ expression="" on_update="" on_delete="">
+ <extra foo="bar" hello="world" bar="baz" />
+ </constraint>
<constraint name="emailuniqueindex" type="UNIQUE" fields="email" />
</constraints>
+
+ <extra foo="bar" hello="world" bar="baz" />
</table>
</tables>
<views>
<view name="email_list" fields="email" order="1">
<sql>SELECT email FROM Basic WHERE email IS NOT NULL</sql>
+ <extra foo="bar" hello="world" bar="baz" />
</view>
</views>
<trigger name="foo_trigger" database_event="insert" on_table="foo"
perform_action_when="after" order="1">
<action>update modified=timestamp();</action>
+ <extra foo="bar" hello="world" bar="baz" />
</trigger>
</triggers>
<procedure name="foo_proc" order="1" owner="Nomar" parameters="foo,bar">
<sql>select foo from bar</sql>
<comments>Go Sox!</comments>
+ <extra foo="bar" hello="world" bar="baz" />
</procedure>
</procedures>
projects / dbsrgits/SQL-Translator.git / commitdiff