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

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