CatalystX::Usul::Schema - Support for database schemas

   package CatalystX::Usul::Model::Schema;

   use parent qw(Catalyst::Model::DBIC::Schema
                 CatalystX::Usul::Model
                 CatalystX::Usul::Schema);

   package YourApp::Model::YourModel;

   use base qw(CatalystX::Usul::Model::Schema);

   __PACKAGE__->config( connect_info => [], schema_class => undef );

   sub new {
      my ($self, $app, @rest) = @_;

      $self->config( connect_info =>
                      $self->connect_info( $app, $rest[0]->{database} ) );
      $self->config( schema_class => $rest[0]->{schema_class} );

      return $self->next::method( $app, @rest );
   }

  <credentials>
    <name>database_we_want_to_connect_to</name>
    <driver>mysql</driver>
    <host>localhost</host>
    <password>encrypt=0QqX325DLs18I8T/wU4/ZQQ=</password>
    <port>3306</port>
    <print_error>0</print_error>
    <raise_error>1</raise_error>
    <user>root</user>
  </credentials>

   my $info_arr = $self->connect_info( $path, $database, $seed );

   my $plain = $self->decrypt( $seed, $encoded );

   my $encrypted = $self->encrypt( $seed, $plain );

# @(#)$Id: Schema.pm 622 2009-06-30 16:26:14Z pjf $

package CatalystX::Usul::Schema;

use strict;
use warnings;
use version; our $VERSION = qv( sprintf '0.3.%d', q$Rev: 622 $ =~ /\d+/gmx );
use parent qw(CatalystX::Usul);

use Crypt::CBC;
use English qw(-no_match_vars);
use MIME::Base64;
use Sys::Hostname;
use XML::Simple;

my $CLEANER = '.*^\s*use\s+Acme::Bleach\s*;\r*\n';
my $KEY     = " \t" x 8;
my $NUL     = q();
my $DATA    = do { local $RS = undef; <DATA> };

__PACKAGE__->mk_accessors( qw(attrs databases) );

sub connect_info {
   my ($self, $path, $db, $seed) = @_; my ($attr, $cfg, $dsn);

   if ($cfg = $self->_read_config( $path )->{ $db }) {
      $dsn  = 'dbi:'.$cfg->{driver}.':database='.$db.';host=';
      $dsn .= $cfg->{host}.';port='.$cfg->{port};
      $attr = { AutoCommit => 1,
                PrintError => $cfg->{print_error} || 0,
                RaiseError => $cfg->{raise_error} || 1 };

      if ($cfg->{password} =~ m{ \A encrypt= (.+) \z }mx) {
         $cfg->{password} = $self->decrypt( $seed, $1 );
      }

      return [ $dsn, $cfg->{user}, $cfg->{password}, $attr ];
   }

   return [ $NUL, $NUL, $NUL, {} ];
}

sub create_ddl {
   my ($self, $dbh, $version, $dir, $unlink) = @_;

   if ($unlink) {
      for my $db (@{ $self->databases }) {
         my $path = $dbh->ddl_filename( $db, $version, $dir );

         unlink $path if (-f $path);
      }
   }

   $dbh->storage->create_ddl_dir( $dbh,
                                  $self->databases,
                                  $version,
                                  $dir,
                                  $self->attrs );
   return 0;
}

sub decrypt {
   my ($self, $seed, $encoded) = @_;

   return unless ($encoded);

   my $cipher = Crypt::CBC->new( -cipher => q(Twofish),
                                 -key    => $self->keygen( $seed ) );

   return $cipher->decrypt( decode_base64( $encoded ) );
}

sub deploy_and_populate {
   my ($self, $dbh, $dir, $schema) = @_;
   my ($cfg, $class, $flds, $hndl, $path, @paths, $re, $res, @rows, $xs);

   $dbh->storage->ensure_connected;
   $dbh->deploy( $self->attrs, $dir );

   $schema =~ s{ :: }{-}gmx;
   $re     = '\A '.$schema.' [-] \d+ [-] (.*) \.xml \z';
   $xs     = XML::Simple->new( ForceArray => [ qw(rows) ] );
   $hndl   = $self->io( $dir );

   while ($path = $hndl->next) {
      push @paths, $path if ($path->filename =~ m{ $re }mx);
   }

   $hndl->close;

   for $path (sort { $a->filename cmp $b->filename } @paths) {
      ($class) = $path->filename =~ m{ $re }mx;
      $self->fatal( 'No class in [_1]', $path->filename ) unless ($class);
      $self->output( "Populating $class" );
      $cfg  = $xs->xml_in( $path->pathname );
      $flds = [ split q( ), $cfg->{fields} ];
      @rows = map { [ map { my $row = $_;
                            $row =~ s{ \A [\'\"] }{}mx;
                            $row =~ s{ [\'\"] \z }{}mx; $row }
                      split m{ , \s* }mx, $_ ] } @{ $cfg->{rows} };
      @{ $res->{ $class } } = $dbh->populate( $class, [ $flds, @rows ] );
   }

   return 0;
}

sub encrypt {
   my ($self, $seed, $plain) = @_;

   return unless ($plain);

   my $cipher = Crypt::CBC->new( -cipher => q(Twofish),
                                 -key    => $self->keygen( $seed ) );

   return encode_base64( $cipher->encrypt( $plain ), $NUL );
}

sub keygen {
   my ($self, $args) = @_;

   $args = { seed => $args || $NUL } unless ($args && ref $args eq q(HASH));

   (my $salt = _inflate( $args->{data} || $DATA )) =~ s{ $CLEANER }{}msx;

   ## no critic
   return substr $self->create_token( ( eval $salt ).$args->{seed} ), 0, 32;
   ## critic
}

# Private methods

sub _inflate {
   local $_ = pop; s{ \A $KEY|[^ \t] }{}gmx; tr{ \t}{01}; return pack 'b*', $_;
}

sub _read_config {
   my ($self, $path) = @_;

   my $xs   = XML::Simple->new();
   my $text = join $NUL,
              grep { !m{ <! .+ > }mx } $self->io( $path )->lock->getlines;
   my $cfg  = $xs->xml_in( $text, ForceArray => [ q(credentials) ] ) || {};

   return $cfg->{credentials} ? $cfg->{credentials} : {};
}

1;

# Local Variables:
# mode: perl
# tab-width: 3
# End:

__DATA__