line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Apache::Voodoo; |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
$VERSION = "3.0200"; |
4
|
|
|
|
|
|
|
|
5
|
4
|
|
|
4
|
|
723
|
use strict; |
|
4
|
|
|
|
|
9
|
|
|
4
|
|
|
|
|
126
|
|
6
|
4
|
|
|
4
|
|
20
|
use warnings; |
|
4
|
|
|
|
|
8
|
|
|
4
|
|
|
|
|
95
|
|
7
|
|
|
|
|
|
|
|
8
|
4
|
|
|
4
|
|
1180
|
use Data::Dumper; |
|
4
|
|
|
|
|
6837
|
|
|
4
|
|
|
|
|
252
|
|
9
|
4
|
|
|
4
|
|
3205
|
use Time::HiRes; |
|
4
|
|
|
|
|
10555
|
|
|
4
|
|
|
|
|
24
|
|
10
|
4
|
|
|
4
|
|
1082
|
use Apache::Voodoo::Exception; |
|
4
|
|
|
|
|
10
|
|
|
4
|
|
|
|
|
23874
|
|
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
sub new { |
13
|
16
|
|
|
16
|
0
|
37
|
my $class = shift; |
14
|
16
|
|
|
|
|
49
|
my $self = {}; |
15
|
|
|
|
|
|
|
|
16
|
16
|
|
|
|
|
53
|
bless $self, $class; |
17
|
|
|
|
|
|
|
|
18
|
16
|
|
|
|
|
106
|
return $self; |
19
|
|
|
|
|
|
|
} |
20
|
|
|
|
|
|
|
|
21
|
5
|
|
|
5
|
0
|
18
|
sub init { } |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
################################################################################ |
24
|
|
|
|
|
|
|
# Debugging |
25
|
|
|
|
|
|
|
################################################################################ |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
sub debug { |
28
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
29
|
|
|
|
|
|
|
|
30
|
0
|
0
|
|
|
|
|
if (ref($Apache::Voodoo::Engine::debug)) { |
31
|
0
|
|
|
|
|
|
$Apache::Voodoo::Engine::debug->debug(@_); |
32
|
|
|
|
|
|
|
} |
33
|
|
|
|
|
|
|
} |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
sub info { |
36
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
37
|
|
|
|
|
|
|
|
38
|
0
|
0
|
|
|
|
|
if (ref($Apache::Voodoo::Engine::debug)) { |
39
|
0
|
|
|
|
|
|
$Apache::Voodoo::Engine::debug->info(@_); |
40
|
|
|
|
|
|
|
} |
41
|
|
|
|
|
|
|
} |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
sub warn { |
44
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
45
|
|
|
|
|
|
|
|
46
|
0
|
0
|
|
|
|
|
if (ref($Apache::Voodoo::Engine::debug)) { |
47
|
0
|
|
|
|
|
|
$Apache::Voodoo::Engine::debug->warn(@_); |
48
|
|
|
|
|
|
|
} |
49
|
|
|
|
|
|
|
} |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
sub error { |
52
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
53
|
|
|
|
|
|
|
|
54
|
0
|
0
|
|
|
|
|
if (ref($Apache::Voodoo::Engine::debug)) { |
55
|
0
|
|
|
|
|
|
$Apache::Voodoo::Engine::debug->error(@_); |
56
|
|
|
|
|
|
|
} |
57
|
|
|
|
|
|
|
} |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
sub exception { |
60
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
61
|
|
|
|
|
|
|
|
62
|
0
|
0
|
|
|
|
|
if (ref($Apache::Voodoo::Engine::debug)) { |
63
|
0
|
|
|
|
|
|
$Apache::Voodoo::Engine::debug->exception(@_); |
64
|
|
|
|
|
|
|
} |
65
|
0
|
|
|
|
|
|
Apache::Voodoo::Exception::RunTime::Thrown->throw(join("\n",@_)); |
66
|
|
|
|
|
|
|
} |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
sub trace { |
69
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
70
|
|
|
|
|
|
|
|
71
|
0
|
0
|
|
|
|
|
if (ref($Apache::Voodoo::Engine::debug)) { |
72
|
0
|
|
|
|
|
|
$Apache::Voodoo::Engine::debug->trace(@_); |
73
|
|
|
|
|
|
|
} |
74
|
|
|
|
|
|
|
} |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
sub table { |
77
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
78
|
|
|
|
|
|
|
|
79
|
0
|
0
|
|
|
|
|
if (ref($Apache::Voodoo::Engine::debug)) { |
80
|
0
|
|
|
|
|
|
$Apache::Voodoo::Engine::debug->table(@_); |
81
|
|
|
|
|
|
|
} |
82
|
|
|
|
|
|
|
} |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
sub mark { |
85
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
86
|
|
|
|
|
|
|
|
87
|
0
|
0
|
|
|
|
|
if (defined($Apache::Voodoo::Engine::debug)) { |
88
|
0
|
|
|
|
|
|
$Apache::Voodoo::Engine::debug->mark(Time::HiRes::time, @_); |
89
|
|
|
|
|
|
|
} |
90
|
|
|
|
|
|
|
} |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
################################################################################ |
93
|
|
|
|
|
|
|
# Behavior control |
94
|
|
|
|
|
|
|
################################################################################ |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
sub set_view { |
97
|
0
|
|
|
0
|
0
|
|
$_[1]->{_view_} = $_[2]; |
98
|
|
|
|
|
|
|
} |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
sub stop_chain { |
101
|
0
|
|
|
0
|
0
|
|
$_[1]->{_stop_chain_} = 1; |
102
|
|
|
|
|
|
|
} |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
sub redirect { |
105
|
0
|
|
|
0
|
0
|
|
shift; |
106
|
0
|
|
|
|
|
|
Apache::Voodoo::Exception::Application::Redirect->throw(target => shift); |
107
|
|
|
|
|
|
|
} |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
sub display_error { |
110
|
0
|
|
|
0
|
0
|
|
shift; |
111
|
0
|
|
|
|
|
|
my ($c,$e,$t); |
112
|
0
|
0
|
0
|
|
|
|
if (@_ == 3) { |
|
|
0
|
|
|
|
|
|
113
|
0
|
|
|
|
|
|
($c,$e,$t) = @_; |
114
|
|
|
|
|
|
|
} |
115
|
|
|
|
|
|
|
elsif (@_ >= 2 && $_[0] =~ /^\s*[\w:\.-]+\s*$/) { |
116
|
0
|
|
|
|
|
|
$c = shift; |
117
|
0
|
|
|
|
|
|
$e = shift; |
118
|
0
|
|
0
|
|
|
|
$t = shift || '/index'; |
119
|
|
|
|
|
|
|
} |
120
|
|
|
|
|
|
|
else { |
121
|
0
|
|
|
|
|
|
$c = '500'; |
122
|
0
|
|
|
|
|
|
$e = shift; |
123
|
0
|
|
0
|
|
|
|
$t = shift || '/index'; |
124
|
|
|
|
|
|
|
} |
125
|
|
|
|
|
|
|
|
126
|
0
|
0
|
|
|
|
|
if (ref($t)) { |
127
|
0
|
|
|
|
|
|
Apache::Voodoo::Exception::Application::DisplayError->throw( |
128
|
|
|
|
|
|
|
code => $c, |
129
|
|
|
|
|
|
|
error => $e, |
130
|
|
|
|
|
|
|
detail => $t |
131
|
|
|
|
|
|
|
); |
132
|
|
|
|
|
|
|
} |
133
|
|
|
|
|
|
|
else { |
134
|
0
|
|
|
|
|
|
Apache::Voodoo::Exception::Application::DisplayError->throw( |
135
|
|
|
|
|
|
|
code => $c, |
136
|
|
|
|
|
|
|
error => $e, |
137
|
|
|
|
|
|
|
target => $t |
138
|
|
|
|
|
|
|
); |
139
|
|
|
|
|
|
|
} |
140
|
|
|
|
|
|
|
} |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
sub access_denied { |
143
|
0
|
|
|
0
|
0
|
|
shift; |
144
|
0
|
|
0
|
|
|
|
my $m = shift || "Access Denied"; |
145
|
0
|
|
0
|
|
|
|
my $t = shift || "/access_denied"; |
146
|
|
|
|
|
|
|
|
147
|
0
|
0
|
|
|
|
|
if (ref($t)) { |
148
|
0
|
|
|
|
|
|
Apache::Voodoo::Exception::Application::AccessDenied->throw( |
149
|
|
|
|
|
|
|
error => $m, |
150
|
|
|
|
|
|
|
detail => $t |
151
|
|
|
|
|
|
|
); |
152
|
|
|
|
|
|
|
} |
153
|
|
|
|
|
|
|
else { |
154
|
0
|
|
|
|
|
|
Apache::Voodoo::Exception::Application::AccessDenied->throw( |
155
|
|
|
|
|
|
|
error => $m, |
156
|
|
|
|
|
|
|
target => $t |
157
|
|
|
|
|
|
|
); |
158
|
|
|
|
|
|
|
} |
159
|
|
|
|
|
|
|
} |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
sub raw_mode { |
162
|
0
|
|
|
0
|
0
|
|
my ($self,$c,$d,$h) = @_; |
163
|
0
|
|
|
|
|
|
Apache::Voodoo::Exception::Application::RawData->throw( |
164
|
|
|
|
|
|
|
"content_type" => $c, |
165
|
|
|
|
|
|
|
"data" => $d, |
166
|
|
|
|
|
|
|
"headers" => $h |
167
|
|
|
|
|
|
|
); |
168
|
|
|
|
|
|
|
} |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
sub history { |
171
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
172
|
0
|
|
|
|
|
|
my $session = shift; |
173
|
0
|
|
|
|
|
|
my $index = shift; |
174
|
|
|
|
|
|
|
|
175
|
0
|
|
|
|
|
|
return $session->{'history'}->[$index]->{'uri'}.'?'.$session->{'history'}->[$index]->{'params'}; |
176
|
|
|
|
|
|
|
} |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
sub tardis { |
179
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
180
|
0
|
|
|
|
|
|
my $p = shift; |
181
|
|
|
|
|
|
|
|
182
|
0
|
|
|
|
|
|
my %targets = map { $_ => 1 } @_; |
|
0
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
|
184
|
0
|
|
|
|
|
|
my $history = $p->{'session'}->{'history'}; |
185
|
|
|
|
|
|
|
|
186
|
0
|
|
|
|
|
|
for (my $i=0; $i <= $#{$history}; $i++) { |
|
0
|
|
|
|
|
|
|
187
|
0
|
0
|
|
|
|
|
if ($targets{$history->[$i]->{'uri'}}) { |
188
|
0
|
|
|
|
|
|
return $self->redirect($self->history($p->{'session'},$i)); |
189
|
|
|
|
|
|
|
} |
190
|
|
|
|
|
|
|
} |
191
|
|
|
|
|
|
|
|
192
|
0
|
|
|
|
|
|
return $self->redirect($self->history($p->{'session'},1)); |
193
|
|
|
|
|
|
|
} |
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
################################################################################ |
196
|
|
|
|
|
|
|
# Text Manipulation |
197
|
|
|
|
|
|
|
################################################################################ |
198
|
|
|
|
|
|
|
|
199
|
|
|
|
|
|
|
sub mkurlparams { |
200
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
201
|
0
|
|
|
|
|
|
my $h = shift; |
202
|
0
|
|
0
|
|
|
|
my $o = shift || {}; |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
# keep track of what keys out of $o we've used in a non-destructive |
205
|
|
|
|
|
|
|
# way to the original structure; |
206
|
0
|
|
|
|
|
|
my %used; |
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
my @return; |
209
|
0
|
|
|
|
|
|
foreach my $key (keys %{$h}) { |
|
0
|
|
|
|
|
|
|
210
|
0
|
0
|
|
|
|
|
next if exists($o->{$key}); |
211
|
|
|
|
|
|
|
|
212
|
|
|
|
|
|
|
# if this key is in $o then we use it's values instead of those in $h |
213
|
0
|
0
|
|
|
|
|
if (defined($o->{$key})) { |
214
|
0
|
0
|
|
|
|
|
if (ref($o->{$key})) { |
215
|
0
|
|
|
|
|
|
push(@return, map { "$key=$_" } @{$o->{$key}} ); |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
} |
217
|
|
|
|
|
|
|
else { |
218
|
0
|
0
|
|
|
|
|
push(@return,"$key=$o->{$key}") if length($o->{$key}); |
219
|
|
|
|
|
|
|
} |
220
|
|
|
|
|
|
|
|
221
|
0
|
|
|
|
|
|
$used{$key} = 1; |
222
|
|
|
|
|
|
|
} |
223
|
|
|
|
|
|
|
else { |
224
|
0
|
0
|
|
|
|
|
if (ref($h->{$key})) { |
225
|
0
|
|
|
|
|
|
push(@return, map { "$key=$_" } @{$h->{$key}} ); |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
226
|
|
|
|
|
|
|
} |
227
|
|
|
|
|
|
|
else { |
228
|
0
|
0
|
0
|
|
|
|
push(@return,"$key=$h->{$key}") if defined($h->{$key}) && length($h->{$key}); |
229
|
|
|
|
|
|
|
} |
230
|
|
|
|
|
|
|
} |
231
|
|
|
|
|
|
|
} |
232
|
|
|
|
|
|
|
|
233
|
|
|
|
|
|
|
# append the data in $o |
234
|
0
|
|
|
|
|
|
foreach my $key (keys %{$o}) { |
|
0
|
|
|
|
|
|
|
235
|
0
|
0
|
|
|
|
|
next if $used{$key}; # this one was used to override the value in $h, skip it |
236
|
|
|
|
|
|
|
|
237
|
0
|
0
|
|
|
|
|
if (ref($o->{$key})) { |
238
|
0
|
|
|
|
|
|
push(@return, map { "$key=$_" } @{$o->{$key}} ); |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
} |
240
|
|
|
|
|
|
|
else { |
241
|
0
|
0
|
|
|
|
|
push(@return,"$key=$o->{$key}") if length($o->{$key}); |
242
|
|
|
|
|
|
|
} |
243
|
|
|
|
|
|
|
} |
244
|
|
|
|
|
|
|
|
245
|
0
|
|
|
|
|
|
return join("&",@return); |
246
|
|
|
|
|
|
|
} |
247
|
|
|
|
|
|
|
|
248
|
|
|
|
|
|
|
sub prep_select { |
249
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
250
|
0
|
|
|
|
|
|
my $list = shift; |
251
|
0
|
|
|
|
|
|
my $select = shift; |
252
|
|
|
|
|
|
|
|
253
|
0
|
0
|
|
|
|
|
unless (ref($select)) { |
254
|
0
|
|
|
|
|
|
$select = [ $select ]; |
255
|
|
|
|
|
|
|
} |
256
|
0
|
|
|
|
|
|
my %selected = map { $_ => 1 } @{$select}; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
257
|
|
|
|
|
|
|
|
258
|
|
|
|
|
|
|
return [ |
259
|
0
|
0
|
|
|
|
|
map { |
260
|
0
|
|
|
|
|
|
{ |
261
|
|
|
|
|
|
|
"ID" => $_->[0], |
262
|
|
|
|
|
|
|
"ID." . $_->[0] => 1, |
263
|
|
|
|
|
|
|
"NAME" => $_->[1], |
264
|
|
|
|
|
|
|
"NAME." . $_->[1] => 1, |
265
|
|
|
|
|
|
|
"SELECTED" => (defined $selected{$_->[0]})?'SELECTED':0 |
266
|
|
|
|
|
|
|
} |
267
|
0
|
|
|
|
|
|
} @{$list} |
268
|
|
|
|
|
|
|
]; |
269
|
|
|
|
|
|
|
} |
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
sub safe_text { |
272
|
|
|
|
|
|
|
# return $_[1] =~ /^[\w\s\.\,\/\[\]\{\}\+\=\-\(\)\:\;\&\?\*\'\!]*$/; |
273
|
0
|
|
|
0
|
0
|
|
return $_[1] =~ /^[\w\s\.\,\/\[\]\{\}\+\=\-\(\)\:\;\&\?\!\*]*$/; |
274
|
|
|
|
|
|
|
} |
275
|
|
|
|
|
|
|
|
276
|
|
|
|
|
|
|
sub sanitize_text { |
277
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
278
|
0
|
|
|
|
|
|
my $text = shift; |
279
|
|
|
|
|
|
|
|
280
|
|
|
|
|
|
|
# return $_[1] =~ /^[\w\s\.\,\/\[\]\{\}\+\=\-\(\)\:\;\&\?\*\'\!]*$/; |
281
|
0
|
|
|
|
|
|
$text =~ s/[^\w\s\.\,\/\[\]\{\}\+\=\-\(\)\:\;\&\?\!\*]/ /g; |
282
|
0
|
|
|
|
|
|
return $text; |
283
|
|
|
|
|
|
|
} |
284
|
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
sub trim { |
286
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
287
|
0
|
|
0
|
|
|
|
my $param = shift || ""; |
288
|
|
|
|
|
|
|
|
289
|
0
|
|
|
|
|
|
$param =~ s/^\s*//o; |
290
|
0
|
|
|
|
|
|
$param =~ s/\s*$//o; |
291
|
|
|
|
|
|
|
|
292
|
0
|
|
|
|
|
|
return $param; |
293
|
|
|
|
|
|
|
} |
294
|
|
|
|
|
|
|
|
295
|
|
|
|
|
|
|
################################################################################ |
296
|
|
|
|
|
|
|
# Database Interaction |
297
|
|
|
|
|
|
|
################################################################################ |
298
|
|
|
|
|
|
|
|
299
|
|
|
|
|
|
|
# deprecated, dbi uses exceptions now. |
300
|
|
|
|
|
|
|
sub db_error { |
301
|
0
|
|
|
0
|
0
|
|
my @caller = caller(1); |
302
|
|
|
|
|
|
|
|
303
|
0
|
|
|
|
|
|
my $query = $DBI::lasth->{'Statement'}; |
304
|
0
|
|
|
|
|
|
$query = join("\n", map { $_ =~ s/^\s*//; $_} split(/\n/,$query)); |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
305
|
|
|
|
|
|
|
|
306
|
0
|
|
|
|
|
|
my $errstr = "\n"; |
307
|
0
|
|
|
|
|
|
$errstr .= "==================== DB ERROR ====================\n"; |
308
|
0
|
|
|
|
|
|
$errstr .= "TIME: ". scalar(localtime) . "\n"; |
309
|
0
|
|
|
|
|
|
$errstr .= "PACKAGE: $caller[0]\n"; |
310
|
0
|
|
|
|
|
|
$errstr .= "FILE: $caller[1]\n"; |
311
|
0
|
|
|
|
|
|
$errstr .= "SUBROUTINE: $caller[3]\n"; |
312
|
0
|
|
|
|
|
|
$errstr .= "LINE: $caller[2]\n\n"; |
313
|
0
|
|
|
|
|
|
$errstr .= "$DBI::errstr\n"; |
314
|
0
|
|
|
|
|
|
$errstr .= "===================== QUERY ======================\n"; |
315
|
0
|
|
|
|
|
|
$errstr .= "$query\n"; |
316
|
0
|
|
|
|
|
|
$errstr .= "==================================================\n"; |
317
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
# don't really care for this, but there doesn't seem to be any way to |
319
|
|
|
|
|
|
|
# terminate this request. |
320
|
0
|
|
|
|
|
|
die $errstr; |
321
|
|
|
|
|
|
|
} |
322
|
|
|
|
|
|
|
|
323
|
|
|
|
|
|
|
sub date_to_sql { |
324
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
325
|
0
|
|
|
|
|
|
my $date = shift; |
326
|
|
|
|
|
|
|
|
327
|
|
|
|
|
|
|
# Get rid of all spaces in the date |
328
|
0
|
|
|
|
|
|
$date =~ s/\s//go; |
329
|
|
|
|
|
|
|
|
330
|
|
|
|
|
|
|
# date missing. return null; |
331
|
0
|
0
|
|
|
|
|
return undef unless (length($date)); |
332
|
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
# Split the date up into month day year |
334
|
0
|
|
|
|
|
|
my ($m,$d,$y) = split(/[\/-]/,$date,3); |
335
|
|
|
|
|
|
|
|
336
|
|
|
|
|
|
|
# assume two digit years belong in 2000 |
337
|
0
|
0
|
|
|
|
|
if ($y < 1000) { $y += 2000; } |
|
0
|
|
|
|
|
|
|
338
|
|
|
|
|
|
|
|
339
|
0
|
|
|
|
|
|
return sprintf("%04d-%02d-%02d",$y,$m,$d); |
340
|
|
|
|
|
|
|
} |
341
|
|
|
|
|
|
|
|
342
|
|
|
|
|
|
|
sub last_insert_id { |
343
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
344
|
0
|
|
|
|
|
|
my $dbh = shift; |
345
|
|
|
|
|
|
|
|
346
|
0
|
|
0
|
|
|
|
my $res = $dbh->selectall_arrayref("SELECT LAST_INSERT_ID()") || $self->db_error(); |
347
|
|
|
|
|
|
|
|
348
|
0
|
|
|
|
|
|
return $res->[0]->[0]; |
349
|
|
|
|
|
|
|
} |
350
|
|
|
|
|
|
|
|
351
|
|
|
|
|
|
|
# this sub is for use with the callback structure of Apache::Voodoo::Table. |
352
|
|
|
|
|
|
|
# $params is injected with a arrayref of column to translate |
353
|
|
|
|
|
|
|
# |
354
|
|
|
|
|
|
|
# since $params is a reference, the actual columns as seen by the db |
355
|
|
|
|
|
|
|
# are added to $params and they get back out that way. |
356
|
|
|
|
|
|
|
# all return values are just error messages (if any) |
357
|
|
|
|
|
|
|
sub month_year_to_sql { |
358
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
359
|
0
|
|
|
|
|
|
my $conn = shift; |
360
|
0
|
|
|
|
|
|
my $params = shift; |
361
|
|
|
|
|
|
|
|
362
|
0
|
|
|
|
|
|
my @errors; |
363
|
|
|
|
|
|
|
|
364
|
0
|
|
|
|
|
|
foreach my $column (@{$params->{'MONTH_YEAR_COLUMNS'}}) { |
|
0
|
|
|
|
|
|
|
365
|
|
|
|
|
|
|
|
366
|
|
|
|
|
|
|
# see if the present button was nailed |
367
|
0
|
0
|
|
|
|
|
if (defined($params->{$column."_present"})) { |
368
|
0
|
|
|
|
|
|
$params->{$column} = '1/1/1000'; |
369
|
|
|
|
|
|
|
} |
370
|
|
|
|
|
|
|
else { |
371
|
0
|
|
|
|
|
|
my $ok = 1; |
372
|
0
|
0
|
0
|
|
|
|
if (!defined($params->{$column."_month"})) { |
|
|
0
|
|
|
|
|
|
373
|
0
|
|
|
|
|
|
push(@errors,"MISSING_${column}_month"); |
374
|
0
|
|
|
|
|
|
$ok = 0; |
375
|
|
|
|
|
|
|
} |
376
|
|
|
|
|
|
|
elsif ($params->{$column."_month"} < 1 || $params->{$column."_month"} > 12) { |
377
|
0
|
|
|
|
|
|
push(@errors,"BAD_${column}_month"); |
378
|
0
|
|
|
|
|
|
$ok = 0; |
379
|
|
|
|
|
|
|
} |
380
|
|
|
|
|
|
|
|
381
|
0
|
0
|
0
|
|
|
|
if (!defined($params->{$column."_year"})) { |
|
|
0
|
|
|
|
|
|
382
|
0
|
|
|
|
|
|
push(@errors,"MISSING_${column}_year"); |
383
|
0
|
|
|
|
|
|
$ok = 0; |
384
|
|
|
|
|
|
|
} |
385
|
|
|
|
|
|
|
elsif ($params->{$column."_year"} < 1000 || $params->{$column."_year"} > 9999) { |
386
|
0
|
|
|
|
|
|
push(@errors,"BAD_${column}_year"); |
387
|
0
|
|
|
|
|
|
$ok = 0; |
388
|
|
|
|
|
|
|
} |
389
|
|
|
|
|
|
|
|
390
|
0
|
0
|
|
|
|
|
if ($ok == 1) { |
391
|
0
|
|
|
|
|
|
$params->{$column} = $params->{$column."_month"} . "/01/" . $params->{$column."_year"}; |
392
|
|
|
|
|
|
|
} |
393
|
|
|
|
|
|
|
} |
394
|
|
|
|
|
|
|
} |
395
|
0
|
|
|
|
|
|
return @errors; |
396
|
|
|
|
|
|
|
} |
397
|
|
|
|
|
|
|
|
398
|
|
|
|
|
|
|
sub pretty_mysql_timestamp { |
399
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
400
|
0
|
|
|
|
|
|
my $time = shift; |
401
|
|
|
|
|
|
|
|
402
|
|
|
|
|
|
|
# make an array out containing every two digits |
403
|
0
|
|
|
|
|
|
my @p = ($time =~ /(\d\d)/go); |
404
|
|
|
|
|
|
|
|
405
|
0
|
|
|
|
|
|
return $self->sql_to_date("$p[0]$p[1]-$p[2]-$p[3]")." ".$self->sql_to_time("$p[4]:$p[5]:$p[6]"); |
406
|
|
|
|
|
|
|
} |
407
|
|
|
|
|
|
|
|
408
|
|
|
|
|
|
|
sub mysql_timestamp { |
409
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
410
|
0
|
|
|
|
|
|
my $time = shift; |
411
|
|
|
|
|
|
|
|
412
|
0
|
|
0
|
|
|
|
my @p = localtime($time || time); |
413
|
|
|
|
|
|
|
|
414
|
0
|
|
|
|
|
|
$time =~ /^\d+\.(\d+)$/; |
415
|
0
|
|
|
|
|
|
return sprintf("%04d%02d%02d%02d%02d%02d",$p[5]+1900,$p[4]+1,$p[3],$p[2],$p[1],$p[0]); |
416
|
|
|
|
|
|
|
} |
417
|
|
|
|
|
|
|
|
418
|
|
|
|
|
|
|
sub sql_to_date { |
419
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
420
|
0
|
|
|
|
|
|
my $date = shift; |
421
|
|
|
|
|
|
|
|
422
|
0
|
0
|
0
|
|
|
|
if (!defined($date) || $date eq "NULL" || $date =~ /^\s*$/) { |
|
|
|
0
|
|
|
|
|
423
|
0
|
|
|
|
|
|
return ""; |
424
|
|
|
|
|
|
|
} |
425
|
|
|
|
|
|
|
|
426
|
0
|
|
|
|
|
|
$date =~ s/ .*//go; |
427
|
|
|
|
|
|
|
|
428
|
0
|
|
|
|
|
|
my ($y,$m,$d) = split(/[\/-]/,$date,3); |
429
|
|
|
|
|
|
|
|
430
|
0
|
|
|
|
|
|
return sprintf("%02d/%02d/%04d",$m,$d,$y); |
431
|
|
|
|
|
|
|
} |
432
|
|
|
|
|
|
|
|
433
|
|
|
|
|
|
|
sub sql_to_time { |
434
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
435
|
0
|
|
|
|
|
|
my $time = shift; |
436
|
|
|
|
|
|
|
|
437
|
0
|
0
|
0
|
|
|
|
if (!defined($time) || $time eq "NULL" || $time =~ /^\s*$/) { |
|
|
|
0
|
|
|
|
|
438
|
0
|
|
|
|
|
|
return ""; |
439
|
|
|
|
|
|
|
} |
440
|
|
|
|
|
|
|
|
441
|
0
|
|
|
|
|
|
$time =~ s/.* //o; |
442
|
|
|
|
|
|
|
|
443
|
0
|
|
|
|
|
|
my ($h,$m,$s) = split(/:/,$time); |
444
|
|
|
|
|
|
|
|
445
|
0
|
0
|
|
|
|
|
if ($h == 12) { # noon |
446
|
0
|
|
|
|
|
|
return sprintf("%2d:%02d PM",$h,$m); |
447
|
|
|
|
|
|
|
} |
448
|
0
|
0
|
|
|
|
|
if ($h == 0) { # midnight |
|
|
0
|
|
|
|
|
|
449
|
0
|
|
|
|
|
|
return sprintf("%2d:%02d AM",12,$m); |
450
|
|
|
|
|
|
|
} |
451
|
|
|
|
|
|
|
elsif ($h > 12) { |
452
|
0
|
|
|
|
|
|
return sprintf("%2d:%02d PM",$h-12,$m); |
453
|
|
|
|
|
|
|
} |
454
|
|
|
|
|
|
|
else { |
455
|
0
|
|
|
|
|
|
return sprintf("%2d:%02d AM",$h,$m); |
456
|
|
|
|
|
|
|
} |
457
|
|
|
|
|
|
|
} |
458
|
|
|
|
|
|
|
|
459
|
|
|
|
|
|
|
sub time_to_sql { |
460
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
461
|
0
|
|
|
|
|
|
my $time = shift; |
462
|
|
|
|
|
|
|
|
463
|
0
|
|
|
|
|
|
$time =~ s/\s*//go; |
464
|
0
|
|
|
|
|
|
$time =~ s/\.//go; |
465
|
|
|
|
|
|
|
|
466
|
0
|
0
|
|
|
|
|
unless ($time =~ /^\d?\d:\d\d(am|pm)?$/io) { |
467
|
0
|
|
|
|
|
|
return undef; |
468
|
|
|
|
|
|
|
} |
469
|
|
|
|
|
|
|
|
470
|
0
|
|
|
|
|
|
my $pm = 'NA'; |
471
|
0
|
0
|
|
|
|
|
if ($time =~ s/([ap])m$//igo) { |
472
|
0
|
0
|
|
|
|
|
$pm = (lc($1) eq "p")?1:0; |
473
|
|
|
|
|
|
|
} |
474
|
|
|
|
|
|
|
|
475
|
0
|
|
|
|
|
|
my ($h,$m) = split(/:/,$time,2); |
476
|
|
|
|
|
|
|
|
477
|
0
|
0
|
0
|
|
|
|
if ($m < 0 || $m > 60) { return undef; } |
|
0
|
|
|
|
|
|
|
478
|
|
|
|
|
|
|
|
479
|
0
|
0
|
0
|
|
|
|
if ($h < 0 || $h > 23) { return undef; } |
|
0
|
|
|
|
|
|
|
480
|
|
|
|
|
|
|
|
481
|
|
|
|
|
|
|
# 12 am is midnight and 12 pm is noon...I've always hated that. |
482
|
0
|
0
|
0
|
|
|
|
if ($pm eq '1' && $h < 12) { |
|
|
0
|
0
|
|
|
|
|
483
|
0
|
|
|
|
|
|
$h += 12; |
484
|
|
|
|
|
|
|
} |
485
|
|
|
|
|
|
|
elsif ($pm eq '0' && $h == 12) { |
486
|
0
|
|
|
|
|
|
$h = 0; |
487
|
|
|
|
|
|
|
} |
488
|
|
|
|
|
|
|
|
489
|
0
|
|
|
|
|
|
return sprintf("%02d:%02d:00",$h,$m); |
490
|
|
|
|
|
|
|
} |
491
|
|
|
|
|
|
|
|
492
|
|
|
|
|
|
|
################################################################################ |
493
|
|
|
|
|
|
|
# Misc |
494
|
|
|
|
|
|
|
################################################################################ |
495
|
|
|
|
|
|
|
|
496
|
|
|
|
|
|
|
|
497
|
|
|
|
|
|
|
# Function: dates_in_order |
498
|
|
|
|
|
|
|
# Purpose: Make sure end date comes after start date |
499
|
|
|
|
|
|
|
sub dates_in_order { |
500
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
501
|
0
|
|
|
|
|
|
my $startdate = shift; |
502
|
0
|
|
|
|
|
|
my $enddate = shift; |
503
|
|
|
|
|
|
|
|
504
|
|
|
|
|
|
|
#split off the parts of the date |
505
|
0
|
|
|
|
|
|
my ($sm,$sd,$sy) = split("/",$startdate, 3); |
506
|
0
|
|
|
|
|
|
my ($em,$ed,$ey) = split("/",$enddate, 3); |
507
|
|
|
|
|
|
|
|
508
|
|
|
|
|
|
|
#make sure the end date is past the start date |
509
|
0
|
0
|
|
|
|
|
if ($ey < $sy) { |
|
|
0
|
|
|
|
|
|
510
|
0
|
|
|
|
|
|
return 0; |
511
|
|
|
|
|
|
|
} |
512
|
|
|
|
|
|
|
elsif ($ey == $sy) { |
513
|
0
|
0
|
|
|
|
|
if ($em < $sm) { |
|
|
0
|
|
|
|
|
|
514
|
0
|
|
|
|
|
|
return 0; |
515
|
|
|
|
|
|
|
} |
516
|
|
|
|
|
|
|
elsif ($em == $sm) { |
517
|
0
|
0
|
|
|
|
|
if ($ed < $sd) { |
518
|
0
|
|
|
|
|
|
return 0; |
519
|
|
|
|
|
|
|
} |
520
|
|
|
|
|
|
|
} |
521
|
|
|
|
|
|
|
} |
522
|
|
|
|
|
|
|
|
523
|
|
|
|
|
|
|
# If we got here we were sucessful |
524
|
0
|
|
|
|
|
|
return 1; |
525
|
|
|
|
|
|
|
} |
526
|
|
|
|
|
|
|
|
527
|
|
|
|
|
|
|
# Function: validate_date |
528
|
|
|
|
|
|
|
# Purpose: Check to make sure a date follows the MM/DD/YYYY format and checks the sanity of the numbers passed in |
529
|
|
|
|
|
|
|
sub validate_date { |
530
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
531
|
0
|
|
|
|
|
|
my $date = shift; |
532
|
0
|
|
|
|
|
|
my $check_future = shift; |
533
|
|
|
|
|
|
|
|
534
|
|
|
|
|
|
|
#Number of days in each month |
535
|
0
|
|
|
|
|
|
my %md = (1 => 31, |
536
|
|
|
|
|
|
|
2 => 29, |
537
|
|
|
|
|
|
|
3 => 31, |
538
|
|
|
|
|
|
|
4 => 30, |
539
|
|
|
|
|
|
|
5 => 31, |
540
|
|
|
|
|
|
|
6 => 30, |
541
|
|
|
|
|
|
|
7 => 31, |
542
|
|
|
|
|
|
|
8 => 31, |
543
|
|
|
|
|
|
|
9 => 30, |
544
|
|
|
|
|
|
|
10 => 31, |
545
|
|
|
|
|
|
|
11 => 30, |
546
|
|
|
|
|
|
|
12 => 31); |
547
|
|
|
|
|
|
|
|
548
|
|
|
|
|
|
|
|
549
|
|
|
|
|
|
|
#Split the date up into month day year |
550
|
0
|
|
|
|
|
|
my ($m,$d,$y) = split("/",$date, 3); |
551
|
|
|
|
|
|
|
|
552
|
|
|
|
|
|
|
#Strip off any leading 0s |
553
|
0
|
|
|
|
|
|
$m *= 1; |
554
|
0
|
|
|
|
|
|
$d *= 1; |
555
|
0
|
|
|
|
|
|
$y *= 1; |
556
|
|
|
|
|
|
|
|
557
|
|
|
|
|
|
|
#If the month isn't within a valid range return |
558
|
0
|
0
|
0
|
|
|
|
if ($m !~ /^\d+$/ || $m < 1 || $m > 12) { |
|
|
|
0
|
|
|
|
|
559
|
0
|
|
|
|
|
|
return 0; |
560
|
|
|
|
|
|
|
} |
561
|
|
|
|
|
|
|
|
562
|
|
|
|
|
|
|
#Check to see if the day is valid on leap years |
563
|
0
|
0
|
0
|
|
|
|
if ($m == 2 && $d == 29) { |
564
|
0
|
0
|
0
|
|
|
|
unless (($y%4 == 0 && $y%100 != 0) || $y%400 == 0){ |
|
|
|
0
|
|
|
|
|
565
|
0
|
|
|
|
|
|
return 0; |
566
|
|
|
|
|
|
|
} |
567
|
|
|
|
|
|
|
} |
568
|
|
|
|
|
|
|
|
569
|
|
|
|
|
|
|
#If the day isn't within a valid range return |
570
|
0
|
0
|
0
|
|
|
|
if ($d !~ /^\d+$/ || $d < 1 || $d > $md{$m}) { |
|
|
|
0
|
|
|
|
|
571
|
0
|
|
|
|
|
|
return 0; |
572
|
|
|
|
|
|
|
} |
573
|
|
|
|
|
|
|
|
574
|
|
|
|
|
|
|
# make sure the year is four digits |
575
|
0
|
0
|
0
|
|
|
|
if ($y !~ /^\d+$/ || $y < 1000 || $y > 9999) { |
|
|
|
0
|
|
|
|
|
576
|
0
|
|
|
|
|
|
return 0; |
577
|
|
|
|
|
|
|
} |
578
|
|
|
|
|
|
|
|
579
|
0
|
0
|
|
|
|
|
if ($check_future == 1) { |
580
|
|
|
|
|
|
|
#Get the local system time |
581
|
0
|
|
|
|
|
|
my ($M,$D,$Y) = (localtime(time))[4,3,5]; |
582
|
0
|
|
|
|
|
|
$M++; |
583
|
0
|
|
|
|
|
|
$Y+=1900; |
584
|
|
|
|
|
|
|
|
585
|
|
|
|
|
|
|
#Make sure the date is in the future |
586
|
0
|
0
|
|
|
|
|
if ($y < $Y) { |
|
|
0
|
|
|
|
|
|
587
|
0
|
|
|
|
|
|
return undef; |
588
|
|
|
|
|
|
|
} |
589
|
|
|
|
|
|
|
elsif ($y == $Y) { |
590
|
0
|
0
|
|
|
|
|
if ($m < $M) { |
|
|
0
|
|
|
|
|
|
591
|
0
|
|
|
|
|
|
return undef; |
592
|
|
|
|
|
|
|
} |
593
|
|
|
|
|
|
|
elsif ($m == $M) { |
594
|
0
|
0
|
|
|
|
|
if ($d <= $D) { |
595
|
0
|
|
|
|
|
|
return undef; |
596
|
|
|
|
|
|
|
} |
597
|
|
|
|
|
|
|
} |
598
|
|
|
|
|
|
|
} |
599
|
|
|
|
|
|
|
} |
600
|
|
|
|
|
|
|
|
601
|
|
|
|
|
|
|
# if we make it this far the date should be ok return sucess |
602
|
0
|
|
|
|
|
|
return 1; |
603
|
|
|
|
|
|
|
} |
604
|
|
|
|
|
|
|
|
605
|
|
|
|
|
|
|
sub pretty_time { |
606
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
607
|
0
|
|
|
|
|
|
my $time = shift; |
608
|
|
|
|
|
|
|
|
609
|
0
|
|
0
|
|
|
|
my @p = localtime($time || time); |
610
|
|
|
|
|
|
|
|
611
|
0
|
|
|
|
|
|
$time =~ /^\d+\.(\d+)$/; |
612
|
0
|
|
|
|
|
|
my $ms = $1; |
613
|
0
|
0
|
|
|
|
|
if ($ms) { |
614
|
0
|
|
|
|
|
|
$ms .= '0' x (5-length($ms)); |
615
|
|
|
|
|
|
|
|
616
|
0
|
|
|
|
|
|
$ms = " " . $ms; |
617
|
|
|
|
|
|
|
} |
618
|
0
|
|
|
|
|
|
return sprintf("%02d/%02d/%04d %02d:%02d:%02d",$p[4]+1, $p[3], $p[5]+1900, $p[2], $p[1], $p[0]) . $ms; |
619
|
|
|
|
|
|
|
} |
620
|
|
|
|
|
|
|
|
621
|
|
|
|
|
|
|
1; |
622
|
|
|
|
|
|
|
|
623
|
|
|
|
|
|
|
################################################################################ |
624
|
|
|
|
|
|
|
# Copyright (c) 2005-2010 Steven Edwards (maverick@smurfbane.org). |
625
|
|
|
|
|
|
|
# All rights reserved. |
626
|
|
|
|
|
|
|
# |
627
|
|
|
|
|
|
|
# You may use and distribute Apache::Voodoo under the terms described in the |
628
|
|
|
|
|
|
|
# LICENSE file include in this package. The summary is it's a legalese version |
629
|
|
|
|
|
|
|
# of the Artistic License :) |
630
|
|
|
|
|
|
|
# |
631
|
|
|
|
|
|
|
################################################################################ |