FabForce::DBDesigner4::DBIC - create DBIC scheme for DBDesigner4 xml file

    use FabForce::DBDesigner4::DBIC;

    my $foo = FabForce::DBDesigner4::DBIC->new();
    $foo->output_path( $some_path );
    $foo->namespace( 'MyApp::DB' );
    $foo->create_schema( $xml_document );

  my $foo = FabForce::DBDesigner4::DBIC->new(
    output_path => '/path/to/dir',
    input_file  => '/path/to/dbdesigner.file',
    namespace   => 'MyApp::Database',
    schema_name => 'MySchema',
  );

  $foo->output_path( '/any/directory' );
  print $foo->output_path;

  $foo->input_file( 'dbdesigner.xml' );
  print $foo->input_file;

  $foo->input_file( 'dbdesigner.xml' );
  $foo->create_schema;

  # or

  $foo->create_schema( 'dbdesigner.xml' );

  DBIC_Scheme Database DBIC MyScheme MyDatabase DBIxClass_Scheme

  $dbic->schema_name( 'MyNewSchema' );

  $foo->namespace( 'MyApp::DB' );

  $foo->prefix( 'belongs_to' => 'fk_' );
  $foo->prefix( 'has_many' => 'has_' );

  __PACKAGE__->belongs_to( 'fk_col1' => 'OtherTable', {'foreign.col1' => 'self.col1' } );

    perldoc FabForce::DBDesigner4::DBIC

package FabForce::DBDesigner4::DBIC;

use warnings;
use strict;
use Carp;
use File::Spec;
use FabForce::DBDesigner4;

our $VERSION = '0.0802';

sub new {
    my ($class,%args) = @_;
    
    my $self = {};
    bless $self, $class;
    
    $self->output_path( $args{output_path} );
    $self->input_file( $args{input_file} );
    $self->namespace( $args{namespace} );
    $self->schema_name( $args{schema_name} );
    
    $self->prefix( 
        'belongs_to'   => '',
        'has_many'     => '',
        'has_one'      => '',
        'many_to_many' => '',
    );
    
    
    return $self;
}

sub output_path {
    my ($self,$path) = @_;
    
    $self->{output_path} = $path if defined $path;
    return $self->{output_path};
}

sub input_file{
    my ($self,$file) = @_;
    
    $self->{_input_file} = $file if defined $file;
    return $self->{_input_file};
}

sub create_schema{
    my ($self, $inputfile) = @_;
    
    $inputfile ||= $self->input_file;
    
    croak "no input file defined" unless defined $inputfile;
    
    my $output_path = $self->output_path || '.';
    my $namespace   = $self->namespace;
    
    my $fabforce    = $self->dbdesigner;
       $fabforce->parsefile( xml => $inputfile );
    my @tables      = $fabforce->getTables;
    
    
    my @files;
    my %relations;
    
    for my $table ( @tables ){
        my $name = $table->name;
        $self->_add_class( $name );
        my $rels = $table->get_foreign_keys;
        for my $to_table ( keys %$rels ){
            $relations{$to_table}->{to}->{$name}   = $rels->{$to_table};
            $relations{$name}->{from}->{$to_table} = $rels->{$to_table};
        }
    }
    
    my @scheme = $self->_main_template;
    
    for my $table ( @tables ){
        push @files, $self->_class_template( $table, $relations{$table->name} );
    }
    
    push @files, @scheme;
    
    $self->_write_files( @files );
}

sub create_scheme {
    &create_schema;
}

sub schema_name {
    my ($self,$name) = @_;
    
    if( @_ == 2 ){
        $name =~ s![^A-Za-z0-9_]!!g if defined $name;
        $self->_schema( $name );
    }
}

sub namespace{
    my ($self,$namespace) = @_;
    
    $self->{namespace} = '' unless defined $self->{namespace};
    
    #print "yes: $namespace\n" if defined $namespace and $namespace =~ /^[A-Z]\w*(::\w+)*$/;
    
    if( defined $namespace and $namespace !~ /^[A-Z]\w*(::\w+)*$/  ){
        croak "no valid namespace given";
    }
    elsif( defined $namespace ){
        $self->{namespace} = $namespace;
    }

    return $self->{namespace};
}

sub prefix{
    if( @_ == 2 ){
        my ($self,$key) = @_;
        return $self->{prefixes}->{$key};
    }

    if( @_ > 1 and @_ % 2 != 0 ){
        my ($self,%prefixes) = @_;
        while( my ($key,$val) = each %prefixes ){
            $self->{prefixes}->{$key} = $val;
        }
    }
}

sub dbdesigner {
    my ($self) = @_;
    
    unless( $self->{_dbdesigner} ){
        $self->{_dbdesigner} = FabForce::DBDesigner4->new;
    }
    
    $self->{_dbdesigner};
}

