use
5.008001;
our
$VERSION
=
"0.07"
;
mysql
=>
'MySQL'
,
odbc
=>
'SQLServer'
,
oracle
=>
'Oracle'
,
pg
=>
'PostgreSQL'
,
sqlite
=>
'SQLite'
,
sybase
=>
'Sybase'
,
pg
=>
'PostgreSQL'
,
db2
=>
'DB2'
,
};
sub
dump
{
my
$class
=
shift
;
my
%args
=
@_
==1 ? %{
$_
[0]} :
@_
;
my
$dbh
=
$args
{dbh} or Carp::croak(
"missing mandatory parameter 'dbh'"
);
my
$inspector
= DBIx::Inspector->new(
dbh
=>
$dbh
);
my
$ret
=
""
;
if
(
ref
$args
{tables} eq
"ARRAY"
) {
for
my
$table_name
(@{
$args
{tables} }) {
$ret
.= _render_table(
$inspector
->table(
$table_name
), \
%args
);
}
}
elsif
(
$args
{tables} ) {
$ret
.= _render_table(
$inspector
->table(
$args
{tables}), \
%args
);
}
else
{
my
$pkg
=
$args
{pkg} or Carp::croak(
"missing mandatory parameter 'pkg'"
);
$ret
.=
"package ${pkg};\n"
;
$ret
.=
"use strict;\n"
;
$ret
.=
"use warnings;\n"
;
$ret
.=
"use DBIx::Schema::DSL;\n"
;
$ret
.=
"\n"
;
my
$db_type
=
$dbh
->{
'Driver'
}{
'Name'
} or
die
'Cannot determine DBI type'
;
my
$driver
= DRIVERS->{
lc
$db_type
} or
warn
"$db_type not supported"
;
$ret
.=
sprintf
(
"database '%s';\n"
,
$driver
)
if
$driver
;
$ret
.=
"default_unsigned;\n"
if
$args
{default_unsigned};
$ret
.=
"default_not_null;\n"
if
$args
{default_not_null};
$ret
.=
"\n"
;
if
(
$args
{table_options}) {
$ret
.=
"add_table_options\n"
;
my
@table_options
;
for
my
$key
(
keys
%{
$args
{table_options}}) {
push
@table_options
=>
sprintf
(
" '%s' => '%s'"
,
$key
,
$args
{table_options}->{
$key
})
}
$ret
.=
join
",\n"
,
@table_options
;
$ret
.=
";\n\n"
;
}
for
my
$table_info
(
sort
{
$a
->name cmp
$b
->name }
$inspector
->tables) {
$ret
.= _render_table(
$table_info
, \
%args
);
}
$ret
.=
"1;\n"
;
}
return
$ret
;
}
sub
_render_table {
my
(
$table_info
,
$args
) =
@_
;
my
$ret
=
""
;
$ret
.=
sprintf
(
"create_table '%s' => columns {\n"
,
$table_info
->name);
for
my
$col
(
$table_info
->columns) {
$ret
.= _render_column(
$col
,
$table_info
,
$args
);
}
$ret
.= _render_index(
$table_info
,
$args
);
$ret
.=
"};\n\n"
;
return
$ret
;
}
sub
_render_column {
my
(
$column_info
,
$table_info
,
$args
) =
@_
;
my
$ret
=
""
;
$ret
.=
sprintf
(
" column '%s'"
,
$column_info
->name);
my
(
$type
,
@opt
) =
split
/ /,
$column_info
->type_name;
if
(
$column_info
->{MYSQL_TYPE_NAME}) {
push
@opt
=>
split
/ /,
$column_info
->{MYSQL_TYPE_NAME};
}
$ret
.=
sprintf
(
", '%s'"
,
$type
);
my
%opt
=
map
{
lc
(
$_
) => 1 }
@opt
;
if
(
lc
(
$type
) =~ /^(enum|set)$/) {
$ret
.=
sprintf
(
" => ['%s']"
,
join
"','"
, @{
$column_info
->{MYSQL_VALUES}});
}
$ret
.=
", signed"
if
$opt
{signed};
$ret
.=
", unsigned"
if
$opt
{unsigned} && !
$args
->{default_unsigned};
if
(
defined
$column_info
->column_size) {
my
$column_size
;
if
(
lc
(
$type
) eq
'decimal'
) {
$column_size
=
sprintf
(
"[%d, %d]"
,
$column_info
->column_size,
$column_info
->{DECIMAL_DIGITS});
}
elsif
(
lc
(
$type
) =~ /^(enum|set)$/) {
;;
}
elsif
(
lc
(
$type
) eq
'varchar'
&&
$column_info
->column_size == 255) {
;;
}
elsif
(
lc
(
$type
) =~ /^(
int
|integer)$/ &&
(
$opt
{unsigned} &&
$column_info
->column_size == 10
or
!
$opt
{unsigned} &&
$column_info
->column_size == 11
)
) {
;;
}
elsif
(
$column_info
->{MYSQL_TYPE_NAME} &&
$column_info
->{MYSQL_TYPE_NAME} !~
$column_info
->column_size) {
;;
}
else
{
$column_size
=
$column_info
->column_size;
}
$ret
.=
sprintf
(
", size => %s"
,
$column_size
)
if
$column_size
;
}
$ret
.=
", null"
if
$column_info
->nullable;
$ret
.=
", not_null"
if
!
$column_info
->nullable && !
$args
->{default_not_null};
if
(
defined
$column_info
->column_def) {
my
$column_def
=
$column_info
->column_def;
if
(
$type
=~ /^(TIMESTAMP|DATETIME)$/ &&
$column_def
eq
'CURRENT_TIMESTAMP'
) {
$ret
.=
sprintf
(
", default => \\'%s'"
,
$column_def
)
}
else
{
$ret
.=
sprintf
(
", default => '%s'"
,
$column_def
)
}
}
if
(
$opt
{auto_increment} or
(
$args
->{dbh}->{
'Driver'
}{
'Name'
} eq
'mysql'
&&
$column_info
->{MYSQL_IS_AUTO_INCREMENT})
) {
$ret
.=
", auto_increment"
}
$ret
.=
";\n"
;
return
$ret
;
}
sub
_render_index {
my
(
$table_info
,
$args
) =
@_
;
my
$ret
=
""
;
my
$ret_primary_key
=
""
;
my
$ret_index_key
=
""
;
my
$ret_foreign_key
=
""
;
my
@fk_list
=
$table_info
->fk_foreign_keys(+{
pk_schema
=>
$table_info
->schema });
for
my
$fk
(
@fk_list
) {
if
(
$fk
->fkcolumn_name eq
sprintf
(
'%s_id'
,
$fk
->pktable_name)) {
$ret_foreign_key
.=
sprintf
(
" belongs_to '%s';\n"
,
$fk
->pktable_name)
}
elsif
(
$fk
->fkcolumn_name eq
'id'
&&
$fk
->pkcolumn_name eq
sprintf
(
'%s_id'
,
$fk
->fktable_name)) {
my
$itr
= _statistics_info(
$args
->{dbh},
$table_info
->schema,
$fk
->pktable_name);
while
(
my
$index_key
=
$itr
->
next
) {
if
(
$index_key
->column_name eq
$fk
->pkcolumn_name) {
my
$has
=
$index_key
->non_unique ?
'has_many'
:
'has_one'
;
$ret_foreign_key
.=
sprintf
(
" %s '%s'\n"
,
$has
,
$fk
->pktable_name);
last
;
}
}
}
elsif
(
$fk
->pktable_name &&
$fk
->pkcolumn_name) {
$ret_foreign_key
.=
sprintf
(
" foreign_key '%s' => '%s','%s'\n"
,
$fk
->fkcolumn_name,
$fk
->pktable_name,
$fk
->pkcolumn_name);
}
}
my
%fkcolumn_map
=
map
{
$_
->
fkcolumn_name
=>
$_
}
@fk_list
;
my
%statistics_info_map
;
my
$statistics_info
= _statistics_info(
$args
->{dbh},
$table_info
->schema,
$table_info
->name);
while
(
my
$statistics
=
$statistics_info
->
next
) {
push
@{
$statistics_info_map
{
$statistics
->index_name}} =>
$statistics
;
}
for
my
$index_name
(
sort
keys
%statistics_info_map
) {
my
@statistics_list
= @{
$statistics_info_map
{
$index_name
}};
my
@column_names
=
map
{
$_
->column_name }
sort
{
$a
->{ORDINAL_POSITION} <=>
$b
->{ORDINAL_POSITION} }
@statistics_list
;
if
(
lc
(
$index_name
) eq
'primary'
) {
$ret_primary_key
.=
sprintf
(
" set_primary_key '%s';\n"
,
join
"','"
,
@column_names
);
}
else
{
next
if
@column_names
== 1 &&
$fkcolumn_map
{
$column_names
[0]};
$ret_index_key
.=
sprintf
(
" add_%sindex '%s' => [%s]%s;\n"
,
$statistics_list
[0]->non_unique ?
''
:
'unique_'
,
$index_name
,
(
join
","
, (
map
{
q{'}
.
$_
.
q{'}
}
@column_names
)),
$statistics_list
[0]->non_unique &&
$statistics_list
[0]->type &&
lc
(
$statistics_list
[0]->type) ne
'btree'
?
sprintf
(
", '%s'"
,
$statistics_list
[0]->type) :
''
,
);
}
}
if
(
$ret_primary_key
or
$ret_index_key
or
$ret_foreign_key
) {
$ret
.=
"\n"
;
$ret
.=
$ret_primary_key
if
$ret_primary_key
;
$ret
.=
$ret_index_key
if
$ret_index_key
;
$ret
.=
$ret_foreign_key
if
$ret_foreign_key
;
}
return
$ret
;
}
sub
_statistics_info {
my
(
$dbh
,
$schema
,
$table_name
) =
@_
;
my
$sth
;
if
(
$dbh
->{
'Driver'
}{
'Name'
} eq
'mysql'
) {
my
$sql
=
q{
SELECT
TABLE_CATALOG AS TABLE_CAT,
TABLE_SCHEMA AS TABLE_SCHEM,
TABLE_NAME,
NON_UNIQUE,
NULL AS INDEX_QUALIFIER,
INDEX_NAME,
INDEX_TYPE AS TYPE,
SEQ_IN_INDEX AS ORDINAL_POSITION,
COLUMN_NAME,
NULL AS ASC_OR_DESC,
CARDINALITY,
NULL AS PAGES,
NULL AS FILTER_CONDITION,
SUB_PART,
PACKED,
NULLABLE,
INDEX_TYPE,
COMMENT
FROM
INFORMATION_SCHEMA.STATISTICS
WHERE
table_schema = ?
AND table_name = ?
}
;
$sth
=
$dbh
->prepare(
$sql
);
$sth
->execute(
$schema
,
$table_name
);
}
else
{
$sth
=
$dbh
->statistics_info(
undef
,
undef
,
$table_name
,
undef
,
undef
);
}
DBIx::Inspector::Iterator->new(
sth
=>
$sth
,
callback
=>
sub
{
my
$row
=
shift
;
DBIx::Inspector::Statics->new(
$row
);
},
);
}
package
DBIx::Inspector::Statics;
sub
new {
my
$class
=
shift
;
my
%args
=
@_
== 1 ? %{
$_
[0] } :
@_
;
bless
{
%args
},
$class
;
}
{
no
strict
'refs'
;
for
my
$k
(
qw/
TABLE_CAT
TABLE_SCHEM
TABLE_NAME
NON_UNIQUE
INDEX_QUALIFIER
INDEX_NAME
TYPE
ORDINAL_POSITION
COLUMN_NAME
ASC_OR_DESC
CARDINALITY
PAGES
FILTER_CONDITION
/
)
{
*{ __PACKAGE__ .
"::"
.
lc
(
$k
) } =
sub
{
$_
[0]->{
$k
} };
}
}
1;