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 database /], end_tag => 0 });
  51 #        tag => "schema", methods => [qw/name database extra/], end_tag => 0 );
  52
  53     #
  54     # Table
  55     #
  56     $xml->startTag( [ $Namespace => "tables" ] );
  57     for my $table ( $schema->get_tables ) {
  58 #        debug "Table:",$table->name;
  59         xml_obj($xml, $table,
  60             { tag => "table",
  61              methods => [qw/name order/],
  62 #             methods => [qw/name order extra/],
  63              end_tag => 0 }
  64          );
  65
  66         #
  67         # Fields
  68         #
  69         xml_obj_children( $xml, $table,
  70             { tag   => 'field',
  71             methods =>[qw/
  72                 name data_type size is_nullable default_value is_auto_increment
  73                 is_primary_key is_foreign_key comments order
  74             /], }
  75 #                is_primary_key is_foreign_key extra comments order
  76         );
  77
  78         #
  79         # Indices
  80         #
  81         xml_obj_children( $xml, $table,
  82             { tag   => 'index',
  83             collection_tag => "indices",
  84             methods => [qw/name type fields options/], }
  85 #            methods => [qw/name type fields options extra/],
  86         );
  87
  88         #
  89         # Constraints
  90         #
  91         xml_obj_children( $xml, $table,
  92             { tag   => 'constraint',
  93 #            methods => [qw/
  94 #                name type fields reference_table reference_fields
  95 #                on_delete on_update match_type expression options deferrable
  96 #                extra
  97 #            /],
  98              methods => [qw/name type expression options deferrable/], }
  99         );
 100
 101         #
 102         # Comments
 103         #
 104         xml_obj_children( $xml, $table,
 105             { tag   => 'comment',
 106 #            collection_tag => "comments",
 107             methods => [qw/
 108                 comments
 109             /], }
 110         );
 111
 112         $xml->endTag( [ $Namespace => 'table' ] );
 113     }
 114     $xml->endTag( [ $Namespace => 'tables' ] );
 115
 116     #
 117     # Views
 118     #
 119     xml_obj_children( $xml, $schema,
 120         { tag   => 'view',
 121         methods => [qw/name sql fields/], }
 122 #        methods => [qw/name sql fields order extra/],
 123     );
 124
 125     #
 126     # Tiggers
 127     #
 128     xml_obj_children( $xml, $schema,
 129         { tag    => 'trigger',
 130         methods => [qw/name database_events action on_table perform_action_when fields order/], }
 131 #        methods => [qw/name database_events action on_table perform_action_when fields order extra/],
 132     );
 133
 134     #
 135     # Procedures
 136     #
 137     xml_obj_children( $xml, $schema,
 138         { tag   => 'procedure',
 139         methods => [qw/name sql parameters owner comments order/], }
 140 #        methods => [qw/name sql parameters owner comments order extra/],
 141     );
 142
 143     $xml->endTag([ $Namespace => 'schema' ]);
 144     $xml->end;
 145
 146     return $io;
 147 }
 148
 149
 150 #
 151 # Takes and XML::Write object, Schema::* parent object, the tag name,
 152 # the collection name and a list of methods (of the children) to write as XML.
 153 # The collection name defaults to the name with an s on the end and is used to
 154 # work out the method to get the children with. eg a name of 'foo' gives a
 155 # collection of foos and gets the members using ->get_foos.
 156 #
 157 #sub xml_obj_children {
 158 method xml_obj_children($xml: $parent, HashRef $args?) {
 159 #    my ($xml,$parent) = (shift,shift);
 160
 161 #    my %args = @_;
 162     my ($name,$collection_name,$methods)
 163         = @{$args}{qw/tag collection_tag methods/};
 164     $collection_name ||= "${name}s";
 165
 166     my $meth;
 167     if ( $collection_name eq 'comments' ) {
 168       $meth = 'comments';
 169     } else {
 170       $meth = "get_$collection_name";
 171     }
 172
 173     my @kids = $parent->$meth;
 174     #@kids || return;
 175     $xml->startTag( [ $Namespace => $collection_name ] );
 176
 177     for my $obj ( @kids ) {
 178         if ( $collection_name eq 'comments' ){
 179             $xml->dataElement( [ $Namespace => 'comment' ], $obj );
 180         } else {
 181             xml_obj($xml, $obj,
 182                 { tag     => "$name",
 183                 end_tag => 1,
 184                 methods => $methods, }
 185             );
 186         }
 187     }
 188     $xml->endTag( [ $Namespace => $collection_name ] );
 189 }
 190
 191 #
 192 # Takes an XML::Writer, Schema::* object and list of method names
 193 # and writes the obect out as XML. All methods values are written as attributes
 194 # except for the methods listed in @MAP_AS_ELEMENTS which get written as child
 195 # data elements.
 196 #
 197 # The attributes/tags are written in the same order as the method names are
 198 # passed.
 199 #
 200 # TODO
 201 # - Should the Namespace be passed in instead of global? Pass in the same
 202 #   as Writer ie [ NS => TAGNAME ]
 203 #
 204 my $elements_re = join("|", @MAP_AS_ELEMENTS);
 205 $elements_re = qr/^($elements_re)$/;
 206 #sub xml_obj {
 207 method xml_obj($xml: $obj, HashRef $args?) {
 208 #    my ($xml, $obj, %args) = @_;
 209     my $tag                = $args->{'tag'}              || '';
 210     my $end_tag            = $args->{'end_tag'}          || '';
 211     my @meths              = @{ $args->{'methods'} };
 212     my $empty_tag          = 0;
 213
 214     # Use array to ensure consistant (ie not hash) ordering of attribs
 215     # The order comes from the meths list passed in.
 216     my @tags;
 217     my @attr;
 218     foreach ( grep { defined $obj->$_ } @meths ) {
 219         my $what = m/$elements_re/ ? \@tags : \@attr;
 220         my $val = $_ eq 'extra'
 221             ? { $obj->$_ }
 222             : $obj->$_;
 223         $val = ref $val eq 'ARRAY' ? join(',', @$val) : $val;
 224         push @$what, $_ => $val;
 225     };
 226     my $child_tags = @tags;
 227     $end_tag && !$child_tags
 228         ? $xml->emptyTag( [ $Namespace => $tag ], @attr )
 229         : $xml->startTag( [ $Namespace => $tag ], @attr );
 230     while ( my ($name,$val) = splice @tags,0,2 ) { warn "NAME: $name, $val";
 231         if ( ref $val eq 'HASH' ) {
 232              $xml->emptyTag( [ $Namespace => $name ],
 233                  map { ($_, $val->{$_}) } sort keys %$val );
 234         }
 235         else {
 236             $xml->dataElement( [ $Namespace => $name ], $val );
 237         }
 238     }
 239     $xml->endTag( [ $Namespace => $tag ] ) if $child_tags && $end_tag;
 240 }
 241 }