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

   1 package SQL::Translator::Producer::XML::SQLFairy;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: SQLFairy.pm,v 1.1 2003-08-21 00:45:43 kycl4rk 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::SqlfXML - 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             => 'SqlfXML',
  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.1 $ =~ /(\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
 112     #
 113     # Table
 114     #
 115     for my $table ( $schema->get_tables ) {
 116         debug "Table:",$table->name;
 117                 xml_obj($xml, $table,
 118                         tag => "table", methods => [qw/name order/], end_tag => 0 );
 119
 120         #
 121         # Fields
 122         #
 123         $xml->startTag( [ $Namespace => 'fields' ] );
 124         for my $field ( $table->get_fields ) {
 125             debug "    Field:",$field->name;
 126                         xml_obj($xml, $field,
 127                                 tag     =>"field",
 128                                 end_tag => 1,
 129                                 methods =>[qw/name data_type default_value is_auto_increment
 130                      is_primary_key is_nullable is_foreign_key order size
 131                                 /],
 132                         );
 133         }
 134         $xml->endTag( [ $Namespace => 'fields' ] );
 135
 136         #
 137         # Indices
 138         #
 139         $xml->startTag( [ $Namespace => 'indices' ] );
 140         for my $index ( $table->get_indices ) {
 141             debug "Index:",$index->name;
 142                         xml_obj($xml, $index,
 143                                 tag     => "index",
 144                                 end_tag => 1,
 145                                 methods =>[qw/fields name options type/],
 146                         );
 147         }
 148         $xml->endTag( [ $Namespace => 'indices' ] );
 149
 150         #
 151         # Constraints
 152         #
 153         $xml->startTag( [ $Namespace => 'constraints' ] );
 154         for my $index ( $table->get_constraints ) {
 155             debug "Constraint:",$index->name;
 156                         xml_obj($xml, $index,
 157                                 tag     => "constraint",
 158                                 end_tag => 1,
 159                                 methods =>[qw/
 160                     deferrable expression fields match_type name
 161                     options on_delete on_update reference_fields
 162                     reference_table type/],
 163                         );
 164         }
 165         $xml->endTag( [ $Namespace => 'constraints' ] );
 166
 167         $xml->endTag( [ $Namespace => 'table' ] );
 168     }
 169
 170     $xml->endTag([ $Namespace => 'schema' ]);
 171     $xml->end;
 172
 173     return $io;
 174 }
 175
 176 # -------------------------------------------------------------------
 177 sub xml_obj {
 178         my ($xml, $obj, %args) = @_;
 179         my $tag                = $args{'tag'}              || '';
 180         my $end_tag            = $args{'end_tag'}          || '';
 181         my $attrib_values      = $PArgs->{'attrib_values'} || '';
 182         my @meths              = @{ $args{'methods'} };
 183         my $empty_tag          = 0;
 184
 185         if ( $attrib_values and $end_tag ) {
 186                 $empty_tag = 1;
 187                 $end_tag   = 0;
 188         }
 189
 190         if ( $attrib_values ) {
 191                 my %attr = map {
 192                         my $val = $obj->$_;
 193                         ($_ => ref($val) eq 'ARRAY' ? join(', ', @$val) : $val);
 194                 } @meths;
 195                 foreach ( keys %attr ) { delete $attr{$_} unless defined $attr{$_}; }
 196                 $empty_tag ? $xml->emptyTag( [ $Namespace => $tag ], %attr )
 197                            : $xml->startTag( [ $Namespace => $tag ], %attr );
 198         }
 199         else {
 200                 $xml->startTag( [ $Namespace => $tag ] );
 201                 xml_objAttr( $xml, $obj, @meths );
 202         }
 203
 204         $xml->endTag( [ $Namespace => $tag ] ) if $end_tag;
 205 }
 206
 207 # -------------------------------------------------------------------
 208 # Takes an XML writer, a Schema::* object and a list of methods and
 209 # adds the XML for those methods.
 210 #
 211 sub xml_objAttr {
 212     my ($xml, $obj, @methods) = @_;
 213     my $emit_empty            = $PArgs->{'emit_empty_tags'};
 214
 215         for my $method ( @methods ) {
 216         my $val = $obj->$method;
 217         debug "        ".ref($obj)."->$method=",
 218               (defined $val ? "'$val'" : "<UNDEF>");
 219         next unless $emit_empty || defined $val;
 220         $val = '' if not defined $val;
 221         $val = ref $val eq 'ARRAY' ? join(',', @$val) : $val;
 222         debug "        Adding Attr:".$method."='",$val,"'";
 223         $xml->dataElement( [ $Namespace => $method ], $val );
 224     }
 225 }
 226
 227 1;
 228
 229 # -------------------------------------------------------------------
 230 # The eyes of fire, the nostrils of air,
 231 # The mouth of water, the beard of earth.
 232 # William Blake
 233 # -------------------------------------------------------------------
 234
 235 =pod
 236
 237 =head1 AUTHORS
 238
 239 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>,
 240 Darren Chamberlain E<lt>darren@cpan.orgE<gt>,
 241 Mark Addison E<lt>mark.addison@itn.co.ukE<gt>.
 242
 243 =head1 SEE ALSO
 244
 245 perl(1), SQL::Translator, SQL::Translator::Parser::SqlfXML,
 246 SQL::Translator::Schema, XML::Writer.
 247
 248 =cut