File Coverage

blib/lib/Apache/Voodoo.pm
Criterion Covered Total %
statement 20 279 7.1
branch 0 122 0.0
condition 0 84 0.0
subroutine 7 40 17.5
pod 0 35 0.0
total 27 560 4.8


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             ################################################################################