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

   1 package SQL::Translator::Producer::XML::SQLFairy;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: SQLFairy.pm,v 1.14 2004-07-08 20:37:26 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 e.g.
  66
  67     <schema name="" database=""
  68       xmlns="http://sqlfairy.sourceforge.net/sqlfairy.xml">
  69
  70       <table name="Story" order="1">
  71
  72         <fields>
  73           <field name="created" data_type="datetime" size="0"
  74             is_nullable="1" is_auto_increment="0" is_primary_key="0"
  75             is_foreign_key="0" order="1">
  76             <comments></comments>
  77           </field>
  78           <field name="id" data_type="BIGINT" size="20"
  79             is_nullable="0" is_auto_increment="1" is_primary_key="1"
  80             is_foreign_key="0" order="3">
  81             <comments></comments>
  82           </field>
  83           ...
  84         </fields>
  85
  86         <indices>
  87           <index name="foobar" type="NORMAL" fields="foo,bar" options="" />
  88         </indices>
  89
  90       </table>
  91
  92       <view name="email_list" fields="email" order="1">
  93         <sql>SELECT email FROM Basic WHERE email IS NOT NULL</sql>
  94       </view>
  95
  96     </schema>
  97
  98 To see a complete example of the XML translate one of your schema :)
  99
 100   $ sqlt -f MySQL -t XML-SQLFairy schema.sql
 101
 102 =head1 ARGS
 103
 104 =over 4
 105
 106 =item add_prefix
 107
 108 Set to true to use the default namespace prefix of 'sqlf', instead of using
 109 the default namespace for
 110 C<http://sqlfairy.sourceforge.net/sqlfairy.xml namespace>
 111
 112 e.g.
 113
 114  <!-- add_prefix=0 -->
 115  <field name="foo" />
 116
 117  <!-- add_prefix=1 -->
 118  <sqlf:field name="foo" />
 119
 120 =item prefix
 121
 122 Set to the namespace prefix you want to use for the
 123 C<http://sqlfairy.sourceforge.net/sqlfairy.xml namespace>
 124
 125 e.g.
 126
 127  <!-- prefix='foo' -->
 128  <foo:field name="foo" />
 129
 130 =back
 131
 132 =head1 LEGACY FORMAT
 133
 134 The previous version of the SQLFairy XML allowed the attributes of the the
 135 schema objects to be written as either xml attributes or as data elements, in
 136 any combination. The old producer could produce attribute only or data element
 137 only versions. While this allowed for lots of flexibility in writing the XML
 138 the result is a great many possible XML formats, not so good for DTD writing,
 139 XPathing etc! So we have moved to a fixed version described above.
 140
 141 This version of the producer will now only produce the new style XML.
 142 To convert your old format files simply pass them through the translator;
 143
 144  sqlt -f XML-SQLFairy -t XML-SQLFairy schema-old.xml > schema-new.xml
 145
 146 =cut
 147
 148 use strict;
 149 use vars qw[ $VERSION @EXPORT_OK ];
 150 $VERSION = sprintf "%d.%02d", q$Revision: 1.14 $ =~ /(\d+)\.(\d+)/;
 151
 152 use Exporter;
 153 use base qw(Exporter);
 154 @EXPORT_OK = qw(produce);
 155
 156 use IO::Scalar;
 157 use SQL::Translator::Utils qw(header_comment debug);
 158 BEGIN {
 159     # Will someone fix XML::Writer already?
 160     local $^W = 0;
 161     require XML::Writer;
 162     import XML::Writer;
 163 }
 164
 165 my $Namespace = 'http://sqlfairy.sourceforge.net/sqlfairy.xml';
 166 my $Name      = 'sqlf';
 167 my $PArgs     = {};
 168
 169 sub produce {
 170     my $translator  = shift;
 171     my $schema      = $translator->schema;
 172     $PArgs          = $translator->producer_args;
 173     my $newlines    = defined $PArgs->{newlines} ? $PArgs->{newlines} : 1;
 174     my $indent      = defined $PArgs->{indent}   ? $PArgs->{indent}   : 2;
 175     my $io          = IO::Scalar->new;
 176
 177     my $prefix = "";
 178     $prefix    = $Name            if $PArgs->{add_prefix};
 179     $prefix    = $PArgs->{prefix} if $PArgs->{prefix};
 180     my $xml         = XML::Writer->new(
 181         OUTPUT      => $io,
 182         NAMESPACES  => 1,
 183         PREFIX_MAP  => { $Namespace => $prefix },
 184         DATA_MODE   => $newlines,
 185         DATA_INDENT => $indent,
 186     );
 187
 188     $xml->xmlDecl('UTF-8');
 189     $xml->comment(header_comment('', ''));
 190     #$xml->startTag([ $Namespace => 'schema' ]);
 191     xml_obj($xml, $schema,
 192         tag => "schema", methods => [qw/name database/], end_tag => 0 );
 193
 194     #
 195     # Table
 196     #
 197     for my $table ( $schema->get_tables ) {
 198         debug "Table:",$table->name;
 199         xml_obj($xml, $table,
 200              tag => "table", methods => [qw/name order/], end_tag => 0 );
 201
 202         #
 203         # Fields
 204         #
 205         $xml->startTag( [ $Namespace => 'fields' ] );
 206         for my $field ( $table->get_fields ) {
 207             debug "    Field:",$field->name;
 208             xml_obj($xml, $field,
 209                 tag     =>"field",
 210                 end_tag => 1,
 211                 methods =>[qw/name data_type size is_nullable default_value
 212                     is_auto_increment is_primary_key is_foreign_key comments order
 213                 /],
 214             );
 215         }
 216         $xml->endTag( [ $Namespace => 'fields' ] );
 217
 218         #
 219         # Indices
 220         #
 221         $xml->startTag( [ $Namespace => 'indices' ] );
 222         for my $index ( $table->get_indices ) {
 223             debug "Index:",$index->name;
 224             xml_obj($xml, $index,
 225                 tag     => "index",
 226                 end_tag => 1,
 227                 methods =>[qw/ name type fields options/],
 228             );
 229         }
 230         $xml->endTag( [ $Namespace => 'indices' ] );
 231
 232         #
 233         # Constraints
 234         #
 235         $xml->startTag( [ $Namespace => 'constraints' ] );
 236         for my $index ( $table->get_constraints ) {
 237             debug "Constraint:",$index->name;
 238             xml_obj($xml, $index,
 239                 tag     => "constraint",
 240                 end_tag => 1,
 241                 methods =>[qw/
 242                     name type fields reference_table reference_fields
 243                     on_delete on_update match_type expression options deferrable
 244                     /],
 245             );
 246         }
 247         $xml->endTag( [ $Namespace => 'constraints' ] );
 248
 249         $xml->endTag( [ $Namespace => 'table' ] );
 250     }
 251
 252     #
 253     # Views
 254     #
 255     for my $foo ( $schema->get_views ) {
 256         xml_obj($xml, $foo, tag => "view",
 257         methods => [qw/name sql fields order/], end_tag => 1 );
 258     }
 259
 260     #
 261     # Tiggers
 262     #
 263     for my $foo ( $schema->get_triggers ) {
 264         xml_obj($xml, $foo, tag => "trigger",
 265         methods => [qw/name database_event action on_table perform_action_when
 266         fields order/], end_tag => 1 );
 267     }
 268
 269     #
 270     # Procedures
 271     #
 272     for my $foo ( $schema->get_procedures ) {
 273         xml_obj($xml, $foo, tag => "procedure",
 274         methods => [qw/name sql parameters owner comments order/], end_tag=>1 );
 275     }
 276
 277     $xml->endTag([ $Namespace => 'schema' ]);
 278     $xml->end;
 279
 280     return $io;
 281 }
 282
 283 # -------------------------------------------------------------------
 284 #
 285 # Takes an XML Write, Schema::* object and list of method names
 286 # and writes the obect out as XML. All methods values are written as attributes
 287 # except for comments, sql and action which get written as child data elements.
 288 #
 289 # The attributes, tags are written in the same order as the method names are
 290 # passed.
 291 #
 292 # TODO
 293 # - Should the Namespace be passed in instead of global? Pass in the same
 294 #   as Writer ie [ NS => TAGNAME ]
 295 #
 296 sub xml_obj {
 297     my ($xml, $obj, %args) = @_;
 298     my $tag                = $args{'tag'}              || '';
 299     my $end_tag            = $args{'end_tag'}          || '';
 300     my @meths              = @{ $args{'methods'} };
 301     my $empty_tag          = 0;
 302
 303     # Use array to ensure consistant (ie not hash) ordering of attribs
 304     # The order comes from the meths list passed in.
 305     my @tags;
 306     my @attr;
 307     foreach ( grep { defined $obj->$_ } @meths ) {
 308         my $what = m/^sql|comments|action$/ ? \@tags : \@attr;
 309         my $val = $obj->$_;
 310         $val = ref $val eq 'ARRAY' ? join(',', @$val) : $val;
 311         push @$what, $_ => $val;
 312     };
 313     my $child_tags = @tags;
 314     $end_tag && !$child_tags
 315         ? $xml->emptyTag( [ $Namespace => $tag ], @attr )
 316         : $xml->startTag( [ $Namespace => $tag ], @attr );
 317     while ( my ($name,$val) = splice @tags,0,2 ) {
 318         $xml->dataElement( [ $Namespace => $name ], $val );
 319     }
 320     $xml->endTag( [ $Namespace => $tag ] ) if $child_tags && $end_tag;
 321 }
 322
 323 1;
 324
 325 # -------------------------------------------------------------------
 326 # The eyes of fire, the nostrils of air,
 327 # The mouth of water, the beard of earth.
 328 # William Blake
 329 # -------------------------------------------------------------------
 330
 331 =pod
 332
 333 =head1 AUTHORS
 334
 335 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>,
 336 Darren Chamberlain E<lt>darren@cpan.orgE<gt>,
 337 Mark Addison E<lt>mark.addison@itn.co.ukE<gt>.
 338
 339 =head1 SEE ALSO
 340
 341 perl(1), SQL::Translator, SQL::Translator::Parser::XML::SQLFairy,
 342 SQL::Translator::Schema, XML::Writer.
 343
 344 =cut