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

   1 package SQL::Translator::Producer::XML::SQLFairy;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: SQLFairy.pm,v 1.15 2004-07-08 23:39:38 grommit Exp $
   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       add_drop_table => 1,
  42   );
  43
  44   print $t->translate;
  45
  46 =head1 DESCRIPTION
  47
  48 Creates XML output of a schema, in SQLFairy format XML.
  49
  50 The XML lives in the 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
  55 The attributes of the objects (e.g. $field->name) are mapped to attributes of
  56 the tag, except for sql, comments and action, which get mapped to child data
  57 elements.
  58
  59 List valued attributes (such as the list of fields in an index)
  60 get mapped to a comma seperated list of values in the attribute.
  61
  62 Child objects, such as a tables fields, get mapped to child tags wrapped in a
  63 set of container tags using the plural of their contained classes name.
  64
  65 L<SQL::Translator::Schema::Field>'s extra attribute (a hash of arbitary data) is
  66 mapped to a tag called extra, with the hash of data as attributes, sorted into
  67 alphabetical order.
  68
  69 e.g.
  70
  71     <schema name="" database=""
  72       xmlns="http://sqlfairy.sourceforge.net/sqlfairy.xml">
  73
  74       <table name="Story" order="1">
  75
  76         <fields>
  77           <field name="id" data_type="BIGINT" size="20"
  78             is_nullable="0" is_auto_increment="1" is_primary_key="1"
  79             is_foreign_key="0" order="3">
  80             <extra ZEROFILL="1" />
  81             <comments></comments>
  82           </field>
  83           <field name="created" data_type="datetime" size="0"
  84             is_nullable="1" is_auto_increment="0" is_primary_key="0"
  85             is_foreign_key="0" order="1">
  86             <extra />
  87             <comments></comments>
  88           </field>
  89           ...
  90         </fields>
  91
  92         <indices>
  93           <index name="foobar" type="NORMAL" fields="foo,bar" options="" />
  94         </indices>
  95
  96       </table>
  97
  98       <view name="email_list" fields="email" order="1">
  99         <sql>SELECT email FROM Basic WHERE email IS NOT NULL</sql>
 100       </view>
 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 = sprintf "%d.%02d", q$Revision: 1.15 $ =~ /(\d+)\.(\d+)/;
 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 my $Namespace = 'http://sqlfairy.sourceforge.net/sqlfairy.xml';
 182 my $Name      = 'sqlf';
 183 my $PArgs     = {};
 184
 185 sub produce {
 186     my $translator  = shift;
 187     my $schema      = $translator->schema;
 188     $PArgs          = $translator->producer_args;
 189     my $newlines    = defined $PArgs->{newlines} ? $PArgs->{newlines} : 1;
 190     my $indent      = defined $PArgs->{indent}   ? $PArgs->{indent}   : 2;
 191     my $io          = IO::Scalar->new;
 192
 193     my $prefix = "";
 194     $prefix    = $Name            if $PArgs->{add_prefix};
 195     $prefix    = $PArgs->{prefix} if $PArgs->{prefix};
 196     my $xml         = XML::Writer->new(
 197         OUTPUT      => $io,
 198         NAMESPACES  => 1,
 199         PREFIX_MAP  => { $Namespace => $prefix },
 200         DATA_MODE   => $newlines,
 201         DATA_INDENT => $indent,
 202     );
 203
 204     $xml->xmlDecl('UTF-8');
 205     $xml->comment(header_comment('', ''));
 206     #$xml->startTag([ $Namespace => 'schema' ]);
 207     xml_obj($xml, $schema,
 208         tag => "schema", methods => [qw/name database/], end_tag => 0 );
 209
 210     #
 211     # Table
 212     #
 213     for my $table ( $schema->get_tables ) {
 214         debug "Table:",$table->name;
 215         xml_obj($xml, $table,
 216              tag => "table", methods => [qw/name order/], end_tag => 0 );
 217
 218         #
 219         # Fields
 220         #
 221         $xml->startTag( [ $Namespace => 'fields' ] );
 222         for my $field ( $table->get_fields ) {
 223             debug "    Field:",$field->name;
 224             xml_obj($xml, $field,
 225                 tag     =>"field",
 226                 end_tag => 1,
 227                 methods =>[qw/name data_type size is_nullable default_value
 228                     is_auto_increment is_primary_key is_foreign_key extra comments order
 229                 /],
 230             );
 231         }
 232         $xml->endTag( [ $Namespace => 'fields' ] );
 233
 234         #
 235         # Indices
 236         #
 237         $xml->startTag( [ $Namespace => 'indices' ] );
 238         for my $index ( $table->get_indices ) {
 239             debug "Index:",$index->name;
 240             xml_obj($xml, $index,
 241                 tag     => "index",
 242                 end_tag => 1,
 243                 methods =>[qw/ name type fields options/],
 244             );
 245         }
 246         $xml->endTag( [ $Namespace => 'indices' ] );
 247
 248         #
 249         # Constraints
 250         #
 251         $xml->startTag( [ $Namespace => 'constraints' ] );
 252         for my $index ( $table->get_constraints ) {
 253             debug "Constraint:",$index->name;
 254             xml_obj($xml, $index,
 255                 tag     => "constraint",
 256                 end_tag => 1,
 257                 methods =>[qw/
 258                     name type fields reference_table reference_fields
 259                     on_delete on_update match_type expression options deferrable
 260                     /],
 261             );
 262         }
 263         $xml->endTag( [ $Namespace => 'constraints' ] );
 264
 265         $xml->endTag( [ $Namespace => 'table' ] );
 266     }
 267
 268     #
 269     # Views
 270     #
 271     for my $foo ( $schema->get_views ) {
 272         xml_obj($xml, $foo, tag => "view",
 273         methods => [qw/name sql fields order/], end_tag => 1 );
 274     }
 275
 276     #
 277     # Tiggers
 278     #
 279     for my $foo ( $schema->get_triggers ) {
 280         xml_obj($xml, $foo, tag => "trigger",
 281         methods => [qw/name database_event action on_table perform_action_when
 282         fields order/], end_tag => 1 );
 283     }
 284
 285     #
 286     # Procedures
 287     #
 288     for my $foo ( $schema->get_procedures ) {
 289         xml_obj($xml, $foo, tag => "procedure",
 290         methods => [qw/name sql parameters owner comments order/], end_tag=>1 );
 291     }
 292
 293     $xml->endTag([ $Namespace => 'schema' ]);
 294     $xml->end;
 295
 296     return $io;
 297 }
 298
 299 # -------------------------------------------------------------------
 300 #
 301 # Takes an XML Write, Schema::* object and list of method names
 302 # and writes the obect out as XML. All methods values are written as attributes
 303 # except for comments, sql and action which get written as child data elements.
 304 #
 305 # The attributes, tags are written in the same order as the method names are
 306 # passed.
 307 #
 308 # TODO
 309 # - Should the Namespace be passed in instead of global? Pass in the same
 310 #   as Writer ie [ NS => TAGNAME ]
 311 #
 312 sub xml_obj {
 313     my ($xml, $obj, %args) = @_;
 314     my $tag                = $args{'tag'}              || '';
 315     my $end_tag            = $args{'end_tag'}          || '';
 316     my @meths              = @{ $args{'methods'} };
 317     my $empty_tag          = 0;
 318
 319     # Use array to ensure consistant (ie not hash) ordering of attribs
 320     # The order comes from the meths list passed in.
 321     my @tags;
 322     my @attr;
 323     foreach ( grep { defined $obj->$_ } @meths ) {
 324         my $what = m/^(sql|comments|action|extra)$/ ? \@tags : \@attr;
 325         my $val = $_ eq 'extra'
 326             ? { $obj->$_ }
 327             : $obj->$_;
 328         $val = ref $val eq 'ARRAY' ? join(',', @$val) : $val;
 329         push @$what, $_ => $val;
 330     };
 331     my $child_tags = @tags;
 332     $end_tag && !$child_tags
 333         ? $xml->emptyTag( [ $Namespace => $tag ], @attr )
 334         : $xml->startTag( [ $Namespace => $tag ], @attr );
 335     while ( my ($name,$val) = splice @tags,0,2 ) {
 336         if ( ref $val eq 'HASH' ) {
 337              $xml->emptyTag( [ $Namespace => $name ],
 338                  map { ($_, $val->{$_}) } sort keys %$val );
 339         }
 340         else {
 341             $xml->dataElement( [ $Namespace => $name ], $val );
 342         }
 343     }
 344     $xml->endTag( [ $Namespace => $tag ] ) if $child_tags && $end_tag;
 345 }
 346
 347 1;
 348
 349 # -------------------------------------------------------------------
 350 # The eyes of fire, the nostrils of air,
 351 # The mouth of water, the beard of earth.
 352 # William Blake
 353 # -------------------------------------------------------------------
 354
 355 =pod
 356
 357 =head1 AUTHORS
 358
 359 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>,
 360 Darren Chamberlain E<lt>darren@cpan.orgE<gt>,
 361 Mark Addison E<lt>mark.addison@itn.co.ukE<gt>.
 362
 363 =head1 SEE ALSO
 364
 365 perl(1), SQL::Translator, SQL::Translator::Parser::XML::SQLFairy,
 366 SQL::Translator::Schema, XML::Writer.
 367
 368 =cut