lib/SQL/Translator.pm

   1 use MooseX::Declare;
   2 class SQL::Translator {
   3     use TryCatch;
   4     use MooseX::Types::Moose qw(Bool HashRef Int Str Undef);
   5     use SQL::Translator::Types qw(DBIHandle Parser Producer Schema);
   6     use SQL::Translator::Object::Schema;
   7
   8     our $VERSION = '0.001';
   9
  10     has 'parser' => (
  11         isa => Str,
  12         is => 'rw',
  13         init_arg => 'from',
  14     );
  15
  16     has 'producer' => (
  17         isa => Str,
  18         is => 'rw',
  19         init_arg => 'to',
  20     );
  21
  22     has '_parser' => (
  23         isa => Parser,
  24         is => 'rw',
  25         lazy_build => 1,
  26         handles => [ qw(parse) ],
  27     );
  28
  29     has '_producer' => (
  30         isa => Producer,
  31         is => 'rw',
  32         lazy_build => 1,
  33         handles => [ qw(produce) ],
  34     );
  35
  36     has 'dbh' => (
  37         isa => DBIHandle,
  38         is => 'ro',
  39         predicate => 'has_dbh',
  40     );
  41
  42     has 'schema' => (
  43         isa => Schema,
  44         is => 'rw',
  45         lazy => 1,
  46         default => sub { SQL::Translator::Object::Schema->new },
  47     );
  48
  49     has 'parser_args' => (
  50         isa => HashRef,
  51         is => 'rw',
  52         predicate => 'has_parser_args',
  53     );
  54
  55     has 'producer_args' => (
  56         isa => HashRef,
  57         is => 'rw',
  58         predicate => 'has_producer_args',
  59     );
  60
  61     has 'add_drop_table' => (isa => Bool, is => 'rw', default => 0);
  62     has 'no_comments' => (isa => Bool, is => 'rw', default => 0);
  63     has 'show_warnings' => (isa => Bool, is => 'rw', default => 1);
  64     has 'trace' => (isa => Bool, is => 'rw', default => 0);
  65     has 'quote_table_names' => (isa => Bool, is => 'rw', default => 0);
  66     has 'quote_field_names' => (isa => Bool, is => 'rw', default => 0);
  67     has 'version' => (isa => Str, is => 'rw');
  68     has 'filename' => (isa => Str, is => 'rw');
  69
  70     has '_producer_mapping' => (
  71         isa => HashRef,
  72         is => 'ro',
  73         default => sub { { MySQL => 'SQL::MySQL', SQLite => 'SQL::SQLite', PostgreSQL => 'SQL::PostgreSQL', XML => 'XML', YAML => 'YAML' } }
  74     );
  75
  76     method _build__parser {
  77         my $class = 'SQL::Translator::Parser';
  78
  79         Class::MOP::load_class($class);
  80
  81         my $parser;
  82         if ($self->has_dbh) {
  83             $parser = $class->new({ translator => $self, dbh => $self->dbh });
  84         } else {
  85             $parser = $class->new({ translator => $self, type => $self->parser || '' });
  86         }
  87
  88         return $parser;
  89     }
  90
  91     method _build__producer {
  92         my $mapping = $self->_producer_mapping;
  93
  94         my $class = 'SQL::Translator::Producer';
  95         my $role = $class . '::' . $mapping->{$self->producer};
  96
  97         Class::MOP::load_class($class);
  98         Class::MOP::load_class($role);
  99
 100         my $producer = $class->new({ translator => $self });
 101         $role->meta->apply($producer);
 102
 103         return $producer;
 104     }
 105
 106     method translate(:$data, :$producer?, :$producer_args?, :$parser?, :$parser_args?) {
 107         my $return;
 108
 109         $parser ||= $self->parser;
 110         if (defined $parser) {
 111             $self->_clear_parser;
 112             $self->parser($parser);
 113             $self->parse($data);
 114             $return = $self->schema;
 115         }
 116
 117         $producer ||= $self->producer;
 118         if (defined $producer) {
 119             $self->_clear_producer;
 120             $self->producer($producer);
 121             $return = $self->produce;
 122         }
 123
 124         return $return;
 125     }
 126
 127     method parser_type { return $self->parser }
 128     method producer_type { return $self->producer }
 129
 130     method engine_version(Int|Str|Undef $v, Str $target = 'perl') {
 131         return undef unless $v;
 132
 133         my @vers;
 134
 135         # X.Y.Z style
 136         if ( $v =~ / ^ (\d+) \. (\d{1,3}) (?: \. (\d{1,3}) )? $ /x ) {
 137             push @vers, $1, $2, $3;
 138         }
 139
 140         # XYYZZ (mysql) style
 141         elsif ( $v =~ / ^ (\d) (\d{2}) (\d{2}) $ /x ) {
 142             push @vers, $1, $2, $3;
 143         }
 144
 145         # XX.YYYZZZ (perl) style or simply X
 146         elsif ( $v =~ / ^ (\d+) (?: \. (\d{3}) (\d{3}) )? $ /x ) {
 147             push @vers, $1, $2, $3;
 148         }
 149         else {
 150             #how do I croak sanely here?
 151             die "Unparseable MySQL version '$v'";
 152         }
 153
 154         if ($target eq 'perl') {
 155             return sprintf ('%d.%03d%03d', map { $_ || 0 } (@vers) );
 156         }
 157         elsif ($target eq 'mysql') {
 158             return sprintf ('%d%02d%02d', map { $_ || 0 } (@vers) );
 159         }
 160         else {
 161             #how do I croak sanely here?
 162             die "Unknown version target '$target'";
 163         }
 164     }
 165 }