lib/SQL/Translator/Producer/YAML.pm

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