lib/SQL/Translator/Parser/DDL/XML.pm

   1 use MooseX::Declare;
   2 role SQL::Translator::Parser::DDL::XML {
   3 use XML::LibXML;
   4 use XML::LibXML::XPathContext;
   5
   6 sub parse {
   7     my ( $translator, $data ) = @_;
   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);
  12
  13     $xp->registerNs("sqlf", "http://sqlfairy.sourceforge.net/sqlfairy.xml");
  14
  15     #
  16     # Work our way through the tables
  17     #
  18     my @nodes = $xp->findnodes(
  19         '/sqlf:schema/sqlf:table|/sqlf:schema/sqlf:tables/sqlf:table'
  20     );
  21     for my $tblnode (
  22         sort {
  23             ("".$xp->findvalue('sqlf:order|@order',$a) || 0)
  24             <=>
  25             ("".$xp->findvalue('sqlf:order|@order',$b) || 0)
  26         } @nodes
  27     ) {
  28         debug "Adding table:".$xp->findvalue('sqlf:name',$tblnode);
  29
  30         my $table = $schema->add_table(
  31             get_tagfields($xp, $tblnode, "sqlf:" => qw/name order extra/)
  32         ) or die $schema->error;
  33
  34         #
  35         # Fields
  36         #
  37         my @nodes = $xp->findnodes('sqlf:fields/sqlf:field',$tblnode);
  38         foreach (
  39             sort {
  40                 ("".$xp->findvalue('sqlf:order',$a) || 0)
  41                 <=>
  42                 ("".$xp->findvalue('sqlf:order',$b) || 0)
  43             } @nodes
  44         ) {
  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/
  48             );
  49
  50             if (
  51                 exists $fdata{'default_value'} and
  52                 defined $fdata{'default_value'}
  53             ) {
  54                 if ( $fdata{'default_value'} =~ /^\s*NULL\s*$/ ) {
  55                     $fdata{'default_value'}= undef;
  56                 }
  57                 elsif ( $fdata{'default_value'} =~ /^\s*EMPTY_STRING\s*$/ ) {
  58                     $fdata{'default_value'} = "";
  59                 }
  60             }
  61
  62             my $field = $table->add_field( %fdata ) or die $table->error;
  63
  64             $table->primary_key( $field->name ) if $fdata{'is_primary_key'};
  65
  66             #
  67             # TODO:
  68             # - We should be able to make the table obj spot this when
  69             #   we use add_field.
  70             #
  71         }
  72
  73         #
  74         # Constraints
  75         #
  76         @nodes = $xp->findnodes('sqlf:constraints/sqlf:constraint',$tblnode);
  77         foreach (@nodes) {
  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/
  81             );
  82             $table->add_constraint( %data ) or die $table->error;
  83         }
  84
  85         #
  86         # Indexes
  87         #
  88         @nodes = $xp->findnodes('sqlf:indices/sqlf:index',$tblnode);
  89         foreach (@nodes) {
  90             my %data = get_tagfields($xp, $_, "sqlf:",
  91                 qw/name type fields options extra/);
  92             $table->add_index( %data ) or die $table->error;
  93         }
  94
  95
  96         #
  97         # Comments
  98         #
  99         @nodes = $xp->findnodes('sqlf:comments/sqlf:comment',$tblnode);
 100         foreach (@nodes) {
 101             my $data = $_->string_value;
 102             $table->comments( $data );
 103         }
 104
 105     } # tables loop
 106
 107     #
 108     # Views
 109     #
 110     @nodes = $xp->findnodes(
 111         '/sqlf:schema/sqlf:view|/sqlf:schema/sqlf:views/sqlf:view'
 112     );
 113     foreach (@nodes) {
 114         my %data = get_tagfields($xp, $_, "sqlf:",
 115             qw/name sql fields order extra/
 116         );
 117         $schema->add_view( %data ) or die $schema->error;
 118     }
 119
 120     #
 121     # Triggers
 122     #
 123     @nodes = $xp->findnodes(
 124         '/sqlf:schema/sqlf:trigger|/sqlf:schema/sqlf:triggers/sqlf:trigger'
 125     );
 126     foreach (@nodes) {
 127         my %data = get_tagfields($xp, $_, "sqlf:", qw/
 128             name perform_action_when database_event database_events fields
 129             on_table action order extra
 130         /);
 131
 132         # back compat
 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 ' .
 136             'event names)';
 137           $data{database_events} = join (', ',
 138             $data{database_events} || (),
 139             $evt,
 140           );
 141         }
 142
 143         # split into arrayref
 144         if (my $evts = $data{database_events}) {
 145           $data{database_events} = [split (/\s*,\s*/, $evts) ];
 146         }
 147
 148         $schema->add_trigger( %data ) or die $schema->error;
 149     }
 150
 151     #
 152     # Procedures
 153     #
 154     @nodes = $xp->findnodes(
 155        '/sqlf:schema/sqlf:procedure|/sqlf:schema/sqlf:procedures/sqlf:procedure'
 156     );
 157     foreach (@nodes) {
 158         my %data = get_tagfields($xp, $_, "sqlf:",
 159         qw/name sql parameters owner comments order extra/
 160         );
 161         $schema->add_procedure( %data ) or die $schema->error;
 162     }
 163
 164     return 1;
 165 }
 166
 167 # -------------------------------------------------------------------
 168 sub get_tagfields {
 169 #
 170 # get_tagfields XP, NODE, NAMESPACE => qw/TAGNAMES/;
 171 # get_tagfields $node, "sqlf:" => qw/name type fields reference/;
 172 #
 173 # Returns hash of data.
 174 # TODO - Add handling of an explicit NULL value.
 175 #
 176
 177     my ($xp, $node, @names) = @_;
 178     my (%data, $ns);
 179     foreach (@names) {
 180         if ( m/:$/ ) { $ns = $_; next; }  # Set def namespace
 181         my $thisns = (s/(^.*?:)// ? $1 : $ns);
 182
 183         my $is_attrib = m/^(sql|comments|action|extra)$/ ? 0 : 1;
 184
 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"
 192                 unless $is_attrib;
 193             debug "Got $_=".( defined $data{ $_ } ? $data{ $_ } : 'UNDEF' );
 194         }
 195         elsif ( $found = $xp->find($tag_path,$node) ) {
 196             if ($_ eq "extra") {
 197                 my %extra;
 198                 foreach ( $found->pop->getAttributes ) {
 199                     $extra{$_->getName} = $_->getData;
 200                 }
 201                 $data{$_} = \%extra;
 202             }
 203             else {
 204                 $data{$_} = "".$found->to_literal;
 205             }
 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"
 209                 if $is_attrib;
 210             debug "Got $_=".( defined $data{ $_ } ? $data{ $_ } : 'UNDEF' );
 211         }
 212     }
 213
 214     return wantarray ? %data : \%data;
 215 }
 216 }