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

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