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

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