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

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