@ISA
=
qw(DBIx::ORM::Declarative)
;
sub
__check_constraints
{
my
(
$self
,
$tab_obj
,
%params
) =
@_
;
carp
"This method requires an object"
and
return
unless
ref
$tab_obj
;
my
%rv
= ();
my
%cons
=
map
{ @{
$_
}{
qw(name constraint)
} }
$tab_obj
->_columns;
my
@pk
=
$tab_obj
->_primary_key;
my
@keys
= ();
my
@vals
= ();
my
@binds
= ();
my
$npk
= 0;
if
(
@pk
)
{
for
my
$k
(
@pk
)
{
my
$v
=
delete
$params
{
$k
};
if
(
defined
$v
)
{
if
(not
$self
->apply_method(
$cons
{
$k
}, 0,
$v
))
{
carp
"column $k constraint failed"
;
return
;
}
push
@binds
,
$v
;
push
@vals
,
'?'
;
push
@keys
,
$k
;
}
else
{
$npk
= 1;
my
$fnp
=
$tab_obj
->_for_null_primary;
if
(
$fnp
)
{
push
@vals
,
$fnp
;
push
@keys
,
$k
;
}
}
}
}
for
my
$k
(
map
{
$_
->{name} }
$tab_obj
->_columns)
{
next
if
grep
{
$_
eq
$k
}
@pk
;
my
$v
=
$params
{
$k
};
if
(not
$self
->apply_method(
$cons
{
$k
}, 0,
$v
))
{
carp
"column $k constraint failed"
;
return
;
}
if
(
exists
$params
{
$k
})
{
push
@keys
,
$k
;
if
(
defined
$v
)
{
push
@binds
,
$v
;
push
@vals
,
'?'
;
}
else
{
push
@vals
,
'NULL'
;
}
}
}
my
%n2s
=
$tab_obj
->_column_map;
my
$kstr
=
''
.
join
(
','
,
map
{
$n2s
{
$_
} }
@keys
);
my
$vstr
=
''
.
join
(
','
,
@vals
);
return
(1,
$kstr
,
$vstr
,
$npk
,
@binds
);
}
sub
__make_sql_safe
{
my
(
$self
,
$str
) =
@_
;
$str
=~ s/\W/_/g;
if
(
$str
=~ /^[^a-zA-Z_]/)
{
$str
=
"_$str"
;
}
$str
;
}
sub
alias
{
my
(
$self
,
@args
) =
@_
;
if
(
@args
<2)
{
if
(
@args
==1)
{
return
$self
->table(
@args
);
}
my
$alias
;
eval
{
$alias
=
$self
->_alias; };
return
$alias
;
}
my
(
$alias
,
$table
) =
@args
;
my
$schema_class
=
ref
$self
||
$self
;
my
$alias_class
=
$schema_class
.
"::$alias"
;
my
$table_class
=
$schema_class
.
"::$table"
;
no
strict
'refs'
;
if
(not @{
$alias_class
.
'::ISA'
})
{
@{
$alias_class
.
'::ISA'
} = (
$table_class
);
*{
$alias_class
.
'::_class'
} =
sub
{
$alias_class
; };
*{
$alias_class
.
'::_table'
} =
sub
{
$alias
; };
*{
$alias_class
.
'::_alias'
} =
sub
{
$table
; };
my
$cons
= *{
$alias_class
} =
sub
{
my
(
$self
) =
@_
;
my
$rv
=
$self
->new;
bless
$rv
,
$alias_class
unless
$rv
->isa(
$alias_class
);
return
$rv
;
} ;
my
$row_class
=
$alias_class
.
'::Rows'
;
@{
$row_class
.
'::ISA'
} = (
$self
->ROW_CLASS,
$alias_class
);
*{
$alias_class
.
'::_row_class'
} =
sub
{
$row_class
; };
$self
->table_method(
$alias
,
$cons
);
}
}
sub
table
{
my
(
$self
,
@args
) =
@_
;
if
(
@args
<2)
{
if
(
@args
==1)
{
my
$table
=
shift
@args
;
return
$self
unless
$table
;
my
$meth
=
$self
->table_method(
$table
);
return
unless
$meth
;
return
$meth
->(
$self
);
}
my
$table
;
eval
{
$table
=
$self
->_table; };
return
$table
;
}
my
%args
=
@args
;
my
$table
=
delete
$args
{table};
carp
"missing table argument"
and
return
unless
$table
;
my
$name
=
delete
$args
{alias} ||
$table
;
my
$primary
=
delete
$args
{primary};
my
$unique
=
delete
$args
{unique};
my
$columns
=
delete
$args
{columns};
carp
"missing column definitions"
and
return
unless
$primary
or
$unique
or
$columns
;
my
$onpnull
=
delete
$args
{for_null_primary};
my
$selonpnull
=
delete
$args
{select_null_primary};
my
$join
=
delete
$args
{join_clause};
my
$group_by
=
delete
$args
{group_by};
my
$super
=
$self
->_schema_class;
my
$table_class
=
$super
.
"::$name"
;
my
$row_class
=
$table_class
.
"::Rows"
;
my
$schema
=
$self
->_schema;
no
strict
'refs'
;
@{
$table_class
.
'::ISA'
} = (
$super
,
$self
->TABLE_CLASS);
@{
$row_class
.
'::ISA'
} = (
$self
->ROW_CLASS,
$table_class
);
*{
$table_class
.
'::_class'
} =
sub
{
$table_class
; };
*{
$table_class
.
'::_row_class'
} =
sub
{
$row_class
; };
*{
$table_class
.
'::_table'
} =
sub
{
$name
; };
*{
$table_class
.
'::_sql_name'
} =
sub
{
$table
; };
*{
$table_class
.
'::_for_null_primary'
} =
sub
{
$onpnull
; };
*{
$table_class
.
'::_select_null_primary'
} =
sub
{
$selonpnull
; };
*{
$table_class
.
'::_join_clause'
} =
sub
{
$join
; };
if
(
$group_by
)
{
my
@p
=
@$group_by
;
*{
$table_class
.
'::_group_by'
} =
sub
{
@p
; };
}
else
{
*{
$table_class
.
'::_group_by'
} =
sub
{ };
}
my
$cons
=
sub
{
my
(
$self
) =
@_
;
my
$rv
=
$self
->new;
bless
$rv
,
$table_class
unless
$rv
->isa(
$table_class
);
return
$rv
;
} ;
*{
$table_class
} =
$cons
;
$self
->table_method(
$name
,
$cons
);
my
%seen_keys
;
my
@newcolumns
;
my
@p
;
@p
=
@$primary
if
$primary
;
*{
$table_class
.
'::_primary_key'
} =
sub
{
@p
; };
$seen_keys
{
$_
} =
{
sql_name
=>
$_
,
name
=>
$_
,
constraint
=>
'isstring'
}
foreach
@p
;
my
%pk
=
map
{(
$_
,1);}
@p
;
@newcolumns
=
@p
;
my
@uniqs
;
push
@uniqs
, [
@p
]
if
@p
;
$unique
||= [ ];
for
my
$un
(
@$unique
)
{
my
%kv
=
map
{(
$_
,1)}
@$un
;
delete
@kv
{
@p
};
next
if
not
%kv
and
scalar
(
@p
) ==
scalar
(
@$un
);
push
@uniqs
, [
@$un
];
for
my
$k
(
@$un
)
{
next
if
$seen_keys
{
$k
};
$seen_keys
{
$k
} = {
sql_name
=>
$k
,
name
=>
$k
,
constraint
=>
'isnullablestring'
};
push
@newcolumns
,
$k
;
}
}
*{
$table_class
.
'::_unique_keys'
} =
sub
{
@uniqs
; };
my
@coldefs
;
my
%colmap
;
for
my
$col
(
@$columns
)
{
my
%cdef
=
%$col
;
my
$sql_name
=
delete
$cdef
{name};
my
$name
=
delete
$cdef
{alias} ||
$sql_name
;
$colmap
{
$name
} =
$sql_name
;
delete
$seen_keys
{
$sql_name
};
my
$constraint
=
delete
$cdef
{constraint};
my
$match
=
delete
$cdef
{matches};
my
$type
=
delete
$cdef
{type};
if
(not
$constraint
)
{
$constraint
=
'isnullablestring'
;
if
(
$match
)
{
$constraint
=
sub
{
my
(
$self
,
$value
) =
@_
;
$value
=~ /
$match
/;
};
}
elsif
(
$type
)
{
if
(
$type
eq
'number'
) {
$constraint
=
'isnumber'
; }
elsif
(
$type
eq
'string'
) {
$constraint
=
'isstring'
; }
elsif
(
$type
eq
'nullablenumber'
)
{
$constraint
=
'isnullablenumber'
;
}
}
}
push
@coldefs
,
{
sql_name
=>
$sql_name
,
name
=>
$name
,
constraint
=>
$constraint
,
column_name
=>
$sql_name
,
};
*{
$row_class
.
"::$name"
} =
$self
->__create_column_accessor(
$sql_name
,
$pk
{
$sql_name
});
}
for
my
$col
(
@newcolumns
)
{
my
$def
=
delete
$seen_keys
{
$col
};
next
unless
$def
;
push
@coldefs
,
$def
;
$colmap
{
$col
} =
$col
;
*{
$row_class
.
"::$col"
} =
$self
->__create_column_accessor(
$col
,
$pk
{
$col
});
}
*{
$table_class
.
'::_columns'
} =
sub
{
@coldefs
; } ;
*{
$table_class
.
'::_column_map'
} =
sub
{
%colmap
; } ;
my
@sql_cols
=
sort
values
%colmap
;
*{
$table_class
.
'::_column_sql_names'
} =
sub
{
@sql_cols
; };
return
&{
$table_class
}(
$self
);
}
sub
join
{
my
(
$self
,
@args
) =
@_
;
if
(
@args
<2)
{
if
(
@args
==1)
{
my
$join
=
shift
@args
;
return
$self
unless
$join
;
my
$meth
=
$self
->join_method(
$join
);
return
unless
$meth
;
return
$meth
->(
$self
);
}
my
$join
;
eval
{
$join
=
$self
->_join; };
return
$join
;
}
my
%args
=
@args
;
my
$name
=
delete
$args
{name};
carp
"duplicate table/join declaration"
and
return
if
$self
->can(
$name
);
my
$super
=
$self
->_schema_class;
my
$join_class
=
$super
.
"::$name"
;
my
$row_class
=
$join_class
.
'::Rows'
;
my
$schema
=
$self
->_schema;
my
$ptab
=
delete
$args
{primary};
carp
"missing join name"
and
return
unless
$name
;
my
$tables
=
delete
$args
{tables};
carp
"missing table(s) to join"
and
return
unless
$ptab
and
$tables
;
my
@req_tabs
= (
$ptab
,
map
{
$_
->{table} }
@$tables
);
carp
"missing required tables"
and
return
if
grep
{ not
$self
->can(
$_
); }
@req_tabs
;
my
$ptab_obj
=
$self
->table(
$ptab
);
carp
"No such table '$ptab'"
and
return
unless
$ptab_obj
;
my
$ptab_name
=
$ptab_obj
->_table;
my
$ptab_alias
=
$self
->__make_sql_safe(
$ptab_name
);
my
@ptab_cols
=
map
{
$_
->{name} }
$ptab_obj
->_columns;
my
@join_table_info
= (
$ptab_obj
->_sql_name .
" $ptab_alias"
);
my
@column_info
=
map
{
(
{
sql_name
=>
"$ptab_alias."
.
$_
->{sql_name},
name
=>
$_
->{name},
constraint
=>
$_
->{constraint},
table
=>
$ptab_name
,
table_alias
=>
$ptab_alias
,
column_name
=>
$_
->{sql_name},
},
{
sql_name
=>
"$ptab_alias."
.
$_
->{sql_name},
name
=>
$ptab_name
.
'_'
.
$_
->{name},
constraint
=>
$_
->{constraint},
table
=>
$ptab_name
,
table_alias
=>
$ptab_alias
,
column_name
=>
$_
->{sql_name},
},
)
}
$ptab_obj
->_columns;
my
%column_map
=
map
{ @{
$_
}{
qw(name sql_name)
} }
@column_info
;
my
@wherefrags
;
my
@group_by
=
map
{
$column_map
{
$_
} }
$ptab_obj
->_group_by;
my
%pkeys
=
map
{(
$_
=> 1,
$ptab_name
.
"_$_"
=> 1)}
$ptab_obj
->_primary_key;
my
@tables_seen
;
my
@tab_info
;
for
my
$tab
(
@$tables
)
{
my
$tab_name
=
$tab
->{table};
my
$tab_obj
=
$self
->table(
$tab_name
);
carp
"No such table '$tab_name'"
and
return
unless
$tab_obj
;
my
$info_ref
= {
table
=>
$tab_name
};
my
@use_cols
=
@ptab_cols
;
my
$usetab_name
=
$ptab_name
;
my
$usetab_alias
=
$ptab_alias
;
my
$secondary
=
$tab
->{on_secondary};
if
(
$secondary
)
{
carp
"Secondary table '$secondary' unknown"
and
return
unless
grep
{
$secondary
eq
$_
}
@tables_seen
;
my
$secondary_obj
=
$self
->table(
$secondary
);
carp
"No such table '$secondary'"
and
return
unless
$secondary_obj
;
$info_ref
->{on_secondary} =
$secondary
;
@use_cols
=
map
{
$_
->{name} }
$secondary_obj
->_columns;
$usetab_name
=
$secondary
;
$usetab_alias
=
$self
->__make_sql_safe(
$usetab_name
);
}
push
@tables_seen
,
$tab_name
;
my
$tab_alias
=
$self
->__make_sql_safe(
$tab_obj
->_table);
my
%join_info
= %{
$tab
->{columns}};
my
@tab_cols
=
$tab_obj
->_columns;
for
my
$k
(
keys
%join_info
)
{
carp
"No such key '$k' on primary table '$usetab_name'"
and
return
unless
grep
{
$k
eq
$_
}
@use_cols
;
carp
"No such key '$k' on secondary table '$tab_name'"
and
return
unless
grep
{
$join_info
{
$k
} eq
$_
->{name} }
@tab_cols
;
$info_ref
->{columns}{
$k
} =
$join_info
{
$k
};
$pkeys
{
$k
} =
$pkeys
{
$join_info
{
$k
}} = 1;
push
@wherefrags
,
"$usetab_alias.$k = $tab_alias.$join_info{$k}"
;
}
push
@tab_info
,
$info_ref
;
push
@join_table_info
,
$tab_obj
->_sql_name .
" $tab_alias"
;
my
%tab_group_by
=
map
{ (
$_
,1) }
$tab_obj
->_group_by;
for
my
$col
(
$tab_obj
->_columns)
{
my
$column_ref
=
"$tab_alias."
.
$col
->{sql_name};
push
@column_info
,
{
sql_name
=>
$column_ref
,
name
=>
$col
->{name},
constraint
=>
$col
->{constraint},
table
=>
$tab_name
,
table_alias
=>
$tab_alias
,
column_name
=>
$_
->{sql_name},
},
{
sql_name
=>
$column_ref
,
name
=>
$tab_name
.
'_'
.
$col
->{name},
constraint
=>
$col
->{constraint},
table
=>
$tab_name
,
table_alias
=>
$tab_alias
,
column_name
=>
$_
->{sql_name},
};
$column_map
{
$col
->{name}} ||=
$column_ref
;
$column_map
{
$tab_name
.
'_'
.
$col
->{name}} ||=
$column_ref
;
push
@group_by
,
$column_ref
if
$tab_group_by
{
$col
->{name}};
}
$pkeys
{
$tab_name
.
"_$_"
} =
$pkeys
{
$_
} = 1
foreach
$tab_obj
->_primary_key;
}
no
strict
'refs'
;
@{
$join_class
.
'::ISA'
} = (
$super
,
$self
->JOIN_CLASS);
@{
$row_class
.
'::ISA'
} = (
$self
->JROW_CLASS,
$join_class
);
*{
$join_class
.
'::_class'
} =
sub
{
$join_class
; };
*{
$join_class
.
'::_row_class'
} =
sub
{
$row_class
; };
*{
$join_class
.
'::_join'
} =
sub
{
$name
; };
*{
$join_class
.
'::_primary'
} =
sub
{
$ptab
; };
my
$join_tabs
=
join
(
', '
,
@join_table_info
);
*{
$join_class
.
'::_sql_name'
} =
sub
{
$join_tabs
; };
my
$where_prefix
=
join
(
' AND '
,
@wherefrags
);
*{
$join_class
.
'::_where_prefix'
} =
sub
{
$where_prefix
; };
*{
$join_class
.
'::_columns'
} =
sub
{
@column_info
; };
*{
$join_class
.
'::_column_map'
} =
sub
{
%column_map
; };
*{
$join_class
.
'::_group_by'
} =
sub
{
@group_by
; };
my
%h
=
reverse
%column_map
;
my
@sql_cols
=
sort
keys
%h
;
*{
$join_class
.
'::_column_sql_names'
} =
sub
{
@sql_cols
; };
my
$cons
=
sub
{
my
(
$self
) =
@_
;
my
$rv
=
$self
->new;
bless
$rv
,
$join_class
unless
$rv
->isa(
$join_class
);
return
$rv
;
} ;
*{
$join_class
} =
$cons
;
$self
->join_method(
$name
,
$cons
);
*{
$join_class
.
'::_join_info'
} =
sub
{
@tab_info
; };
*{
$row_class
.
"::$_"
} =
$self
->__create_column_accessor(
$column_map
{
$_
},
$pkeys
{
$_
})
foreach
keys
%column_map
;
return
&{
$join_class
}(
$self
);
}
sub
__create_column_accessor
{
my
(
$self
,
$name
,
$pk_flag
) =
@_
;
if
(
$pk_flag
)
{
return
sub
{
my
$self
=
shift
;
carp
"$name is not a class method"
and
return
unless
ref
$self
;
carp
"$name is part of the primary key"
and
return
$self
if
@_
;
return
$self
->{__data}{
$name
};
};
}
return
sub
{
my
$self
=
shift
;
carp
"$name is not a class method"
and
return
unless
ref
$self
;
my
$val
=
$self
->{__data}{
$name
};
if
(
@_
)
{
my
$nval
=
$_
[0];
return
$self
if
not
defined
$val
and not
defined
$nval
;
if
(not
defined
$val
or
$nval
ne
$val
)
{
delete
$self
->{__data}{
$name
};
$self
->{__data}{
$name
} =
$nval
if
defined
$nval
;
$self
->{__dirty} = 1;
}
return
$self
;
}
return
$val
;
};
}
1;