our
$AUTHORITY
=
'cpan:MATY'
;
$PMLTQ::SQLEvaluator::VERSION
=
'2.0.1'
;
use
5.006;
our
$SEPARATE_TREES
=0;
BEGIN {
import
PMLTQ::Common
qw(:tredmacro :constants)
;
}
our
$MIN_CLIENT_VERSION
=
'0.2'
;
our
$ALLOW_MISPLACED_PG_JOIN
= 1;
sub
check_client_version {
my
(
$self
,
$version
)=
@_
;
return
(
defined
(
$version
) &&
length
(
$version
) && Treex::PML::Schema::cmp_revisions(
$MIN_CLIENT_VERSION
,
$version
)<=0) ? 1 : 0;
}
sub
new {
my
(
$class
,
$query_tree
,
$opts
)=
@_
;
if
($^O eq
'MSWin32'
) {
die
"Not supported OS, PMLTQ::SQLEvaluator requires Sys::SigAction\n"
;
}
else
{
}
my
$self
=
bless
{
dbi
=>
$opts
->{dbi},
connect
=>
$opts
->{
connect
},
debug
=>
$opts
->{debug},
results
=>
undef
,
query_nodes
=>
undef
,
type_decls
=> {},
schema_types
=> {},
schemas
=> {},
returns_nodes
=> 1,
},
$class
;
$self
->prepare_query(
$query_tree
,
$opts
)
if
$query_tree
;
return
$self
;
}
sub
get_results {
my
$self
=
shift
;
return
$self
->{results} || [];
}
sub
get_query_nodes {
my
$self
=
shift
;
return
$self
->{query_nodes};
}
sub
get_sql {
my
$self
=
shift
;
return
$self
->{sql};
}
sub
prepare_sql {
my
(
$self
,
$sql
,
$opts
)=
@_
;
$self
->{sth} =
undef
;
$self
->{sql} =
$sql
;
my
$dbi
=
$self
->{dbi} ||
$self
->
connect
();
print
STDERR
"$sql\n"
if
$opts
->{debug_sql};
return
$self
->run_sql_query(
$sql
,{
use_cursor
=>
$opts
->{use_cursor},
limit
=>
$opts
->{limit},
prepare_only
=> 1,
return_sth
=> 1,
no_distinct
=>
$opts
->{no_distinct},
RaiseError
=>1,
timeout
=>
$opts
->{timeout},
});
}
sub
get_pmlrf_relation_map {
my
(
$self
)=
@_
;
$self
->init_relation_maps;
return
$self
->{pmlrf_relations_map};
}
sub
init_relation_maps {
my
(
$self
)=
@_
;
return
if
ref
$self
->{pmlrf_relations_map};
my
@types
= @{
$self
->get_node_types};
my
%pmlrf_relations
;
my
@pmlrf_relations
;
my
@user_relations
;
{
my
%pmlref_map
;
foreach
my
$node_type
(
@types
) {
my
$schema_name
=
$self
->get_schema_name_for(
$node_type
);
if
(!
exists
$pmlref_map
{
$schema_name
}) {
my
$results
=
$self
->run_sql_query(
qq(SELECT "ref_type", "target_layer", "target_type" FROM "${schema_name}__#pmlref_map")
,{
RaiseError
=>1 });
my
$pmlref_map
=
$pmlref_map
{
$schema_name
} = {};
for
my
$r
(
@$results
) {
$pmlref_map
->{
$r
->[0]} =
$r
;
}
}
my
$decl
=
$self
->get_decl_for(
$node_type
);
my
@attributes
=
$decl
->get_attribute_paths({
no_nodes
=>1,
no_childnodes
=> 1});
foreach
my
$p
(
@attributes
) {
my
$attr_decl_path
=
$decl
->find(
$p
)->get_decl_path;
$attr_decl_path
=~s{^!([^/]*?)(?:\.type)?(/|$)}{$1$2};
my
$target
=
$pmlref_map
{
$schema_name
}{
$attr_decl_path
};
if
(
defined
$target
) {
push
@pmlrf_relations
,
$p
;
$pmlrf_relations
{
$node_type
}{
$p
}=
$target
;
}
}
}
}
{
my
%usr_rel
;
my
$usr_rels
=
$self
->run_sql_query(
qq(SELECT "relname", "reverse", "node_type", "target_node_type", "tbl" FROM "#PML_USR_REL")
,
{
RaiseError
=>1 });
for
my
$r
(
@$usr_rels
) {
push
@user_relations
,
$r
->[0];
push
@user_relations
,
$r
->[1]
if
$r
->[1];
$usr_rel
{
$r
->[2] }{
$r
->[0] } = [
$r
->[4],
undef
,
$r
->[3] ]
if
$r
->[0];
$usr_rel
{
$r
->[3] }{
$r
->[1] } = [
undef
,
$r
->[0],
$r
->[2] ]
if
$r
->[1];
}
$self
->{user_defined_relations} = \
@user_relations
;
$self
->{user_defined_relations_map} = \
%usr_rel
;
}
my
@relations
=
sort
(uniq(
@user_relations
,
@pmlrf_relations
));
$self
->{specific_relations} = \
@relations
;
$self
->{pmlrf_relations} = [
sort
(uniq(
@pmlrf_relations
))];
$self
->{pmlrf_relations_map} = \
%pmlrf_relations
;
return
;
}
sub
get_pmlrf_relation_map_for_type {
my
(
$self
,
$type
)=
@_
;
my
$map
=
$self
->get_pmlrf_relation_map;
return
$map
->{
$type
}
if
exists
$map
->{
$type
};
my
%rels
;
for
my
$nt
(
keys
%$map
) {
for
my
$rel
(@{
$self
->{pmlrf_relations}}) {
if
(
$rel
and
exists
(
$map
->{
$nt
}{
$rel
}) and ((
$nt
.
'/'
.
$rel
) =~ m{^\Q
$type
\E/(.*)$})) {
$rels
{$1}=
$map
->{
$nt
}{
$rel
};
}
}
}
return
$map
->{
$type
}=\
%rels
;
}
sub
get_user_defined_relations {
my
(
$self
,
$type
)=
@_
;
if
(
$type
) {
my
$map
=
$self
->get_user_defined_relation_map();
$map
=
ref
(
$map
) &&
$map
->{
$type
};
return
$map
? [
sort
keys
%$map
] : [];
}
else
{
$self
->init_relation_maps;
return
$self
->{user_defined_relations};
}
}
sub
get_pmlrf_relations {
my
(
$self
,
$type
)=
@_
;
if
(
$type
) {
my
$map
=
$self
->get_pmlrf_relation_map();
return
[]
unless
ref
$map
;
my
$rels
=
$map
->{
$type
};
my
$path
=
''
;
while
(!
$rels
and
$type
=~s{/([^/]+)$}{}) {
$path
= $1.
'/'
.
$path
;
$rels
=
$map
->{
$type
};
}
return
$rels
? [
map
{ /^\Q
$path
\E(.*)/ ? $1 : () }
sort
keys
%$rels
] : [];
}
else
{
$self
->init_relation_maps;
return
$self
->{pmlrf_relations};
}
}
sub
get_specific_relations {
my
$self
=
shift
;
return
[uniq(
@{
$self
->get_pmlrf_relations(
@_
)},
@{
$self
->get_user_defined_relations(
@_
)},
)];
}
sub
get_user_defined_relation_map {
my
(
$self
)=
@_
;
$self
->init_relation_maps;
return
$self
->{user_defined_relations_map};
}
sub
get_user_defined_relation_map_for_type {
my
(
$self
,
$type
)=
@_
;
my
$map
=
$self
->get_user_defined_relation_map;
return
$map
->{
$type
}
if
exists
$map
->{
$type
};
return
;
}
sub
get_relation_target_type {
my
(
$self
,
$node_type
,
$relation
,
$full
)=
@_
;
my
$i
=0;
for
my
$map
({
$node_type
=>
$self
->get_pmlrf_relation_map_for_type(
$node_type
) },
$self
->get_user_defined_relation_map) {
my
$target
=
$map
->{
$node_type
} &&
$map
->{
$node_type
}{
$relation
};
if
(
$target
) {
return
$full
? [
$i
,
$target
] :
$target
->[2];
}
$i
++;
}
return
;
}
sub
prepare_query {
my
(
$self
,
$query_tree
,
$opts
)=
@_
;
$opts
||={};
unless
(
ref
(
$query_tree
)) {
$query_tree
= PMLTQ::Common::parse_query(
$query_tree
,{
pmlrf_relations
=>
$self
->get_pmlrf_relations,
user_defined_relations
=>
$self
->get_user_defined_relations,
});
}
my
$use_planner
=
USE_PLANNER eq
'always'
? 1
: USE_PLANNER eq
'forests'
? ( (
$query_tree
->children > 0) ? 1 : 0 )
: 0;
$self
->{id} =
$query_tree
->{id} ||
'no_ID'
;
$self
->{query_nodes} = [PMLTQ::Common::FilterQueryNodes(
$query_tree
)];
{
my
%id
;
my
%name2node_hash
;
my
@nodes
=
grep
{
$_
->{
'#name'
} =~ /^(?:node|subquery)$/ }
$query_tree
->descendants;
my
%node_types
=
map
{
$_
=> 1 } @{
$self
->get_node_types};
my
%schema_names
=
map
{
$_
=> 1 } @{
$self
->get_schema_names};
my
$default_type
=
$query_tree
->{
'node-type'
};
if
(
$default_type
and !
$node_types
{
$default_type
}) {
die
"The query specifies an invalid type '$default_type' as default node type!"
;
}
for
my
$node
(
@nodes
) {
{
my
$n
=
$node
->{name};
if
(
defined
(
$n
) and
length
(
$n
)) {
if
(
exists
$name2node_hash
{
$n
}) {
die
"Name \$$n used for more than one selector!\n"
;
}
$name2node_hash
{
$n
}=
$node
;
}
}
if
(PMLTQ::Common::IsMemberNode(
$node
)) {
if
(
$node
->{
'node-type'
}) {
my
$type
= PMLTQ::Common::GetMemberNodeType(
$node
,
$self
);
unless
(
$self
->get_decl_for(
$type
)) {
die
"Invalid type attribute path '$type' for member "
.PMLTQ::Common::as_text(
$node
).
"\n"
;
}
}
else
{
die
"Member must specify attribute name: "
.PMLTQ::Common::as_text(
$node
).
"\n"
;
}
next
;
}
elsif
(
$node
->{
'node-type'
} eq
'*'
) {
if
(
keys
(
%schema_names
)>1) {
my
(
$rel
) = SeqV(
$node
->{relation});
$rel
=
$rel
?
$rel
->name :
''
;
die
"Node-type wildcard '*' cannot be used for data with multiple layers: "
.PMLTQ::Common::as_text(
$node
).
" in relation $rel\n"
.
"\nHint: try one of "
.
join
(
" "
,
map
"$_:*"
,
sort
keys
(
%schema_names
)).
"\n"
;
}
}
elsif
(
$node
->{
'node-type'
} =~ m{^([^/]+):\*$}) {
my
$schema_name
= $1;
if
(!
$schema_names
{
$schema_name
}) {
my
(
$rel
) = SeqV(
$node
->{relation});
$rel
=
$rel
?
$rel
->name :
''
;
die
"The query specifies an invalid schema name '$schema_name' for node: "
.PMLTQ::Common::as_text(
$node
).
" in relation $rel\n"
;
}
}
elsif
(
$node
->{
'node-type'
}) {
if
(!
$node_types
{
$node
->{
'node-type'
}}) {
my
(
$rel
) = SeqV(
$node
->{relation});
$rel
=
$rel
?
$rel
->name :
''
;
die
"The query specifies an invalid type '$node->{'node-type'}' for node: "
.PMLTQ::Common::as_text(
$node
).
" in relation $rel\n"
;
}
}
else
{
my
$parent
=
$node
->parent;
while
(
$parent
and (
$parent
->{
'#name'
}||
''
) !~/^(?:node|subquery)$/) {
$parent
=
$parent
->parent;
}
my
(
$rel
) = SeqV(
$node
->{relation});
my
@types
=
(
$parent
&&
$rel
) ?
(PMLTQ::Common::GetRelativeQueryNodeType(
$parent
->{
'node-type'
},
$self
,
$rel
)
) : @{
$self
->get_node_types};
if
(
@types
== 1) {
$node
->{
'node-type'
} =
$types
[0];
}
elsif
(
$default_type
) {
$node
->{
'node-type'
} =
$default_type
;
}
else
{
die
"Could not determine node type of node in "
.(
$rel
?
'the '
.(
$rel
->name eq
'user-defined'
?
$rel
->value->{label} :
$rel
->name)
:
'an unknown'
).
" relation "
.(
$parent
?
"to $parent->{'#name'} $parent->{'node-type'}:"
:
':'
)
.PMLTQ::Common::as_text(
$node
).
"\n"
.
"Possible types are: "
.
join
(
','
,
@types
).
" !\n"
;
}
}
}
%id
=
map
{
my
$n
=
$_
->{name};
(
defined
(
$n
) and
length
(
$n
)) ? (
$_
=>
$n
) : ()
}
@nodes
;
my
$id
=
'n0'
;
my
%occup
;
@occup
{
values
%id
}=();
for
my
$n
(
@nodes
) {
unless
(
defined
$id
{
$n
} and
length
$id
{
$n
}) {
$id
++
while
exists
$occup
{
$id
};
$id
{
$n
}=
$id
;
if
(
$use_planner
) {
$n
->{name}=
$id
;
}
$occup
{
$id
}=1;
$name2node_hash
{
$id
}=
$n
;
}
}
$self
->{id_map}=\
%id
;
$self
->{name2node}=\
%name2node_hash
;
}
$self
->{query_node_order}=
undef
;
if
(
$use_planner
) {
Treex::PML::Document->determine_node_type(
$_
)
for
(
$query_tree
,
$query_tree
->descendants);
my
$query_nodes
=
$self
->{query_nodes};
$self
->{query_node_order} = {
map
{
$query_nodes
->[
$_
] =>
$_
} 0..
$#$query_nodes
};
my
$roots
= PMLTQ::Planner::plan(
$query_nodes
,
$query_tree
);
for
my
$root
(
@$roots
) {
for
my
$subquery
(
grep
{
$_
->{
'#name'
} eq
'subtree'
}
$root
->descendants) {
my
$subquery_roots
= PMLTQ::Planner::plan(
[PMLTQ::Common::FilterQueryNodes(
$subquery
)],
$subquery
->parent,
$subquery
);
}
}
$self
->{query_nodes} = [PMLTQ::Common::FilterQueryNodes(
$query_tree
)];
}
$self
->{sql}=
undef
;
$self
->{join_id}=0;
my
$sql
=
$self
->serialize_conditions(
$query_tree
,
{
%$opts
,
returns_nodes
=>\
$self
->{returns_nodes},
});
$self
->prepare_sql(
$sql
,
{
use_cursor
=>
$opts
->{use_cursor},
limit
=> (
$self
->{returns_nodes} ?
abs
(
$opts
->{node_limit}||0)||
undef
:
abs
(
$opts
->{row_limit}||0)||
undef
),
timeout
=>
$opts
->{timeout},
no_distinct
=>
$opts
->{no_distinct},
},
);
return
$query_tree
;
}
sub
type_mapper {
my
(
$self
)=
@_
;
return
$self
;
}
sub
get_type_of_node {
my
(
$self
,
$name
)=
@_
;
my
$n
=
$self
->{name2node}{
$name
};
return
$n
&& ( PMLTQ::Common::GetQueryNodeType(
$n
,
$self
) );
}
sub
get_type_decl_for_node {
my
(
$self
,
$name
)=
@_
;
my
$n
=
$self
->{name2node}{
$name
};
my
$node_type
=
$n
&& ( PMLTQ::Common::GetQueryNodeType(
$n
,
$self
) );
return
$node_type
&&
$self
->get_decl_for(
$node_type
);
}
sub
connect
{
my
(
$self
)=
@_
;
return
$self
->{dbi}
if
$self
->{dbi};
my
$cfg
=
$self
->{
connect
};
eval
{
my
$h
= Sys::SigAction::set_sig_handler(
'ALRM'
,
sub
{
die
"timed out connecting to database on $cfg->{host}\n"
;
},
{
flags
=>0 ,
safe
=>0 } );
alarm
(20);
$self
->{layout_version} =
$cfg
->{layout_version}||0;
import
DBD::Pg
qw(:async)
;
my
$string
=
'dbi:Pg:'
.(
$cfg
->{host} ?
'host='
.
$cfg
->{host}.
';'
:
''
)
.(
$cfg
->{database} ?
"database="
.
$cfg
->{database}.
';'
:
''
)
.(
$cfg
->{port} ?
"port="
.
$cfg
->{port} :
''
);
$self
->{dbi} = DBI->
connect
(
$string
,
$cfg
->{username},
$cfg
->{password},
{
RaiseError
=> 1,
AutoCommit
=>0,
ReadOnly
=> 1
}
);
alarm
(0);
die
"Connection failed"
if
not
$self
->{dbi};
};
alarm
(0);
if
($@) {
print
STDERR
"$@"
;
undef
$self
->{dbi};
die
"Unable to connect to the database."
;
}
return
$self
->{dbi};
}
sub
run {
my
(
$self
,
$opts
)=
@_
;
delete
$self
->{results};
$opts
||={};
my
$dbi
=
$self
->{dbi} ||
$self
->
connect
||
die
(
"Not connected to DBI!\n"
);
my
$timeout
=
$opts
->{timeout};
my
$t0
= new Benchmark;
my
$results
=
eval
{
if
(
$opts
->{use_cursor}) {
my
$buffer
=
$self
->cursor_next(1);
$opts
->{return_sth} ?
$self
->{sth} :
$buffer
;
}
else
{
$self
->run_sql_query(
$self
->{sth},{
timeout
=>
$timeout
,
timeout_callback
=>
$opts
->{timeout_callback},
RaiseError
=> 1,
return_sth
=>
$opts
->{return_sth},
use_cursor
=>
$opts
->{use_cursor},
})
}
};
if
($@) {
my
$err
= $@;
$err
=~s/\n/ /g;
if
(
$err
=~ /^TIMEOUT /) {
die
"$self->{id}\tTIMEOUT\t"
.(
$timeout
).
"s\n"
;
}
else
{
die
"$self->{id}\tFAIL\t$err\n"
;
}
return
;
}
my
$t1
= new Benchmark;
my
$time
= timestr(timediff(
$t1
,
$t0
));
unless
(
$opts
->{quiet}) {
my
$no_results
=
$opts
->{return_sth} ?
'?'
:
$opts
->{count} ?
$results
->[0][0]
:
scalar
(
@$results
);
print
STDERR
"$self->{id}\tOK\tPg\t$no_results\t$time\n"
if
$self
->{debug};
}
if
(
$opts
->{return_sth}) {
return
$results
;
}
else
{
return
$self
->{results}=
$results
;
}
}
sub
find_special_attribute {
my
(
$self
,
$decl
,
$role
)=
@_
;
if
(
$decl
->get_decl_type == PML_ELEMENT_DECL) {
$decl
=
$decl
->get_content_decl;
}
my
(
$m
)=
$decl
->can(
'find_members_by_role'
) &&
$decl
->find_members_by_role(
$role
);
return
$m
&&
$m
->get_name;
}
sub
idx_to_pos {
my
(
$self
,
$idx_list
,
$force_id
)=
@_
;
my
@res
;
my
%id_attr
;
my
$layout
=
$self
->{layout_version};
for
my
$ident
(
@$idx_list
) {
my
(
$idx
,
$type
)=
split
'/'
,
$ident
,2;
$idx
=
int
(
$idx
);
my
$node_id
;
if
(
$type
=~s{[+@](.*)$}{}) {
$node_id
= $1;
}
my
$basename
=
$self
->get_schema_name_for(
$type
);
my
$node_tab
=
$self
->get_node_table_for(
$type
);
my
$id_attrs
=
''
;
if
(
$layout
>1) {
unless
(
exists
(
$id_attr
{
$type
})) {
my
$decl
=
$self
->get_decl_for(
$type
);
$id_attr
{
$type
} =
$self
->find_special_attribute(
$decl
,
'#ID'
);
}
$id_attrs
=
$id_attr
{
$type
} ?
qq{, "n"."$id_attr{$type}
",
"f"
.
"top"
} :
q{, null, "f"."top"}
;
}
my
$sql
=
<<"EOF". "LIMIT 1;";
SELECT "f"."file", "f"."tree_no", "n"."#idx"-"n"."#root_idx" $id_attrs
FROM "${node_tab}" "n" JOIN "${basename}__#files" "f" ON "n"."#root_idx"="f"."#idx"
WHERE "n"."#idx" = ${idx}
EOF
my
$result
=
$self
->run_sql_query(
$sql
,{
MaxRows
=>1,
RaiseError
=>1 });
$result
=
$result
->[0];
my
(
$fn
,
$tn
,
$nn
,
$id
,
$is_top
) =
@$result
;
if
(
defined
(
$id
) and (!
$is_top
||
$force_id
)) {
push
@res
,
$fn
.
'#'
.
$id
;
}
else
{
push
@res
,
$fn
.
'##'
.(
$tn
+1).
'.'
.
$nn
;
}
}
return
@res
;
}
sub
ids_to_pos {
my
(
$self
,
$ids
,
$id_suffix
)=
@_
;
my
$resolved
= 0;
my
@sql
;
my
$top_col
;
if
(
$self
->{layout_version}>1) {
$top_col
=
q{, "f"."top"}
;
}
else
{
$top_col
=
q{, 1}
;
}
foreach
my
$node_type
(@{
$self
->get_node_types}) {
my
$decl
=
$self
->get_decl_for(
$node_type
);
my
$id_attr
=
$self
->find_special_attribute(
$decl
,
'#ID'
);
next
unless
$id_attr
;
my
$node_tab
=
$self
->get_node_table_for(
$node_type
);
my
$basename
=
$self
->get_schema_name_for(
$node_type
);
my
$id_tests
=
join
(
' OR '
,
map
{
my
$id
=
$_
;
$id
=~s{'}{}g;
$id
=~s{\\}{}g;
qq{"n"."$id_attr" = '$id'}
}
@$ids
);
my
$sql
;
$sql
=
<<"EOF";
SELECT "f"."file", "f"."tree_no", "n"."#idx"-"n"."#root_idx", "n"."$id_attr"$top_col
FROM "${node_tab}" "n" JOIN "${basename}__#files" "f" ON "n"."#root_idx"="f"."#idx"
WHERE $id_tests
EOF
push
@sql
,
$sql
;
}
my
$sql
=
join
(
" UNION\n"
,
@sql
);
my
$rows
=
$self
->run_sql_query(
$sql
,{
MaxRows
=>
scalar
(
@$ids
),
RaiseError
=>1 });
my
%result
=
map
{
$_
->[3] =>
$_
,
}
@$rows
;
my
@res
;
for
my
$id
(
@$ids
) {
my
$row
=
$result
{
$id
};
if
(
$row
) {
my
(
$fn
,
$tn
,
$nn
,
undef
,
$is_top
) =
@$row
;
if
(
$id_suffix
or !(
lc
(
$is_top
) eq
'true'
or
$is_top
==1)) {
push
@res
,
$fn
.
'#'
.
$id
;
}
else
{
push
@res
,
$fn
.
'##'
.(
$tn
+1).
'.'
.
$nn
;
}
}
else
{
push
@res
,
undef
;
}
}
return
@res
;
}
sub
close_cursor {
my
(
$self
)=
@_
;
my
$dbi
=
$self
->{dbi} ||
die
"Not connected to DBI!\n"
;
my
$cursor
=
delete
$self
->{cursor};
return
unless
$cursor
;
my
$close
=
delete
$cursor
->{
close
};
$close
->(
$self
)
if
$close
;
delete
$cursor
->{distinct};
return
$cursor
;
}
sub
cursor_sth {
my
(
$self
)=
@_
;
return
$self
->{cursor} ?
$self
->{cursor}{sth} :
undef
;
}
sub
cursor_next {
my
(
$self
,
$keep
)=
@_
;
my
$cursor
=
$self
->{cursor};
my
$csr
=
$cursor
->{name};
my
$buffer
=
$cursor
->{buffer}||=[];
my
$sth
=
$cursor
->{sth};
my
$distinct
=
$cursor
->{distinct};
if
(!
@$buffer
and (!
defined
(
$cursor
->{limit}) or
$cursor
->{limit}>0)) {
$cursor
->{buffer}=[];
my
$size
=
$cursor
->{buffer_size};
while
(1) {
if
(
$csr
) {
if
(
defined
(
$cursor
->{limit}) and
$cursor
->{limit}<
$size
) {
$size
=
$cursor
->{buffer_size} =
$cursor
->{limit};
if
(
$distinct
) {
my
$ratio
=
$cursor
->{ratio} ? (
$cursor
->{ratio}[0]/
$cursor
->{ratio}[1]) :
undef
;
$size
=
$ratio
?
int
(
$size
/
$ratio
)+1 :
$size
;
}
$sth
=
$cursor
->{sth} =
$self
->{dbi}->prepare(
qq{FETCH $size FROM "$csr"}
,{
pg_async
=> 1 });
}
my
$opts
= {
timeout
=>
$cursor
->{timeout},
update_timeout
=>1 };
$buffer
=
$self
->run_sql_query(
$sth
,
$opts
);
$cursor
->{timeout} =
$opts
->{timeout};
}
else
{
if
(
defined
(
$cursor
->{limit}) and
$cursor
->{limit}<
$size
) {
$size
=
$cursor
->{buffer_size} =
$cursor
->{limit};
}
$buffer
=
$sth
->fetchall_arrayref(
undef
,
$size
);
}
if
(
$buffer
and
@$buffer
and
$distinct
) {
no
warnings;
foreach
my
$row
(
@$buffer
) {
my
$key
=
join
(
"\x0"
,
@$row
);
unless
(
exists
$distinct
->{
$key
}) {
push
@{
$cursor
->{buffer}},
$row
;
$distinct
->{
$key
}=
undef
;
}
}
$buffer
=
$cursor
->{buffer};
$cursor
->{ratio}||=[0,0];
$cursor
->{ratio}[0]+=
scalar
(
@$buffer
);
$cursor
->{ratio}[1]+=
$size
;
next
if
!
@$buffer
;
}
elsif
(
$distinct
) {
$cursor
->{buffer} =
$buffer
;
}
else
{
$cursor
->{buffer} =
$buffer
;
}
last
;
}
if
(
defined
(
$cursor
->{limit}) and
$buffer
) {
splice
(
@$buffer
,
$cursor
->{limit})
if
(
@$buffer
>
$cursor
->{limit});
$cursor
->{limit} -=
scalar
(
@$buffer
);
}
}
if
(
$buffer
and
@$buffer
) {
return
$keep
?
$buffer
:
shift
(
@$buffer
);
}
else
{
return
;
}
}
sub
run_sql_query {
my
(
$self
,
$sql_or_sth
,
$opts
)=
@_
;
my
$dbi
=
$self
->{dbi} ||
die
"Not connected to DBI!\n"
;
local
$dbi
->{RaiseError} =
$opts
->{RaiseError};
local
$dbi
->{LongReadLen} =
$opts
->{LongReadLen}
if
exists
(
$opts
->{LongReadLen});
my
$canceled
= 0;
if
(
$opts
->{use_cursor}) {
$self
->close_cursor
if
$self
->{cursor};
my
$cursor
=
$self
->{cursor} = {};
my
$size
=
$opts
->{cursor_buffer_size} || 10_000;
$cursor
->{limit} =
$opts
->{limit} ||
$size
;
$size
=
$cursor
->{limit}
if
$cursor
->{limit} <
$size
;
$cursor
->{buffer_size} =
$size
;
$cursor
->{distinct}={}
if
(
$opts
->{no_distinct} and
$self
->{returns_nodes});
$cursor
->{timeout} =
$opts
->{timeout};
my
$csr
=
"pmltq_"
.$$;
$cursor
->{name}=
$csr
;
eval
{
$dbi
->
do
(
qq{DECLARE "$csr" CURSOR FOR }
.
$sql_or_sth
);
};
my
$err
= $@;
if
(
$err
) {
$dbi
->rollback();
die
$err
;
}
$cursor
->{
close
} =
sub
{
eval
{
$dbi
->
do
(
qq{CLOSE "$csr"}
) };
$dbi
->rollback()
if
$@;
};
if
(
$opts
->{return_sth}) {
$cursor
->{sth} =
$dbi
->prepare(
qq{FETCH $size FROM "$csr"}
,{
pg_async
=> 1 });
if
(
$opts
->{prepare_only}) {
$self
->{sth} =
$cursor
->{sth};
}
return
$cursor
->{sth};
}
else
{
return
;
}
}
my
$sth
=
ref
(
$sql_or_sth
) ?
$sql_or_sth
:
$dbi
->prepare(
$sql_or_sth
,{
pg_async
=> 1 } );
if
(
$opts
->{use_cursor}) {
$self
->{cursor}{sth}=
$sth
;
}
if
(
$opts
->{prepare_only}) {
if
(
$opts
->{return_sth} ) {
return
$self
->{sth} =
$sth
;
}
else
{
return
;
}
}
my
$step
=0.05;
my
$time
=
$opts
->{timeout};
eval
{
$sth
->execute(
ref
(
$opts
->{Bind}) ? @{
$opts
->{Bind}} : ());
if
(
defined
$time
) {
while
(!
$sth
->pg_ready) {
$time
-=
$step
;
Time::HiRes::
sleep
(
$step
);
if
(
$time
<=0) {
if
(
$opts
->{
'timeout_callback'
} and
$opts
->{
'timeout_callback'
}->(
$self
)) {
$time
=
$opts
->{timeout};
}
else
{
$sth
->pg_cancel();
$opts
->{timeout} = 0
if
$opts
->{update_timeout};
die
"TIMEOUT\n"
}
}
}
}
$sth
->pg_result;
};
my
$err
= $@;
if
(
$err
) {
$dbi
->rollback();
die
$err
;
}
$opts
->{timeout} =
$time
if
$opts
->{update_timeout};
if
(
$opts
->{return_sth}) {
return
$sth
;
}
elsif
(
$opts
->{use_cursor}) {
return
;
}
else
{
return
$sth
->fetchall_arrayref(
undef
,
$opts
->{limit});
}
}
sub
serialize_conditions {
my
(
$self
,
$node
,
$opts
)=
@_
;
$opts
||={};
if
(
$node
->parent or
$opts
->{output_filter}) {
return
[
$self
->serialize_element({
%$opts
,
name
=>
'and'
,
condition
=>
$node
,
is_positive_conjunct
=> 1,
})];
}
else
{
return
$self
->build_sql(
$node
,{
node_IDs
=>
$opts
->{node_IDs},
returns_nodes
=>
$opts
->{returns_nodes},
no_filters
=>
$opts
->{no_filters},
count
=>
$opts
->{count},
node_limit
=>
$opts
->{node_limit},
row_limit
=>
$opts
->{row_limit},
select_first
=>
$opts
->{select_first},
no_distinct
=>
$opts
->{no_distinct},
});
}
}
sub
relation {
my
(
$self
,
$id
,
$rel
,
$target
,
$opts
)=
@_
;
my
$relation
=
$rel
->name;
my
$params
=
$rel
->value;
if
(
$relation
eq
'ancestor'
) {
$relation
=
'descendant'
;
(
$id
,
$target
)=(
$target
,
$id
);
}
elsif
(
$relation
eq
'parent'
) {
$relation
=
'child'
;
(
$id
,
$target
)=(
$target
,
$id
);
}
elsif
(
$relation
eq
'order-follows'
) {
$relation
=
'order-precedes'
;
(
$id
,
$target
)=(
$target
,
$id
);
}
elsif
(
$relation
eq
'depth-first-follows'
) {
$relation
=
'depth-first-precedes'
;
(
$id
,
$target
)=(
$target
,
$id
);
}
my
$cond
;
if
(
$relation
eq
'user-defined'
) {
return
$self
->user_defined_relation(
$id
,
$params
,
$target
,
$opts
);
}
elsif
(
$relation
eq
'descendant'
) {
$cond
=
qq{"$id"."#root_idx"="$target"."#root_idx" AND "$id"."#idx"!="$target"."#idx" AND }
.
qq{"$target"."#idx" BETWEEN "$id"."#idx" AND "$id"."#r"}
;
my
$min
=
$params
->{min_length}||0;
my
$max
=
$params
->{max_length}||0;
if
(
$min
>0 and
$max
>0) {
$cond
.=
qq{ AND "$target"."#lvl"-"$id"."#lvl" BETWEEN $min AND $max}
;
}
elsif
(
$min
>0) {
$cond
.=
qq{ AND "$target"."#lvl"-"$id"."#lvl">=$min}
}
elsif
(
$max
>0) {
$cond
.=
qq{ AND "$target"."#lvl"-"$id"."#lvl"<=$max}
}
}
elsif
(
$relation
eq
'sibling'
) {
$cond
=
qq{"$id"."#parent_idx"="$target"."#parent_idx" AND "$id"."#idx"!="$target"."#idx"}
;
my
$min
=
$params
->{min_length};
my
$max
=
$params
->{max_length};
if
(
$min
and
$max
) {
$cond
.=
qq{ AND "$target"."#chord"-"$id"."#chord" BETWEEN $min AND $max}
;
}
elsif
(
$min
) {
$cond
.=
qq{ AND "$target"."#chord"-"$id"."#chord">=$min}
}
elsif
(
$max
) {
$cond
.=
qq{ AND "$target"."#chord"-"$id"."#chord"<=$max}
}
}
elsif
(
$relation
eq
'child'
) {
$cond
=
qq{"$id"."#idx"="$target"."#parent_idx"}
;
}
elsif
(
$relation
eq
'depth-first-precedes'
) {
$cond
=
qq{"$id"."#root_idx"="$target"."#root_idx"}
;
my
$min
=
$params
->{min_length}||0;
my
$max
=
$params
->{max_length}||0;
if
(
$min
!=0 and
$max
!=0) {
$cond
.=
qq{ AND "$target"."#idx"-"$id"."#idx" BETWEEN $min AND $max}
.
((
$min
>0 or
$max
<0) ?
q{}
:
qq{ AND "$target"."#idx"!="$id"."#idx"}
)
}
elsif
(
$min
!=0) {
$cond
.=
qq{ AND "$target"."#idx"-"$id"."#idx">=$min}
.(
$min
>0 ?
q{}
:
qq{ AND "$target"."#idx"!="$id"."#idx"}
);
}
elsif
(
$max
!=0) {
$cond
.=
qq{ AND "$target"."#idx"-"$id"."#idx"<=$max}
.(
$max
<0 ?
q{}
:
qq{ AND "$target"."#idx"!="$id"."#idx"}
);
}
else
{
$cond
.=
qq{ AND "$target"."#idx">"$id"."#idx"}
}
}
elsif
(
$relation
eq
'same-tree-as'
) {
$cond
=
qq{"$id"."#root_idx"="$target"."#root_idx"}
;
}
elsif
(
$relation
eq
'same-document-as'
) {
$cond
=
$self
->serialize_predicate(
{
id
=>
$opts
->{id},
type
=>
$opts
->{type},
join
=>
$opts
->{
join
},
is_positive_conjunct
=>
$opts
->{is_positive_conjunct},
expression
=>
qq{file(\$$target)}
,
},
{
id
=>
$opts
->{id},
type
=>
$opts
->{type},
join
=>
$opts
->{
join
},
is_positive_conjunct
=>
$opts
->{is_positive_conjunct},
expression
=>
qq{file(\$$id)}
,
},
'='
,
$opts
);
}
elsif
(
$relation
eq
'order-precedes'
) {
my
$flags
=
$self
->get_schema_flags(
$self
->get_schema_name_for(
$opts
->{type}));
my
(
$S
,
$T
);
if
(
defined
(
$flags
) and (
$flags
& MAX_MIN_ORD)>0) {
$S
= {
sql
=>
qq{"$id"."#max_ord"}
,
col_type
=> COL_NUMERIC,
};
$T
= {
sql
=>
qq{"$target"."#min_ord"}
,
col_type
=> COL_NUMERIC,
};
}
else
{
my
$decl
=
$self
->get_decl_for(
$opts
->{type});
my
$order
=
$self
->find_special_attribute(
$decl
,
'#ORDER'
);
if
(
$order
) {
$T
= {
id
=>
$opts
->{id},
type
=>
$opts
->{type},
join
=>
$opts
->{
join
},
is_positive_conjunct
=>
$opts
->{is_positive_conjunct},
expression
=>
qq{\$$target.$order}
,
};
$S
= {
id
=>
$opts
->{id},
type
=>
$opts
->{type},
join
=>
$opts
->{
join
},
is_positive_conjunct
=>
$opts
->{is_positive_conjunct},
expression
=>
qq{\$$id.$order}
,
};
}
}
if
(not
defined
(
$S
)) {
die
"No ordering is defined on nodes of type '$opts->{type}'!\n"
;
}
my
(
$min
,
$max
)=
map
{ (
defined
(
$_
) and
length
(
$_
)) ?
$_
:
undef
}
map
{
$params
->{
$_
} }
qw(min_length max_length)
;
$cond
=
qq{"$id"."#root_idx"="$target"."#root_idx" AND }
;
if
(
defined
(
$min
) and
defined
(
$max
)) {
$cond
.=
$self
->serialize_predicate(
$T
,
$S
,
qq{<$min,$max>}
,
$opts
)
.((
$min
>0 or
$max
<0) ?
q{}
:
qq{ AND "$target"."#idx"!="$id"."#idx"}
);
}
elsif
(
defined
(
$min
)) {
$cond
.=
$self
->serialize_predicate(
$T
,
$S
,
qq{<$min,>}
,
$opts
)
.(
$min
>0 ?
q{}
:
qq{ AND "$target"."#idx"!="$id"."#idx"}
);
}
elsif
(
defined
(
$max
)) {
$cond
.=
$self
->serialize_predicate(
$T
,
$S
,
qq{<,$max>}
,
$opts
)
.(
$max
<0 ?
q{}
:
qq{ AND "$target"."#idx"!="$id"."#idx"}
);
}
else
{
$cond
.=
$self
->serialize_predicate(
$T
,
$S
,
'>'
,
$opts
);
}
}
elsif
(
$relation
eq
'member'
) {
my
$path
=
$self
->{name2node}{
$target
}{
'node-type'
};
$cond
=
$self
->serialize_predicate(
{
id
=>
$opts
->{id},
type
=>
$opts
->{type},
join
=>
$opts
->{
join
},
is_positive_conjunct
=>
$opts
->{is_positive_conjunct},
expression
=>
qq{\$$id.$path}
,
allow_non_atomic
=> 1,
},
qq{"$target"."#idx"}
,
q(=)
,
$opts
,
);
}
else
{
die
"Unsupported relation: $relation between nodes $id and $target\n"
;
}
return
$cond
;
}
sub
_is_transitive {
my
(
$min
,
$max
)=
@_
;
return
((!(
defined
(
$min
) &&
length
(
$min
))
&& !(
defined
(
$max
) &&
length
(
$max
))) || (
defined
(
$max
) &&
$max
==1)) ? 0 : 1;
}
sub
user_defined_relation {
my
(
$self
,
$id
,
$params
,
$target
,
$opts
)=
@_
;
my
$relation
=
$params
->{label};
my
$type
=
$opts
->{type};
my
$cond
;
my
$from_id
=
$opts
->{id};
my
$target_spec
=
$self
->get_relation_target_type(
$type
,
$relation
,1);
if
(
$target_spec
and
$target_spec
->[0] == 1
and !
$target_spec
->[1][0]) {
(
$id
,
$target
)=(
$target
,
$id
);
$target_spec
=
$self
->get_relation_target_type(
$type
,
$target_spec
->[1][1],1);
$relation
=
$target_spec
->[1][1]
if
$target_spec
;
}
unless
(
$target_spec
) {
die
"Relation '$relation' not defined for nodes of type '$type'. "
.
"\nPossible PMLREF relations: "
.
join
(
', '
,@{
$self
->get_pmlrf_relations(
$type
)}).
"\nPossible user-defined relations: "
.
join
(
', '
,@{
$self
->get_user_defined_relations(
$type
)});
}
my
$min
=
$params
->{min_length};
my
$max
=
$params
->{max_length};
if
(
defined
(
$min
) &&
length
(
$min
) &&
defined
(
$max
) &&
length
(
$min
) && (
$min
>
$max
)) {
die
"Invalid bounds for transitive relation '$relation\{$min,$max}'\n"
;
}
if
((
defined
(
$min
) &&
length
(
$min
) ||
defined
(
$max
) &&
length
(
$min
)) and
$type
ne
$target_spec
->[1][2]) {
die
"Cannot create transitive closure for relation with different start-node and end-node types: '$type' -> '$target_spec->[1][2]'\n"
;
}
my
$transitive
= _is_transitive(
$min
,
$max
);
if
(
$target_spec
->[0]==0) {
my
$path
=
$relation
;
if
(
$path
=~/\.rf$/) {
my
$decl
=
$self
->get_decl_for(
$type
);
$decl
=
$decl
&&
$decl
->find(
$relation
);
if
(
$decl
) {
if
(
$decl
->get_decl_type == PML_CDATA_DECL and
$decl
->get_format eq
'PMLREF'
) {
$path
=~s/\.rf$//;
}
}
}
if
(
$transitive
) {
my
$rec_table
=
$self
->precompute_table({
type
=>
$type
,
path
=>
$path
,
recursive
=>1,
max
=>
$max
});
$cond
=
$self
->tabular_relation(
$opts
,
"#rec_"
.
$rec_table
->{name},
$id
,
$target
,
$min
,
$max
);
}
else
{
$cond
=
$self
->serialize_predicate(
{
id
=>
$from_id
,
type
=>
$type
,
join
=>
$opts
->{
join
},
expression
=>
qq{\$$id.$path}
,
is_positive_conjunct
=>
$opts
->{is_positive_conjunct},
},
qq{"$target"."#idx"}
,
q(=)
,
$opts
,
);
}
}
else
{
my
$table
=
$target_spec
->[1][0];
if
(
$transitive
) {
my
$rec_table
=
$self
->precompute_table({
type
=>
$type
,
table
=>
$table
,
recursive
=>1,
max
=>
$max
});
$table
=
"#rec_"
.
$rec_table
->{name};
$cond
=
$self
->tabular_relation(
$opts
,
$table
,
$id
,
$target
,
$min
,
$max
);
}
else
{
$cond
=
$self
->tabular_relation(
$opts
,
$table
,
$id
,
$target
,
undef
,
undef
);
}
}
return
$cond
;
}
sub
precompute_table {
my
(
$self
,
$spec
)=
@_
;
my
$precomputed
=
$self
->{precompute_recursive_relation}||={};
my
$rec_table
;
my
$table
;
if
(
$spec
->{table}) {
$table
=
$spec
->{table}
}
else
{
$table
=
$spec
->{type}.
'/'
.
$spec
->{path};
}
if
(
exists
(
$precomputed
->{
$table
})) {
$rec_table
=
$precomputed
->{
$table
};
if
(
$spec
->{recursive} and !
$rec_table
->{recursive}) {
$rec_table
->{recursive}=1;
$rec_table
->{max}=
$spec
->{max}
}
elsif
(
$spec
->{recursive}) {
if
(
defined
(
$spec
->{max})) {
$rec_table
->{max} =
$spec
->{max}
if
defined
(
$rec_table
->{max}) and
$spec
->{max}>
$rec_table
->{max};
}
else
{
$rec_table
->{max}=
undef
;
}
}
}
else
{
$rec_table
=
$spec
;
$rec_table
->{name}=
scalar
(
keys
(
%$precomputed
));
$precomputed
->{
$table
} =
$rec_table
;
}
return
$rec_table
;
}
sub
tabular_relation {
my
(
$self
,
$opts
,
$table
,
$id
,
$target
,
$min
,
$max
)=
@_
;
my
$join
=
$opts
->{
join
};
my
$depth
=
''
;
if
(
defined
(
$min
) and
defined
(
$max
)) {
$depth
=
" AND %s.depth BETWEEN $min AND $max"
}
elsif
(
defined
(
$min
)) {
$depth
=
" AND %s.depth >= $min"
}
elsif
(
defined
(
$max
)) {
$depth
=
" AND %s.depth <= $max"
}
if
(
$opts
->{is_positive_conjunct}) {
my
$join_to
;
if
(
$opts
->{subquery}) {
$join_to
=
$opts
->{id} eq
$id
?
$id
:
$target
;
}
else
{
$join_to
=
$opts
->{id} eq
$id
?
$target
:
$id
;
}
my
$J
= (
$join
->{
$join_to
}||=[]);
my
$i
=
@$J
;
my
$eid
=
$join_to
.
"/U-$i"
;
$depth
=
sprintf
(
$depth
,
qq{"$eid"}
);
if
(
$join_to
eq
$target
) {
push
@$J
,[
$eid
,
$table
,
qq{"$eid"."#value"="$target"."#idx"}
.
$depth
];
return
qq("$eid"."#idx" = "$id"."#idx")
;
}
else
{
push
@$J
,[
$eid
,
$table
,
qq("$eid"."#idx" = "$id"."#idx")
.
$depth
];
return
qq{"$eid"."#value"="$target"."#idx"}
;
}
}
else
{
$depth
=
sprintf
(
$depth
,
'x'
);
return
qq{ EXISTS (SELECT 1 FROM "$table" x WHERE x."#idx" = "$id"."#idx" AND x."#value"="$target"."#idx"${depth}
) };
}
}
sub
get_tabspec {
my
(
$self
,
$id
,
$node_type
,
$n
)=
@_
;
my
$tabspec
;
if
(PMLTQ::Common::IsMemberNode(
$n
,
$self
)) {
my
$query_type
= PMLTQ::Common::DeclPathToQueryType(
$self
->get_decl_for(
$node_type
)->get_decl_path);
$tabspec
= [
$self
->get_real_table_name(
$query_type
),
$id
,
$n
];
}
else
{
$tabspec
= [
$self
->get_node_table_for(
$node_type
),
$id
,
$n
];
}
return
$tabspec
;
}
sub
build_sql {
my
(
$self
,
$tree
,
$opts
)=
@_
;
$opts
||={};
my
(
$format
,
$count
,
$tree_parent_id
) =
map
{
$opts
->{
$_
}}
qw(format count parent_id)
;
$count
||=0;
my
@nodes
= PMLTQ::Common::FilterQueryNodes(
$tree
);
my
@select
;
my
@table
;
my
@where
;
my
%conditions
;
my
$extra_joins
=
$opts
->{
join
} || {};
local
$self
->{precompute_recursive_relation}
unless
$tree
->parent;
for
(
my
$i
=0;
$i
<
@nodes
;
$i
++) {
my
$n
=
$nodes
[
$i
];
my
$node_type
= PMLTQ::Common::GetQueryNodeType(
$n
,
$self
);
my
$id
=
$self
->{id_map}{
$n
};
push
@select
,
$id
;
my
$parent
=
$n
->parent;
while
(
$parent
and (
$parent
->{
'#name'
}||
''
) !~/^(?:node|subquery)$/) {
$parent
=
$parent
->parent;
}
my
$parent_id
=
defined
(
$parent
) &&
$self
->{id_map}{
$parent
};
$conditions
{
$id
} = PMLTQ::Common::as_text(
$n
);
my
@conditions
;
{
my
$tabspec
=
$self
->get_tabspec(
$id
,
$node_type
,
$n
);
if
(
$parent
&&
$parent
->parent) {
my
$parent_type
= PMLTQ::Common::GetQueryNodeType(
$parent
,
$self
);
my
(
$rel
) = SeqV(
$n
->{relation});
$rel
||= PMLTQ::Common::SetRelation(
$n
,
'child'
);
my
$relation
=
$self
->relation(
$parent_id
,
$rel
,
$id
, {
%$opts
,
id
=>
$id
,
join
=>
$extra_joins
,
subquery
=> (
$n
->{
'#name'
} eq
'subquery'
? 1 : 0),
type
=>PMLTQ::Common::GetQueryNodeType(
$parent
,
$self
),
is_positive_conjunct
=>1,
});
if
((
$n
->{optional} &&
$parent_type
eq
$node_type
) or
$n
->{
'#name'
} eq
'subquery'
or
$rel
->name eq
'same-document-as'
) {
push
@table
,
$tabspec
;
push
@conditions
, [
$relation
,
$n
];
}
else
{
push
@{
$extra_joins
->{
$parent_id
}}, [
$tabspec
->[1],
$tabspec
->[0],
$relation
,
$n
->{optional} ?
'LEFT'
:
''
];
}
}
else
{
push
@table
,
$tabspec
;
}
}
unless
(
$n
->{overlapping}) {
push
@conditions
,
(
map
{
[
qq{"$self->{id_map}
{
$_
}".
"#idx"
}.
(
((
$_
->parent ==
$n
->parent) &&
$conditions
{
$id
} eq
$conditions
{
$self
->{id_map}{
$_
}}) ?
'<'
:
'!='
).
qq{"${id}
".
"#idx"
},
$n
] }
grep
{
my
$type
=PMLTQ::Common::GetQueryNodeType(
$_
,
$self
);
!
$_
->{overlapping} and (
$type
eq
$node_type
)
}
map
{
$nodes
[
$_
] } 0..(
$i
-1));
}
{
my
$conditions
=
$self
->serialize_conditions(
$n
,{
type
=>
$node_type
,
id
=>
$id
,
parent_id
=>
$parent_id
,
join
=>
$extra_joins
,
});
push
@conditions
, [
$conditions
,
$n
]
if
@$conditions
;
}
if
(
$n
->{optional}) {
if
(
@conditions
) {
@conditions
= ( [ [[
'(('
], @{PMLTQ::Common::_group(\
@conditions
,[
"\n AND "
])}, [
qq{) OR "$id"."#idx"="$parent_id"."#idx")}
]],
$n
] );
}
}
push
@where
,
@conditions
;
}
my
@sql
= ([
'SELECT '
]);
my
@outputs
= (
$opts
->{no_filters} ||
$tree
->parent) ? () : PMLTQ::Common::merge_filters(
$tree
->{
'output-filters'
});
my
$returns_nodes
=
$opts
->{returns_nodes} || \
my
$dummy
;
if
(
$count
== 2) {
$$returns_nodes
=0;
push
@sql
,[
'count(DISTINCT "'
.
$self
->{id_map}{
$tree
}.
'"."#idx")'
,
'space'
];
}
elsif
(
$count
== 3) {
$$returns_nodes
=0;
push
@sql
,[
'1'
,
'space'
];
}
elsif
(
$count
) {
$$returns_nodes
=0;
push
@sql
,[
'count(1)'
,
'space'
];
}
elsif
(
@outputs
) {
$$returns_nodes
=0;
push
@sql
, (
(
$opts
->{select_first} ? () : ([
"DISTINCT\n "
])),
map
{
my
$n
=
$nodes
[
$_
];
((
$_
==0 ? () : [
",\n "
,
'space'
]),
[
qq{"$select[$_]"."#idx"}
,
$n
],
[
' AS "'
.
$select
[
$_
].
'.#idx"'
,
$n
],
)
} 0..
$#nodes
);
}
else
{
$$returns_nodes
=1;
my
@order
=
$self
->{query_node_order} ? @{
$self
->{query_node_order}}{
@nodes
} : (0..
$#nodes
);
die
"Internal error: cannot recover query_node_order"
if
@order
!=
@nodes
;
my
$i
=0;
push
@sql
, (
((
$opts
->{select_first} ||
$opts
->{no_distinct}) ? () : ([
"DISTINCT\n "
])),
map
{
my
$o
=
$_
;
my
$n
=
$nodes
[
$o
];
my
$sep
= PMLTQ::Common::IsMemberNode(
$n
) ?
'//'
:
'/'
;
my
$node_type
= PMLTQ::Common::GetQueryNodeType(
$n
,
$self
);
((
$i
++==0 ? () : [
",\n "
,
'space'
]),
[
qq{"$select[$o]"."#idx" || '$sep$node_type' }
.(
$opts
->{node_IDs} ?
do
{
my
@types
;
if
(
$node_type
=~m{^(?:([^/]+):)?\*$}) {
@types
=@{
$self
->get_node_types($1)};
}
else
{
@types
=(
$node_type
);
}
my
@col
;
if
(
$SEPARATE_TREES
==1 or
@types
>1 or (
@types
and
$types
[0] ne
$node_type
)) {
my
$name
=
$self
->{id_map}{
$n
};
@col
=
map
[
$_
,
$self
->join_table_for_type_cast({
id
=>
$name
,
cast
=>
$_
,
join
=>
$extra_joins
,
left
=>(
@types
>1 ? 1 : 0),
}) ],
@types
;
}
else
{
@col
=([
$node_type
,
$select
[
$o
]]);
}
for
my
$col
(
@col
) {
my
$decl
=
$self
->get_decl_for(
$col
->[0]);
$col
->[2] =
$self
->find_special_attribute(
$decl
,
'#ID'
);
}
@col
=
grep
$_
->[2],
@col
;
if
(
@col
==1) {
qq{ || '\@' || "$col[0]->[1]"."$col[0]->[2]" }
}
elsif
(
@col
>1) {
qq{ || '\@' || COALESCE(}
.
join
(
','
,
map
qq{"$_->[1]"."$_->[2]"}
,
@col
).
qq{)}
}
else
{
q{}
}
}
:
''
),
$n
],
[
' AS "'
.
$select
[
$_
].
'.#addr"'
,
$n
],
)
}
@order
);
}
{
my
$i
=0;
my
%seen
;
for
my
$t
(
@table
) {
my
(
$tab
,
$name
,
$node
)=
@$t
;
push
@sql
, (
$i
++)==0 ? [
"\nFROM\n "
,
'space'
] : [
",\n "
,
'space'
];
push
@sql
, [
qq{"$tab" "$name"}
,
$node
];
$self
->serialize_joins(\
@sql
,
$extra_joins
,
$name
,
$node
, \
%seen
);
}
for
my
$name
(
grep
{
$_
ne
'..'
}
keys
%$extra_joins
) {
$self
->serialize_joins(\
@sql
,
$extra_joins
,
$name
,
undef
, \
%seen
);
}
}
my
$have_where
=0;
{
my
@w
=@{PMLTQ::Common::_group(\
@where
,[
"\n AND "
])};
push
@sql
, [
"\nWHERE\n "
,
'space'
],
@w
if
@w
;
$have_where
= 1
if
@w
;
}
if
(
defined
$opts
->{select_first}) {
my
$limit
=
'LIMIT 1'
;
push
@sql
, [
"\n"
.
$limit
,
'space'
];
}
if
(
@outputs
) {
my
$output_opts
;
$$returns_nodes
=0;
my
$first
= first {
$_
->{
'#name'
} eq
'node'
}
$tree
->children;
$output_opts
= {
id
=>
$self
->{id_map}{
$first
},
join
=> {},
referred_nodes
=> {},
};
my
(
@f_sql
,
@f_where
);
push
@f_sql
, [
'SELECT '
];
push
@f_sql
, [
'DISTINCT '
]
if
$outputs
[0]->{distinct};
$output_opts
->{group_by} =
$self
->serialize_columns(
$outputs
[0]->{
'group-by'
},0,
$output_opts
,
'group_by'
);
push
@f_where
, @{
$self
->serialize_conditions(
$outputs
[0]->{
'where'
},
{
%$output_opts
,
output_filter
=>1,
output_filter_where_clause
=>1})}
if
ref
$outputs
[0]->{
'where'
};
push
@f_sql
,[
$self
->serialize_columns(
$outputs
[0]->{
return
},0,
$output_opts
,
'select'
),
'space'
];
$output_opts
->{prev_columns}=
$outputs
[0]->{
return
};
$output_opts
->{column_types} = [
map
$self
->compute_data_type(
$_
,{
%$output_opts
,
output_filter
=>1}), @{
$output_opts
->{prev_columns}}
];
push
@f_sql
, [
" FROM (\n"
];
unshift
@sql
,
@f_sql
;
push
@sql
, [
qq{\n) "#qnodes"\n}
];
{
my
%seen
;
my
@f_table
=
map
{
my
$n
=
$self
->{name2node}{
$_
};
$self
->get_tabspec(
$_
,PMLTQ::Common::GetQueryNodeType(
$n
,
$self
),
$n
)
}
sort
keys
%{
$output_opts
->{referred_nodes}};
for
my
$t
(
@f_table
) {
my
(
$tab
,
$name
,
$node
)=
@$t
;
my
$left
=
$node
->{optional} &&
$node
->parent
&& PMLTQ::Common::GetQueryNodeType(
$node
,
$self
) ne PMLTQ::Common::GetQueryNodeType(
$node
->parent,
$self
);
push
@sql
, [(
$left
?
' LEFT '
:
' '
).
qq{JOIN "$tab" "$name" ON "$name"."#idx"="#qnodes"."$name.#idx"\n}
,
$node
];
$self
->serialize_joins(\
@sql
,
$output_opts
->{
join
},
$name
,
$node
, \
%seen
);
}
for
my
$name
(
grep
{
$_
ne
'..'
}
keys
%{
$output_opts
->{
join
}}) {
$self
->serialize_joins(\
@sql
,
$output_opts
->{
join
},
$name
,
undef
, \
%seen
);
}
}
my
@f_w
=@{PMLTQ::Common::_group(\
@f_where
,[
"\n AND "
])};
push
@sql
, [
"\nWHERE\n "
,
'space'
],
@f_w
if
@f_w
;
my
$group_by
=
delete
$output_opts
->{group_by};
push
@sql
,
(
@$group_by
?
[
"\n GROUP BY "
.
join
(
', '
,
@$group_by
).
"\n"
,
$tree
] : ()),
(
$outputs
[0]->{
'sort-by'
} ?
[
"\n ORDER BY "
.
$self
->serialize_columns(
$outputs
[0]->{
'sort-by'
},1,
$output_opts
,
'order_by'
),
$tree
] : ());
shift
@outputs
;
my
$i
=1;
for
my
$out
(
@outputs
) {
$output_opts
->{group_by} =
$self
->serialize_columns(
$out
->{
'group-by'
},
$i
,
$output_opts
,
'group_by'
);
unshift
@sql
, [
'SELECT '
.(
$out
->{distinct} ?
'DISTINCT '
:
''
)
.
$self
->serialize_columns(
$out
->{
'return'
},
$i
,
$output_opts
,
'select'
).
" FROM (\n"
,
$tree
];
push
@sql
,
[
qq{) "#filter_$i" \n}
,
$tree
];
if
(
$out
->{where}) {
push
@sql
, [
"\nWHERE\n"
,
'space'
],
@{
$self
->serialize_conditions(
$out
->{
'where'
},{
%$output_opts
,
output_filter
=>
$i
+1,
output_filter_where_clause
=>1}) };
}
$output_opts
->{prev_columns}=
$out
->{
'return'
};
$output_opts
->{column_types} = [
map
$self
->compute_data_type(
$_
,{
%$output_opts
,
output_filter
=>
$i
+1}), @{
$output_opts
->{prev_columns}}
];
my
$group_by
=
delete
$output_opts
->{group_by};
push
@sql
,
(
@$group_by
?
[
"\n GROUP BY "
.
join
(
', '
,
@$group_by
).
"\n"
,
$tree
] : ()),
(
$out
->{
'sort-by'
} ?
[
"\n ORDER BY "
.
$self
->serialize_columns(
$out
->{
'sort-by'
},
$i
+1,
$output_opts
,
'order_by'
).
"\n"
,
$tree
] : ());
$i
++;
}
}
unless
(
defined
(
$tree_parent_id
) and
defined
(
$self
->{id_map}{
$tree
})) {
if
(
$$returns_nodes
) {
unless
(
$opts
->{no_distinct}) {
if
(
$opts
->{node_limit}) {
if
(
$opts
->{node_limit}<0 or
$opts
->{node_limit}==1) {
push
@sql
, [
' '
.
'LIMIT '
.
abs
(
$opts
->{node_limit}).
';'
];
}
else
{
unshift
@sql
, [
'SELECT * FROM ('
];
push
@sql
, [
qq{\n) "results" }
.
'LIMIT '
.
$opts
->{node_limit}.
';'
];
}
}
}
}
elsif
(
$opts
->{row_limit}) {
unshift
@sql
, [
'SELECT * FROM ('
];
push
@sql
, [
qq{) "#count" }
.
'LIMIT '
.
$opts
->{row_limit}.
';'
];
}
if
(
$self
->{precompute_recursive_relation}) {
my
@with
;
my
$tables
=
delete
$self
->{precompute_recursive_relation};
my
$next_with_clause
=
(
grep
({ !
$_
->{recursive} }
values
(
%$tables
)))
?
qq{WITH\n}
:
qq{WITH RECURSIVE\n}
;
for
my
$key
(
reverse
sort
keys
%$tables
) {
my
$spec
=
$tables
->{
$key
};
my
$out
;
my
%joins
;
my
$rel_table
;
if
(
$spec
->{table}) {
$rel_table
=
$spec
->{table};
}
else
{
my
$pt
= PMLTQ::Common::parse_expression(
$spec
->{path});
my
$out
=
$self
->serialize_expression_pt(
$pt
,{
id
=>
'#n'
, # just a fake node ID
join
=> \
%joins
,
type
=>
$spec
->{type},
expression
=>
$spec
->{path},
is_positive_conjunct
=>1
},\
%joins
);
$rel_table
=
"#rel_"
.
$spec
->{name};
push
@with
, [
$next_with_clause
.
qq{ "$rel_table" AS (\n}
.
qq{ SELECT "#n"."#idx" "#idx", $out "#value" FROM "$spec->{type}
"
"#n"
}];
$next_with_clause
=
qq{),\n}
;
}
for
my
$name
(
grep
{
$_
ne
'..'
}
keys
%joins
) {
for
my
$join_spec
(@{
$joins
{
$name
}}) {
my
(
$join_as
,
$join_tab
,
$join_on
,
$join_type
)=@{
$join_spec
};
$join_tab
=
$self
->get_real_table_name(
$join_tab
);
$join_type
||=
''
;
push
@with
, [
"\n "
,
'space'
], [
qq($join_type JOIN "$join_tab" "$join_as" ON $join_on)
]
}
}
if
(
$spec
->{recursive}) {
my
$select
;
my
$max_depth
=
''
;
$select
=
qq{ SELECT "#idx" "#idx", "#value" "#value", 1 depth, '['||"#idx"||']' path FROM "$rel_table"\n}
.
qq{ UNION\n}
.
qq{ SELECT r."#idx", c."#value", r.depth+1, r.path || '[' || c."#idx"||']'\n}
.
qq{ FROM "#rec_$spec->{name}
" r\n}.
qq{ JOIN "$rel_table" c ON r."#value" = c."#idx"\n}
.
qq{ WHERE r."#idx" != c."#value" and strpos(path,'[' || c."#idx" || ']')=0\n}
.
(
defined
(
$spec
->{max}) ?
qq{ AND r.depth <= $spec->{max}
\n} :
q{}
);
push
@with
, [
qq{$next_with_clause "#rec_$spec->{name}
" AS (\n}.
$select
];
}
push
@with
, [
qq{)\n}
];
$next_with_clause
=
qq{,\n}
;
}
unshift
@sql
,
@with
;
}
}
if
(
$format
) {
return
PMLTQ::Common::make_string_with_tags(\
@sql
,[
$tree
]);
}
else
{
return
PMLTQ::Common::make_string(\
@sql
);
}
}
sub
serialize_joins {
my
(
$self
,
$sql
,
$extra_joins
,
$name
,
$node
,
$seen
)=
@_
;
return
if
$seen
->{
$name
} or
$name
eq
'..'
;
$seen
->{
$name
}=1;
for
my
$join_spec
(@{
$extra_joins
->{
$name
}}) {
my
(
$join_as
,
$join_tab
,
$join_on
,
$join_type
)=@{
$join_spec
};
$join_tab
=
$self
->get_real_table_name(
$join_tab
);
$join_type
||=
''
;
push
@$sql
, [
"\n "
,
'space'
], [
qq($join_type JOIN "$join_tab" "$join_as" ON $join_on)
,(
$node
?
$node
: ())];
unless
(
$node
) {
print
STDERR
qq{MISPLACED_JOIN: $join_type JOIN "$join_tab" "$join_as" ON $join_on\n}
;
}
}
for
my
$join_spec
(@{
$extra_joins
->{
$name
}}) {
$self
->serialize_joins(
$sql
,
$extra_joins
,
$join_spec
->[0],
$node
,
$seen
);
}
}
sub
serialize_columns {
my
(
$self
,
$col_list
,
$j
,
$opts
,
$type
,
$prev_columns
)=
@_
;
my
@cols
;
my
$i
=1;
for
my
$col
(ListV(
$col_list
)) {
my
$dir
;
if
(
$type
eq
'order_by'
) {
if
(
$col
=~s{\s+(asc|desc)}{}) {
$dir
=
uc
($1);
}
}
my
(
$str
,
$wrap
,
$cal_be_null
)=
$self
->serialize_expression({
%$opts
,
expression
=>
$col
,
output_filter
=>
$j
+1,
is_positive_conjunct
=>1});
push
@cols
,
$str
.(
$type
eq
'select'
?
' AS c'
.(
$j
+1).
'_'
.(
$i
++) :
''
).
(
$dir
?
' '
.
$dir
:
''
)
}
return
$type
eq
'group_by'
? \
@cols
:
join
(
', '
,
@cols
);
}
sub
get_real_table_name {
my
(
$self
,
$path
)=
@_
;
croak(
"No table!"
)
unless
defined
$path
;
if
(
exists
$self
->{pml_tables}{
$path
}) {
return
$self
->{pml_tables}{
$path
};
}
my
$p
=
$path
;
my
$prefix
= (
$p
=~s/^(
my
$results
=
$self
->run_sql_query(
qq(SELECT "table" FROM "#PMLTABLES" WHERE "type" = ? )
,{
MaxRows
=>1,
RaiseError
=>1,
Bind
=>[
$p
] });
my
$table
=
$results
->[0][0];
return
$self
->{pml_tables}{
$path
} =
$table
?
$prefix
.
$table
:
$path
;
}
sub
get_node_table_for {
my
(
$self
,
$type
)=
@_
;
my
$table
;
if
(
$type
eq
'*'
) {
$table
=
$self
->get_schema_names->[0].
'__#trees'
;
}
elsif
(
$type
=~m{^([^/]+):\*$}) {
$table
= $1.
'__#trees'
;
}
else
{
$table
=
$SEPARATE_TREES
==1 ?
$self
->get_schema_name_for(
$type
).
'__#trees'
:
$type
;
}
return
$self
->get_real_table_name(
$table
);
}
sub
get_schema_name_for {
my
(
$self
,
$type
)=
@_
;
if
(
$type
eq
'*'
) {
return
$self
->get_schema_names->[0];
}
elsif
(
$type
=~m{^([^/]+):\*$}) {
return
$1;
}
if
(
exists
$self
->{schema_types}{
$type
}) {
if
(
defined
$self
->{schema_types}{
$type
} ) {
return
$self
->{schema_types}{
$type
};
}
else
{
confess(
"Did not find schema name for type $type (0)\n"
);
}
}
croak(
"No type!"
)
unless
defined
$type
;
my
$results
=
$self
->run_sql_query(
qq(SELECT "root" FROM "#PMLTYPES" WHERE "type" = ? OR ? LIKE ("type" || '/%')
),{
MaxRows
=>1,
RaiseError
=>1,
Bind
=>[
$type
,
$type
] });
my
$schema_name
=
$results
->[0][0];
if
(
$schema_name
) {
return
$self
->{schema_types}{
$type
} =
$schema_name
}
else
{
$results
=
$self
->run_sql_query(
qq(SELECT DISTINCT "root" FROM "#PMLTYPES")
,{
RaiseError
=>1});
for
$schema_name
(
map
$_
->[0],
@$results
) {
my
$schema
=
$self
->get_schema(
$schema_name
);
if
(PMLTQ::Common::QueryTypeToDecl(
$type
,
$schema
)) {
return
$self
->{schema_types}{
$type
} =
$schema_name
}
}
$self
->{schema_types}{
$type
} =
undef
;
confess(
"Did not find schema name for type $type\n"
);
}
}
sub
get_schema {
my
(
$self
,
$name
)=
@_
;
return
unless
$name
;
if
(
$self
->{schemas}{
$name
}) {
return
$self
->{schemas}{
$name
};
}
my
$results
=
$self
->run_sql_query(
qq(SELECT "schema" FROM "#PML" WHERE "root" = ? )
,
{
MaxRows
=>1,
RaiseError
=>1,
LongReadLen
=> 512*1024,
Bind
=>[
$name
] });
unless
(
ref
(
$results
) and
ref
(
$results
->[0]) and
$results
->[0][0]) {
die
"Failed to obtain PML schema $name\n"
;
}
return
$self
->{schemas}{
$name
} = Treex::PML::Schema->new({
string
=>
$results
->[0][0]});
}
sub
get_node_types {
my
(
$self
,
$schema_name
)=
@_
;
if
(
$schema_name
) {
return
$self
->{schema_node_types}{
$schema_name
}
if
defined
$self
->{schema_node_types};
my
$results
=
$self
->run_sql_query(
qq(SELECT "type","root" FROM "#PMLTYPES" ORDER BY "type")
,{
MaxRows
=>1,
RaiseError
=>1 });
my
$cached
=
$self
->{schema_node_types} = {};
for
my
$row
(
@$results
) {
push
@{
$cached
->{
$row
->[1]}},
$row
->[0];
}
return
$self
->{schema_node_types}{
$schema_name
};
}
else
{
return
$self
->{node_types}
if
defined
$self
->{node_types};
my
$results
=
$self
->run_sql_query(
qq(SELECT "type" FROM "#PMLTYPES" ORDER BY "type")
,{
MaxRows
=>1,
RaiseError
=>1 });
return
$self
->{node_types} = [
map
$_
->[0],
@$results
];
}
}
sub
get_schema_names {
my
(
$self
)=
@_
;
return
$self
->{schema_names}
if
defined
$self
->{schema_names};
my
$results
=
$self
->run_sql_query(
qq(SELECT "root" FROM "#PML" ORDER BY "root")
,{
MaxRows
=>1,
RaiseError
=>1 });
return
$self
->{schema_names} = [
map
$_
->[0],
@$results
];
}
sub
get_decl_for {
my
(
$self
,
$type
)=
@_
;
return
unless
$type
;
return
$self
->{type_decls}{
$type
} ||= PMLTQ::Common::QueryTypeToDecl(
$type
,
$self
->get_schema_for_type(
$type
));
}
sub
get_schema_for_type {
my
(
$self
,
$type
)=
@_
;
return
$self
->get_schema(
$self
->get_schema_name_for(
$type
));
}
sub
get_schema_flags {
my
(
$self
,
$schema_name
)=
@_
;
return
$self
->{schema_flags}{
$schema_name
}
if
exists
(
$self
->{schema_flags});
my
$rows
=
eval
{
$self
->run_sql_query(
qq(SELECT "root","flags" FROM "#PML")
,{
RaiseError
=>1 });
};
$self
->{schema_flags} = {
map
{
$_
->[0] =>
$_
->[1] } @{
$rows
|| []}
};
return
$self
->{schema_flags}{
$schema_name
};
}
sub
join_table_for_type_cast {
my
(
$self
,
$opts
)=
@_
;
my
(
$node_id
,
$cast
,
$ref_join
,
$check_joins
,
$left
) =
@$opts
{
qw(id cast join check_joins left)
};
my
$id
=
$node_id
.
"/#n_"
.
$cast
;
unless
(first {
$_
->[0] eq
$id
} (@{
$ref_join
->{
$node_id
}},
map
{ @{
$_
->{
$node_id
}} } @{
$check_joins
||[]})) {
push
@{
$ref_join
->{
$node_id
}},
[
$id
,
$cast
,
qq("$node_id"."#type"='$cast' AND "$id"."#idx" = "$node_id"."#idx")
,
$left
?
'LEFT'
: () ];
}
return
$id
;
}
my
%asoc_precedence
= (
div
=> 1,
mod
=> 1,
'*'
=> 1,
'&'
=> 0,
'-'
=> 0,
'+'
=> 0,
);
sub
serialize_expression_pt {
my
(
$self
,
$pt
,
$opts
,
$extra_joins
)=
@_
;
my
$this_node_id
=
$opts
->{id};
if
(
ref
(
$pt
)) {
my
$type
=
shift
@$pt
;
if
(
$type
eq
'ATTR'
or
$type
eq
'REF_ATTR'
) {
if
(
defined
(
$opts
->{output_filter}) and
$opts
->{output_filter}>1) {
die
"Attribute reference cannot be used in output filter columns whose input is not the body of the query: '$opts->{expression}'"
}
my
(
$id
,
$attr
,
$cmp
,
$node_type
,
$cast
,
$decl
);
if
(
$type
eq
'REF_ATTR'
) {
$id
=
$pt
->[0];
$pt
=
$pt
->[1];
die
"Error in attribute reference of node $id in expression $opts->{expression} of node '$this_node_id'"
unless
shift
(
@$pt
) eq
'ATTR'
;
if
(
$id
eq
'$'
) {
$cmp
=0;
$id
=
$this_node_id
;
$node_type
=
$opts
->{type};
}
else
{
$cmp
=
$self
->cmp_subquery_scope(
$this_node_id
,
$id
);
if
(
$cmp
<0) {
die
"Node '$id' belongs to a sub-query and cannot be referred from the scope of node '$this_node_id' ($opts->{expression})\n"
;
}
$node_type
=
$self
->get_type_of_node(
$id
);
}
}
else
{
$cmp
=0;
$id
=
$this_node_id
;
$node_type
=
$opts
->{type};
}
if
(
$pt
->[0] =~ /^(.+)\?$/) {
$cast
= $1;
shift
@$pt
;
}
elsif
(
$node_type
=~m{^(?:([^/]+):)?\*$}) {
my
$node_types
=
$self
->get_node_types($1);
my
@possibilities
;
my
$path
=
join
'/'
,
map
{ (
$_
eq
'[]'
or
$_
eq
'content()'
) ?
'#content'
:
$_
}
@$pt
;
for
my
$nt
(
@$node_types
) {
my
$decl
=
$self
->get_decl_for(
$nt
);
my
$attr_decl
=
$decl
&&
$decl
->find(
$path
);
$attr_decl
=
$attr_decl
->get_content_decl
while
(
$attr_decl
and (
$attr_decl
->get_decl_type == PML_LIST_DECL or
$attr_decl
->get_decl_type == PML_ALT_DECL));
push
@possibilities
,
$type
eq
'REF_ATTR'
? [
'REF_ATTR'
,
$id
,[
'ATTR'
,
$nt
.
'?'
,
@$pt
]] : [
'ATTR'
,
$nt
.
'?'
,
@$pt
]
if
(
$attr_decl
and
$attr_decl
->is_atomic);
}
if
(!
@possibilities
) {
die
"The attribute path '$path' is not valid for any node type matched by the '$node_type' wildcard: @$node_types\n"
;
}
elsif
(
@possibilities
== 1) {
return
$self
->serialize_expression_pt(
$possibilities
[0],
$opts
,
$extra_joins
);
}
else
{
return
$self
->serialize_expression_pt([
'FUNC'
,
'first_defined'
,\
@possibilities
],
$opts
,
$extra_joins
);
}
}
$decl
=
$self
->get_decl_for(
$cast
||
$node_type
);
if
(!
$decl
) {
die
"Couldn't determine node type of node '$id' to evaluate $opts->{expression}\n"
;
}
my
$table
=PMLTQ::Common::DeclPathToQueryType(
$decl
->get_decl_path);
$opts
->{referred_nodes}{
$id
}=1
if
ref
(
$opts
->{referred_nodes});
my
$node_id
=
$id
;
my
$j
;
$j
=
$opts
->{
join
};
$extra_joins
->{
$node_id
}||=[];
my
$ref_join
=
$opts
->{
join
};
$ref_join
=
$ref_join
->{
'..'
}
for
1..
$cmp
;
$ref_join
->{
$node_id
}||=[];
if
(
$SEPARATE_TREES
==1 or (
$cast
and
$cast
ne
$node_type
)) {
$id
=
$self
->join_table_for_type_cast({
id
=>
$node_id
,
left
=>(
$cast
?1:0),
cast
=>
$table
,
join
=>
$ref_join
,
check_joins
=> [
$extra_joins
]
});
}
else
{
$id
=
$node_id
;
}
my
@t
=
@$pt
;
my
$column
;
my
$iter
=0;
while
(
$iter
++ < 100) {
my
(
$mdecl
,
$mtable
);
my
$can_be_null
= (
$cast
and
$iter
== 1) ? 1 : 0;
my
$decl_is
=
$decl
->get_decl_type;
my
$extra_condition
;
my
$pos_condition
;
my
$prev
=
$id
;
if
(
$decl_is
== PML_STRUCTURE_DECL or
$decl_is
== PML_CONTAINER_DECL) {
last
unless
@t
;
$column
=
shift
@t
;
if
(
$column
eq
'[]'
or
$column
eq
'content()'
) {
$column
=
'#content'
;
}
$mdecl
=
$decl
->get_member_by_name(
$column
);
if
(!
$mdecl
and
$decl_is
== PML_STRUCTURE_DECL) {
$mdecl
=
$decl
->get_member_by_name(
$column
.
'.rf'
);
$mdecl
=
undef
unless
$mdecl
;
}
if
(
$column
eq
'#content'
) {
$can_be_null
=1;
}
elsif
(
$mdecl
) {
unless
(
$mdecl
->is_required) {
$can_be_null
=1;
}
$mdecl
=
$mdecl
->get_knit_content_decl;
}
}
elsif
(
$decl_is
== PML_LIST_DECL) {
shift
@t
if
@t
and
$t
[0] eq
'LM'
;
$mdecl
=
$decl
->get_knit_content_decl;
$column
=
'#value'
;
$can_be_null
=1;
}
elsif
(
$decl_is
== PML_ALT_DECL) {
shift
@t
if
@t
and
$t
[0] eq
'AM'
;
$mdecl
=
$decl
->get_knit_content_decl;
$column
=
'#value'
;
$can_be_null
=1;
}
elsif
(
$decl_is
== PML_SEQUENCE_DECL) {
last
unless
@t
;
$column
=
shift
@t
;
if
(
$column
=~s/^\[(\d+)\]//g) {
$pos_condition
=
qq{"#pos" = $1-1 }
;
}
elsif
(
$column
=~s/\[\s*(\d+)\s*\]$//g) {
$pos_condition
=
qq{"#elpos" = $1-1 }
;
}
$mdecl
=
$decl
->get_element_by_name(
$column
);
if
(
$mdecl
) {
$mtable
=
'#e_'
.PMLTQ::Common::DeclPathToQueryType(
$mdecl
->get_knit_content_decl->get_decl_path);
}
else
{
die
"Sequence does not allow element '$column' in expression $opts->{expression} at node "
.(
$cast
||
$node_type
)
.
" \$$this_node_id: "
.
join
(
'/'
,
@t
);
}
$can_be_null
=1;
}
elsif
(
$decl_is
== PML_ELEMENT_DECL) {
$mdecl
=
$decl
->get_knit_content_decl;
$column
=
'#value'
;
}
elsif
(
$decl
->is_atomic) {
die
"Cannot apply attribute path to an atomic type in expression $opts->{expression} at node "
.(
$cast
||
$node_type
)
.
" \$$this_node_id: "
.
join
(
'/'
,
@t
);
}
else
{
die
ref
(
$self
).
" internal error: Didn't expect type $decl_is\n"
;
}
die
"Didn't find member '$column' on '$table' while compiling expression $opts->{expression} of node '$this_node_id'"
unless
$mdecl
;
my
$mdecl_is
=
$mdecl
->get_decl_type;
$opts
->{can_be_null}=1
if
$can_be_null
;
my
$is_ambiguous
= (
$mdecl_is
== PML_LIST_DECL or
$mdecl_is
== PML_ALT_DECL or
$mdecl_is
== PML_SEQUENCE_DECL) ? 1 : 0;
if
(
$mdecl
->is_atomic) {
if
(
@t
) {
die
"Cannot follow attribute path past atomic type while compiling expression $opts->{expression} of node "
.(
$cast
||
$node_type
).
" \$$this_node_id: "
.
join
(
'/'
,
@t
);
}
return
qq( "$prev"."$column" )
;
}
elsif
(
$opts
->{allow_non_atomic} and
$mdecl
->get_decl_type != PML_ELEMENT_DECL and
((!
@t
and
$mdecl
->get_decl_type != PML_LIST_DECL and
$mdecl
->get_decl_type != PML_ALT_DECL)
or(
@t
==1 and
$t
[0] eq
'.'
))) {
return
qq( "$id"."$column" )
;
}
else
{
my
$j
=
$ref_join
;
my
$left
=
''
;
if
(
$opts
->{use_exists}==2) {
$j
=
$extra_joins
;
}
elsif
(
$opts
->{allow_non_atomic}) {
}
elsif
(
$opts
->{can_be_null} or (
$is_ambiguous
and
$cmp
)) {
if
(!
$opts
->{is_positive_conjunct}) {
$opts
->{use_exists}||=1;
$j
=
$extra_joins
;
}
elsif
(
$cmp
) {
if
(
$ALLOW_MISPLACED_PG_JOIN
) {
$j
=
$opts
->{
join
};
}
else
{
$opts
->{use_exists}||=1;
$j
=
$extra_joins
;
}
}
else
{
$opts
->{use_exists}||=1
unless
(PREFER_LEFT_JOINS);
if
(
$opts
->{use_exists}) {
$j
=
$extra_joins
;
}
else
{
$left
=
'LEFT'
;
}
}
}
my
$i
=
$self
->{join_id}++;
$id
=
$node_id
.
"/$i"
;
my
$condition
=
qq("$id"."#idx" = "$prev"."$column")
;
if
(
$pos_condition
) {
$condition
=
qq{($condition AND "$id".$pos_condition)}
;
}
if
(
$extra_condition
) {
$condition
=
qq{($condition AND "$id".$extra_condition)}
;
}
my
$mdecl_is
=
$mdecl
->get_decl_type;
if
((
$mdecl_is
== PML_LIST_DECL) and
@t
and
$t
[0]=~m{^\[\s*(\d+)\s*\]$}) {
if
(
$mdecl
->is_ordered) {
$condition
=
qq{($condition AND "$id"."#pos" = $1-1)}
;
shift
@t
;
}
else
{
my
$p
=
$mdecl
->get_decl_path;
$p
=~s/^!//;
die
"Cannot use index '$t[0]' in expression '$opts->{expression}' of node '$this_node_id' on value of type '$p' that is declared in the PML schema as an *unordered* list"
;
}
}
$table
=
$mtable
||PMLTQ::Common::DeclPathToQueryType(
$mdecl
->get_decl_path);
push
@{
$j
->{
$node_id
}},[
$id
,
$table
,
$condition
,
$opts
->{output_filter} ?
'LEFT'
:
$left
];
}
$decl
=
$mdecl
;
}
if
(
$iter
>=100) {
die
"Deep recursion while compiling '$opts->{expression}' of node '$this_node_id'"
;
}
die
"Expression '$opts->{expression}' of node '$this_node_id' does not lead to an attomic value"
;
}
elsif
(
$type
eq
'FUNC'
) {
my
$name
=
$pt
->[0];
my
$args
=
$pt
->[1];
$opts
->{can_be_null}=1;
my
$id
;
if
(
$name
=~/^(?:descendants|lbrothers|sons|depth|depth_first_order|order_span_min|order_span_max|name|type_of)$/) {
if
(
$args
and
@$args
==1 and !
ref
(
$args
->[0]) and
$args
->[0]=~s/^\$//) {
$id
=
$args
->[0];
if
(
$self
->cmp_subquery_scope(
$this_node_id
,
$id
)<0) {
die
"Node '$id' belongs to a sub-query and cannot be referred from the scope of node '$this_node_id' ($opts->{expression})\n"
;
}
}
elsif
(
$args
and
@$args
) {
die
"Wrong arguments for function ${name}() in expression $opts->{expression} of node '$this_node_id'!\nUsage: ${name}(\$node?)\n"
;
}
else
{
$id
=
$this_node_id
;
}
$opts
->{referred_nodes}{
$id
}=1
if
ref
(
$opts
->{referred_nodes});
if
(
$name
=~ /^order_span/) {
my
$span
= $1;
my
$flags
=
$self
->get_schema_flags(
$self
->get_schema_name_for(
$opts
->{type}));
if
(!
defined
(
$flags
) or !(
$flags
& MAX_MIN_ORD)) {
my
$n
=
$self
->{name2node}{
$id
};
$n
or
die
"Cannot refer to node '$id' from $name() in expression $opts->{expression} of node '$this_node_id'!\n"
;
my
$type
= PMLTQ::Common::GetQueryNodeType(
$n
,
$self
);
my
$decl
=
$self
->get_decl_for(
$type
);
if
(
$decl
->get_decl_type == PML_ELEMENT_DECL) {
$decl
=
$decl
->get_content_decl;
}
my
(
$order
) =
map
{
$_
->get_name }
$decl
->find_members_by_role(
'#ORDER'
);
if
(
defined
$order
) {
return
qq{"$id"."$order"}
}
else
{
die
"No ordering is defined on nodes of type '$type'!\n"
;
}
}
}
return
(
$name
eq
'descendants'
) ?
qq{("$id"."#r"-"$id"."#idx")}
: (
$name
eq
'lbrothers'
) ?
qq{"$id"."#chord"}
: (
$name
eq
'sons'
) ?
qq{"$id"."#chld"}
: (
$name
eq
'depth'
) ?
qq{"$id"."#lvl"}
: (
$name
eq
'depth_first_order'
) ?
qq{("$id"."#idx"-"$id"."#root_idx")}
: (
$name
=~
'order_span_min'
) ?
qq{"$id"."#min_ord"}
: (
$name
eq
'order_span_max'
) ?
qq{"$id"."#max_ord"}
: (
$name
eq
'name'
) ?
qq{"$id"."#name"}
: (
$name
eq
'type_of'
) ?
qq{"$id"."#type"}
:
die
"PMLTQ internal error while compiling expression: should never get here!"
;
}
elsif
(
$name
eq
'length'
) {
if
(
$args
and
@$args
==1) {
my
$ret
=
'LENGTH('
.
$self
->serialize_expression_pt(
$args
->[0],
$opts
,
$extra_joins
)
.
')'
;
return
$ret
;
}
else
{
die
"Wrong arguments for function ${name}() in expression $opts->{expression} of node '$this_node_id'!\nUsage: ${name}(string)\n"
;
}
}
elsif
(
$name
=~/^(?:lower|upper)$/) {
if
(
$args
and
@$args
==1) {
return
uc
(
$name
).
'('
.
$self
->serialize_expression_pt(
$args
->[0],
$opts
,
$extra_joins
)
.
')'
;
}
else
{
die
"Wrong arguments for function ${name}() in expression $opts->{expression} of node '$this_node_id'!\nUsage: ${name}(string)\n"
;
}
}
elsif
(
$name
=~/^(?:
abs
|floor|ceil|
exp
|
sqrt
|ln)$/) {
if
(
$args
and
@$args
==1) {
return
uc
(
$name
).
'('
.
$self
->serialize_expression_pt(
$args
->[0],
$opts
,
$extra_joins
)
.
')'
;
}
else
{
die
"Wrong arguments for function ${name}() in expression $opts->{expression} of node '$this_node_id'!\nUsage: ${name}(number)\n"
;
}
}
elsif
(
$name
=~ /^(?:
log
|power)$/) {
my
$func
=
uc
(
$name
);
if
(
$args
and
@$args
==1) {
return
$func
.
'(10,CAST('
.
$self
->serialize_expression_pt(
$args
->[0],
$opts
,
$extra_joins
)
.
' AS FLOAT))'
;
}
elsif
(
$args
and
@$args
==2) {
return
$func
.
'('
.
$self
->serialize_expression_pt(
$args
->[0],
$opts
,
$extra_joins
).
','
.
'CAST('
.
$self
->serialize_expression_pt(
$args
->[1],
$opts
,
$extra_joins
).
' AS FLOAT)'
.
')'
;
}
else
{
die
"Wrong arguments for function ${name}() in expression $opts->{expression} of node '$this_node_id'!\nUsage: ${name}(base,number) or ${name}(number)\n"
;
}
}
elsif
(
$name
eq
'address'
) {
my
@arg
;
if
(
$args
and
@$args
) {
my
$ref
=
$args
->[0];
die
"Wrong arguments for function ${name}() in expression $opts->{expression} of node '$this_node_id'!\nUsage: ${name}(\$node?)\n"
if
(
@$args
>1 or
$ref
!~/^\$(?!\d)/);
@arg
= (
$ref
);
}
return
$self
->serialize_expression_pt(
[
'EXP'
=>
[
FUNC
=>
'file'
, [
@arg
]],
'&'
,
"'##'"
,
'&'
,
[
FUNC
=>
'tree_no'
, [
@arg
]],
'&'
,
"'.'"
,
'&'
,
[
FUNC
=>
'depth_first_order'
, [
@arg
]],
],
$opts
,
$extra_joins
);
}
elsif
(
$name
=~ /^(file|tree_no)$/) {
my
$id
;
if
(
$args
and
@$args
) {
my
$ref
=
$args
->[0];
die
"Wrong arguments for function ${name}() in expression $opts->{expression} of node '$this_node_id'!\nUsage: ${name}(\$node?)\n"
if
(
@$args
>1 or not
$ref
=~s/^\$(?!\d)//);
$id
=
$ref
eq
'$'
?
$this_node_id
:
$ref
;
}
else
{
$id
=
$this_node_id
;
}
my
$n
=
$self
->{name2node}{
$id
};
my
$cmp
=
$self
->cmp_subquery_scope(
$this_node_id
,
$id
);
if
(!
$n
or
$cmp
<0) {
die
"Node '$id' belongs to a sub-query and cannot be referred from the scope of node '$this_node_id' ($opts->{expression})\n"
;
}
$opts
->{referred_nodes}{
$id
}=1
if
ref
(
$opts
->{referred_nodes});
my
$j
=
$opts
->{
join
};
$j
=
$j
->{
'..'
}
for
1..
$cmp
;
my
$J
= (
$j
->{
$id
}||=[]);
my
$table
=
$self
->get_schema_name_for(PMLTQ::Common::GetQueryNodeType(
$n
,
$self
)).
'__#files'
;
my
$fid
=
$id
.
"/#file"
;
push
@$J
,[
$fid
,
$table
,
qq("$fid"."#idx" = "$id"."#root_idx")
]
unless
first {
$_
->[0] eq
$fid
}
@$J
;
return
$name
eq
'tree_no'
?
qq{("$fid"."$name"+1)}
:
qq{"$fid"."$name"}
;
}
elsif
(
$name
eq
'rbrothers'
) {
my
$id
;
if
(
$args
and
@$args
) {
my
$ref
=
$args
->[0];
die
"Wrong arguments for function ${name}() in expression $opts->{expression} of node '$this_node_id'!\nUsage: ${name}(\$node?)\n"
if
(
@$args
>1 or not
$ref
=~s/^\$(?!\d)//);
$id
=
$ref
eq
'$'
?
$this_node_id
:
$ref
;
}
else
{
$id
=
$this_node_id
;
}
my
$n
=
$self
->{name2node}{
$id
};
my
$cmp
=
$self
->cmp_subquery_scope(
$this_node_id
,
$id
);
if
(!
$n
or
$cmp
<0) {
die
"Node '$id' belongs to a sub-query and cannot be referred from the scope of node '$this_node_id' ($opts->{expression})\n"
;
}
$opts
->{referred_nodes}{
$id
}=1
if
ref
(
$opts
->{referred_nodes});
my
$j
=
$opts
->{
join
};
$j
=
$j
->{
'..'
}
for
1..
$cmp
;
my
$J
= (
$j
->{
$id
}||=[]);
my
$table
=
$self
->get_schema_name_for(PMLTQ::Common::GetQueryNodeType(
$n
,
$self
)).
'__#trees'
;
my
$p_id
=
$id
.
"/#parent"
;
push
@$J
,[
$p_id
,
$table
,
qq("$p_id"."#idx" = "$id"."#parent_idx")
]
unless
first {
$_
->[0] eq
$p_id
}
@$J
;
return
qq{("$p_id"."#chld"-"$id"."#chord"-1)}
;
}
elsif
(
$name
eq
'id'
) {
my
$id
;
if
(
$args
and
@$args
) {
my
$ref
=
$args
->[0];
die
"Wrong arguments for function ${name}() in expression $opts->{expression} of node '$this_node_id'!\nUsage: ${name}(\$node?)\n"
if
(
@$args
>1 or not
$ref
=~s/^\$(?!\d)//);
$id
=
$ref
eq
'$'
?
$this_node_id
:
$ref
;
}
else
{
$id
=
$this_node_id
;
}
my
$n
=
$self
->{name2node}{
$id
};
$n
or
die
"Cannot refer to node '$id' from $name() in expression $opts->{expression} of node '$this_node_id'!\n"
;
$opts
->{referred_nodes}{
$id
}=1
if
ref
(
$opts
->{referred_nodes});
my
$decl
=
$self
->get_decl_for(PMLTQ::Common::GetQueryNodeType(
$n
,
$self
));
if
(
$decl
->get_decl_type == PML_ELEMENT_DECL) {
$decl
=
$decl
->get_content_decl;
}
my
(
$m
)=
$decl
->find_members_by_role(
'#ID'
);
my
$id_attr
=
defined
(
$m
) &&
$m
->get_name;
if
(
defined
$id_attr
) {
return
$self
->serialize_expression_pt([
'REF_ATTR'
,
$id
,[
$id_attr
]],
$opts
,
$extra_joins
);
}
else
{
return
'NULL'
;
}
}
elsif
(
$name
=~/^(?:round|trunc)$/) {
if
(
$args
and
@$args
and
@$args
<3) {
return
uc
(
$name
).
'('
.
join
(
','
,
map
{
$self
->serialize_expression_pt(
$_
,
$opts
,
$extra_joins
) }
@$args
)
.
')'
;
}
else
{
die
"Wrong arguments for function ${name}() in expression $opts->{expression} of node '$this_node_id'!\nUsage: ${name}(string)\n"
;
}
}
elsif
(
$name
eq
'percnt'
) {
if
(
$args
and
@$args
>0 and
@$args
<3) {
my
@args
=
map
{
$self
->serialize_expression_pt(
$_
,
$opts
,
$extra_joins
) }
@$args
;
my
$ret
=
'round(100*('
.
$args
[0].
')'
. (
@args
>1 ?
','
.
$args
[1] :
''
).
q[)]
;
return
$ret
;
}
else
{
die
"Wrong arguments for function percnt() in expression $opts->{expression} of node '$this_node_id'!\nUsage: percnt(number,precision?)\n"
;
}
}
elsif
(
$name
eq
'substr'
) {
if
(
$args
and
@$args
>1 and
@$args
<4) {
my
$cast_to_string
;
if
(
$self
->compute_data_type(
$args
->[0],
$opts
)!=COL_STRING) {
$cast_to_string
=1;
}
my
@args
=
map
{
$self
->serialize_expression_pt(
$_
,
$opts
,
$extra_joins
) }
@$args
;
$args
[1].=
'+1'
;
$args
[0]=
'cast('
.
$args
[0].
' as varchar)'
if
$cast_to_string
;
return
'SUBSTR('
.
join
(
','
,
@args
) .
')'
;
}
else
{
die
"Wrong arguments for function ${name}() in expression $opts->{expression} of node '$this_node_id'!\nUsage: substr(string,from,length?)\n"
;
}
}
elsif
(
$name
=~/(?:replace|
tr
)$/) {
if
(
$args
and
@$args
==3) {
my
$cast_to_string
;
if
(
$self
->compute_data_type(
$args
->[0],
$opts
)!=COL_STRING) {
$cast_to_string
=1;
}
my
@args
=
map
{
$self
->serialize_expression_pt(
$_
,
$opts
,
$extra_joins
) }
@$args
;
$args
[0]=
'cast('
.
$args
[0].
' as varchar)'
if
$cast_to_string
;
return
(
$name
eq
'tr'
?
'TRANSLATE'
:
uc
(
$name
) ).
'('
.
join
(
','
,
@args
)
.
')'
;
}
else
{
die
"Wrong arguments for function ${name}() in expression $opts->{expression} of node '$this_node_id'!\nUsage: $name"
.
(
$name
eq
'replace'
?
"(string,target,replacement)\n"
:
"(string,from_chars,to_chars)\n"
);
}
}
elsif
(
$name
eq
'substitute'
) {
if
(
$args
and
@$args
>=3 and
@$args
<=4) {
my
@cast_to_string
;
for
(0..2) {
$cast_to_string
[
$_
]= (
$self
->compute_data_type(
$args
->[
$_
],
$opts
)!=COL_STRING) ? 1 : 0
if
$_
<
@$args
;
}
my
@args
=
map
{
$self
->serialize_expression_pt(
$_
,
$opts
,
$extra_joins
) }
@$args
;
for
(0..2) {
$args
[
$_
]=
'cast('
.
$args
[
$_
].
' as varchar)'
if
(
$_
<
@$args
and
$cast_to_string
[
$_
]);
}
my
$match_opts
=
$args
[3];
if
(
defined
(
$match_opts
) and (
ref
(
$match_opts
) or
$match_opts
!~/^\s*
'[icnmg]*'
\s*$/)) {
die
"Wrong match options $match_opts for function ${name}() in expression $opts->{expression} of node '$this_node_id'!\nUsage: $name(string,pattern,replacement,options), where options is a literal string consisting only of characters from the set [icnmg]\n"
;
}
return
'REGEXP_REPLACE('
.
join
(
','
,
@args
[0..2],
$match_opts
?
$match_opts
: ()).
')'
}
else
{
die
"Wrong arguments for function ${name}() in expression $opts->{expression} of node '$this_node_id'!\nUsage: $name(string,pattern,replacement,options)\n"
;
}
}
elsif
(
$name
eq
'match'
) {
if
(
$args
and
@$args
>=2 and
@$args
<=3) {
my
@cast_to_string
;
for
(0..1) {
$cast_to_string
[
$_
]= (
$self
->compute_data_type(
$args
->[
$_
],
$opts
)!=COL_STRING) ? 1 : 0
if
$_
<
@$args
;
}
my
@args
=
map
{
$self
->serialize_expression_pt(
$_
,
$opts
,
$extra_joins
) }
@$args
;
for
(0..1) {
$args
[
$_
]=
'cast('
.
$args
[
$_
].
' as varchar)'
if
(
$_
<
@$args
and
$cast_to_string
[
$_
]);
}
my
$match_opts
=
$args
[2];
if
(
defined
(
$match_opts
) and (
ref
(
$match_opts
) or
$match_opts
!~/^\s*
'[icnm]*'
\s*$/)) {
die
"Wrong match options [$match_opts] for function ${name}() in expression $opts->{expression} of node '$this_node_id'!\nUsage: $name(string,pattern,options?), where options is a literal string consisting only of characters from the set [icnm]\n"
;
}
return
'(REGEXP_MATCHES('
.
qq{$args[0],'(' || $args[1] || ')',}
.(
$match_opts
||
q('')
)
.
'))[1]'
}
else
{
die
"Wrong arguments for function ${name}() in expression $opts->{expression} of node '$this_node_id'!\nUsage: $name(string,pattern,options?)\n"
;
}
}
elsif
(
$name
eq
'first_defined'
) {
if
(!
$args
or
@$args
<2) {
die
"Wrong arguments for function ${name}() in expression $opts->{expression} of node '$this_node_id'!\nUsage: $name(value1,value2,...)\n"
;
}
my
@types
=
map
{
$self
->compute_data_type(
$_
,
$opts
) }
@$args
;
my
@args
=
map
{
$self
->serialize_expression_pt(
$_
,
$opts
,
$extra_joins
) }
@$args
;
if
(first {
$_
!=COL_NUMERIC }
@types
) {
for
(
@args
) {
if
(
shift
(
@types
)!=COL_STRING ) {
$_
=
qq{cast($_ as varchar)}
;
}
}
}
return
'COALESCE('
.
join
(
','
,
@args
).
')'
}
else
{
die
"Function ${name}() unknown or not yet implemented!\n"
;
}
}
elsif
(
$type
eq
'EVERY'
) {
$opts
->{use_exists}=2;
$opts
->{is_positive_conjunct}=0;
if
(
$opts
->{output_filter}) {
die
"Cannot use quantifier '*' in output filter: '$opts->{expression}'"
}
return
$self
->serialize_expression_pt(
$pt
->[0],
$opts
,
$extra_joins
);
}
elsif
(
$type
eq
'IF'
) {
my
(
$condition
,
$if_true
,
$if_false
) =
@$pt
;
my
$test
= PMLTQ::Common::make_string([
$self
->serialize_element({
name
=>
$condition
->{
'#name'
},
condition
=>
$condition
,
is_positive_conjunct
=> 1,
%$opts
,
})]);
my
(
$true_type
,
$false_type
) =
map
$self
->compute_data_type(
$_
,
$opts
), (
$if_true
,
$if_false
);
my
(
$if_true_sql
,
$if_false_sql
) =
map
{
$self
->serialize_expression_pt(
$_
,
$opts
,
$extra_joins
) }
(
$if_true
,
$if_false
);
if
(
$true_type
!=
$false_type
or
$true_type
== COL_UNKNOWN) {
$_
=
qq{cast($_ as varchar)}
for
(
$if_true_sql
,
$if_false_sql
);
}
return
qq{(CASE WHEN $test THEN $if_true_sql ELSE $if_false_sql END)}
;
}
elsif
(
$type
eq
'ANALYTIC_FUNC'
) {
my
$name
=
shift
@$pt
;
die
"The analytic function ${name}() can only be used in an output filter expression!\n"
unless
$opts
->{
'output_filter'
};
die
"The analytic function ${name}() cannot be used in the 'filter' clause!\n"
if
$opts
->{
'output_filter_where_clause'
};
my
$args
=
shift
@$pt
;
die
"The analytic function $name without an 'over' clause cannot be used to compute an argument to another analytic function without an 'over' clause $opts->{aggregated} in the output filter expression $opts->{expression}!\n"
if
defined
(
$opts
->{
'aggregated'
})
and !
@$pt
and !(
$opts
->{group_by} and @{
$opts
->{group_by}});
$name
=
'ratio_to_report'
if
$name
eq
'ratio'
;
my
@args
;
if
(
$args
) {
if
(
$name
eq
'concat'
) {
die
"The analytic function $name takes one or two arguments concat(STR, SEPARATOR?) in the output filter expression $opts->{expression}; got @$args!\n"
if
@$args
==0 or
@$args
>2;
if
(
@$args
==2) {
unless
(
defined
(
$args
->[1]) and !
ref
(
$args
->[1]) and
$args
->[1]!~/^\$/) {
die
"The second argument to concat(STR, SEPARATOR?) must be a literal string or number in $opts->{expression}!\n"
;
}
}
}
elsif
(
$name
=~ /^(rank|dense_rank|row_number)/ and
@$args
>0) {
die
"The analytic function $name takes no arguments in the output filter expression $opts->{expression}!\n"
;
}
elsif
(
@$args
>1) {
die
"The analytic function $name takes at most one arguments in the output filter expression $opts->{expression}!\n"
;
}
for
my
$arg
(
@$args
) {
push
@args
,
$self
->serialize_expression_pt(
$arg
,{
%$opts
,
(
@$pt
? () : (
aggregated
=>
$name
,
group_by
=>
undef
))
},
$extra_joins
)
}
}
my
$out
=
''
;
if
(
$name
eq
'concat'
) {
$out
=
q{concat_agg(}
;
if
(
@args
==1) {
$out
.=
$args
[0];
}
elsif
(
@args
==2) {
my
$sep
=
$args
[1];
$out
=
q{regexp_replace(}
.
$out
.
$args
[0].
' || '
.
$sep
;
}
}
elsif
(
$name
eq
'ratio_to_report'
) {
my
$arg
=
@args
?
$args
[0] :
'count(*)'
;
$out
=
'(('
.
$arg
.
') / sum('
.
$arg
;
}
else
{
$out
=
uc
(
$name
).
'('
.(
@args
?
$args
[0] :
''
);
}
unless
(
@args
) {
if
(
$name
eq
'count'
) {
$out
.=
'*'
}
elsif
(
$name
eq
'ratio_to_report'
) {
$out
.=
'count(*)'
}
elsif
(
$name
!~ /^(rank|dense_rank|row_number)/) {
if
(
$opts
->{group_by} and @{
$opts
->{group_by}}) {
$out
.=
$opts
->{group_by}[0];
}
elsif
(
$opts
->{
'output_filter'
}<2) {
die
"Cannot use analytic function ${name}() with implicit argument (\$1) in the first filter!\n"
;
}
else
{
$out
.=
'c'
.(
$opts
->{
'output_filter'
}-1).
'_1'
;
}
}
}
$out
.=
')'
;
my
(
$over
,
$sort
)=
@$pt
;
if
((
$over
and
@$over
) or (
$sort
and
@$sort
) or
$name
=~ /^(rank|dense_rank|row_number)/) {
$out
.=
' OVER ('
;
if
(
$over
and
@$over
and !(
@$over
==1 and
$over
->[0] eq
'ALL'
)) {
$out
.=
'PARTITION BY '
.
join
(
','
,
map
{
$self
->serialize_expression_pt(
$_
,
$opts
,
$extra_joins
) }
@$over
)
}
if
(
$sort
and
@$sort
) {
$out
.=
' ORDER BY '
.
join
(
','
,
map
{
$self
->serialize_expression_pt(
$_
->[0],
$opts
,
$extra_joins
).
(
$_
->[1] ?
' '
.
uc
(
$_
->[1]) :
''
)
}
@$sort
);
if
(
$name
!~ /^(rank|dense_rank|row_number)/) {
$out
.=
' RANGE BETWEEN UNBOUNDED PRECEDING AND UNBOUNDED FOLLOWING'
}
}
$out
.=
')'
;
}
if
(
$name
eq
'concat'
) {
if
(
@args
==2) {
my
$trim_separator
=
$args
[1];
if
(
$trim_separator
=~ /^(\s
*E
?)([
'])(.*?)(['
]\s*)$/) {
my
(
$lead
,
$lead2
,
$body
,
$trail
)=($1,$2,$3,$4);
$body
=~s/\\(.)/$1/g;
$body
=
quotemeta
(
$body
);
$body
=~s/\\/\\\\/g;
$body
=~s/
'/\\'
/g;
$lead
=~s/$/E/
if
$lead
!~/E/;
$trim_separator
=
$lead
.
$lead2
.
$body
.
'$'
.
$trail
;
}
elsif
(
$trim_separator
=~ /^(\s*[NU]?[
'])(.*?)(['
]\s*)$/) {
my
(
$lead
,
$body
,
$trail
)=($1,$2,$3);
$body
=~s/
''
/
'/g; # unquote '
$body
=
quotemeta
(
$body
);
$body
=~s/
'/'
'/g; # quote '
$trim_separator
=
$lead
.
$body
.
'$'
.
$trail
;
}
$out
.=
qq{,$trim_separator,'')}
;
}
}
return
$out
;
}
elsif
(
$type
eq
'EXP'
) {
my
$out
=
''
;
my
$mult
=
''
;
$mult
=
$self
->serialize_expression_pt(
shift
@$pt
,
$opts
,
$extra_joins
)
if
@$pt
;
while
(
@$pt
) {
my
$op
=
shift
@$pt
;
die
"Missing left expression for operator '$op' in expression $opts->{expression} of node '$this_node_id'\n"
unless
@$pt
;
my
$exp
=
$self
->serialize_expression_pt(
shift
@$pt
,
$opts
,
$extra_joins
);
if
(
$op
eq
'div'
) {
$mult
=
qq{($mult / $exp)}
;
}
elsif
(
$op
eq
'mod'
) {
$mult
=
qq{MOD($mult,$exp)}
;
}
elsif
(
$op
eq
'*'
) {
$mult
=
qq{($mult * $exp)}
;
}
elsif
(
$op
eq
'&'
) {
$out
.=
qq{$mult || }
;
$mult
=
$exp
;
}
elsif
(
$op
=~ /^[-+]$/) {
$out
.=
qq{$mult $op }
;
$mult
=
$exp
;
}
else
{
die
"Urecognized operator '$op' in expression $opts->{expression} of node '$this_node_id'\n"
;
}
}
return
qq{($out$mult)}
}
elsif
(
$type
eq
'SET'
) {
my
$res
=
'('
.
join
(
','
,
map
{
$self
->serialize_expression_pt(
$_
,
$opts
,
$extra_joins
) }
@$pt
)
.
')'
;
$opts
->{can_be_null}=0;
return
$res
;
}
else
{
die
"Internal error: unrecognized parse tree item $type\n"
;
}
}
else
{
if
(
$pt
=~/^[-0-9]/) {
return
qq( $pt )
;
}
elsif
(
$pt
=~s/^(['"])(.*)\1$/$2/s) {
$pt
=~s/\\(.)/$1/sg;
$opts
->{can_be_null}=1
if
!
length
$pt
;
if
(
$pt
=~m/\\/) {
$pt
=~s/
'/\\'
/sg;
$pt
=~s{\\}{\\\\}g;
qq( E'$pt' )
;
}
else
{
$pt
=~s/
'/'
'/sg;
qq( '$pt' )
;
}
}
elsif
(
$pt
=~s/^\$//) {
if
(
$pt
=~ /^\d+$/) {
die
"Column reference \$$pt can only be used in an output filter; error in expression '$opts->{expression}' of node '$this_node_id'\n"
unless
$opts
->{
'output_filter'
};
my
$col
;
if
(!
$opts
->{output_filter_where_clause} and
$opts
->{group_by} and @{
$opts
->{group_by}}) {
$col
=
$opts
->{group_by}[
$pt
-1];
if
(!
defined
$col
) {
die
"Cannot refer to column number $pt from the expression $opts->{expression} following a 'for' with "
.
scalar
(@{
$opts
->{group_by}}).
" column(s): ("
.
join
(
', '
,ListV(
$opts
->{group_by})).
")!\n"
;
}
}
else
{
if
(
$opts
->{
'output_filter'
}<2) {
die
"Cannot refer to a numbered column \$$pt from the first filter!\n"
;
}
elsif
(
$pt
-1 < ListV(
$opts
->{prev_columns})) {
$col
=
'c'
.(
$opts
->{
'output_filter'
}-1).
'_'
.
$pt
;
}
else
{
die
"Cannot refer to column number $pt from the expression '$opts->{expression}' following a filter with "
.
scalar
(@{
$opts
->{prev_columns}}).
" column(s): ("
.
join
(
', '
,ListV(
$opts
->{prev_columns})).
")!\n"
;
}
}
return
' '
.
$col
.
' '
;
}
if
(
defined
(
$opts
->{
'output_filter'
}) and
$opts
->{
'output_filter'
}==1) {
if
(
$pt
eq
'$'
) {
die
"The variable '\$\$' cannot be used in an output filter!\n"
;
}
elsif
(
$self
->cmp_subquery_scope(
$this_node_id
,
$pt
)<0) {
die
"Node '$pt' belongs to a sub-query and cannot be referred from the scope of node '$this_node_id' ($opts->{expression})\n"
;
}
return
qq{ "#qnodes"."$pt.#idx" }
; # not
"$pt"
.
"#idx"
!!
}
elsif
(
$opts
->{
'output_filter'
}) {
die
(
"Cannot refer to a named node '$pt' from an output filters except for the first filter! ($opts->{expression})\n"
);
}
else
{
return
qq{ "$this_node_id"."#idx" }
if
$pt
eq
'$'
;
if
(
$self
->cmp_subquery_scope(
$this_node_id
,
$pt
)<0) {
die
"Node '$pt' belongs to a sub-query and cannot be referred from the scope of node '$this_node_id' ($opts->{expression})\n"
;
}
return
qq( "$pt"."#idx" )
;
}
}
else
{
die
"Token '$pt' not recognized in expression $opts->{expression} of node '$this_node_id'\n"
;
}
}
}
sub
serialize_expression {
my
(
$self
,
$opts
)=
@_
;
my
$pt
=
$opts
->{
'output_filter'
}
? PMLTQ::Common::parse_column_expression(
$opts
->{expression})
: PMLTQ::Common::parse_expression(
$opts
->{expression});
die
"Invalid expression '$opts->{expression}' on node '$opts->{id}'"
unless
defined
$pt
;
my
$extra_joins
=
$opts
->{
'output_filter'
} ?
$opts
->{
join
} : {};
$opts
->{use_exists}=0;
$opts
->{can_be_null}=0;
my
$out
=
$self
->serialize_expression_pt(
$pt
,
$opts
,
$extra_joins
);
my
$wrap
;
if
(!
$opts
->{
'output_filter'
} and
$opts
->{use_exists}) {
my
@from
;
my
@where
;
for
my
$name
(
grep
{
$_
ne
'..'
}
keys
(
%$extra_joins
)) {
if
(
$extra_joins
->{
$name
}) {
my
$table
;
for
my
$join_spec
(@{
$extra_joins
->{
$name
}}) {
my
(
$join_as
,
$join_tab
,
$join_on
,
$join_type
)=@{
$join_spec
};
$join_type
||=
''
;
$join_tab
=
$self
->get_real_table_name(
$join_tab
);
if
(
defined
$table
) {
$table
.=
qq(\n $join_type JOIN "$join_tab" "$join_as" ON $join_on)
;
}
else
{
$table
=
qq("$join_tab" "$join_as")
;
push
@where
,
$join_on
;
}
}
push
@from
,
$table
;
}
}
if
(
@from
) {
$wrap
=(
$opts
->{use_exists}==2 ?
'NOT EXISTS'
:
'EXISTS'
).
' (SELECT *'
.
' FROM '
.
join
(
', '
,
@from
)
.
' WHERE '
.
join
(
"\n AND "
,
@where
);
$wrap
=~s/%/%%/g;
$wrap
.=
"\n AND "
if
@where
;
if
(
$opts
->{use_exists}==2) {
$wrap
.=
'NOT(%s) )'
;
}
else
{
$wrap
.=
'%s )'
;
}
}
}
return
(
$out
,
$wrap
,
$opts
->{can_be_null});
}
sub
compute_data_type {
my
(
$self
,
$exp
,
$opts
)=
@_
;
if
(
$opts
->{output_filter}) {
return
PMLTQ::Common::compute_column_data_type(
$self
,
$exp
,
$opts
);
}
else
{
return
PMLTQ::Common::compute_expression_data_type(
$self
,
$exp
,
$opts
);
}
}
sub
serialize_predicate {
my
(
$self
,
$L
,
$R
,
$operator
,
$opts
)=
@_
;
$opts
->{
join
}||={};
my
(
$left
,
$wrap_left
,
$left_can_be_null
) =
ref
(
$L
) ?
(
defined
(
$L
->{sql}) ? (
$L
->{sql}) :
$self
->serialize_expression(
$L
)) : (
$L
);
if
(
ref
(
$L
) and
defined
(
$L
->{use_exists}) and
$L
->{use_exists}==2) {
$R
->{is_positive_conjunct}=0;
$R
->{can_be_null}=1;
}
my
$right_every
;
my
(
$right
,
$wrap_right
,
$right_can_be_null
) =
ref
(
$R
) ?
(
defined
(
$R
->{sql}) ? (
$R
->{sql}) :
$self
->serialize_expression(
$R
)) : (
$R
);
my
$is_positive_conjunct
=
$opts
->{is_positive_conjunct};
my
$negate
=
$operator
=~ s/^!// ? 1 : 0;
$is_positive_conjunct
=0
if
$is_positive_conjunct
&&
$negate
;
my
$res
;
my
(
$R_type
,
$L_type
) = (COL_UNKNOWN, COL_UNKNOWN);
$R_type
=
ref
(
$R
) ?
(
defined
(
$R
->{col_type}) ?
$R
->{col_type} :
$self
->compute_data_type(
$R
->{expression},
$opts
))
:
defined
(
$opts
->{R_type}) ?
$opts
->{R_type} : COL_UNKNOWN;
$L_type
=
ref
(
$L
) ?
(
defined
(
$L
->{col_type}) ?
$L
->{col_type} :
$self
->compute_data_type(
$L
->{expression},
$opts
))
:
defined
(
$opts
->{L_type}) ?
$opts
->{L_type} : COL_UNKNOWN;
if
(
$right
=~
qr{^\s*[NE]?''\s*$}
and
$left
=~
qr{^\s*[NE]?''\s*$}
) {
$res
=
qq{0=0}
}
elsif
(
$right
=~
qr{^\s*[NE]?''\s*$}
) {
if
(
$L_type
== COL_STRING) {
$res
=
qq{($left }
.
uc
(
$operator
).
qq{ $right OR $left IS NULL)}
}
else
{
$res
=
qq{$left IS NULL}
}
}
elsif
(
$left
=~
qr{^\s*[NE]?''\s*$}
) {
if
(
$R_type
== COL_STRING) {
$res
=
qq{($right }
.
uc
(
$operator
).
qq{ $left OR $right IS NULL)}
}
else
{
$res
=
qq{$right IS NULL}
}
}
if
(!
defined
$res
) {
if
(
$operator
=~/[<>=]/) {
if
(
$L_type
== COL_NUMERIC and
$R_type
!= COL_NUMERIC) {
$left
=
qq{cast($left as varchar)}
;
}
elsif
(
$R_type
== COL_NUMERIC and
$L_type
!= COL_NUMERIC) {
$right
=
qq{cast($right as varchar)}
;
}
}
my
$cmp
=
$operator
=~/^<(.*),(.*)>$/ ?
qq{($left - $right)}
.
(
(
length
($1) and
length
($2)) ?
qq{BETWEEN $1 AND $2}
:
length
($1) ?
qq{>=$1}
:
length
($2) ?
qq{<=$2}
:
die
(
"Internal error: cannot serialize operator $operator\n"
)
)
:
qq{$left }
.
uc
(
$operator
).
qq{ $right}
;
$res
=
'('
.
$cmp
.(
$left_can_be_null
&& !
$is_positive_conjunct
?
qq{ AND $left IS NOT NULL}
:
''
)
.(
$right_can_be_null
&& !
$is_positive_conjunct
?
qq{ AND $right IS NOT NULL}
:
''
)
.
')'
;
}
$res
=
qq{NOT($res)}
if
$negate
;
if
(
defined
$wrap_right
) {
$res
=
sprintf
(
$wrap_right
,
$res
);
}
if
(
defined
$wrap_left
) {
$res
=
sprintf
(
$wrap_left
,
$res
);
}
return
$res
;
}
sub
serialize_element {
my
(
$self
,
$opts
)=
@_
;
my
(
$name
,
$node
,
$as_id
,
$parent_as_id
)=
map
{
$opts
->{
$_
}}
qw(name condition id parent_id)
;
my
$is_positive_conjunct
=
$opts
->{is_positive_conjunct};
if
(
$name
eq
'test'
) {
return
[
$self
->serialize_predicate({
%$opts
,
expression
=>
$node
->{a},
is_positive_conjunct
=>
$is_positive_conjunct
},
{
%$opts
,
expression
=>
$node
->{b},
is_positive_conjunct
=>
$is_positive_conjunct
},
$node
->{operator},
$opts
),
$node
];
}
elsif
(
$name
=~ /^(?:and|or|not)$/) {
my
@c
=
$node
->children;
if
(
defined
(
$is_positive_conjunct
)) {
if
(
$name
eq
'not'
) {
$is_positive_conjunct
=!
$is_positive_conjunct
;
$is_positive_conjunct
=
undef
if
@c
>1 and !
$is_positive_conjunct
;
}
elsif
(
$name
eq
'and'
) {
$is_positive_conjunct
=
undef
if
@c
>1 and !
$is_positive_conjunct
;
}
elsif
(
$name
eq
'or'
) {
$is_positive_conjunct
=
undef
if
@c
>1 and
$is_positive_conjunct
;
}
}
@c
=
grep
{
@$_
}
map
{
my
$n
=
$_
->{
'#name'
};
$self
->serialize_element({
%$opts
,
name
=>
$n
,
condition
=>
$_
,
id
=>
$as_id
,
parent_id
=>
$parent_as_id
,
is_positive_conjunct
=>
$is_positive_conjunct
})
}
grep
{
$_
->{
'#name'
} ne
'node'
}
@c
;
return
unless
@c
;
return
$name
eq
'not'
? [[[
'NOT('
],@{PMLTQ::Common::_group(\
@c
,[
"\n AND "
])},[
')'
]],
$node
] :
$name
eq
'and'
? [[[
'('
],@{PMLTQ::Common::_group(\
@c
,[
"\n AND "
])},[
')'
]],
$node
] :
$name
eq
'or'
? [[[
'('
],@{PMLTQ::Common::_group(\
@c
,[
"\n OR "
])},[
')'
]],
$node
] : ();
}
elsif
(
$name
eq
'subquery'
) {
my
@sql
;
my
@occ
;
my
@vals
=
grep
ref
, AltV(
$node
->{occurrences});
@vals
=(Treex::PML::Factory->createStructure({
min
=>1}))
unless
@vals
;
my
(
$exists
,
$not_exists
);
$exists
= (
@vals
==1 and
$vals
[0]{min}==1 and
(!
defined
(
$vals
[0]{max}) or !
length
(
$vals
[0]{max})));
$not_exists
= ( !
$exists
and
@vals
== 1
and
defined
$vals
[0]{max} and
length
$vals
[0]{max} and
$vals
[0]{max} == 0
and (
$vals
[0]{min}||0) == 0);
my
$subquery
=
$self
->build_sql(
$node
,{
format
=> 1,
count
=> (
$exists
||
$not_exists
) ? 3 : 2,
parent_id
=>
$opts
->{id},
join
=> {
'..'
=>
$opts
->{
join
},
},
});
if
(
$exists
) {
return
[[[
'EXISTS ('
],
@$subquery
,[
qq')'
]],
$node
];
}
elsif
(
$not_exists
) {
return
[[[
'NOT EXISTS ('
],
@$subquery
,[
qq')'
]],
$node
];
}
else
{
for
my
$occ
(
@vals
) {
my
(
$min
,
$max
)=(
$occ
->{min},
$occ
->{max});
$min
=
''
unless
defined
$min
;
$max
=
''
unless
defined
$max
;
if
(
length
(
$min
) and
length
(
$max
)) {
if
(
$min
==
$max
) {
push
@occ
,[[[
'('
],
@$subquery
,[
qq')=$min'
]],
$node
];
}
else
{
push
@occ
,[[[
'('
],
@$subquery
,[
qq') BETWEEN $min AND $max'
]],
$node
];
}
}
elsif
(
length
(
$min
)) {
push
@occ
,[[[
'('
],
@$subquery
,[
qq')>=$min'
]],
$node
];
}
elsif
(
length
(
$max
)) {
push
@occ
,[[[
'('
],
@$subquery
,[
qq')<=$max'
]],
$node
];
}
}
return
(
@occ
? [[ [
'('
],@{PMLTQ::Common::_group(\
@occ
,[
' OR '
])},[
')'
] ],
$node
] : ());
}
}
elsif
(
$name
eq
'ref'
) {
my
$target
=
$node
->{target};
my
$cmp
=
$self
->cmp_subquery_scope(
$node
,
$target
);
if
(
$cmp
<0) {
die
"Node '$as_id' belongs to a sub-query and cannot be referred from the scope of node '$target'\n"
;
}
my
(
$rel
) = SeqV(
$node
->{relation});
if
(
$target
and
$rel
) {
return
[
'('
.
$self
->relation(
$as_id
,
$rel
,
$target
,
{
%$opts
,
is_positive_conjunct
=>((
$opts
->{is_positive_conjunct} || !
$cmp
)
? 1 :
undef
)},
$opts
).
')'
,
$node
];
}
else
{
return
;
}
}
else
{
Carp::cluck(
"Unknown element $name "
);
return
;
}
}
sub
cmp_subquery_scope {
my
(
$self
,
$src
,
$target
)=
@_
;
$_
=
ref
(
$_
) ?
$_
:
$self
->{name2node}{
$_
} || croak(
"Didn't find node '\$$_'"
)
for
$src
,
$target
;
return
PMLTQ::Common::cmp_subquery_scope(
$src
,
$target
);
}
sub
DESTROY {
my
$self
=
shift
;
$self
->{dbi}->disconnect()
if
$self
->{dbi};
}
1;
Hide Show 43 lines of Pod