#!/usr/bin/perl

use DBI;
use Data::Dumper;
#use Lingua::EN::Inflect qw/PL/;

my $basename = 'My::Data';
my $dsn  = 'dbi:mysql:database:127.0.0.1';
my $user = 'user';
my $pass = 'pass';

my $dbh  = DBI -> connect( $dsn, $user, $pass );

my $table_sth = $dbh->table_info('%','','');


print "package $basename;\n\n";
print "use base 'Class::DBI';\n\n";
print "use DateTime;\nuse DateTime::Format::ISO8601;\n\n";
print "$basename->connection('$dsn', '$user', '$pass');\n\n\n\n";


foreach $table ( @{$table_sth->fetchall_arrayref()} ) {
    my ($cat, $schema, $table_name, $type, $remarks) = @{$table};


    $table{$table_name}{camel_name} = "${basename}::".SI(CamelCaps($ta
+ble_name));
    $table{$table_name}{type}       = $type;
    $table{$table_name}{remarks}    = $remarks;

    my $column_sth = $dbh->column_info($cat, $schema, $table_name, '%'
+);

    foreach $column ( sort { $a->[16] <=> $b->[16] } @{$column_sth->fe
+tchall_arrayref } ) {
        my (undef, undef, undef, $col_name, $data_type, $data_type_nam
+e,
            $col_size, $buffer_len, $decimals, undef, $nullable, $rema
+rks,
            $default, $sql_data_type, $sql_data_subtype, $col_char_siz
+e, $order,
            undef, undef, undef,undef,undef,undef,undef,undef,undef,un
+def,undef,
            undef,undef,undef,undef,undef,undef,undef,undef,$max_card,
+$dtd_ident,undef
        ) = @{$column};

        push(@{$table{$table_name}{cols}}, {
            name => $col_name,
            remark => $remark || $dtd_ident,
            type => $dtd_ident,
        });
    }


}

foreach $table (keys %table) {

    print div();
    print "# $table{$table}{remarks}\n" if $table{$table}{remarks};
    print 'package '.$table{$table}{camel_name}.";\n";
    print div();
    print "use base '$basename';\n\n";
    print $table{$table}{camel_name}."->table( '$table' );\n";
    print $table{$table}{camel_name}."->columns(\n\tAll => qw/\n\t\t".
+ join("\n\t\t", map{$_->{name}}@{$table{$table}{cols}}) . "\n\t/)\n);
+\n";
    print "die('You forgot to check the definition for the '$table' ta
+ble. Or you forgot to remove this message!');\n";

    # Check all columns for foreign key looking fields. eg ${tablename
+}_id
    my $has_a = 0;
    foreach my $col ( @{$table{$table}{cols}} ) {
        if ($col->{name}=~/^(.+)_id$/) {
            my $rel_col = $1;
            my $class =
                ($table{$rel_col})     ? $table{$rel_col}{camel_name} 
+    :
                ($table{PL($rel_col)}) ? $table{PL($rel_col)}{camel_na
+me} : '';
            next unless $class;
            print $table{$table}{camel_name}."->has_a( ".$col->{name}.
+" => '$class' );\n";
        } elsif ($col->{type} =~ /int\(1[01]\)/ and $col->{name} =~ /(
+start|end|expir|received|delivered|quarantined)/) {
            print $table{$table}{camel_name}."->has_a(\n";
            print "\t$col->{name} => 'DateTime',\n";
            print "\tinflate => sub { DateTime->from_epoch( shift ) },
+\n";
            print "\tdeflate => 'epoch'\n";
            print ");\n";
        } elsif ($col->{type} =~ /(date|time)/) {
            print $table{$table}{camel_name}."->has_a(\n";
            print "\t$col->{name} => 'DateTime',\n";
            print "\tinflate => sub { DateTime::Format::ISO8601->parse
+_datetime( shift ) },\n";
            print qq|\tdeflate => "strftime('%H:%M:%S')"\n|;
            print ");\n";
        }
        $has_a++;
    }
    print "\n" if $has_a;

    # Check everywhere else for foreign keys to our table
    my $table_singular = SI($table);
    my $has_many = 0;
    foreach my $tbl ( grep {$_ ne $table} keys %table ) {
        foreach my $col ( @{$table{$tbl}{cols}}) {
            #print "Looking for ${table_singular}_id : $col->{name}\n"
+;
            next unless $col->{name} eq "${table_singular}_id";
            print $table{$table}{camel_name}."->has_many( ". CamelCaps
+(PL($tbl)) ." => '$table{$tbl}{camel_name}' );\n";
        }
    }
    print "\n" if $has_many;
    print "\n";

}




sub CamelCaps {
    my $string = shift;
    return join('', map { ucfirst lc $_ } split(/[^a-z]/i,$string));
}

sub div {
    return '#' . ('-' x 71) . "\n";
}

sub SI {
    # Simple singularifier
    my $plural = shift;
    $plural =~ s/ces$/x/i and return $plural;
    $plural =~ s/ies$/y/i and return $plural;
    $plural =~ s/s$//i and return $plural;
    return $plural
}

sub PL {
    # Simple pluralizer
    my $singular = shift;
    $singular =~ s/y$/ies/i and return $singular;
    $singular =~ s/x$/ces/i and return $singular;
    $singular .= 's' unless $singular =~ /s$/;
    return $singular
}

[download]

In reply to Class::DBI Builder by BigLug

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post, it's "PerlMonks-approved HTML":


  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, details, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, summary, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.