2 role SQL::Translator::Parser::DDL::XML {
3 use MooseX::MultiMethods;
4 use MooseX::Types::Moose qw(Any);
6 use XML::LibXML::XPathContext;
7 use aliased 'SQL::Translator::Object::Column';
8 use aliased 'SQL::Translator::Object::Constraint';
9 use aliased 'SQL::Translator::Object::Index';
10 use aliased 'SQL::Translator::Object::Procedure';
11 use aliased 'SQL::Translator::Object::Table';
12 use aliased 'SQL::Translator::Object::Trigger';
13 use aliased 'SQL::Translator::Object::View';
14 use SQL::Translator::Types qw(Schema);
16 multi method parse(Schema $data) { $data }
17 multi method parse(Any $data) {
18 my $translator = $self->translator;
19 my $schema = $translator->schema;
20 # local $DEBUG = $translator->debug;
21 my $doc = XML::LibXML->new->parse_string($data);
22 my $xp = XML::LibXML::XPathContext->new($doc);
24 $xp->registerNs("sqlf", "http://sqlfairy.sourceforge.net/sqlfairy.xml");
27 # Work our way through the tables
29 my @nodes = $xp->findnodes(
30 '/sqlf:schema/sqlf:table|/sqlf:schema/sqlf:tables/sqlf:table'
34 ("".$xp->findvalue('sqlf:order|@order',$a) || 0)
36 ("".$xp->findvalue('sqlf:order|@order',$b) || 0)
39 # debug "Adding table:".$xp->findvalue('sqlf:name',$tblnode);
41 my $table = Table->new({
42 get_tagfields($xp, $tblnode, "sqlf:" => qw/name order extra/), schema => $schema
44 $schema->add_table($table);
49 my @nodes = $xp->findnodes('sqlf:fields/sqlf:field',$tblnode);
52 ("".$xp->findvalue('sqlf:order',$a) || 0)
54 ("".$xp->findvalue('sqlf:order',$b) || 0)
57 my %fdata = get_tagfields($xp, $_, "sqlf:",
58 qw/name data_type size default_value is_nullable extra
59 is_auto_increment is_primary_key is_foreign_key comments/
63 exists $fdata{'default_value'} and
64 defined $fdata{'default_value'}
66 if ( $fdata{'default_value'} =~ /^\s*NULL\s*$/ ) {
67 $fdata{'default_value'}= undef;
69 elsif ( $fdata{'default_value'} =~ /^\s*EMPTY_STRING\s*$/ ) {
70 $fdata{'default_value'} = "";
74 $fdata{table} = $table;
75 $fdata{sql_data_type} = $self->data_type_mapping->{$fdata{data_type}} || -99999;
76 my $field = Column->new(%fdata);
77 $table->add_column($field);
79 $field->is_primary_key(1) if $fdata{is_primary_key};
83 # - We should be able to make the table obj spot this when
91 @nodes = $xp->findnodes('sqlf:constraints/sqlf:constraint',$tblnode);
93 my %data = get_tagfields($xp, $_, "sqlf:",
94 qw/name type table fields reference_fields reference_table
95 match_type on_delete on_update extra/
98 $data{table} = $table;
99 my $constraint = Constraint->new(%data);
100 $table->add_constraint($constraint);
106 @nodes = $xp->findnodes('sqlf:indices/sqlf:index',$tblnode);
108 my %data = get_tagfields($xp, $_, "sqlf:",
109 qw/name type fields options extra/);
111 $data{table} = $table;
112 my $index = Index->new(%data);
113 $table->add_index($index);
120 @nodes = $xp->findnodes('sqlf:comments/sqlf:comment',$tblnode);
122 my $data = $_->string_value;
123 $table->comments( $data );
131 @nodes = $xp->findnodes(
132 '/sqlf:schema/sqlf:view|/sqlf:schema/sqlf:views/sqlf:view'
135 my %data = get_tagfields($xp, $_, "sqlf:",
136 qw/name sql fields extra/
138 my $view = View->new(%data);
139 $schema->add_view($view);
145 @nodes = $xp->findnodes(
146 '/sqlf:schema/sqlf:trigger|/sqlf:schema/sqlf:triggers/sqlf:trigger'
149 my %data = get_tagfields($xp, $_, "sqlf:", qw/
150 name perform_action_when database_event database_events fields
151 on_table action extra
155 if (my $evt = $data{database_event} and $translator->{show_warnings}) {
156 # carp 'The database_event tag is deprecated - please use ' .
157 # 'database_events (which can take one or more comma separated ' .
159 $data{database_events} = join (', ',
160 $data{database_events} || (),
165 # split into arrayref
166 if (my $evts = $data{database_events}) {
167 $data{database_events} = [split (/\s*,\s*/, $evts) ];
169 my $trigger = Trigger->new(%data);
170 $schema->add_trigger($trigger);
176 @nodes = $xp->findnodes(
177 '/sqlf:schema/sqlf:procedure|/sqlf:schema/sqlf:procedures/sqlf:procedure'
180 my %data = get_tagfields($xp, $_, "sqlf:",
181 qw/name sql parameters owner comments extra/
183 my $procedure = Procedure->new(%data);
184 $schema->add_procedure($procedure);
190 # -------------------------------------------------------------------
193 # get_tagfields XP, NODE, NAMESPACE => qw/TAGNAMES/;
194 # get_tagfields $node, "sqlf:" => qw/name type fields reference/;
196 # Returns hash of data.
197 # TODO - Add handling of an explicit NULL value.
200 my ($xp, $node, @names) = @_;
203 if ( m/:$/ ) { $ns = $_; next; } # Set def namespace
204 my $thisns = (s/(^.*?:)// ? $1 : $ns);
206 my $is_attrib = m/^(sql|comments|action|extra)$/ ? 0 : 1;
208 my $attrib_path = "\@$_";
209 my $tag_path = "$thisns$_";
210 if ( my $found = $xp->find($attrib_path,$node) ) {
211 $data{$_} = "".$found->to_literal;
212 warn "Use of '$_' as an attribute is depricated."
213 ." Use a child tag instead."
214 ." To convert your file to the new version see the Docs.\n"
216 # debug "Got $_=".( defined $data{ $_ } ? $data{ $_ } : 'UNDEF' );
218 elsif ( $found = $xp->find($tag_path,$node) ) {
221 foreach ( $found->pop->getAttributes ) {
222 $extra{$_->getName} = $_->getData;
227 $data{$_} = "".$found->to_literal;
229 warn "Use of '$_' as a child tag is depricated."
230 ." Use an attribute instead."
231 ." To convert your file to the new version see the Docs.\n"
233 # debug "Got $_=".( defined $data{ $_ } ? $data{ $_ } : 'UNDEF' );
237 return wantarray ? %data : \%data;