File Coverage

blib/lib/OpenCA/TRIStateCGI.pm
Criterion Covered Total %
statement 9 297 3.0
branch 0 132 0.0
condition 0 19 0.0
subroutine 3 16 18.7
pod 0 13 0.0
total 12 477 2.5


line stmt bran cond sub pod time code
1             ## OpenCA::TRIStateCGI.pm
2             ##
3             ## Copyright (C) 1998-1999 Massimiliano Pala (madwolf@openca.org)
4             ## All rights reserved.
5             ##
6             ## This library is free for commercial and non-commercial use as long as
7             ## the following conditions are aheared to. The following conditions
8             ## apply to all code found in this distribution, be it the RC4, RSA,
9             ## lhash, DES, etc., code; not just the SSL code. The documentation
10             ## included with this distribution is covered by the same copyright terms
11             ##
12             ## Copyright remains Massimiliano Pala's, and as such any Copyright notices
13             ## in the code are not to be removed.
14             ## If this package is used in a product, Massimiliano Pala should be given
15             ## attribution as the author of the parts of the library used.
16             ## This can be in the form of a textual message at program startup or
17             ## in documentation (online or textual) provided with the package.
18             ##
19             ## Redistribution and use in source and binary forms, with or without
20             ## modification, are permitted provided that the following conditions
21             ## are met:
22             ## 1. Redistributions of source code must retain the copyright
23             ## notice, this list of conditions and the following disclaimer.
24             ## 2. Redistributions in binary form must reproduce the above copyright
25             ## notice, this list of conditions and the following disclaimer in the
26             ## documentation and/or other materials provided with the distribution.
27             ## 3. All advertising materials mentioning features or use of this software
28             ## must display the following acknowledgement:
29             ## "This product includes OpenCA software written by Massimiliano Pala
30             ## (madwolf@openca.org) and the OpenCA Group (www.openca.org)"
31             ## 4. If you include any Windows specific code (or a derivative thereof) from
32             ## some directory (application code) you must include an acknowledgement:
33             ## "This product includes OpenCA software (www.openca.org)"
34             ##
35             ## THIS SOFTWARE IS PROVIDED BY OPENCA DEVELOPERS ``AS IS'' AND
36             ## ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
37             ## IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
38             ## ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
39             ## FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
40             ## DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
41             ## OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
42             ## HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
43             ## LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
44             ## OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
45             ## SUCH DAMAGE.
46             ##
47             ## The licence and distribution terms for any publically available version or
48             ## derivative of this code cannot be changed. i.e. this code cannot simply be
49             ## copied and put under another distribution licence
50             ## [including the GNU Public Licence.]
51             ##
52              
53             ## Porpouse :
54             ## ==========
55             ##
56             ## Build a class to use with tri-state CGI (based on CGI library)
57             ##
58             ## Project Status:
59             ## ===============
60             ##
61             ## Started : 8 December 1998
62             ## Last Modified : 12 Genuary 2001
63              
64 1     1   704 use strict;
  1         1  
  1         45  
65              
66             package OpenCA::TRIStateCGI;
67              
68 1     1   2263 use CGI;
  1         20859  
  1         9  
69              
70             @OpenCA::TRIStateCGI::ISA = ( @OpenCA::TRIStateCGI::ISA, "CGI" );
71             # Items to export into callers namespace by default. Note: do not export
72             # names by default without a very good reason. Use EXPORT_OK instead.
73             # Do not simply export all your public functions/methods/constants.
74              
75             $OpenCA::TRIStateCGI::VERSION = '1.5.5';
76              
77 1     1   1248 use FileHandle;
  1         20583  
  1         6  
