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

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