lib/SQL/Translator/Producer/YAML.pm

   1 package SQL::Translator::Producer::YAML;
   2
   3 # -------------------------------------------------------------------
   4 # Copyright (C) 2002-2009 SQLFairy Authors
   5 #
   6 # This program is free software; you can redistribute it and/or
   7 # modify it under the terms of the GNU General Public License as
   8 # published by the Free Software Foundation; version 2.
   9 #
  10 # This program is distributed in the hope that it will be useful, but
  11 # WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 # General Public License for more details.
  14 #
  15 # You should have received a copy of the GNU General Public License
  16 # along with this program; if not, write to the Free Software
  17 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
  18 # 02111-1307  USA
  19 # -------------------------------------------------------------------
  20
  21 =head1 NAME
  22
  23 SQL::Translator::Producer::YAML - A YAML producer for SQL::Translator
  24
  25 =head1 SYNOPSIS
  26
  27   use SQL::Translator;
  28
  29   my $translator = SQL::Translator->new(producer => 'YAML');
  30
  31 =head1 DESCRIPTION
  32
  33 This module uses YAML to serialize a schema to a string so that it
  34 can be saved to disk.  Serializing a schema and then calling producers
  35 on the stored can realize significant performance gains when parsing
  36 takes a long time.
  37
  38 =cut
  39
  40 use strict;
  41 use vars qw($VERSION);
  42 $VERSION = '1.59';
  43
  44 use YAML qw(Dump);
  45
  46 sub produce {
  47     my $translator = shift;
  48     my $schema     = $translator->schema;
  49
  50     return Dump({
  51         schema => {
  52             tables => {
  53                 map { ($_->name => view_table($_)) }
  54                     $schema->get_tables,
  55             },
  56             views => {
  57                 map { ($_->name => view_view($_)) }
  58                     $schema->get_views,
  59             },
  60             triggers => {
  61                 map { ($_->name => view_trigger($_)) }
  62                     $schema->get_triggers,
  63             },
  64             procedures => {
  65                 map { ($_->name => view_procedure($_)) }
  66                     $schema->get_procedures,
  67             },
  68         },
  69         translator => {
  70             add_drop_table => $translator->add_drop_table,
  71             filename       => $translator->filename,
  72             no_comments    => $translator->no_comments,
  73             parser_args    => $translator->parser_args,
  74             producer_args  => $translator->producer_args,
  75             parser_type    => $translator->parser_type,
  76             producer_type  => $translator->producer_type,
  77             show_warnings  => $translator->show_warnings,
  78             trace          => $translator->trace,
  79             version        => $translator->version,
  80         },
  81         keys %{$schema->extra} ? ('extra' => { $schema->extra } ) : (),
  82     });
  83 }
  84
  85 sub view_table {
  86     my $table = shift;
  87
  88     return {
  89         'name'        => $table->name,
  90         'order'       => $table->order,
  91         'options'     => $table->options  || [],
  92         $table->comments ? ('comments'    => $table->comments ) : (),
  93         'constraints' => [
  94             map { view_constraint($_) } $table->get_constraints
  95         ],
  96         'indices'     => [
  97             map { view_index($_) } $table->get_indices
  98         ],
  99         'fields'      => {
 100             map { ($_->name => view_field($_)) }
 101                 $table->get_fields
 102         },
 103         keys %{$table->extra} ? ('extra' => { $table->extra } ) : (),
 104     };
 105 }
 106
 107 sub view_constraint {
 108     my $constraint = shift;
 109
 110     return {
 111         'deferrable'       => scalar $constraint->deferrable,
 112         'expression'       => scalar $constraint->expression,
 113         'fields'           => [ map { ref $_ ? $_->name : $_ } $constraint->field_names ],
 114         'match_type'       => scalar $constraint->match_type,
 115         'name'             => scalar $constraint->name,
 116         'options'          => scalar $constraint->options,
 117         'on_delete'        => scalar $constraint->on_delete,
 118         'on_update'        => scalar $constraint->on_update,
 119         'reference_fields' => [ map { ref $_ ? $_->name : $_ } $constraint->reference_fields ],
 120         'reference_table'  => scalar $constraint->reference_table,
 121         'type'             => scalar $constraint->type,
 122         keys %{$constraint->extra} ? ('extra' => { $constraint->extra } ) : (),
 123     };
 124 }
 125
 126 sub view_field {
 127     my $field = shift;
 128
 129     return {
 130         'order'             => scalar $field->order,
 131         'name'              => scalar $field->name,
 132         'data_type'         => scalar $field->data_type,
 133         'size'              => [ $field->size ],
 134         'default_value'     => scalar $field->default_value,
 135         'is_nullable'       => scalar $field->is_nullable,
 136         'is_primary_key'    => scalar $field->is_primary_key,
 137         'is_unique'         => scalar $field->is_unique,
 138         $field->is_auto_increment ? ('is_auto_increment' => 1) : (),
 139         $field->comments ? ('comments' => $field->comments) : (),
 140         keys %{$field->extra} ? ('extra' => { $field->extra } ) : (),
 141     };
 142 }
 143
 144 sub view_procedure {
 145     my $procedure = shift;
 146
 147     return {
 148         'order'      => scalar $procedure->order,
 149         'name'       => scalar $procedure->name,
 150         'sql'        => scalar $procedure->sql,
 151         'parameters' => scalar $procedure->parameters,
 152         'owner'      => scalar $procedure->owner,
 153         'comments'   => scalar $procedure->comments,
 154         keys %{$procedure->extra} ? ('extra' => { $procedure->extra } ) : (),
 155     };
 156 }
 157
 158 sub view_trigger {
 159     my $trigger = shift;
 160
 161     return {
 162         'order'               => scalar $trigger->order,
 163         'name'                => scalar $trigger->name,
 164         'perform_action_when' => scalar $trigger->perform_action_when,
 165         'database_events'     => scalar $trigger->database_events,
 166         'fields'              => scalar $trigger->fields,
 167         'on_table'            => scalar $trigger->on_table,
 168         'action'              => scalar $trigger->action,
 169         keys %{$trigger->extra} ? ('extra' => { $trigger->extra } ) : (),
 170     };
 171 }
 172
 173 sub view_view {
 174     my $view = shift;
 175
 176     return {
 177         'order'  => scalar $view->order,
 178         'name'   => scalar $view->name,
 179         'sql'    => scalar $view->sql,
 180         'fields' => scalar $view->fields,
 181         keys %{$view->extra} ? ('extra' => { $view->extra } ) : (),
 182     };
 183 }
 184
 185 sub view_index {
 186     my $index = shift;
 187
 188     return {
 189         'name'      => scalar $index->name,
 190         'type'      => scalar $index->type,
 191         'fields'    => scalar $index->fields,
 192         'options'   => scalar $index->options,
 193         keys %{$index->extra} ? ('extra' => { $index->extra } ) : (),
 194     };
 195 }
 196
 197 1;
 198
 199 =head1 SEE ALSO
 200
 201 SQL::Translator, YAML, http://www.yaml.org/.
 202
 203 =head1 AUTHORS
 204
 205 darren chamberlain E<lt>darren@cpan.orgE<gt>,
 206 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>.
 207
 208 =cut