2 role SQL::Translator::Parser::DDL::XML {
4 use XML::LibXML::XPathContext;
7 my $translator = $self->translator;
8 my $schema = $translator->schema;
9 local $DEBUG = $translator->debug;
10 my $doc = XML::LibXML->new->parse_string($data);
11 my $xp = XML::LibXML::XPathContext->new($doc);
13 $xp->registerNs("sqlf", "http://sqlfairy.sourceforge.net/sqlfairy.xml");
16 # Work our way through the tables
18 my @nodes = $xp->findnodes(
19 '/sqlf:schema/sqlf:table|/sqlf:schema/sqlf:tables/sqlf:table'
23 ("".$xp->findvalue('sqlf:order|@order',$a) || 0)
25 ("".$xp->findvalue('sqlf:order|@order',$b) || 0)
28 debug "Adding table:".$xp->findvalue('sqlf:name',$tblnode);
30 my $table = $schema->add_table(
31 get_tagfields($xp, $tblnode, "sqlf:" => qw/name order extra/)
32 ) or die $schema->error;
37 my @nodes = $xp->findnodes('sqlf:fields/sqlf:field',$tblnode);
40 ("".$xp->findvalue('sqlf:order',$a) || 0)
42 ("".$xp->findvalue('sqlf:order',$b) || 0)
45 my %fdata = get_tagfields($xp, $_, "sqlf:",
46 qw/name data_type size default_value is_nullable extra
47 is_auto_increment is_primary_key is_foreign_key comments/
51 exists $fdata{'default_value'} and
52 defined $fdata{'default_value'}
54 if ( $fdata{'default_value'} =~ /^\s*NULL\s*$/ ) {
55 $fdata{'default_value'}= undef;
57 elsif ( $fdata{'default_value'} =~ /^\s*EMPTY_STRING\s*$/ ) {
58 $fdata{'default_value'} = "";
62 my $field = $table->add_field( %fdata ) or die $table->error;
64 $table->primary_key( $field->name ) if $fdata{'is_primary_key'};
68 # - We should be able to make the table obj spot this when
76 @nodes = $xp->findnodes('sqlf:constraints/sqlf:constraint',$tblnode);
78 my %data = get_tagfields($xp, $_, "sqlf:",
79 qw/name type table fields reference_fields reference_table
80 match_type on_delete on_update extra/
82 $table->add_constraint( %data ) or die $table->error;
88 @nodes = $xp->findnodes('sqlf:indices/sqlf:index',$tblnode);
90 my %data = get_tagfields($xp, $_, "sqlf:",
91 qw/name type fields options extra/);
92 $table->add_index( %data ) or die $table->error;
99 @nodes = $xp->findnodes('sqlf:comments/sqlf:comment',$tblnode);
101 my $data = $_->string_value;
102 $table->comments( $data );
110 @nodes = $xp->findnodes(
111 '/sqlf:schema/sqlf:view|/sqlf:schema/sqlf:views/sqlf:view'
114 my %data = get_tagfields($xp, $_, "sqlf:",
115 qw/name sql fields order extra/
117 $schema->add_view( %data ) or die $schema->error;
123 @nodes = $xp->findnodes(
124 '/sqlf:schema/sqlf:trigger|/sqlf:schema/sqlf:triggers/sqlf:trigger'
127 my %data = get_tagfields($xp, $_, "sqlf:", qw/
128 name perform_action_when database_event database_events fields
129 on_table action order extra
133 if (my $evt = $data{database_event} and $translator->{show_warnings}) {
134 carp 'The database_event tag is deprecated - please use ' .
135 'database_events (which can take one or more comma separated ' .
137 $data{database_events} = join (', ',
138 $data{database_events} || (),
143 # split into arrayref
144 if (my $evts = $data{database_events}) {
145 $data{database_events} = [split (/\s*,\s*/, $evts) ];
148 $schema->add_trigger( %data ) or die $schema->error;
154 @nodes = $xp->findnodes(
155 '/sqlf:schema/sqlf:procedure|/sqlf:schema/sqlf:procedures/sqlf:procedure'
158 my %data = get_tagfields($xp, $_, "sqlf:",
159 qw/name sql parameters owner comments order extra/
161 $schema->add_procedure( %data ) or die $schema->error;
167 # -------------------------------------------------------------------
170 # get_tagfields XP, NODE, NAMESPACE => qw/TAGNAMES/;
171 # get_tagfields $node, "sqlf:" => qw/name type fields reference/;
173 # Returns hash of data.
174 # TODO - Add handling of an explicit NULL value.
177 my ($xp, $node, @names) = @_;
180 if ( m/:$/ ) { $ns = $_; next; } # Set def namespace
181 my $thisns = (s/(^.*?:)// ? $1 : $ns);
183 my $is_attrib = m/^(sql|comments|action|extra)$/ ? 0 : 1;
185 my $attrib_path = "\@$_";
186 my $tag_path = "$thisns$_";
187 if ( my $found = $xp->find($attrib_path,$node) ) {
188 $data{$_} = "".$found->to_literal;
189 warn "Use of '$_' as an attribute is depricated."
190 ." Use a child tag instead."
191 ." To convert your file to the new version see the Docs.\n"
193 debug "Got $_=".( defined $data{ $_ } ? $data{ $_ } : 'UNDEF' );
195 elsif ( $found = $xp->find($tag_path,$node) ) {
198 foreach ( $found->pop->getAttributes ) {
199 $extra{$_->getName} = $_->getData;
204 $data{$_} = "".$found->to_literal;
206 warn "Use of '$_' as a child tag is depricated."
207 ." Use an attribute instead."
208 ." To convert your file to the new version see the Docs.\n"
210 debug "Got $_=".( defined $data{ $_ } ? $data{ $_ } : 'UNDEF' );
214 return wantarray ? %data : \%data;