sub _write_files{
    my ($self, %files) = @_;
    
    for my $package ( keys %files ){
        my @path;
        push @path, $self->output_path if $self->output_path;
        push @path, split /::/, $package;
        my $file = pop @path;
        my $dir  = File::Spec->catdir( @path );
        
        $dir = $self->_untaint_path( $dir );
        
        unless( -e $dir ){
            $self->_mkpath( $dir );
        }

        if( open my $fh, '>', $dir . '/' . $file . '.pm' ){
            print $fh $files{$package};
            close $fh;
        }
        else{
            croak "Couldn't create $file.pm";
        }
    }
}

sub _untaint_path{
    my ($self,$path) = @_;
    ($path) = ( $path =~ /(.*)/ );
    # win32 uses ';' for a path separator, assume others use ':'
    my $sep = ($^O =~ /win32/i) ? ';' : ':';
    # -T disallows relative directories in the PATH
    $path = join $sep, grep !/^\./, split /$sep/, $path;
    return $path;
}

sub _mkpath{
    my ($self, $path) = @_;
    
    my @parts = split /[\\\/]/, $path;
    
    for my $i ( 0..$#parts ){
        my $dir = File::Spec->catdir( @parts[ 0..$i ] );
        $dir = $self->_untaint_path( $dir );
        mkdir $dir unless -e $dir;
    }
}

sub _add_class{
    my ($self,$class) = @_;
    
    push @{ $self->{_classes} }, $class if defined $class;
}

sub _get_classes{
    my ($self) = @_;
    
    return @{ $self->{_classes} };
}

sub _schema{
    my ($self,$name) = @_;
    
    $self->{_scheme} = $name if defined $name;
    return $self->{_scheme};
}

sub _has_many_template{
    my ($self, $to, $arrayref) = @_;
    
    my $package = $self->namespace . '::' . $self->_schema . '::Result::' . $to;
       $package =~ s/^:://;
    my $name    = (split /::/, $package)[-1];
    
    my $string = '';
    for my $arref ( @$arrayref ){
        my ($foreign_field,$field) = @$arref;
        my $temp = $self->prefix( 'has_many' ) . $name;
    
        $string .= qq~
__PACKAGE__->has_many( $temp => '$package',
                          { 'foreign.$foreign_field' => 'self.$field' });
~;
    }

    return $string;
}

sub _belongs_to_template{
    my ($self, $from, $arrayref) = @_;
    
    my $package = $self->namespace . '::' . $self->_schema . '::Result::' . $from;
       $package =~ s/^:://;
    my $name    = (split /::/, $package)[-1];
    
    my $string = '';
    for my $arref ( @$arrayref ){
        my ($field,$foreign_field) = @$arref;
        my $temp_field = $self->prefix( 'belongs_to' ) . $name;
    
        $string .= qq~
__PACKAGE__->belongs_to($temp_field => '$package',
                          { 'foreign.$foreign_field' => 'self.$field' });
~;
    }

    return $string;
}

sub _class_template{
    my ($self,$table,$relations) = @_;
    
    my $name    = $table->name;
    my $package = $self->namespace . '::' . $self->_schema . '::Result::' . $name;
       $package =~ s/^:://;
    
    my ($has_many, $belongs_to) = ('','');
    
    for my $to_table ( keys %{ $relations->{to} } ){
        $has_many .= $self->_has_many_template( $to_table, $relations->{to}->{$to_table} );
    }

    for my $from_table ( keys %{ $relations->{from} } ){
        $belongs_to .= $self->_belongs_to_template( $from_table, $relations->{from}->{$from_table} );
    }
    
    my @columns = $table->column_names;
    my $column_string = join "\n", map{ "    " . $_ }@columns;
    
    my $primary_key   = join " ", $table->key;
    
    my $template = qq~package $package;
        
use strict;
use warnings;
use base qw(DBIx::Class);

__PACKAGE__->load_components( qw/PK::Auto Core/ );
__PACKAGE__->table( '$name' );
__PACKAGE__->add_columns( qw/
$column_string
/);
__PACKAGE__->set_primary_key( qw/ $primary_key / );

$has_many
$belongs_to

1;~;

    return $package, $template;
}

sub _main_template{
    my ($self) = @_;
    
    my @class_names  = $self->_get_classes;
    my $classes      = join "\n", map{ "    " . $_ }@class_names;
    
    my $schema_name  = $self->_schema;
    my @schema_names = qw(DBIC_Schema Database DBIC MySchema MyDatabase DBIxClass_Schema);
    
    for my $schema ( @schema_names ){
        last if $schema_name;
        unless( grep{ $_ eq $schema }@class_names ){
            $schema_name = $schema;
            last;
        }
    }

    croak "couldn't determine a package name for the schema" unless $schema_name;
    
    $self->_schema( $schema_name );
    
    my $namespace  = $self->namespace . '::' . $schema_name;
       $namespace  =~ s/^:://;
       
    my $template = qq~package $namespace;

use base qw/DBIx::Class::Schema/;

__PACKAGE__->load_namespaces;

1;~;

    return $namespace, $template;
}

1; # End of FabForce::DBDesigner4::DBIC