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

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