#!/usr/bin/env perl
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"
;
my
$dbh
= DBI->
connect
(
$dsn
,
$user
,
$pass
, +{
RaiseError
=> 1 })
or
die
$DBI::errstr
;
my
$a
=
$dbh
->selectcol_arrayref(
"show tables from $db_name"
);
unless
(
@table_names
){
@table_names
=
sort
@$a
if
$a
;
}
my
%all_tables
;
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
$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"
;
while
(
my
(
$ft
,
$h
) =
each
%all_tables
){
next
if
$ft
eq
$t
;
for
my
$fk
(
values
%$h
){
next
unless
$fk
=~ m/^ ([\w_]+?) _? (U?ID) $/ix;
my
(
$gt
,
$gk
) = ($1, $2);
if
(
$gt
eq
$t
&&
@pkcols
== 1 &&
$pkcols
[0] eq
$gk
){
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