--- /dev/null
+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;
+}
+}
--- /dev/null
+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. <comments>blah, blah...</comments>
+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;
+}
+}
projects / dbsrgits/SQL-Translator-2.0-ish.git / commitdiff