From: Justin Hunter Date: Wed, 19 Aug 2009 09:38:28 +0000 (-0700) Subject: initial XML Parser/Producer X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=b9d9888766208af2eaa6a72dec8cc0d00b31f368;p=dbsrgits%2FSQL-Translator-2.0-ish.git initial XML Parser/Producer --- diff --git a/lib/SQL/Translator/Parser/DDL/XML.pm b/lib/SQL/Translator/Parser/DDL/XML.pm new file mode 100644 index 0000000..6021b03 --- /dev/null +++ b/lib/SQL/Translator/Parser/DDL/XML.pm @@ -0,0 +1,216 @@ +use MooseX::Declare; +role SQL::Translator::Parser::DDL::XML { +use XML::LibXML; +use XML::LibXML::XPathContext; + +sub parse { + my ( $translator, $data ) = @_; + my $schema = $translator->schema; + local $DEBUG = $translator->debug; + my $doc = XML::LibXML->new->parse_string($data); + my $xp = XML::LibXML::XPathContext->new($doc); + + $xp->registerNs("sqlf", "http://sqlfairy.sourceforge.net/sqlfairy.xml"); + + # + # Work our way through the tables + # + my @nodes = $xp->findnodes( + '/sqlf:schema/sqlf:table|/sqlf:schema/sqlf:tables/sqlf:table' + ); + for my $tblnode ( + sort { + ("".$xp->findvalue('sqlf:order|@order',$a) || 0) + <=> + ("".$xp->findvalue('sqlf:order|@order',$b) || 0) + } @nodes + ) { + debug "Adding table:".$xp->findvalue('sqlf:name',$tblnode); + + my $table = $schema->add_table( + get_tagfields($xp, $tblnode, "sqlf:" => qw/name order extra/) + ) or die $schema->error; + + # + # Fields + # + my @nodes = $xp->findnodes('sqlf:fields/sqlf:field',$tblnode); + foreach ( + sort { + ("".$xp->findvalue('sqlf:order',$a) || 0) + <=> + ("".$xp->findvalue('sqlf:order',$b) || 0) + } @nodes + ) { + my %fdata = get_tagfields($xp, $_, "sqlf:", + qw/name data_type size default_value is_nullable extra + is_auto_increment is_primary_key is_foreign_key comments/ + ); + + if ( + exists $fdata{'default_value'} and + defined $fdata{'default_value'} + ) { + if ( $fdata{'default_value'} =~ /^\s*NULL\s*$/ ) { + $fdata{'default_value'}= undef; + } + elsif ( $fdata{'default_value'} =~ /^\s*EMPTY_STRING\s*$/ ) { + $fdata{'default_value'} = ""; + } + } + + my $field = $table->add_field( %fdata ) or die $table->error; + + $table->primary_key( $field->name ) if $fdata{'is_primary_key'}; + + # + # TODO: + # - We should be able to make the table obj spot this when + # we use add_field. + # + } + + # + # Constraints + # + @nodes = $xp->findnodes('sqlf:constraints/sqlf:constraint',$tblnode); + foreach (@nodes) { + my %data = get_tagfields($xp, $_, "sqlf:", + qw/name type table fields reference_fields reference_table + match_type on_delete on_update extra/ + ); + $table->add_constraint( %data ) or die $table->error; + } + + # + # Indexes + # + @nodes = $xp->findnodes('sqlf:indices/sqlf:index',$tblnode); + foreach (@nodes) { + my %data = get_tagfields($xp, $_, "sqlf:", + qw/name type fields options extra/); + $table->add_index( %data ) or die $table->error; + } + + + # + # Comments + # + @nodes = $xp->findnodes('sqlf:comments/sqlf:comment',$tblnode); + foreach (@nodes) { + my $data = $_->string_value; + $table->comments( $data ); + } + + } # tables loop + + # + # Views + # + @nodes = $xp->findnodes( + '/sqlf:schema/sqlf:view|/sqlf:schema/sqlf:views/sqlf:view' + ); + foreach (@nodes) { + my %data = get_tagfields($xp, $_, "sqlf:", + qw/name sql fields order extra/ + ); + $schema->add_view( %data ) or die $schema->error; + } + + # + # Triggers + # + @nodes = $xp->findnodes( + '/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 database_events fields + on_table action order extra + /); + + # back compat + if (my $evt = $data{database_event} and $translator->{show_warnings}) { + carp 'The database_event tag is deprecated - please use ' . + 'database_events (which can take one or more comma separated ' . + 'event names)'; + $data{database_events} = join (', ', + $data{database_events} || (), + $evt, + ); + } + + # split into arrayref + if (my $evts = $data{database_events}) { + $data{database_events} = [split (/\s*,\s*/, $evts) ]; + } + + $schema->add_trigger( %data ) or die $schema->error; + } + + # + # Procedures + # + @nodes = $xp->findnodes( + '/sqlf:schema/sqlf:procedure|/sqlf:schema/sqlf:procedures/sqlf:procedure' + ); + foreach (@nodes) { + my %data = get_tagfields($xp, $_, "sqlf:", + qw/name sql parameters owner comments order extra/ + ); + $schema->add_procedure( %data ) or die $schema->error; + } + + return 1; +} + +# ------------------------------------------------------------------- +sub get_tagfields { +# +# get_tagfields XP, NODE, NAMESPACE => qw/TAGNAMES/; +# get_tagfields $node, "sqlf:" => qw/name type fields reference/; +# +# Returns hash of data. +# TODO - Add handling of an explicit NULL value. +# + + my ($xp, $node, @names) = @_; + my (%data, $ns); + foreach (@names) { + if ( m/:$/ ) { $ns = $_; next; } # Set def namespace + my $thisns = (s/(^.*?:)// ? $1 : $ns); + + my $is_attrib = m/^(sql|comments|action|extra)$/ ? 0 : 1; + + my $attrib_path = "\@$_"; + my $tag_path = "$thisns$_"; + if ( my $found = $xp->find($attrib_path,$node) ) { + $data{$_} = "".$found->to_literal; + warn "Use of '$_' as an attribute is depricated." + ." Use a child tag instead." + ." To convert your file to the new version see the Docs.\n" + unless $is_attrib; + debug "Got $_=".( defined $data{ $_ } ? $data{ $_ } : 'UNDEF' ); + } + elsif ( $found = $xp->find($tag_path,$node) ) { + if ($_ eq "extra") { + my %extra; + foreach ( $found->pop->getAttributes ) { + $extra{$_->getName} = $_->getData; + } + $data{$_} = \%extra; + } + else { + $data{$_} = "".$found->to_literal; + } + warn "Use of '$_' as a child tag is depricated." + ." Use an attribute instead." + ." To convert your file to the new version see the Docs.\n" + if $is_attrib; + debug "Got $_=".( defined $data{ $_ } ? $data{ $_ } : 'UNDEF' ); + } + } + + return wantarray ? %data : \%data; +} +} diff --git a/lib/SQL/Translator/Producer/XML.pm b/lib/SQL/Translator/Producer/XML.pm new file mode 100644 index 0000000..9339993 --- /dev/null +++ b/lib/SQL/Translator/Producer/XML.pm @@ -0,0 +1,241 @@ +use MooseX::Declare; +role SQL::Translator::Producer::XML { +use MooseX::Types::Moose qw(HashRef); +use IO::Scalar; +#use SQL::Translator::Utils qw(header_comment debug); +BEGIN { + # Will someone fix XML::Writer already? + local $^W = 0; + require XML::Writer; + import XML::Writer; +} + +# Which schema object attributes (methods) to write as xml elements rather than +# as attributes. e.g. blah, blah... +my @MAP_AS_ELEMENTS = qw/sql comments action extra/; + +my $Namespace = 'http://sqlfairy.sourceforge.net/sqlfairy.xml'; +my $Name = 'sqlf'; +my $PArgs = {}; +my $no_comments; + +method produce { + my $translator = $self; + my $schema = $translator->schema; + $no_comments = $translator->no_comments; +# $PArgs = $translator->producer_args; + my $newlines = defined $PArgs->{newlines} ? $PArgs->{newlines} : 1; + my $indent = defined $PArgs->{indent} ? $PArgs->{indent} : 2; + my $io = IO::Scalar->new; + + # Setup the XML::Writer and set the namespace + my $prefix = ""; + $prefix = $Name if $PArgs->{add_prefix}; + $prefix = $PArgs->{prefix} if $PArgs->{prefix}; + my $xml = XML::Writer->new( + OUTPUT => $io, + NAMESPACES => 1, + PREFIX_MAP => { $Namespace => $prefix }, + DATA_MODE => $newlines, + DATA_INDENT => $indent, + ); + + # Start the document + $xml->xmlDecl('UTF-8'); + +# $xml->comment(header_comment('', '')) +# unless $no_comments; + + xml_obj($xml, $schema, + { tag => "schema", methods => [qw/name database /], end_tag => 0 }); +# tag => "schema", methods => [qw/name database extra/], end_tag => 0 ); + + # + # Table + # + $xml->startTag( [ $Namespace => "tables" ] ); + for my $table ( $schema->get_tables ) { +# debug "Table:",$table->name; + xml_obj($xml, $table, + { tag => "table", + methods => [qw/name order/], +# methods => [qw/name order extra/], + end_tag => 0 } + ); + + # + # Fields + # + xml_obj_children( $xml, $table, + { tag => 'field', + methods =>[qw/ + name data_type size is_nullable default_value is_auto_increment + is_primary_key is_foreign_key comments order + /], } +# is_primary_key is_foreign_key extra comments order + ); + + # + # Indices + # + xml_obj_children( $xml, $table, + { tag => 'index', + collection_tag => "indices", + methods => [qw/name type fields options/], } +# methods => [qw/name type fields options extra/], + ); + + # + # Constraints + # + xml_obj_children( $xml, $table, + { tag => 'constraint', +# methods => [qw/ +# name type fields reference_table reference_fields +# on_delete on_update match_type expression options deferrable +# extra +# /], + methods => [qw/name type expression options deferrable/], } + ); + + # + # Comments + # + xml_obj_children( $xml, $table, + { tag => 'comment', +# collection_tag => "comments", + methods => [qw/ + comments + /], } + ); + + $xml->endTag( [ $Namespace => 'table' ] ); + } + $xml->endTag( [ $Namespace => 'tables' ] ); + + # + # Views + # + xml_obj_children( $xml, $schema, + { tag => 'view', + methods => [qw/name sql fields/], } +# methods => [qw/name sql fields order extra/], + ); + + # + # Tiggers + # + xml_obj_children( $xml, $schema, + { tag => 'trigger', + methods => [qw/name database_events action on_table perform_action_when fields order/], } +# methods => [qw/name database_events action on_table perform_action_when fields order extra/], + ); + + # + # Procedures + # + xml_obj_children( $xml, $schema, + { tag => 'procedure', + methods => [qw/name sql parameters owner comments order/], } +# methods => [qw/name sql parameters owner comments order extra/], + ); + + $xml->endTag([ $Namespace => 'schema' ]); + $xml->end; + + return $io; +} + + +# +# Takes and XML::Write object, Schema::* parent object, the tag name, +# the collection name and a list of methods (of the children) to write as XML. +# The collection name defaults to the name with an s on the end and is used to +# work out the method to get the children with. eg a name of 'foo' gives a +# collection of foos and gets the members using ->get_foos. +# +#sub xml_obj_children { +method xml_obj_children($xml: $parent, HashRef $args?) { +# my ($xml,$parent) = (shift,shift); + +# my %args = @_; + my ($name,$collection_name,$methods) + = @{$args}{qw/tag collection_tag methods/}; + $collection_name ||= "${name}s"; + + my $meth; + if ( $collection_name eq 'comments' ) { + $meth = 'comments'; + } else { + $meth = "get_$collection_name"; + } + + my @kids = $parent->$meth; + #@kids || return; + $xml->startTag( [ $Namespace => $collection_name ] ); + + for my $obj ( @kids ) { + if ( $collection_name eq 'comments' ){ + $xml->dataElement( [ $Namespace => 'comment' ], $obj ); + } else { + xml_obj($xml, $obj, + { tag => "$name", + end_tag => 1, + methods => $methods, } + ); + } + } + $xml->endTag( [ $Namespace => $collection_name ] ); +} + +# +# Takes an XML::Writer, Schema::* object and list of method names +# and writes the obect out as XML. All methods values are written as attributes +# except for the methods listed in @MAP_AS_ELEMENTS which get written as child +# data elements. +# +# The attributes/tags are written in the same order as the method names are +# passed. +# +# TODO +# - Should the Namespace be passed in instead of global? Pass in the same +# as Writer ie [ NS => TAGNAME ] +# +my $elements_re = join("|", @MAP_AS_ELEMENTS); +$elements_re = qr/^($elements_re)$/; +#sub xml_obj { +method xml_obj($xml: $obj, HashRef $args?) { +# my ($xml, $obj, %args) = @_; + my $tag = $args->{'tag'} || ''; + my $end_tag = $args->{'end_tag'} || ''; + my @meths = @{ $args->{'methods'} }; + my $empty_tag = 0; + + # Use array to ensure consistant (ie not hash) ordering of attribs + # The order comes from the meths list passed in. + my @tags; + my @attr; + foreach ( grep { defined $obj->$_ } @meths ) { + my $what = m/$elements_re/ ? \@tags : \@attr; + my $val = $_ eq 'extra' + ? { $obj->$_ } + : $obj->$_; + $val = ref $val eq 'ARRAY' ? join(',', @$val) : $val; + push @$what, $_ => $val; + }; + my $child_tags = @tags; + $end_tag && !$child_tags + ? $xml->emptyTag( [ $Namespace => $tag ], @attr ) + : $xml->startTag( [ $Namespace => $tag ], @attr ); + while ( my ($name,$val) = splice @tags,0,2 ) { warn "NAME: $name, $val"; + if ( ref $val eq 'HASH' ) { + $xml->emptyTag( [ $Namespace => $name ], + map { ($_, $val->{$_}) } sort keys %$val ); + } + else { + $xml->dataElement( [ $Namespace => $name ], $val ); + } + } + $xml->endTag( [ $Namespace => $tag ] ) if $child_tags && $end_tag; +} +}