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 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 use vars qw[ $VERSION @EXPORT_OK ];
 146 $VERSION = '1.59';
 147
 148 use Exporter;
 149 use base qw(Exporter);
 150 @EXPORT_OK = qw(produce);
 151
 152 use IO::Scalar;
 153 use SQL::Translator::Utils qw(header_comment debug);
 154 BEGIN {
 155     # Will someone fix XML::Writer already?
 156     local $^W = 0;
 157     require XML::Writer;
 158     import XML::Writer;
 159 }
 160
 161 # Which schema object attributes (methods) to write as xml elements rather than
 162 # as attributes. e.g. <comments>blah, blah...</comments>
 163 my @MAP_AS_ELEMENTS = qw/sql comments action extra/;
 164
 165
 166
 167 my $Namespace = 'http://sqlfairy.sourceforge.net/sqlfairy.xml';
 168 my $Name      = 'sqlf';
 169 my $PArgs     = {};
 170 my $no_comments;
 171
 172 sub produce {
 173     my $translator  = shift;
 174     my $schema      = $translator->schema;
 175     $no_comments    = $translator->no_comments;
 176     $PArgs          = $translator->producer_args;
 177     my $newlines    = defined $PArgs->{newlines} ? $PArgs->{newlines} : 1;
 178     my $indent      = defined $PArgs->{indent}   ? $PArgs->{indent}   : 2;
 179     my $io          = IO::Scalar->new;
 180
 181     # Setup the XML::Writer and set the namespace
 182     my $prefix = "";
 183     $prefix    = $Name            if $PArgs->{add_prefix};
 184     $prefix    = $PArgs->{prefix} if $PArgs->{prefix};
 185     my $xml         = XML::Writer->new(
 186         OUTPUT      => $io,
 187         NAMESPACES  => 1,
 188         PREFIX_MAP  => { $Namespace => $prefix },
 189         DATA_MODE   => $newlines,
 190         DATA_INDENT => $indent,
 191     );
 192
 193     # Start the document
 194     $xml->xmlDecl('UTF-8');
 195
 196     $xml->comment(header_comment('', ''))
 197       unless $no_comments;
 198
 199     xml_obj($xml, $schema,
 200         tag => "schema", methods => [qw/name database extra/], end_tag => 0 );
 201
 202     #
 203     # Table
 204     #
 205     $xml->startTag( [ $Namespace => "tables" ] );
 206     for my $table ( $schema->get_tables ) {
 207         debug "Table:",$table->name;
 208         xml_obj($xml, $table,
 209              tag => "table",
 210              methods => [qw/name order extra/],
 211              end_tag => 0
 212          );
 213
 214         #
 215         # Fields
 216         #
 217         xml_obj_children( $xml, $table,
 218             tag   => 'field',
 219             methods =>[qw/
 220                 name data_type size is_nullable default_value is_auto_increment
 221                 is_primary_key is_foreign_key extra comments order
 222             /],
 223         );
 224
 225         #
 226         # Indices
 227         #
 228         xml_obj_children( $xml, $table,
 229             tag   => 'index',
 230             collection_tag => "indices",
 231             methods => [qw/name type fields options extra/],
 232         );
 233
 234         #
 235         # Constraints
 236         #
 237         xml_obj_children( $xml, $table,
 238             tag   => 'constraint',
 239             methods => [qw/
 240                 name type fields reference_table reference_fields
 241                 on_delete on_update match_type expression options deferrable
 242                 extra
 243             /],
 244         );
 245
 246         #
 247         # Comments
 248         #
 249         xml_obj_children( $xml, $table,
 250             tag   => 'comment',
 251             collection_tag => "comments",
 252             methods => [qw/
 253                 comments
 254             /],
 255         );
 256
 257         $xml->endTag( [ $Namespace => 'table' ] );
 258     }
 259     $xml->endTag( [ $Namespace => 'tables' ] );
 260
 261     #
 262     # Views
 263     #
 264     xml_obj_children( $xml, $schema,
 265         tag   => 'view',
 266         methods => [qw/name sql fields order extra/],
 267     );
 268
 269     #
 270     # Tiggers
 271     #
 272     xml_obj_children( $xml, $schema,
 273         tag    => 'trigger',
 274         methods => [qw/name database_events action on_table perform_action_when
 275             fields order extra/],
 276     );
 277
 278     #
 279     # Procedures
 280     #
 281     xml_obj_children( $xml, $schema,
 282         tag   => 'procedure',
 283         methods => [qw/name sql parameters owner comments order extra/],
 284     );
 285
 286     $xml->endTag([ $Namespace => 'schema' ]);
 287     $xml->end;
 288
 289     return $io;
 290 }
 291
 292
 293 #
 294 # Takes and XML::Write object, Schema::* parent object, the tag name,
 295 # the collection name and a list of methods (of the children) to write as XML.
 296 # The collection name defaults to the name with an s on the end and is used to
 297 # work out the method to get the children with. eg a name of 'foo' gives a
 298 # collection of foos and gets the members using ->get_foos.
 299 #
 300 sub xml_obj_children {
 301     my ($xml,$parent) = (shift,shift);
 302     my %args = @_;
 303     my ($name,$collection_name,$methods)
 304         = @args{qw/tag collection_tag methods/};
 305     $collection_name ||= "${name}s";
 306
 307     my $meth;
 308     if ( $collection_name eq 'comments' ) {
 309       $meth = 'comments';
 310     } else {
 311       $meth = "get_$collection_name";
 312     }
 313
 314     my @kids = $parent->$meth;
 315     #@kids || return;
 316     $xml->startTag( [ $Namespace => $collection_name ] );
 317
 318     for my $obj ( @kids ) {
 319         if ( $collection_name eq 'comments' ){
 320             $xml->dataElement( [ $Namespace => 'comment' ], $obj );
 321         } else {
 322             xml_obj($xml, $obj,
 323                 tag     => "$name",
 324                 end_tag => 1,
 325                 methods => $methods,
 326             );
 327         }
 328     }
 329     $xml->endTag( [ $Namespace => $collection_name ] );
 330 }
 331
 332 #
 333 # Takes an XML::Writer, Schema::* object and list of method names
 334 # and writes the obect out as XML. All methods values are written as attributes
 335 # except for the methods listed in @MAP_AS_ELEMENTS which get written as child
 336 # data elements.
 337 #
 338 # The attributes/tags are written in the same order as the method names are
 339 # passed.
 340 #
 341 # TODO
 342 # - Should the Namespace be passed in instead of global? Pass in the same
 343 #   as Writer ie [ NS => TAGNAME ]
 344 #
 345 my $elements_re = join("|", @MAP_AS_ELEMENTS);
 346 $elements_re = qr/^($elements_re)$/;
 347 sub xml_obj {
 348     my ($xml, $obj, %args) = @_;
 349     my $tag                = $args{'tag'}              || '';
 350     my $end_tag            = $args{'end_tag'}          || '';
 351     my @meths              = @{ $args{'methods'} };
 352     my $empty_tag          = 0;
 353
 354     # Use array to ensure consistant (ie not hash) ordering of attribs
 355     # The order comes from the meths list passed in.
 356     my @tags;
 357     my @attr;
 358     foreach ( grep { defined $obj->$_ } @meths ) {
 359         my $what = m/$elements_re/ ? \@tags : \@attr;
 360         my $val = $_ eq 'extra'
 361             ? { $obj->$_ }
 362             : $obj->$_;
 363         $val = ref $val eq 'ARRAY' ? join(',', @$val) : $val;
 364         push @$what, $_ => $val;
 365     };
 366     my $child_tags = @tags;
 367     $end_tag && !$child_tags
 368         ? $xml->emptyTag( [ $Namespace => $tag ], @attr )
 369         : $xml->startTag( [ $Namespace => $tag ], @attr );
 370     while ( my ($name,$val) = splice @tags,0,2 ) {
 371         if ( ref $val eq 'HASH' ) {
 372              $xml->emptyTag( [ $Namespace => $name ],
 373                  map { ($_, $val->{$_}) } sort keys %$val );
 374         }
 375         else {
 376             $xml->dataElement( [ $Namespace => $name ], $val );
 377         }
 378     }
 379     $xml->endTag( [ $Namespace => $tag ] ) if $child_tags && $end_tag;
 380 }
 381
 382 1;
 383
 384 # -------------------------------------------------------------------
 385 # The eyes of fire, the nostrils of air,
 386 # The mouth of water, the beard of earth.
 387 # William Blake
 388 # -------------------------------------------------------------------
 389
 390 =pod
 391
 392 =head1 AUTHORS
 393
 394 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>,
 395 Darren Chamberlain E<lt>darren@cpan.orgE<gt>,
 396 Mark Addison E<lt>mark.addison@itn.co.ukE<gt>.
 397
 398 =head1 SEE ALSO
 399
 400 L<perl(1)>, L<SQL::Translator>, L<SQL::Translator::Parser::XML::SQLFairy>,
 401 L<SQL::Translator::Schema>, L<XML::Writer>.
 402
 403 =cut