#!/usr/bin/env perl
# vim:set ft=perl ai si et ts=4 sts=4 sw=4 tw=0:
use strict;
use DBI;
my($host,$port,$user,$pass) = ('localhost',3306,'','');
my ($do_has_a, $do_has_many, $do_split, $do_modules, $split_dir, $module_prefix, $do_pod);
GetOptions('host|h=s'=> \$host,
'port|P=i'=> \$port,
'user|u=s'=> \$user,
'pass|p=s'=> \$pass,
'has-a|has_a' => \$do_has_a,
'has-many|has_many' => \$do_has_many,
'all|a' => sub {$do_has_a = $do_has_many = 1 },
'gen-modules' => \$do_modules,
'module-prefix=s' => \$module_prefix,
'split-dir=s' => \$split_dir,
'pod' => \$do_pod,
) && @ARGV or print(<<ENDUSAGE) and exit;
Usage: $0 [OPTIONS] database [table,...]
Generates DBO perl code for the given database and tables to stdout.
If no tables are specified, then code for all tables is generated.
OPTIONS
-h,--host HOST Connect to HOST running server (default: localhost)
-P,--port PORT Connect to PORT on HOST (default: 3306)
-u,--user USER Connect as USER (default: '')
-p,--pass PASSWORD Authenticate with PASSWORD(default: '')
--has-a Generate `has_a' relationships.
--has-many Generate `has_many' relationships.
-a,--all Generate all relationships.
--gen-modules Generate a complete Perl module for each table.
--pod Generate POD.
--module-prefix NAME Prefix module names with `NAME::'.
--split-dir DIR Split modules into files in DIR. Implies --gen-modules
EXAMPLES
# get the minimal code snippet:
dbo-gen -u john -p xxx db tablename
# all modules in one file:
dbo-gen -u john -p xxx --all --gen-modules db > DBClasses.pm
# build a directory of modules:
dbo-gen -u john -p xxx --all --pod --gen-modules --split-dir=libdir/ --module-prefix="DB" db
ENDUSAGE
my $OUT = \*STDOUT;
if (defined $split_dir){
if (!-d $split_dir || ! -w $split_dir){
die "Error: Bad directory given `$split_dir' -- $!\n";
}
$do_modules = $do_split = 1;
}
($module_prefix ||= '') =~ s/::$//;
$module_prefix .= '::' if length $module_prefix;
my ($db_name, @table_names) = @ARGV;
my $dsn = "dbi:mysql:database=$db_name;host=$host;port=$port";
## CONNECT
my $dbh = DBI->connect($dsn, $user, $pass, +{ RaiseError => 1 })
or die $DBI::errstr;
## Get a list of ALL tables
my $a = $dbh->selectcol_arrayref("show tables from $db_name");
unless (@table_names){
@table_names = sort @$a if $a;
}
my %all_tables; ## ($tname => +{ $key_field => $key_field } )
if (@$a){
for my $t (@$a){
$all_tables{$t} = +{};
for (@{$dbh->selectall_arrayref("show columns from $t")}){
my ($field,$type,$null,$key,$default,$extra) = @$_;
$all_tables{$t}->{$field} = $field if $key =~ m/^MUL/i;
}
}
}
sub Cname { "$module_prefix$_[0]" }
my $fmt = '%-28s %s';
for my $t (@table_names){
my $mname = Cname($t);
if ($do_split){
my $path = "$split_dir/$t.pm";
$OUT = new IO::File "> $path" || die "Error: Could not write to file `$path' -- $!\n";
}
if ($do_modules){
my $podsnip = $do_pod ? "\n=head1 NAME\n\n$mname - object access to $t table via DBO\n\n=cut\n\n":'';
print $OUT "package $mname;\n"
.$podsnip
."use strict;\n"
."use warnings;\n"
."use base qw(DBO::Base);\n";
}
print $OUT "##-# Auto-generated by `dbo-gen' (See the DBO manual.).\n";
printf $OUT $fmt, "__PACKAGE__->def_data_source", "('$db_name', '$t');\n";
my @acols;
my @pkcols;
my @kcols;
my @hacols;
my @hmcols;
for (@{$dbh->selectall_arrayref("show columns from $t")}){
my ($field,$type,$null,$key,$default,$extra) = @$_;
my %h;
$h{'auto_increment'} = 1 if $extra =~ m/auto_increment/i;
printf $OUT $fmt, "__PACKAGE__->def_column", "('$field'";
if (scalar keys %h){
print $OUT ", {", join(',', map {"$_ => $h{$_}"} keys %h), "}";
}
print $OUT ");\n";
push @acols, $field;
push @pkcols, $field if $key =~ m/^PRI/i;
push @kcols, $field if $key =~ m/^MUL/i;
}
warn "table $t has no primary key!" unless @pkcols;
printf $OUT $fmt, "__PACKAGE__->def_primary_key","('@pkcols');\n" if @pkcols == 1;
printf $OUT $fmt, "__PACKAGE__->def_primary_key","([qw(@{[ join ' ', @pkcols ]})]);\n" if @pkcols > 1;
for my $f (@kcols){
printf $OUT $fmt, "__PACKAGE__->def_key", "('$f');\n";
}
if ($do_has_a){
print $OUT "\n";
for my $f (@kcols){
next unless $f =~ m/^ ([\w_]+?) _? (U?ID) $/ix;
my ($ft, $fk) = ($1, $2);
##my $fpkg = $ft; ## replace _ with :: to create package names
##$fpkg =~ s/_/::/g;
my $kn = $ft;
$kn =~ s/([a-z])([A-Z])/$1\_$2/g;
$kn = lc $kn;
push @hacols, [$kn, $f, $ft];
printf $OUT $fmt, "__PACKAGE__->def_has_a", qq/('$kn', '$f', '$ft', '$fk');\n/;
}
}
if ($do_has_many){
print $OUT "\n";
## Attempt to find incoming foreign keys for has_many relationship.
while (my ($ft, $h) = each %all_tables){
next if $ft eq $t; ## same table
for my $fk (values %$h){
next unless $fk =~ m/^ ([\w_]+?) _? (U?ID) $/ix;
my ($gt, $gk) = ($1, $2); ## guess table, guess key
if ($gt eq $t && @pkcols == 1 && $pkcols[0] eq $gk){
## make a nice name
my $fk_n = $ft;
$fk_n =~ s/([a-z])([A-Z])/$1\_$2/g;
$fk_n = (lc $fk_n) . 's';
push @hmcols, [$fk_n, $ft];
printf $OUT $fmt, "__PACKAGE__->def_has_many", qq/('$fk_n', '$ft', '@{[ $pkcols[0] ]}', '$fk');\n/;
}
}
}
}
print $OUT "##-# End auto-generated DBO code.\n";
if ($do_modules && $do_pod){
print $OUT "\n\n# Called by new().\n"
."sub init {\n"
." my (\$self, \@args) = \@_;\n"
." # init code goes here\n"
."}\n";
}
print $OUT "\n1;\n__END__\n" if $do_modules;
if ($do_pod){
my $somecol = !@acols
? 'foo'
: @acols >=2
? $acols[1]
: $acols[0];
print $OUT "\n=head1 SYNOPSIS\n\n"
." \$obj = new $mname();\n"
." \$obj->insert;\n\n"
." \$obj = new $mname(\$pk_value);\n\n"
." \$obj->update;\n"
." \$obj->delete;\n\n"
." \$all_objs = $mname->selectall_arrayref;\n"
." \$some_objs = $mname->select->where(+{ $somecol => '?'}, 'bar')->selectall_arrayref;\n\n";
print $OUT "=head1 DESCRIPTION\n\n"
."C<$mname> provides object-oriented access to the $t table via DBO.\n"
."It extends L<DBO::Base> with an accessor method for each column in the $t table,\n"
."and methods to get other DBO-based objects via foreign keys.\n\n";
print $OUT "=head1 CONSTRUCTORS\n\n"
."=over\n\n"
."=item new ()\n\n"
."Creates a new C<$mname> object. The object is not bound (not in the database).\n"
."In order to bind it, simply C<insert> it. You must first set the primary key\n"
."value unless the column is automatically generated (e.g., auto_increment).\n\n"
."=item new (PK_VALUE)\n\n"
."Creates a new C<$mname> object that is bound by the primary key given by PK_VALUE.\n"
."Remember to call C<update> to store any changes you make to the object.\n\n"
."=back\n\n";
print $OUT "=head1 ACCESSOR METHODS\n\n"
."The following methods are get/set accessors. With no arguments, you get the column value\n"
."(possibly triggering a database select). With an argument, you set the\n"
."value (but no database action is taken).\n\n"
. (join "\n", map {" $_"} @acols)
."\n\n";
if (@hacols || @hmcols){
print $OUT "=over\n\n";
for (@hacols){
my ($kn, $f, $ft) = @$_;
print $OUT "=item $kn\n\n"
."Returns a L<@{[Cname($ft)]}> object, or undef if `$f' was NULL.\n\n";
}
for (@hmcols){
my ($kn, $ft) = @$_;
print $OUT "=item $kn\n\n"
."Returns an arrayref of L<@{[Cname($ft)]}> objects, possibly empty.\n"
."The array is cached. Calling \$obj->$kn(undef) will clear the cache.\n\n";
}
print $OUT "=back\n\n";
}
print $OUT "=head1 SEE ALSO\n\n"
.(join ",\n", map {"L<$_>"} ("DBO", map{Cname($_)} (map{$_->[2]} @hacols), (map{$_->[1]} @hmcols)))
."\n\n";
}
$OUT->close() if $do_split;
}
1
__END__