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

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