$VERSION
= 0.04;
use
constant
DEFAULT_TYPE
=>
'SQL_VARCHAR'
;
storage_type (
'Array'
,
sub
{
my
(
$class
,
%args
) =
@_
;
my
$specialisation_module
=
$args
{connection}->load_module(
'PLSQL'
);
my
$self
=
$specialisation_module
->new(
%args
);
return
$self
;
});
has
'$.plsql'
;
has
'%.bind_variables'
=> (
item_accessor
=>
'bind_variable'
);
has
'@.bind_in_variables'
;
has
'@.bind_inout_variables'
;
has
'@.bind_out_variables'
;
has
'$.default_type'
=> (
default
=> DEFAULT_TYPE);
has
'$.default_width'
=> (
default
=> DEFAULT_WIDTH);
sub
initialise {
my
(
$self
) =
@_
;
$self
->initialise_bind_variables();
$self
->SUPER::initialise();
}
sub
initialise_bind_variables {
my
(
$self
) =
@_
;
my
$plsql
=
$self
->plsql;
my
$bind_variables
=
$self
->bind_variables;
$plsql
=~ s/\'[^\']*\'//g;
while
(
$plsql
=~ s/into\s:(\w+)//i) {
my
$bind_variable
= $1;
my
$out_flag
= 1;
my
$variable
=
$bind_variables
->{
$bind_variable
};
if
(
$variable
&&
$variable
->{binding}) {
$variable
->{binding} =
'inout'
if
(
$out_flag
&&
$variable
->{binding} eq
'in'
);
}
else
{
$variable
=
$bind_variables
->{
$bind_variable
} =
$self
->default_variable_info
unless
$variable
;
$variable
->{binding} =
$out_flag
?
'out'
:
'in'
;
}
}
while
(
$plsql
=~ s/:(\w+)\s*(:*)//) {
my
$bind_variable
= $1;
my
$out_flag
= $2;
my
$variable
=
$bind_variables
->{
$bind_variable
};
if
(
$variable
&&
$variable
->{binding}) {
$variable
->{binding} =
'inout'
if
(
$out_flag
&&
$variable
->{binding} eq
'in'
);
}
else
{
$variable
=
$bind_variables
->{
$bind_variable
} =
$self
->default_variable_info
unless
$variable
;
$variable
->{binding} =
$out_flag
?
'out'
:
'in'
;
}
}
$self
->set_binding_order();
}
sub
set_binding_order {
my
(
$self
) =
@_
;
my
$bind_variables
=
$self
->bind_variables;
my
$bind_in_variables
=
$self
->bind_in_variables;
my
$bind_inout_variables
=
$self
->bind_inout_variables;
my
$bind_out_variables
=
$self
->bind_out_variables;
foreach
my
$k
(
sort
keys
%$bind_variables
) {
my
$variable
=
$bind_variables
->{
$k
};
if
(
$variable
->{binding} eq
'in'
) {
push
@$bind_in_variables
,
$k
;
}
elsif
(
$variable
->{binding} eq
'out'
) {
push
@$bind_out_variables
,
$k
;
}
else
{
push
@$bind_inout_variables
,
$k
;
}
}
}
sub
default_variable_info {
my
$self
=
shift
;
{
type
=>
$self
->default_type,
width
=>
$self
->default_width,
@_
};
}
sub
plsql_block_name {
my
(
$self
) =
@_
;
my
$result
=
"anonymous_"
;
if
(
$self
->name =~ m/\s+/) {
$result
.=
unpack
(
"%32C*"
,
$self
->name);
}
else
{
$result
.=
$self
->name;
}
substr
(
$result
, 0, 30);
}
sub
plsql_block_declaration {
my
(
$self
) =
@_
;
my
$result
=
''
;
foreach
my
$k
(
$self
->bind_variable_order) {
$result
.= (
$result
?
', '
:
''
) .
$self
->variable_declaration(
$k
);
}
$result
;
}
sub
bind_variable_order {
my
(
$self
) =
@_
;
(
$self
->bind_in_variables,
$self
->bind_inout_variables,
$self
->bind_out_variables);
}
sub
binded_in_variables {
my
(
$self
) =
@_
;
(
$self
->bind_in_variables,
$self
->bind_inout_variables);
}
sub
binded_out_variables {
my
(
$self
) =
@_
;
(
$self
->bind_inout_variables,
$self
->bind_out_variables);
}
sub
variable_declaration {
my
(
$self
,
$variable_name
) =
@_
;
my
$variable
=
$self
->bind_variable(
$variable_name
);
my
$type
=
$variable
->{type};
uc
(
$variable
->{binding}) .
' '
.
$variable_name
.
' '
.
$self
->get_type(
$type
) .
$self
->type_precision(
$variable_name
);
}
sub
type_precision {
my
(
$self
,
$variable_name
) =
@_
;
my
$variable
=
$self
->bind_variable(
$variable_name
);
(
$variable
->{type} &&
$variable
->{type} =~ /CHAR/ ?
'('
.
$variable
->{width} .
')'
:
''
)
}
sub
block_source {
my
(
$self
) =
@_
;
"BEGIN\n"
.
$self
->parsed_plsql
.
"\nEND;"
;
}
sub
parsed_plsql {
my
(
$self
) =
@_
;
my
$plsql
=
$self
->plsql;
my
$bind_variables
=
$self
->bind_variables;
foreach
my
$variable
(
sort
keys
%$bind_variables
) {
$plsql
=~ s/:
$variable
/
$variable
/g;
}
$plsql
;
}
sub
is_block_changed {
my
(
$self
,
@bind_param
) =
@_
;
my
$connection
=
$self
->connection;
my
$record
=
$connection
->record(
$self
->sql_defintion(
'find_function'
),
@bind_param
);
my
$routine_definition
=
$record
->{routine_definition} or
return
1;
$routine_definition
=~ s/[\n\r\s\t;]//g;
my
$block_source
=
$self
->block_source;
$block_source
=~ s/[\n\r\s\t;]//g;
if
(
$block_source
ne
$routine_definition
) {
$self
->drop_plsql_block;
return
1
};
!!
undef
;
}
1;