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

   1 package SQL::Translator::Producer::XML::SQLFairy;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: SQLFairy.pm,v 1.11 2004-03-04 14:39:46 dlc 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 ARGS
  47
  48 Takes the following extra producer args.
  49
  50 =over 4
  51
  52 =item * emit_empty_tags
  53
  54 Default is false, set to true to emit <foo></foo> style tags for undef values
  55 in the schema.
  56
  57 =item * attrib_values
  58
  59 Set true to use attributes for values of the schema objects instead of tags.
  60
  61  <!-- attrib_values => 0 -->
  62  <table>
  63    <name>foo</name>
  64    <order>1</order>
  65  </table>
  66
  67  <!-- attrib_values => 1 -->
  68  <table name="foo" order="1">
  69  </table>
  70
  71 =back
  72
  73 =head1 DESCRIPTION
  74
  75 Creates XML output of a schema.
  76
  77 =cut
  78
  79 use strict;
  80 use vars qw[ $VERSION @EXPORT_OK ];
  81 $VERSION = sprintf "%d.%02d", q$Revision: 1.11 $ =~ /(\d+)\.(\d+)/;
  82
  83 use Exporter;
  84 use base qw(Exporter);
  85 @EXPORT_OK = qw(produce);
  86
  87 use IO::Scalar;
  88 use SQL::Translator::Utils qw(header_comment debug);
  89 BEGIN {
  90     # Will someone fix XML::Writer already?
  91     local $^W = 0;
  92     require XML::Writer;
  93     import XML::Writer;
  94 }
  95
  96 my $Namespace = 'http://sqlfairy.sourceforge.net/sqlfairy.xml';
  97 my $Name      = 'sqlt';
  98 my $PArgs     = {};
  99
 100 sub produce {
 101     my $translator  = shift;
 102     my $schema      = $translator->schema;
 103     $PArgs          = $translator->producer_args;
 104     my $io          = IO::Scalar->new;
 105     my $xml         = XML::Writer->new(
 106         OUTPUT      => $io,
 107         NAMESPACES  => 1,
 108         PREFIX_MAP  => { $Namespace => $Name },
 109         DATA_MODE   => 1,
 110         DATA_INDENT => 2,
 111     );
 112
 113     $xml->xmlDecl('UTF-8');
 114     $xml->comment(header_comment('', ''));
 115     #$xml->startTag([ $Namespace => 'schema' ]);
 116     xml_obj($xml, $schema,
 117         tag => "schema", methods => [qw/name database/], end_tag => 0 );
 118
 119     #
 120     # Table
 121     #
 122     for my $table ( $schema->get_tables ) {
 123         debug "Table:",$table->name;
 124         xml_obj($xml, $table,
 125              tag => "table", methods => [qw/name order/], end_tag => 0 );
 126
 127         #
 128         # Fields
 129         #
 130         $xml->startTag( [ $Namespace => 'fields' ] );
 131         for my $field ( $table->get_fields ) {
 132             debug "    Field:",$field->name;
 133             xml_obj($xml, $field,
 134                 tag     =>"field",
 135                 end_tag => 1,
 136                 methods =>[qw/name data_type size is_nullable default_value
 137                     is_auto_increment is_primary_key is_foreign_key comments order
 138                 /],
 139             );
 140         }
 141         $xml->endTag( [ $Namespace => 'fields' ] );
 142
 143         #
 144         # Indices
 145         #
 146         $xml->startTag( [ $Namespace => 'indices' ] );
 147         for my $index ( $table->get_indices ) {
 148             debug "Index:",$index->name;
 149             xml_obj($xml, $index,
 150                 tag     => "index",
 151                 end_tag => 1,
 152                 methods =>[qw/ name type fields options/],
 153             );
 154         }
 155         $xml->endTag( [ $Namespace => 'indices' ] );
 156
 157         #
 158         # Constraints
 159         #
 160         $xml->startTag( [ $Namespace => 'constraints' ] );
 161         for my $index ( $table->get_constraints ) {
 162             debug "Constraint:",$index->name;
 163             xml_obj($xml, $index,
 164                 tag     => "constraint",
 165                 end_tag => 1,
 166                 methods =>[qw/
 167                     name type fields reference_table reference_fields
 168                     on_delete on_update match_type expression options deferrable
 169                     /],
 170             );
 171         }
 172         $xml->endTag( [ $Namespace => 'constraints' ] );
 173
 174         $xml->endTag( [ $Namespace => 'table' ] );
 175     }
 176
 177     #
 178     # Views
 179     #
 180     for my $foo ( $schema->get_views ) {
 181         xml_obj($xml, $foo, tag => "view",
 182         methods => [qw/name sql fields order/], end_tag => 1 );
 183     }
 184
 185     #
 186     # Tiggers
 187     #
 188     for my $foo ( $schema->get_triggers ) {
 189         xml_obj($xml, $foo, tag => "trigger",
 190         methods => [qw/name database_event action on_table perform_action_when
 191         fields order/], end_tag => 1 );
 192     }
 193
 194     #
 195     # Procedures
 196     #
 197     for my $foo ( $schema->get_procedures ) {
 198         xml_obj($xml, $foo, tag => "procedure",
 199         methods => [qw/name sql parameters owner comments order/], end_tag=>1 );
 200     }
 201
 202     $xml->endTag([ $Namespace => 'schema' ]);
 203     $xml->end;
 204
 205     return $io;
 206 }
 207
 208 # -------------------------------------------------------------------
 209 #
 210 # TODO
 211 # - Doc this sub
 212 # - Should the Namespace be passed in instead of global? Pass in the same
 213 #   as Writer ie [ NS => TAGNAME ]
 214 #
 215 sub xml_obj {
 216     my ($xml, $obj, %args) = @_;
 217     my $tag                = $args{'tag'}              || '';
 218     my $end_tag            = $args{'end_tag'}          || '';
 219     my $attrib_values      = $PArgs->{'attrib_values'} || '';
 220     my @meths              = @{ $args{'methods'} };
 221     my $empty_tag          = 0;
 222
 223     if ( $attrib_values and $end_tag ) {
 224         $empty_tag = 1;
 225         $end_tag   = 0;
 226     }
 227
 228     if ( $attrib_values ) {
 229         # Use array to ensure consistant (ie not hash) ordering of attribs
 230         # The order comes from the meths list passes in.
 231         my @attr = map {
 232             my $val = $obj->$_;
 233             ($_ => ref($val) eq 'ARRAY' ? join(', ', @$val) : $val);
 234         } grep { defined $obj->$_ } @meths;
 235         $empty_tag ? $xml->emptyTag( [ $Namespace => $tag ], @attr )
 236                    : $xml->startTag( [ $Namespace => $tag ], @attr );
 237     }
 238     else {
 239         $xml->startTag( [ $Namespace => $tag ] );
 240         xml_objAttr( $xml, $obj, @meths );
 241     }
 242
 243     $xml->endTag( [ $Namespace => $tag ] ) if $end_tag;
 244 }
 245
 246 # -------------------------------------------------------------------
 247 # Takes an XML writer, a Schema::* object and a list of methods and
 248 # adds the XML for those methods.
 249 #
 250 sub xml_objAttr {
 251     my ($xml, $obj, @methods) = @_;
 252     my $emit_empty            = $PArgs->{'emit_empty_tags'};
 253
 254     for my $method ( @methods ) {
 255         my $val = $obj->$method;
 256         debug "        ".ref($obj)."->$method=",
 257               (defined $val ? "'$val'" : "<UNDEF>");
 258         next unless $emit_empty || defined $val;
 259         $val = '' if not defined $val;
 260         $val = ref $val eq 'ARRAY' ? join(',', @$val) : $val;
 261         debug "        Adding Attr:".$method."='",$val,"'";
 262         $xml->dataElement( [ $Namespace => $method ], $val );
 263     }
 264 }
 265
 266 1;
 267
 268 # -------------------------------------------------------------------
 269 # The eyes of fire, the nostrils of air,
 270 # The mouth of water, the beard of earth.
 271 # William Blake
 272 # -------------------------------------------------------------------
 273
 274 =pod
 275
 276 =head1 AUTHORS
 277
 278 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>,
 279 Darren Chamberlain E<lt>darren@cpan.orgE<gt>,
 280 Mark Addison E<lt>mark.addison@itn.co.ukE<gt>.
 281
 282 =head1 SEE ALSO
 283
 284 perl(1), SQL::Translator, SQL::Translator::Parser::XML::SQLFairy,
 285 SQL::Translator::Schema, XML::Writer.
 286
 287 =cut