lib/SQL/Translator/Producer/XML.pm

   1 use MooseX::Declare;
   2 role SQL::Translator::Producer::XML {
   3 use MooseX::Types::Moose qw(HashRef);
   4 use IO::Scalar;
   5 #use SQL::Translator::Utils qw(header_comment debug);
   6 BEGIN {
   7     # Will someone fix XML::Writer already?
   8     local $^W = 0;
   9     require XML::Writer;
  10     import XML::Writer;
  11 }
  12
  13 # Which schema object attributes (methods) to write as xml elements rather than
  14 # as attributes. e.g. <comments>blah, blah...</comments>
  15 my @MAP_AS_ELEMENTS = qw/sql comments action extra/;
  16
  17 my $Namespace = 'http://sqlfairy.sourceforge.net/sqlfairy.xml';
  18 my $Name      = 'sqlf';
  19 my $PArgs     = {};
  20 my $no_comments;
  21
  22 method produce {
  23     my $translator  = $self->translator;
  24     my $schema      = $translator->schema;
  25     $no_comments    = $translator->no_comments;
  26 #    $PArgs          = $translator->producer_args;
  27     my $newlines    = defined $PArgs->{newlines} ? $PArgs->{newlines} : 1;
  28     my $indent      = defined $PArgs->{indent}   ? $PArgs->{indent}   : 2;
  29     my $io          = IO::Scalar->new;
  30
  31     # Setup the XML::Writer and set the namespace
  32     my $prefix = "";
  33     $prefix    = $Name            if $PArgs->{add_prefix};
  34     $prefix    = $PArgs->{prefix} if $PArgs->{prefix};
  35     my $xml         = XML::Writer->new(
  36         OUTPUT      => $io,
  37         NAMESPACES  => 1,
  38         PREFIX_MAP  => { $Namespace => $prefix },
  39         DATA_MODE   => $newlines,
  40         DATA_INDENT => $indent,
  41     );
  42
  43     # Start the document
  44     $xml->xmlDecl('UTF-8');
  45
  46 #    $xml->comment(header_comment('', ''))
  47 #      unless $no_comments;
  48
  49     xml_obj($xml, $schema,
  50         { tag => "schema", methods => [qw/name extra/], end_tag => 0 });
  51
  52     #
  53     # Table
  54     #
  55     $xml->startTag( [ $Namespace => "tables" ] );
  56     for my $table ( $schema->get_tables ) {
  57 #        debug "Table:",$table->name;
  58         xml_obj($xml, $table,
  59             { tag => "table",
  60              methods => [qw/name extra/],
  61              end_tag => 0 }
  62          );
  63
  64         #
  65         # Fields
  66         #
  67         xml_obj_children( $xml, $table,
  68             { tag   => 'field',
  69             methods =>[qw/
  70                 name data_type size is_nullable default_value is_auto_increment
  71                 is_primary_key is_foreign_key extra comments
  72             /], }
  73         );
  74
  75         #
  76         # Indices
  77         #
  78         xml_obj_children( $xml, $table,
  79             { tag   => 'index',
  80             collection_tag => "indices",
  81             methods => [qw/name type fields extra/], }
  82         );
  83
  84         #
  85         # Constraints
  86         #
  87         xml_obj_children( $xml, $table,
  88             { tag   => 'constraint',
  89 #            methods => [qw/
  90 #                name type fields reference_table reference_fields
  91 #                on_delete on_update match_type expression options deferrable
  92 #                extra
  93 #            /],
  94              methods => [qw/name type expression options deferrable extra/], }
  95         );
  96
  97         #
  98         # Comments
  99         #
 100         xml_obj_children( $xml, $table,
 101             { tag   => 'comment',
 102             methods => [qw/ comments /], }
 103         );
 104
 105         $xml->endTag( [ $Namespace => 'table' ] );
 106     }
 107     $xml->endTag( [ $Namespace => 'tables' ] );
 108
 109     #
 110     # Views
 111     #
 112     xml_obj_children( $xml, $schema,
 113         { tag   => 'view',
 114         methods => [qw/name sql fields extra/], }
 115     );
 116
 117     #
 118     # Tiggers
 119     #
 120     xml_obj_children( $xml, $schema,
 121         { tag    => 'trigger',
 122         methods => [qw/name database_events action on_table perform_action_when fields extra/], }
 123     );
 124
 125     #
 126     # Procedures
 127     #
 128     xml_obj_children( $xml, $schema,
 129         { tag   => 'procedure',
 130         methods => [qw/name sql parameters owner comments extra/], }
 131     );
 132
 133     $xml->endTag([ $Namespace => 'schema' ]);
 134     $xml->end;
 135
 136     return $io;
 137 }
 138
 139
 140 #
 141 # Takes and XML::Write object, Schema::* parent object, the tag name,
 142 # the collection name and a list of methods (of the children) to write as XML.
 143 # The collection name defaults to the name with an s on the end and is used to
 144 # work out the method to get the children with. eg a name of 'foo' gives a
 145 # collection of foos and gets the members using ->get_foos.
 146 #
 147 #sub xml_obj_children {
 148 method xml_obj_children($xml: $parent, HashRef $args?) {
 149 #    my ($xml,$parent) = (shift,shift);
 150
 151 #    my %args = @_;
 152     my ($name,$collection_name,$methods)
 153         = @{$args}{qw/tag collection_tag methods/};
 154     $collection_name ||= "${name}s";
 155
 156     my $meth;
 157     if ( $collection_name eq 'comments' ) {
 158       $meth = 'comments';
 159     } else {
 160       $meth = "get_$collection_name";
 161     }
 162
 163     my @kids = $parent->$meth;
 164     #@kids || return;
 165     $xml->startTag( [ $Namespace => $collection_name ] );
 166
 167     for my $obj ( @kids ) {
 168         if ( $collection_name eq 'comments' ){
 169             $xml->dataElement( [ $Namespace => 'comment' ], $obj );
 170         } else {
 171             xml_obj($xml, $obj,
 172                 { tag     => "$name",
 173                 end_tag => 1,
 174                 methods => $methods, }
 175             );
 176         }
 177     }
 178     $xml->endTag( [ $Namespace => $collection_name ] );
 179 }
 180
 181 #
 182 # Takes an XML::Writer, Schema::* object and list of method names
 183 # and writes the obect out as XML. All methods values are written as attributes
 184 # except for the methods listed in @MAP_AS_ELEMENTS which get written as child
 185 # data elements.
 186 #
 187 # The attributes/tags are written in the same order as the method names are
 188 # passed.
 189 #
 190 # TODO
 191 # - Should the Namespace be passed in instead of global? Pass in the same
 192 #   as Writer ie [ NS => TAGNAME ]
 193 #
 194 my $elements_re = join("|", @MAP_AS_ELEMENTS);
 195 $elements_re = qr/^($elements_re)$/;
 196 #sub xml_obj {
 197 method xml_obj($xml: $obj, HashRef $args?) {
 198 #    my ($xml, $obj, %args) = @_;
 199     my $tag                = $args->{'tag'}              || '';
 200     my $end_tag            = $args->{'end_tag'}          || '';
 201     my @meths              = @{ $args->{'methods'} };
 202     my $empty_tag          = 0;
 203
 204     # Use array to ensure consistant (ie not hash) ordering of attribs
 205     # The order comes from the meths list passed in.
 206     my @tags;
 207     my @attr;
 208     foreach ( grep { defined $obj->$_ } @meths ) {
 209         my $what = m/$elements_re/ ? \@tags : \@attr;
 210         my $val = $_ eq 'extra'
 211             ? { $obj->$_ }
 212             : $obj->$_;
 213         $val = ref $val eq 'ARRAY' ? join(',', @$val) : $val;
 214         push @$what, $_ => $val;
 215     };
 216     my $child_tags = @tags;
 217     $end_tag && !$child_tags
 218         ? $xml->emptyTag( [ $Namespace => $tag ], @attr )
 219         : $xml->startTag( [ $Namespace => $tag ], @attr );
 220     while ( my ($name,$val) = splice @tags,0,2 ) { warn "NAME: $name, $val";
 221         if ( ref $val eq 'HASH' ) {
 222              $xml->emptyTag( [ $Namespace => $name ],
 223                  map { ($_, $val->{$_}) } sort keys %$val );
 224         }
 225         else {
 226             $xml->dataElement( [ $Namespace => $name ], $val );
 227         }
 228     }
 229     $xml->endTag( [ $Namespace => $tag ] ) if $child_tags && $end_tag;
 230 }
 231 }