lib/SQL/Translator/Producer/XML/SQLFairy.pm

   1 package SQL::Translator::Producer::XML::SQLFairy;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: SQLFairy.pm 1440 2009-01-17 16:31:57Z jawnsy $
   5 # -------------------------------------------------------------------
   6 # Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org>,
   7 #                    darren chamberlain <darren@cpan.org>,
   8 #                    Chris Mungall <cjm@fruitfly.org>,
   9 #                    Mark Addison <mark.addison@itn.co.uk>.
  10 #
  11 # This program is free software; you can redistribute it and/or
  12 # modify it under the terms of the GNU General Public License as
  13 # published by the Free Software Foundation; version 2.
  14 #
  15 # This program is distributed in the hope that it will be useful, but
  16 # WITHOUT ANY WARRANTY; without even the implied warranty of
  17 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 # General Public License for more details.
  19 #
  20 # You should have received a copy of the GNU General Public License
  21 # along with this program; if not, write to the Free Software
  22 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
  23 # 02111-1307  USA
  24 # -------------------------------------------------------------------
  25
  26 =pod
  27
  28 =head1 NAME
  29
  30 SQL::Translator::Producer::XML::SQLFairy - SQLFairy's default XML format
  31
  32 =head1 SYNOPSIS
  33
  34   use SQL::Translator;
  35
  36   my $t              = SQL::Translator->new(
  37       from           => 'MySQL',
  38       to             => 'XML-SQLFairy',
  39       filename       => 'schema.sql',
  40       show_warnings  => 1,
  41   );
  42
  43   print $t->translate;
  44
  45 =head1 DESCRIPTION
  46
  47 Creates XML output of a schema, in the flavor of XML used natively by the
  48 SQLFairy project (L<SQL::Translator>). This format is detailed here.
  49
  50 The XML lives in the C<http://sqlfairy.sourceforge.net/sqlfairy.xml> namespace.
  51 With a root element of <schema>.
  52
  53 Objects in the schema are mapped to tags of the same name as the objects class
  54 (all lowercase).
  55
  56 The attributes of the objects (e.g. $field->name) are mapped to attributes of
  57 the tag, except for sql, comments and action, which get mapped to child data
  58 elements.
  59
  60 List valued attributes (such as the list of fields in an index)
  61 get mapped to comma seperated lists of values in the attribute.
  62
  63 Child objects, such as a tables fields, get mapped to child tags wrapped in a
  64 set of container tags using the plural of their contained classes name.
  65
  66 An objects's extra attribute (a hash of arbitary data) is
  67 mapped to a tag called extra, with the hash of data as attributes, sorted into
  68 alphabetical order.
  69
  70 e.g.
  71
  72     <schema name="" database=""
  73       xmlns="http://sqlfairy.sourceforge.net/sqlfairy.xml">
  74
  75       <tables>
  76         <table name="Story" order="1">
  77           <fields>
  78             <field name="id" data_type="BIGINT" size="20"
  79               is_nullable="0" is_auto_increment="1" is_primary_key="1"
  80               is_foreign_key="0" order="3">
  81               <extra ZEROFILL="1" />
  82               <comments></comments>
  83             </field>
  84             <field name="created" data_type="datetime" size="0"
  85               is_nullable="1" is_auto_increment="0" is_primary_key="0"
  86               is_foreign_key="0" order="1">
  87               <extra />
  88               <comments></comments>
  89             </field>
  90             ...
  91           </fields>
  92           <indices>
  93             <index name="foobar" type="NORMAL" fields="foo,bar" options="" />
  94           </indices>
  95         </table>
  96       </tables>
  97
  98       <views>
  99         <view name="email_list" fields="email" order="1">
 100           <sql>SELECT email FROM Basic WHERE email IS NOT NULL</sql>
 101         </view>
 102       </views>
 103
 104     </schema>
 105
 106 To see a complete example of the XML translate one of your schema :)
 107
 108   $ sqlt -f MySQL -t XML-SQLFairy schema.sql
 109
 110 =head1 ARGS
 111
 112 =over 4
 113
 114 =item add_prefix
 115
 116 Set to true to use the default namespace prefix of 'sqlf', instead of using
 117 the default namespace for
 118 C<http://sqlfairy.sourceforge.net/sqlfairy.xml namespace>
 119
 120 e.g.
 121
 122  <!-- add_prefix=0 -->
 123  <field name="foo" />
 124
 125  <!-- add_prefix=1 -->
 126  <sqlf:field name="foo" />
 127
 128 =item prefix
 129
 130 Set to the namespace prefix you want to use for the
 131 C<http://sqlfairy.sourceforge.net/sqlfairy.xml namespace>
 132
 133 e.g.
 134
 135  <!-- prefix='foo' -->
 136  <foo:field name="foo" />
 137
 138 =item newlines
 139
 140 If true (the default) inserts newlines around the XML, otherwise the schema is
 141 written on one line.
 142
 143 =item indent
 144
 145 When using newlines the number of whitespace characters to use as the indent.
 146 Default is 2, set to 0 to turn off indenting.
 147
 148 =back
 149
 150 =head1 LEGACY FORMAT
 151
 152 The previous version of the SQLFairy XML allowed the attributes of the the
 153 schema objects to be written as either xml attributes or as data elements, in
 154 any combination. The old producer could produce attribute only or data element
 155 only versions. While this allowed for lots of flexibility in writing the XML
 156 the result is a great many possible XML formats, not so good for DTD writing,
 157 XPathing etc! So we have moved to a fixed version described above.
 158
 159 This version of the producer will now only produce the new style XML.
 160 To convert your old format files simply pass them through the translator :)
 161
 162  $ sqlt -f XML-SQLFairy -t XML-SQLFairy schema-old.xml > schema-new.xml
 163
 164 =cut
 165
 166 use strict;
 167 use vars qw[ @EXPORT_OK ];
 168
 169 use Exporter;
 170 use base qw(Exporter);
 171 @EXPORT_OK = qw(produce);
 172
 173 use IO::Scalar;
 174 use SQL::Translator::Utils qw(header_comment debug);
 175 BEGIN {
 176     # Will someone fix XML::Writer already?
 177     local $^W = 0;
 178     require XML::Writer;
 179     import XML::Writer;
 180 }
 181
 182 # Which schema object attributes (methods) to write as xml elements rather than
 183 # as attributes. e.g. <comments>blah, blah...</comments>
 184 my @MAP_AS_ELEMENTS = qw/sql comments action extra/;
 185
 186
 187
 188 my $Namespace = 'http://sqlfairy.sourceforge.net/sqlfairy.xml';
 189 my $Name      = 'sqlf';
 190 my $PArgs     = {};
 191
 192 sub produce {
 193     my $translator  = shift;
 194     my $schema      = $translator->schema;
 195     $PArgs          = $translator->producer_args;
 196     my $newlines    = defined $PArgs->{newlines} ? $PArgs->{newlines} : 1;
 197     my $indent      = defined $PArgs->{indent}   ? $PArgs->{indent}   : 2;
 198     my $io          = IO::Scalar->new;
 199
 200     # Setup the XML::Writer and set the namespace
 201     my $prefix = "";
 202     $prefix    = $Name            if $PArgs->{add_prefix};
 203     $prefix    = $PArgs->{prefix} if $PArgs->{prefix};
 204     my $xml         = XML::Writer->new(
 205         OUTPUT      => $io,
 206         NAMESPACES  => 1,
 207         PREFIX_MAP  => { $Namespace => $prefix },
 208         DATA_MODE   => $newlines,
 209         DATA_INDENT => $indent,
 210     );
 211
 212     # Start the document
 213     $xml->xmlDecl('UTF-8');
 214     $xml->comment(header_comment('', ''));
 215     xml_obj($xml, $schema,
 216         tag => "schema", methods => [qw/name database extra/], end_tag => 0 );
 217
 218     #
 219     # Table
 220     #
 221     $xml->startTag( [ $Namespace => "tables" ] );
 222     for my $table ( $schema->get_tables ) {
 223         debug "Table:",$table->name;
 224         xml_obj($xml, $table,
 225              tag => "table",
 226              methods => [qw/name order extra/],
 227              end_tag => 0
 228          );
 229
 230         #
 231         # Fields
 232         #
 233         xml_obj_children( $xml, $table,
 234             tag   => 'field',
 235             methods =>[qw/
 236                 name data_type size is_nullable default_value is_auto_increment
 237                 is_primary_key is_foreign_key extra comments order
 238             /],
 239         );
 240
 241         #
 242         # Indices
 243         #
 244         xml_obj_children( $xml, $table,
 245             tag   => 'index',
 246             collection_tag => "indices",
 247             methods => [qw/name type fields options extra/],
 248         );
 249
 250         #
 251         # Constraints
 252         #
 253         xml_obj_children( $xml, $table,
 254             tag   => 'constraint',
 255             methods => [qw/
 256                 name type fields reference_table reference_fields
 257                 on_delete on_update match_type expression options deferrable
 258                 extra
 259             /],
 260         );
 261
 262         #
 263         # Comments
 264         #
 265         xml_obj_children( $xml, $table,
 266             tag   => 'comment',
 267             collection_tag => "comments",
 268             methods => [qw/
 269                 comments
 270             /],
 271         );
 272
 273         $xml->endTag( [ $Namespace => 'table' ] );
 274     }
 275     $xml->endTag( [ $Namespace => 'tables' ] );
 276
 277     #
 278     # Views
 279     #
 280     xml_obj_children( $xml, $schema,
 281         tag   => 'view',
 282         methods => [qw/name sql fields order extra/],
 283     );
 284
 285     #
 286     # Tiggers
 287     #
 288     xml_obj_children( $xml, $schema,
 289         tag    => 'trigger',
 290         methods => [qw/name database_event action on_table perform_action_when
 291             fields order extra/],
 292     );
 293
 294     #
 295     # Procedures
 296     #
 297     xml_obj_children( $xml, $schema,
 298         tag   => 'procedure',
 299         methods => [qw/name sql parameters owner comments order extra/],
 300     );
 301
 302     $xml->endTag([ $Namespace => 'schema' ]);
 303     $xml->end;
 304
 305     return $io;
 306 }
 307
 308
 309 #
 310 # Takes and XML::Write object, Schema::* parent object, the tag name,
 311 # the collection name and a list of methods (of the children) to write as XML.
 312 # The collection name defaults to the name with an s on the end and is used to
 313 # work out the method to get the children with. eg a name of 'foo' gives a
 314 # collection of foos and gets the members using ->get_foos.
 315 #
 316 sub xml_obj_children {
 317     my ($xml,$parent) = (shift,shift);
 318     my %args = @_;
 319     my ($name,$collection_name,$methods)
 320         = @args{qw/tag collection_tag methods/};
 321     $collection_name ||= "${name}s";
 322
 323     my $meth;
 324     if ( $collection_name eq 'comments' ) {
 325       $meth = 'comments';
 326     } else {
 327       $meth = "get_$collection_name";
 328     }
 329
 330     my @kids = $parent->$meth;
 331     #@kids || return;
 332     $xml->startTag( [ $Namespace => $collection_name ] );
 333
 334     for my $obj ( @kids ) {
 335         if ( $collection_name eq 'comments' ){
 336             $xml->dataElement( [ $Namespace => 'comment' ], $obj );
 337         } else {
 338             xml_obj($xml, $obj,
 339                 tag     => "$name",
 340                 end_tag => 1,
 341                 methods => $methods,
 342             );
 343         }
 344     }
 345     $xml->endTag( [ $Namespace => $collection_name ] );
 346 }
 347
 348 #
 349 # Takes an XML::Writer, Schema::* object and list of method names
 350 # and writes the obect out as XML. All methods values are written as attributes
 351 # except for the methods listed in @MAP_AS_ELEMENTS which get written as child
 352 # data elements.
 353 #
 354 # The attributes/tags are written in the same order as the method names are
 355 # passed.
 356 #
 357 # TODO
 358 # - Should the Namespace be passed in instead of global? Pass in the same
 359 #   as Writer ie [ NS => TAGNAME ]
 360 #
 361 my $elements_re = join("|", @MAP_AS_ELEMENTS);
 362 $elements_re = qr/^($elements_re)$/;
 363 sub xml_obj {
 364     my ($xml, $obj, %args) = @_;
 365     my $tag                = $args{'tag'}              || '';
 366     my $end_tag            = $args{'end_tag'}          || '';
 367     my @meths              = @{ $args{'methods'} };
 368     my $empty_tag          = 0;
 369
 370     # Use array to ensure consistant (ie not hash) ordering of attribs
 371     # The order comes from the meths list passed in.
 372     my @tags;
 373     my @attr;
 374     foreach ( grep { defined $obj->$_ } @meths ) {
 375         my $what = m/$elements_re/ ? \@tags : \@attr;
 376         my $val = $_ eq 'extra'
 377             ? { $obj->$_ }
 378             : $obj->$_;
 379         $val = ref $val eq 'ARRAY' ? join(',', @$val) : $val;
 380         push @$what, $_ => $val;
 381     };
 382     my $child_tags = @tags;
 383     $end_tag && !$child_tags
 384         ? $xml->emptyTag( [ $Namespace => $tag ], @attr )
 385         : $xml->startTag( [ $Namespace => $tag ], @attr );
 386     while ( my ($name,$val) = splice @tags,0,2 ) {
 387         if ( ref $val eq 'HASH' ) {
 388              $xml->emptyTag( [ $Namespace => $name ],
 389                  map { ($_, $val->{$_}) } sort keys %$val );
 390         }
 391         else {
 392             $xml->dataElement( [ $Namespace => $name ], $val );
 393         }
 394     }
 395     $xml->endTag( [ $Namespace => $tag ] ) if $child_tags && $end_tag;
 396 }
 397
 398 1;
 399
 400 # -------------------------------------------------------------------
 401 # The eyes of fire, the nostrils of air,
 402 # The mouth of water, the beard of earth.
 403 # William Blake
 404 # -------------------------------------------------------------------
 405
 406 =pod
 407
 408 =head1 AUTHORS
 409
 410 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>,
 411 Darren Chamberlain E<lt>darren@cpan.orgE<gt>,
 412 Mark Addison E<lt>mark.addison@itn.co.ukE<gt>.
 413
 414 =head1 SEE ALSO
 415
 416 L<perl(1)>, L<SQL::Translator>, L<SQL::Translator::Parser::XML::SQLFairy>,
 417 L<SQL::Translator::Schema>, L<XML::Writer>.
 418
 419 =cut