lib/SQL/Translator/Producer/SqlfXML.pm

   1 package SQL::Translator::Producer::SqlfXML;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: SqlfXML.pm,v 1.4 2003-08-14 12:03:00 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 #
  10 # This program is free software; you can redistribute it and/or
  11 # modify it under the terms of the GNU General Public License as
  12 # published by the Free Software Foundation; version 2.
  13 #
  14 # This program is distributed in the hope that it will be useful, but
  15 # WITHOUT ANY WARRANTY; without even the implied warranty of
  16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17 # General Public License for more details.
  18 #
  19 # You should have received a copy of the GNU General Public License
  20 # along with this program; if not, write to the Free Software
  21 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
  22 # 02111-1307  USA
  23 # -------------------------------------------------------------------
  24
  25 use strict;
  26 use warnings;
  27 use vars qw[ $VERSION ];
  28 $VERSION = sprintf "%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/;
  29
  30 use Exporter;
  31 use base qw(Exporter);
  32 our @EXPORT_OK = qw(produce);
  33
  34 use IO::Scalar;
  35 use SQL::Translator::Utils qw(header_comment);
  36 use XML::Writer;
  37
  38 my $namespace = 'http://sqlfairy.sourceforge.net/sqlfairy.xml';
  39 my $name = 'sqlt';
  40
  41 {
  42 our ($translator,$PArgs,$schema);
  43
  44 sub debug { $translator->debug(@_,"\n"); } # Shortcut.
  45
  46 sub produce {
  47     $translator = shift;
  48     $PArgs      = $translator->producer_args;
  49     $schema     = $translator->schema;
  50
  51     my $io       = IO::Scalar->new;
  52     my $xml         = XML::Writer->new(
  53         OUTPUT      => $io,
  54         NAMESPACES  => 1,
  55         PREFIX_MAP  => { $namespace => $name },
  56         DATA_MODE   => 1,
  57         DATA_INDENT => 2,
  58     );
  59
  60     $xml->xmlDecl('UTF-8');
  61     $xml->comment(header_comment('', ''));
  62     $xml->startTag([ $namespace => 'schema' ]);
  63
  64     #
  65     # Table
  66     #
  67     for my $table ( $schema->get_tables ) {
  68         debug "Table:",$table->name;
  69                 xml_obj($xml, $table,
  70                         tag => "table", methods => [qw/name order/], end_tag => 0 );
  71
  72         #
  73         # Fields
  74         #
  75         $xml->startTag( [ $namespace => 'fields' ] );
  76         for my $field ( $table->get_fields ) {
  77             debug "    Field:",$field->name;
  78                         xml_obj($xml, $field,
  79                                 tag     =>"field",
  80                                 end_tag => 1,
  81                                 methods =>[qw/name data_type default_value is_auto_increment
  82                      is_primary_key is_nullable is_foreign_key order size
  83                                 /],
  84                         );
  85         }
  86         $xml->endTag( [ $namespace => 'fields' ] );
  87
  88         #
  89         # Indices
  90         #
  91         $xml->startTag( [ $namespace => 'indices' ] );
  92         for my $index ( $table->get_indices ) {
  93             debug "Index:",$index->name;
  94                         xml_obj($xml, $index,
  95                                 tag     => "index",
  96                                 end_tag => 1,
  97                                 methods =>[qw/fields name options type/],
  98                         );
  99         }
 100         $xml->endTag( [ $namespace => 'indices' ] );
 101
 102         #
 103         # Constraints
 104         #
 105         $xml->startTag( [ $namespace => 'constraints' ] );
 106         for my $index ( $table->get_constraints ) {
 107             debug "Constraint:",$index->name;
 108                         xml_obj($xml, $index,
 109                                 tag     => "constraint",
 110                                 end_tag => 1,
 111                                 methods =>[qw/
 112                     deferrable expression fields match_type name
 113                     options on_delete on_update reference_fields
 114                     reference_table type/],
 115                         );
 116         }
 117         $xml->endTag( [ $namespace => 'constraints' ] );
 118
 119         $xml->endTag( [ $namespace => 'table' ] );
 120     }
 121
 122     $xml->endTag([ $namespace => 'schema' ]);
 123     $xml->end;
 124
 125     return $io;
 126 }
 127
 128 sub xml_obj {
 129         my ($xml, $obj, %args) = @_;
 130         my $tag   = $args{tag};
 131         my @meths = @{$args{methods}};
 132         my $attrib_values = $PArgs->{attrib_values};
 133         my $empty_tag = 0;
 134         my $end_tag   = $args{end_tag};
 135         if ( $attrib_values and $end_tag ) {
 136                 $empty_tag = 1;
 137                 $end_tag   = 0;
 138         }
 139
 140         if ( $attrib_values ) {
 141                 my %attr = map {
 142                         my $val = $obj->$_;
 143                         ($_ => ref($val) eq 'ARRAY' ? join(", ",@$val) : $val);
 144                 } @meths;
 145                 foreach (keys %attr) { delete $attr{$_} unless defined $attr{$_}; }
 146                 $empty_tag ? $xml->emptyTag( [ $namespace => $tag ], %attr )
 147                            : $xml->startTag( [ $namespace => $tag ], %attr );
 148         }
 149         else {
 150                 $xml->startTag( [ $namespace => $tag ] );
 151                 xml_objAttr($xml,$obj, @meths);
 152         }
 153         $xml->endTag( [ $namespace => $tag ] ) if $end_tag;
 154
 155 }
 156
 157 # Takes an xml writer, a Schema::* object and a list of methods and adds the
 158 # XML for those methods.
 159 sub xml_objAttr {
 160     my ($xml, $obj, @methods) = @_;
 161     my $emit_empty = $PArgs->{emit_empty_tags};
 162         for my $method (@methods) {
 163         my $val = $obj->$method;
 164         debug "        ".ref($obj)."->$method=",
 165               (defined $val ? "'$val'" : "<UNDEF>");
 166         next unless $emit_empty || defined $val;
 167         $val = "" if not defined $val;
 168         $val = ref $val eq 'ARRAY' ? join(',', @$val) : $val;
 169         debug "        Adding Attr:".$method."='",$val,"'";
 170         $xml->dataElement( [ $namespace => $method ], $val );
 171     }
 172 }
 173
 174 } # End of our scoped bit
 175
 176 1;
 177
 178 # -------------------------------------------------------------------
 179 # The eyes of fire, the nostrils of air,
 180 # The mouth of water, the beard of earth.
 181 # William Blake
 182 # -------------------------------------------------------------------
 183
 184 =head1 NAME
 185
 186 SQL::Translator::Producer::SqlfXML - XML output
 187
 188 =head1 SYNOPSIS
 189
 190   use SQL::Translator;
 191
 192   my $translator = SQL::Translator->new(
 193       show_warnings  => 1,
 194       add_drop_table => 1,
 195   );
 196   print = $obj->translate(
 197       from     => "MySQL",
 198       to       => "SqlfXML",
 199       filename => "fooschema.sql",
 200   );
 201
 202 =head1 ARGS
 203
 204 Takes the following extra producer args.
 205
 206 =item emit_empty_tags
 207
 208 Default is false, set to true to emit <foo></foo> style tags for undef values
 209 in the schema.
 210
 211 =item attrib_values
 212
 213 Set true to use attributes for values of the schema objects instead of tags.
 214
 215  <!-- attrib_values => 0 -->
 216  <table>
 217    <name>foo</name>
 218    <order>1</order>
 219  </table>
 220
 221  <!-- attrib_values => 1 -->
 222  <table name="foo" order="1">
 223  </table>
 224
 225 =head1 DESCRIPTION
 226
 227 Creates XML output of a schema.
 228
 229 =head1 TODO
 230
 231 =head1 AUTHOR
 232
 233 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>,
 234 darren chamberlain E<lt>darren@cpan.orgE<gt>,
 235 mark addison E<lt>mark.addison@itn.co.ukE<gt>,
 236
 237 =head1 SEE ALSO
 238
 239 perl(1), SQL::Translator, SQL::Translator::Parser::SqlfXML,
 240 SQL::Translator::Schema, XML::Writer.