78             our ($STDERR, $STDOUT);
79             $STDOUT = \*STDOUT;
80             $STDERR = \*STDERR;
81              
82             our ($errno, $errval);
83              
84             # Preloaded methods go here.
85              
86             ## General Functions
87             sub status {
88 0     0 0   my $self = shift;
89 0           my @keys = @_;
90              
91 0           my $ret = $self->param('status');
92 0 0         if ( $ret =~ /(client\-filled\-form|client\-confirmed\-form)/ ) {
93 0           return $ret;
94             } else {
95 0           return "start";
96             };
97             }
98              
99             ## New AutoChecking Input Object
100              
101             sub newInput {
102              
103 0     0 0   my $self = shift;
104 0           my @keys = @_;
105              
106 0           my ( $ret, $error, $m );
107 0           my ( $type, $maxlen, $minlen, $regx, $name, $values);
108              
109             ## Rearrange CGI's function changed in perl 5.6.1 - CGI ver 2.75+
110 0 0         if ( $CGI::VERSION >= 2.60 ) {
111 0 0         if ( ref(@_[0]) ne "HASH" ) {
112 0           @keys = { @keys };
113             }
114              
115 0           ( $name, $values ) = $self->rearrange(["NAME"], @keys );
116              
117 0           $type = $values->{'-intype'};
118             } else {
119            
120 0           ( $type, $maxlen, $minlen, $regx) =
121             $self->rearrange(["INTYPE","MAXLEN","MINLEN","REGX"],
122             @keys);
123             }
124              
125             ## Check if there is an Error
126 0 0         $error = $self->newInputCheck(@_) if ( $self->status ne "start" );
127              
128             ## Generate the Input Type
129 0           $ret = $self->$type(@_);
130            
131             ## Clean Out NON HTML TAGS
132 0           $m = "(INTYPE|MAXLEN|MINLEN|REGX)=\".*\"";
133 0           $ret =~ s/$m//g;
134            
135             ## Concatenate the Error to the Input Object if present
136 0           $ret .= $error;
137            
138 0           return $ret;
139             }
140              
141             sub newInputCheck {
142              
143 0     0 0   my $self = shift;
144 0           my @keys = @_;
145              
146 0           my ( $ret, $m, $p, $l );
147 0           my ( $name, $values, $type, $maxlen, $minlen, $regx, $name );
148              
149             ## Rearrange CGI's function changed in perl 5.6.1 - CGI ver 2.75+
150 0 0         if ( $CGI::VERSION >= 2.60 ) {
151 0 0         if ( ref(@_[0]) ne "HASH" ) {
152 0           @keys = { @keys };
153             }
154              
155 0           ( $name, $values ) = $self->rearrange(["NAME"], @keys );
156              
157 0           $type = $values->{'-intype'};
158 0           $maxlen = $values->{'-maxlen'};
159 0           $minlen = $values->{'-minlen'};
160 0           $regx = $values->{'-regx'};
161 0           $name = $values->{'-name'};
162              
163             } else {
164 0           ( $type, $maxlen, $minlen, $regx, $name) =
165             $self->rearrange(["INTYPE","MAXLEN","MINLEN","REGX",
166             "NAME"], @keys);
167             }
168            
169 0           $p = $self->param("$name");
170              
171 0 0         if( $maxlen != "" ) {
172 0           $l = length($p);
173 0 0         if ( $l > $maxlen ) {
174 0           $ret = "Error (max. $maxlen)";
175 0           $ret = "
$ret
";
176 0           return $ret;
177             }
178             };
179              
180 0 0         if( $minlen != "" ) {
181 0           $l = length($p);
182 0 0         if ( $l < $minlen ) {
183 0           $ret = "Error (min. $minlen)";
184 0           $ret = "
$ret
";
185 0           return $ret;
186             }
187             };
188              
189 0 0         if ( length($regx) < 2 ) {
190 0           return $ret;
191             };
192            
193 0           $m = $regx;
194            
195 0 0         $m = "[a-zA-Z\ ¡-ÿ]+" if ( "$regx" eq "LETTERS" );
196             ## $m = "[a-zA-Z\ \,\.\_\:\'\`\\\/\(\)\!\;]+" if ( "$regx" eq "TEXT" );
197 0 0         $m = "[ -\@a-zA-Z]+" if ( "$regx" eq "TEXT" );
198 0 0         $m = "[0-9]+" if ( "$regx" eq "NUMERIC" );
199 0 0         $m = "[ -\@a-zA-Z]+" if ( "$regx" eq "MIXED" );
200 0 0         $m = "[0-9\-\/]+" if ( "$regx" eq "DATE" );
201 0 0         $m = "[0-9\-\+\\\(\)]+" if ( "$regx" eq "TEL" );
202 0 0         $m = "[0-9a-zA-Z\-\_\.]+\@[a-zA-Z0-9\_\.\-]+" if ( "$regx" eq "EMAIL" );
203 0 0         $m = "[a-zA-Z¡-ÿ -\@]+" if ( "$regx" eq "LATIN1_LETTERS" );
204 0 0         $m = "[ -\@a-zA-Z¡-ÿ]+" if ( "$regx" eq "LATIN1" );
205              
206 0           $p =~ s/$m//g;
207              
208 0 0         if ( length($p) == 0 ) {
209 0           $ret = "
(OK)
";
210             } else {
211 0 0         $ret .= "Use only chars" if ( $regx eq "TEXT" );
212 0 0         $ret .= "Use only LATIN1 chars" if ($regx eq "LATIN1_LETTERS");
213 0 0         $ret .= "Use only LATIN1 chars/numbers" if ( $regx eq "LATIN1");
214 0 0         $ret .= "Use only numbers" if ( $regx eq "NUMERIC" );
215 0 0         $ret .= "Use only chars./numbers" if ( $regx eq "MIXED" );
216 0 0         $ret .= "Use xx\/xx\/xxxx format." if ( $regx eq "DATE" );
217 0 0         $ret .= "Use ++xx-xxx-xxxxxx format." if ( $regx eq "TEL" );
218 0 0         $ret .= 'Use aabbcc@dddd.eee.ff' if ( $regx eq "EMAIL" );
219 0 0         $ret = "Undefined Error" if ($ret eq "");
220              
221 0           $ret = "
Error. $ret
";
222             }
223 0           return $ret;
224             }
225              
226             sub checkForm {
227              
228 0     0 0   my $self = shift;
229 0           my @keys = @_;
230              
231 0           my ( $ret, $in, $m );
232            
233 0           for $in ( @keys ) {
234 0           $ret .= $self->newInputCheck( %$in );
235             }
236              
237 0           $m = "
|OK|[\ \(\)]";
238 0           $ret =~ s/$m//g;
239              
240 0           return $ret;
241             };
242              
243             sub printError {
244 0     0 0   my $self = shift;
245 0           my @keys = @_;
246              
247 0           my ( $html, $ret );
248              
249 0           my $errCode = $keys[0];
250 0           my $errTxt = $keys[1];
251              
252 0           $html = $self->start_html(-title=>'Error Accessing the Service',
253             -BGCOLOR=>'#FFFFFF');
254              
255 0           $html .= '';
256             ## $html .= $self->setFont( -size=>'+4',
257             ## -face=>"Helvetica",
258             ## -color=>'#E54211');
259              
260 0           $html .= "Error ( code $errCode )";
261 0           $html .= "

\n";
262            
263 0           $html .= '';
264             ## $html .= $self->setFont( -size=>'+1',
265             ## -color=>'#113388');
266              
267 0 0         if( "$errTxt" ne "" ) {
268             ## The Error Code is Present in the Array, so Let's treat it...
269 0           $html .= $errTxt;
270              
271             } else {
272             ## General Error Message
273 0           $html .= "General Error Protection Fault : The Error Could" .
274             " not be determined by the server,
";
275 0           $html .= "if the error persists, please contact the system" .
276             " administrator for further explanation.

\n";
277             };
278              
279 0           $html .= "
\n\n";
280 0           $html .= "\n\n";
281            
282 0           return $html;
283             }
284              
285             ## this functionality is part of OpenCA::Tools
286             ## OpenCA::Tools configure files to so getFile in OpenCA::TRIStateCGI is a bug
287             ##
288             ## sub getFile {
289             ## my $self = shift;
290             ## my @keys = @_;
291             ##
292             ## my ( $ret, $temp );
293             ##
294             ## open( FD, $keys[0] ) || return;
295             ## while ( $temp = ) {
296             ## $ret .= $temp;
297             ## };
298             ## return $ret;
299             ## }
300              
301             sub subVar {
302 0     0 0   my $self = shift;
303 0           my @keys = @_;
304              
305 0           my ( $text, $parname, $var, $ret, $match );
306              
307 0           $text = $keys[0];
308 0           $parname = $keys[1];
309 0           $var = $keys[2];
310              
311 0           $match = "\\$parname";
312 0           $text =~ s/$match/$var/g;
313              
314 0           return $text;
315             }
316              
317             sub startTable {
318 0     0 0   my $self = shift;
319 0           my $keys = { @_ };
320              
321 0           my $width = $keys->{WIDTH};
322              
323 0           my $titleColor = $keys->{TITLE_COLOR};
324 0           my $cellColor = $keys->{CELL_COLOR};
325              
326 0           my $titleBg = $keys->{TITLE_BGCOLOR};
327 0           my $tableBg = $keys->{TABLE_BGCOLOR};
328 0           my $cellBg = $keys->{CELL_BGCOLOR};
329 0   0       my $spacing = ( $keys->{SPACING} or "1");
330 0   0       my $padding = ( $keys->{PADDING} or "1");
331 0   0       my $cellPad = ( $keys->{CELLPADDING} or "1");
332              
333 0           my @cols = @{ $keys->{COLS} };
  0            
334              
335 0           my ( $ret, $name );
336              
337 0 0         $width = "100%" if (not $width);
338 0 0         $cellColor = "#000000" if ( not $cellColor );
339              
340 0 0         $titleBg = "#DDDDEE" if ( not $titleBg );
341 0 0         $cellBg = "#FFFFFF" if ( not $cellBg );
342              
343 0           my $titleFont = "FONT FACE=Helvetica,Arial";
344 0 0         $titleFont .= " color=\"$titleColor\"" if( $titleColor );
345            
346 0           $ret = "
347 0 0         $ret .= "BGCOLOR=\"$tableBg\"" if ( $tableBg );
348 0           $ret .= ">
\n";
349              
350 0           $ret .= "\n"; \n"; \n"; \n"; \n"; \n"; \n";
351 0           $ret .= " CELLSPACING=\"$spacing\" FGCOLOR=\"$cellColor\">\n";
352 0           $ret .= "
353              
354 0           foreach $name (@cols) {
355 0           $ret .= "<$titleFont>$name
356             }
357              
358 0           $ret .= "
359              
360 0           return $ret;
361             }
362              
363             sub addTableLine {
364 0     0 0   my $self = shift;
365 0           my $keys = { @_ };
366              
367 0           my @data = @{ $keys->{DATA} };
  0            
368 0           my $bgColor = $keys->{BGCOLOR};
369 0           my $color = $keys->{COLOR};
370              
371 0           my ( $val, $colorEnd, $ret );
372            
373 0 0         if( $bgColor ) {
374 0           $ret = "
375             } else {
376 0           $ret = "
377             }
378              
379 0 0         if( $color ) {
380 0           $color = "";
381 0           $colorEnd = "";
382             }
383              
384 0           foreach $val ( @data ) {
385 0           $ret .= "$color $val $colorEnd
386             }
387 0           $ret .= "
388              
389 0           return $ret;
390             }
391              
392             sub endTable {
393 0     0 0   my $self = shift;
394 0           my $ret;
395              
396 0           $ret = "

\n";

397              
398 0           return $ret;
399             }
400              
401             sub printCopyMsg {
402 0     0 0   my $self = shift;
403 0           my @keys = @_;
404 0           my $ret;
405              
406 0           my $msg = $keys[0];
407              
408 0 0         $msg = "© 1998 by OpenCA Group" if ( not $msg );
409 0           $ret = "

$msg
";
410              
411 0           return $ret;
412             }
413              
414             sub buildRefs {
415 0     0 0   my $self = shift;
416 0           my $keys = { @_ };
417              
418 0           my ( $ret, $i, $link, $pages, $current, $from, $to, $title );
419              
420 0           my $elements = $keys->{ELEMENTS};
421 0           my $maxItems = $keys->{MAXITEMS};
422 0           my $factor = $keys->{FACTOR};
423 0           my $mode = $keys->{MODE};
424              
425 0 0         $maxItems = 30 if ( not $maxItems );
426              
427 0 0         if ($keys->{NOW_FIRST}) {
428 0           $from = $keys->{NOW_FIRST};
429             } else {
430 0   0       $from = ( $self->param('viewFrom') or 0 );
431             }
432 0 0         if ($keys->{NOW_LAST}) {
433 0           $to = $keys->{NOW_LAST};
434             } else {
435 0   0       $to = ( $self->param('viewTo') or undef );
436             }
437              
438 0           my $first = $keys->{FIRST};
439 0           my $last = $keys->{LAST};
440              
441 0 0         if ( $elements == 0 ) {
    0          
442 0           $title = "
" .
443             "No Extra References";
444             } elsif ($mode =~ /EXP/i) {
445              
446 0           my $total_links = 0;
447 0           $title = "
Extra References ";
448              
449             ## fix wrong parameters
450 0 0         if ($factor > $maxItems) {
451 0           my $h = $factor;
452 0           $factor = $maxItems;
453 0           $maxItems = $h;
454             }
455 0 0         $factor=2 if ($factor < 2);
456              
457             ## backward references
458              
459 0 0         if ($from != $first) {
460              
461 0           $total_links++;
462              
463             ## first element
464 0           my @list = ();
465              
466             ## calculate links
467 0           while (1) {
468 0           my $hfrom;
469 0 0         if ($from > ($maxItems * exp (log($factor)*@list))) {
470 0           $hfrom = $maxItems * sprintf( "%.0f", exp (log($factor)*@list));
471             } else {
472 0           $hfrom = $from - $first;
473             }
474              
475 0 0 0       if ( ($hfrom != ($from - $first)) and
476             ($elements < ($from - $first))
477             ) {
478 0           $hfrom = $hfrom * $from / $elements;
479 0           $hfrom = sprintf( "%.0f", $hfrom);
480             }
481              
482 0           $hfrom = $from - $hfrom;
483              
484 0 0         $hfrom = $first
485             if ($hfrom < $first);
486              
487 0           $list [@list] = $hfrom;
488              
489 0 0         last if ($hfrom <= $first);
490             }
491              
492             ## build links
493 0           for (my $i=$#list; $i >= 0; $i--) {
494 0           $self->param( -name=>"viewFrom", -value=>$list[$i]);
495 0           $link = $self->self_url();
496 0           $title .= "  ";
497 0 0         $title .= "|"
498             if ($i == $#list);
499 0           for (my $k=0; $k <= $i; $k++) {
500 0           $title .= "<";
501             }
502 0           $title .= " ";
503             }
504             }
505              
506             ## forward references
507              
508 0 0         if ($to != $last) {
509              
510 0           $total_links++;
511              
512             ## first element
513 0           my @list = ();
514              
515             ## calculate links
516 0           while (1) {
517 0           my $hfrom;
518 0 0         if ($last > ($to - $maxItems + 1 + $maxItems * exp (log($factor)*@list))) {
519 0           $hfrom = -$maxItems + 1 +$maxItems * sprintf( "%.0f", exp (log($factor)*@list));
520             } else {
521 0           $hfrom = $last - $to;
522             }
523              
524 0 0 0       if ( ($hfrom != ($last - $to)) and
      0        
525             ($hfrom != 1) and
526             ($elements < ($last - $to))
527             ) {
528 0           $hfrom = $hfrom * $last / $elements;
529 0           $hfrom = sprintf( "%.0f", $hfrom);
530             }
531              
532 0           $hfrom = $to + $hfrom;
533              
534 0 0         $hfrom = $last - $maxItems + 1
535             if ($hfrom > $last - $maxItems);
536              
537 0           $list [@list] = $hfrom;
538              
539 0 0         last if ($hfrom > ($last - $maxItems));
540             }
541              
542             ## build links
543 0           for (my $i=0; $i <= $#list; $i++) {
544 0           $self->param( -name=>"viewFrom", -value=>$list[$i]);
545 0           $link = $self->self_url();
546 0           $title .= "  ";
547 0           for (my $k=0; $k <= $i; $k++) {
548 0           $title .= ">";
549             }
550 0 0         $title .= "|"
551             if ($i == $#list);
552 0           $title .= " ";
553             }
554              
555             }
556              
557 0 0         if ( $total_links < 1 ) {
558 0           $title = "
" .
559             "No Extra References";
560             }
561              
562             } else {
563              
564 0           $pages = int $elements / $maxItems;
565 0 0         $pages++ if( $elements % $maxItems );
566              
567 0           $current = int $from / $maxItems;
568             ## $current++ if ( $from % $maxItems );
569              
570 0           $title = "
Extra References ";
571              
572 0           for( $i = 0; $i < $pages ; $i++ ) {
573 0           my ( $from, $pnum );
574            
575 0           $pnum = $i + 1;
576 0           $from = sprintf( "%lx", $i * $maxItems + 1);
577              
578 0 0         if ( $i != $current ) {
579 0           $self->param( -name=>"viewFrom", -value=>"$from" );
580 0           $link = $self->self_url();
581 0           $title .= "  $pnum ";
582             } else {
583 0           $title .= "  $pnum ";
584             }
585             }
586 0 0         if ( $pages <= 1 ) {
587 0           $title = "
" .
588             "No Extra References";
589             }
590              
591             }
592              
593 0           $title .= "";
594 0           $ret = $self->startTable( COLS=>[ "$title" ],
595             TITLE_BGCOLOR=>"#EEEEF1",
596             TABLE_BGCOLOR=>"#000000" );
597              
598 0           $ret .= $self->endTable();
599              
600              
601 0           return $ret;
602             }
603              
604             sub setError {
605 0     0 0   my $self = shift;
606              
607 0 0         if (scalar (@_) == 4) {
608 0           my $keys = { @_ };
609 0           $errval = $keys->{ERRVAL};
610 0           $errno = $keys->{ERRNO};
611             } else {
612 0           $errno = $_[0];
613 0           $errval = $_[1];
614             }
615              
616 0           print $STDERR "PKI Master Alert: Access control is misconfigured\n";
617 0           print $STDERR "PKI Master Alert: Aborting all operations\n";
618 0           print $STDERR "PKI Master Alert: Error: $errno\n";
619 0           print $STDERR "PKI Master Alert: Message: $errval\n";
620 0           print $STDERR "PKI Master Alert: debugging messages of access control follow\n";
621 0           $self->{debug_fd} = $STDERR;
622 0           $self->debug ();
623 0           $self->{debug_fd} = $STDOUT;
624              
625             ## support for: return $self->setError (1234, "Something fails.") if (not $xyz);
626 0           return undef;
627             }
628              
629             sub debug {
630              
631 0     0 0   my $self = shift;
632 0 0         if ($_[0]) {
633 0           $self->{debug_msg}[scalar @{$self->{debug_msg}}] = $_[0];
  0            
634 0 0         $self->debug () if ($self->{DEBUG});
635             } else {
636 0           my $msg;
637 0           foreach $msg (@{$self->{debug_msg}}) {
  0            
638 0           $msg =~ s/ / /g;
639 0           my $oldfh = select $self->{debug_fd};
640 0           print $STDOUT $msg."
\n";
641 0           select $oldfh;
642             }
643 0           $self->{debug_msg} = ();
644             }
645              
646             }
647              
648             #############################################################################
649             ## check the channel ##
650             #############################################################################
651             # Autoload methods go after =cut, and are processed by the autosplit program.
652              
653             1;