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

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