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

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