1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
|
package UR::BoolExpr::Template::PropertyComparison;
use warnings;
use strict;
our $VERSION = "0.47"; # UR $VERSION;
# Define the class metadata.
require UR;
UR::Object::Type->define(
class_name => __PACKAGE__,
is => ['UR::BoolExpr::Template'],
#has => [qw/
# rule_type
# subject_class_name
# property_name
# comparison_operator
# value
# resolution_code_perl
# resolution_code_sql
#/],
#id_by => ['subject_class_name','logic_string']
);
use UR::BoolExpr::Template::PropertyComparison::Equals;
use UR::BoolExpr::Template::PropertyComparison::LessThan;
use UR::BoolExpr::Template::PropertyComparison::In;
use UR::BoolExpr::Template::PropertyComparison::Like;
sub property_name {
(split(' ',$_[0]->logic_detail))[0]
}
sub comparison_operator {
(split(' ',$_[0]->logic_detail))[1]
}
sub sub_group {
my $self = shift;
my $spec = $self->property_name;
if ($spec =~ /-/) {
#$DB::single = 1;
}
if ($spec =~ /^(.*)+\-(\w+)(\?|)(\..+|)/) {
return $2 . $3;
}
else {
return '';
}
}
sub get_underlying_rules_for_values {
return;
}
sub num_values {
# Not strictly correct...
return 1;
}
sub evaluate_subject_and_values {
my ($self,$subject,$comparison_value) = @_;
my @property_values = $subject->__get_attr__($self->property_name);
return $self->_compare($comparison_value, @property_values);
}
sub resolve_subclass_for_comparison_operator {
my $class = shift;
my $comparison_operator = shift;
# Remove any escape sequence that may have been put in at UR::BoolExpr::resolve()
$comparison_operator =~ s/-.+$// if $comparison_operator;
my $suffix = UR::Util::class_suffix_for_operator($comparison_operator);
my $subclass_name = join('::', $class, $suffix);
my $subclass_meta = UR::Object::Type->get($subclass_name);
unless ($subclass_meta) {
Carp::confess("Unknown operator '$comparison_operator'");
}
return $subclass_name;
}
sub _get_for_subject_class_name_and_logic_detail {
my $class = shift;
my $subject_class_name = shift;
my $logic_detail = shift;
my ($property_name, $comparison_operator) = split(' ',$logic_detail, 2);
my $subclass_name = $class->resolve_subclass_for_comparison_operator($comparison_operator);
my $id = $subclass_name->__meta__->resolve_composite_id_from_ordered_values($subject_class_name, 'PropertyComparison', $logic_detail);
return $subclass_name->get($id);
}
sub comparison_value_and_escape_character_to_regex {
my ($class, $value, $escape) = @_;
return '' unless defined($value);
# anyone who uses the % as an escape character deserves to suffer
if ($value eq '%') {
return '^.+$';
}
my $regex = $value;
# Escape all special characters in the regex.
$regex =~ s/([\(\)\[\]\{\}\+\*\.\?\|\^\$\-])/\\$1/g;
# Handle the escape sequence
if (defined $escape)
{
$escape =~ s/\\/\\\\/g; # replace \ with \\
$regex =~ s/(?<!${escape})\%/\.\*/g;
$regex =~ s/(?<!${escape})\_/./g;
#LSF: Take away the escape characters.
$regex =~ s/$escape\%/\%/g;
$regex =~ s/$escape\_/\_/g;
}
else
{
$regex =~ s/\%/\.\*/g;
$regex =~ s/\_/\./g;
}
# Wrap the regex in delimiters.
$regex = "^${regex}\$";
my $exception = do {
local $@;
$regex = eval { qr($regex) };
$@;
};
if ($exception) {
Carp::confess($exception);
}
return $regex;
}
1;
=head1 NAME
UR::BoolExpr::Template::PropertyComparison - implements logic for rules with a logic_type of "PropertyComparison"
=head1 SEE ALSO
UR::Object(3), UR::BoolExpr::Temmplate(3), UR::BoolExpr(3), UR::BoolExpr::Template::PropertyComparison::*
=cut
|
