no
strict
'refs'
;
no
warnings
'once'
;
my
$tmp
;
sub
_rename_camelCase_keys {
my
$hashref
=
shift
;
foreach
my
$key
(
keys
%$hashref
) {
my
$new_key
=
$key
;
$new_key
=~ s/([a-z])([A-Z])/$1_\L$2\E/g
and
$hashref
->{
$new_key
} =
delete
$hashref
->{
$key
};
}
$tmp
=
delete
$hashref
->{-post_sQL} and
$hashref
->{-post_SQL} =
$tmp
;
}
no
warnings
'redefine'
;
my
$orig_Schema
= \
&Schema
;
*Schema
=
sub
{
my
(
$class
,
$schema_class_name
,
%args
) =
@_
;
DBIx::DataModel::Compatibility::V1::_rename_camelCase_keys(\
%args
);
my
%singleton_args
;
foreach
my
$key
(
qw/dbh debug dbi_prepare_method
sql_abstract sql_dialect/
) {
$tmp
=
delete
$args
{
$key
} and
$singleton_args
{
$key
} =
$tmp
;
}
if
(
my
$vp
=
delete
$args
{view_parent}) {
$args
{join_parent} ||= [];
$args
{join_parent} = [
$args
{join_parent}]
unless
ref
$args
{join_parent};
push
@{
$args
{join_parent}},
@$vp
;
}
my
$schema_class
=
$class
->
$orig_Schema
(
$schema_class_name
,
%args
);
if
(
%singleton_args
) {
my
%sqlam_args
;
if
(
my
$sqla
=
delete
$singleton_args
{sql_abstract}) {
my
$fake_sqla
= SQL::Abstract->new;
for
my
$op_name
(
qw/special_ops unary_ops/
) {
my
$n_builtin_ops
= @{
$fake_sqla
->{
$op_name
}};
splice
@{
$sqla
->{
$op_name
}}, -
$n_builtin_ops
;
}
%sqlam_args
=
%$sqla
if
$sqla
;
}
if
(
my
$dialect
=
delete
$singleton_args
{sql_dialect}) {
if
(
ref
$dialect
) {
DBIx::DataModel::Compatibility::V1::_rename_camelCase_keys(
$dialect
);
$sqlam_args
{
$_
} =
$dialect
->{
$_
}
foreach
keys
%$dialect
;
}
else
{
$dialect
=~ s/^MySQL/MySQL_old/;
$sqlam_args
{sql_dialect} =
$dialect
;
}
}
$singleton_args
{sql_abstract} = SQL::Abstract::More->new(
%sqlam_args
);
my
$singleton
=
$schema_class
->singleton(
%singleton_args
);
}
return
$schema_class
;
};
no
warnings
'redefine'
;
my
$orig_Type
= \
&Type
;
*Type
=
*ColumnType
=
sub
{
my
(
$self
,
$type_name
,
%handlers
) =
@_
;
my
$tmp
;
$tmp
=
delete
$handlers
{fromDB} and
$handlers
{from_DB} =
$tmp
;
$tmp
=
delete
$handlers
{toDB} and
$handlers
{to_DB} =
$tmp
;
$self
->
$orig_Type
(
$type_name
,
%handlers
);
};
my
$orig_new
= \
&new
;
*new
=
sub
{
my
(
$class
,
%options
) =
@_
;
$class
->
$orig_new
(
sql_no_inner_after_left_join
=> 1,
%options
);
};
sub
tables {
my
$self
=
shift
;
return
map
{
$_
->class}
values
%{
$self
->{table}};
}
sub
views {
my
$self
=
shift
;
return
map
{
$_
->class}
values
%{
$self
->{table}};
}
no
warnings
'redefine'
;
*_createPackage
= \
&DBIx::DataModel::Meta::Utils::define_class
;
*doTransaction
= \
&do_transaction
;
sub
_defineMethod {
my
(
$class
,
$target
,
$method_name
,
$body
,
$is_silent
) =
@_
;
my
%args
= (
class
=>
$target
,
name
=>
$method_name
,
body
=>
$body
,
);
$args
{check_override} = 0
if
$is_silent
;
DBIx::DataModel::Meta::Utils->define_method(
%args
);
}
sub
ColumnType {
my
$self
=
shift
;
$self
->metadm->Type(
@_
);
}
sub
Autoload {
my
(
$class
,
$toggle
) =
@_
;
DBIx::DataModel::Source::Table->Autoload(
$toggle
);
}
sub
autoInsertColumns {
my
$class
=
shift
;
return
$class
->metadm->auto_insert_columns;
}
sub
autoUpdateColumns {
my
$class
=
shift
;
return
$class
->metadm->auto_update_columns;
}
sub
noUpdateColumns {
my
$class
=
shift
;
my
%no_update_column
=
$class
->metadm->no_update_column;
return
keys
%no_update_column
;
}
sub
AutoInsertColumns {
my
(
$class
,
%handlers
) =
@_
;
$class
->metadm->{auto_insert_columns} = \
%handlers
;
}
sub
AutoUpdateColumns {
my
(
$class
,
%handlers
) =
@_
;
$class
->metadm->{auto_update_columns} = \
%handlers
;
}
sub
NoUpdateColumns {
my
(
$class
,
@columns
) =
@_
;
$class
->metadm->{no_update_columns} = {
map
{
$_
=> 1}
@columns
};
}
sub
tables {
my
$class
=
shift
;
$class
->metadm->tables;
}
sub
selectImplicitlyFor {
my
$self
=
shift
;
$self
->select_implicitly_for(
@_
);
}
sub
classData {
my
$class
=
shift
;
return
$class
->singleton;
}
sub
localizeState {
my
$class
=
shift
;
return
$class
->localize_state;
}
no
warnings
'redefine'
;
*primKey
= \
&primary_key
;
sub
MethodFromJoin {
my
$self
=
shift
;
$self
->metadm->define_navigation_method(
@_
);
}
sub
createStatement {
my
$class
=
shift
;
carp
"->createStatement() is obsolete, use "
.
"->select(.., -resultAs => 'statement')"
;
return
$class
->
select
(
@_
,
-resultAs
=>
'statement'
);
}
sub
selectImplicitlyFor {
my
$self
=
shift
;
carp
"HACK: obsolete method \$source->selectImplicitlyFor() is delegated "
.
"to \$schema->select_implicitly_for(); the semantics is not exactly "
.
"identical"
;
$self
->metadm->schema->class->select_implicitly_for(
@_
);
}
sub
_autoloader {
my
$self
=
shift
;
my
$class
=
ref
(
$self
) ||
$self
;
my
$attribute
=
our
$AUTOLOAD
;
$attribute
=~ s/^.*:://;
return
if
$attribute
eq
'DESTROY'
;
return
$self
->{
$attribute
}
if
ref
(
$self
) and
exists
$self
->{
$attribute
};
croak
"no $attribute method in $class"
;
}
sub
Autoload {
my
(
$class
,
$toggle
) =
@_
;
not
ref
(
$class
) or croak
"Autoload is a class method"
;
defined
(
$toggle
) or croak
"Autoload : missing toggle value"
;
no
strict
'refs'
;
if
(
$toggle
) {
*{
"${class}::AUTOLOAD"
} = \
&_autoloader
;
}
else
{
delete
${
"${class}::"
}{AUTOLOAD};
}
}
no
warnings
'redefine'
;
sub
DefaultColumns {
my
(
$class
,
$columns
) =
@_
;
$class
->metadm->default_columns(
$columns
);
}
sub
ColumnType {
my
(
$class
,
$typeName
,
@args
) =
@_
;
$class
->metadm->define_column_type(
$typeName
,
@args
);
}
sub
ColumnHandlers {
my
(
$class
,
$columnName
,
%handlers
) =
@_
;
$class
->metadm->define_column_handlers(
$columnName
,
%handlers
);
}
sub
AutoExpand {
my
(
$class
,
@roles
) =
@_
;
$class
->metadm->define_auto_expand(
@roles
);
}
sub
autoInsertColumns {
my
$self
=
shift
;
$self
->metadm->auto_insert_column;
}
sub
autoUpdateColumns {
my
$self
=
shift
;
$self
->metadm->auto_update_column;
}
sub
noUpdateColumns {
my
$self
=
shift
;
my
%no_update_columns
=
$self
->metadm->no_update_column;
return
keys
%no_update_columns
;
}
sub
componentRoles {
my
$self
=
shift
;
$self
->metadm->components;
}
sub
applyColumnHandler {
my
$class
=
shift
;
$class
->apply_column_handler(
@_
);
}
sub
AutoInsertColumns {
my
(
$class
,
%handlers
) =
@_
;
$class
->metadm->{auto_insert_columns} = \
%handlers
;
}
sub
AutoUpdateColumns {
my
(
$class
,
%handlers
) =
@_
;
$class
->metadm->{auto_update_columns} = \
%handlers
;
}
sub
NoUpdateColumns {
my
(
$class
,
@columns
) =
@_
;
$class
->metadm->{no_update_columns} = {
map
{
$_
=> 1}
@columns
};
}
sub
blessFromDB {
my
$class
=
shift
;
$class
->bless_from_DB(
@_
);
}
sub
db_table {
my
$class
=
shift
;
return
$class
->metadm->db_from;
}
no
warnings
'redefine'
;
my
$orig_refine
= \
&refine
;
*refine
=
sub
{
my
$self
=
shift
;
my
%args
;
if
(
$_
[0] and not
ref
(
$_
[0]) and
$_
[0] =~ /^-/) {
%args
=
@_
;
}
else
{
no
warnings
'uninitialized'
;
$args
{-columns} =
shift
unless
!
@_
or reftype
$_
[0] eq
'HASH'
;
$args
{-where} =
shift
unless
!
@_
or reftype
$_
[0] eq
'ARRAY'
;
$args
{-orderBy} =
shift
unless
!
@_
or reftype
$_
[0] eq
'HASH'
;
croak
"too many args for select()"
if
@_
;
}
DBIx::DataModel::Compatibility::V1::_rename_camelCase_keys(\
%args
);
if
(
my
$distinct
=
delete
$args
{-distinct}) {
ref
$distinct
or
$distinct
= [
$distinct
];
unshift
@$distinct
,
'-distinct'
;
$args
{-columns} =
$distinct
;
}
$args
{-result_as} =~ s/^(cursor|iter(ator)?)/statement/i
if
$args
{-result_as};
$self
->
$orig_refine
(
%args
);
};
*{rowCount} = \
&row_count
;
*{pageCount} = \
&page_count
;
*{gotoPage} = \
&goto_page
;
*{shiftPages} = \
&shift_pages
;
*{nextPage} = \
&next_page
;
*{pageBoundaries} = \
&page_boundaries
;
*{pageRows} = \
&page_rows
;
no
warnings
'redefine'
;
*{rowCount} = \
&row_count
;
$INC
{
"DBIx/DataModel/Table.pm"
} = 1;
our
@ISA
=
qw/DBIx::DataModel::Source::Table/
;
$INC
{
"DBIx/DataModel/View.pm"
} = 1;
our
@ISA
=
qw/DBIx::DataModel::Source::Table/
;
1;