]> Dogcows Code - chaz/p5-CGI-Ex/blob - lib/CGI/Ex.pm
add PSGI handler
[chaz/p5-CGI-Ex] / lib / CGI / Ex.pm
1 package CGI::Ex;
2
3 =head1 NAME
4
5 CGI::Ex - CGI utility suite - makes powerful application writing fun and easy
6
7 =cut
8
9 ###----------------------------------------------------------------###
10 # Copyright 2003-2012 - Paul Seamons #
11 # Distributed under the Perl Artistic License without warranty #
12 ###----------------------------------------------------------------###
13
14 ### See perldoc at bottom
15
16 use strict;
17 use vars qw($VERSION
18 $PREFERRED_CGI_MODULE
19 $PREFERRED_CGI_REQUIRED
20 $AUTOLOAD
21 $DEBUG_LOCATION_BOUNCE
22 $CURRENT
23 @EXPORT @EXPORT_OK
24 );
25 use base qw(Exporter);
26
27 BEGIN {
28 $VERSION = '2.37';
29 $PREFERRED_CGI_MODULE ||= 'CGI';
30 @EXPORT = ();
31 @EXPORT_OK = qw(get_form
32 get_cookies
33 print_content_type
34 content_type
35 content_typed
36 set_cookie
37 location_bounce
38 );
39
40 ### cache mod_perl version (light if or if not mod_perl)
41 my $v = (! $ENV{'MOD_PERL'}) ? 0
42 # mod_perl/1.27 or mod_perl/1.99_16 or mod_perl/2.0.1
43 # if MOD_PERL is set - don't die if regex fails - just assume 1.0
44 : ($ENV{'MOD_PERL'} =~ m{ ^ mod_perl / (\d+\.[\d_]+) (?: \.\d+)? $ }x) ? $1
45 : '1.0_0';
46 sub _mod_perl_version () { $v }
47 sub _is_mod_perl_1 () { $v < 1.98 && $v > 0 }
48 sub _is_mod_perl_2 () { $v >= 1.98 }
49
50 ### cache apache request getter (light if or if not mod_perl)
51 my $sub;
52 if (_is_mod_perl_1) { # old mod_perl
53 require Apache;
54 $sub = sub { Apache->request };
55 } elsif (_is_mod_perl_2) {
56 if (eval { require Apache2::RequestRec }) { # debian style
57 require Apache2::RequestUtil;
58 $sub = sub { Apache2::RequestUtil->request };
59 } else { # fedora and mandrake style
60 require Apache::RequestUtil;
61 $sub = sub { Apache->request };
62 }
63 } else {
64 $sub = sub {};
65 }
66 sub apache_request_sub () { $sub }
67 }
68
69 ###----------------------------------------------------------------###
70
71 # my $cgix = CGI::Ex->new;
72 sub new {
73 my $class = shift || die "Missing class name";
74 my $self = ref($_[0]) ? shift : {@_};
75 return bless $self, $class;
76 }
77
78 ###----------------------------------------------------------------###
79
80 ### allow for holding another classed CGI style object
81 # my $query = $cgix->object;
82 # $cgix->object(CGI->new);
83 sub object {
84 my $self = shift || die 'Usage: my $query = $cgix_obj->object';
85 $self->{'object'} = shift if $#_ != -1;
86
87 if (! defined $self->{'object'}) {
88 $PREFERRED_CGI_REQUIRED ||= do {
89 my $file = $self->{'cgi_module'} || $PREFERRED_CGI_MODULE;
90 $file .= ".pm";
91 $file =~ s|::|/|g;
92 eval { require $file };
93 die "Couldn't require $PREFERRED_CGI_MODULE: $@" if $@;
94 1; # return of do
95 };
96 $self->{'object'} = $PREFERRED_CGI_MODULE->new;
97 }
98
99 return $self->{'object'};
100 }
101
102 ### allow for calling CGI MODULE methods
103 sub AUTOLOAD {
104 my $self = shift;
105 my $meth = ($AUTOLOAD =~ /(\w+)$/) ? $1 : die "Invalid method $AUTOLOAD";
106 return $self->object->$meth(@_);
107 }
108
109 sub DESTROY { }
110
111 ###----------------------------------------------------------------###
112
113 ### Form getter that will act like CGI->new->Vars only it will return arrayrefs
114 ### for values that are arrays
115 # my $hash = $cgix->get_form;
116 # my $hash = $cgix->get_form(CGI->new);
117 # my $hash = get_form();
118 # my $hash = get_form(CGI->new);
119 sub get_form {
120 my $self = shift || __PACKAGE__->new;
121 if (! $self->isa(__PACKAGE__)) { # get_form(CGI->new) syntax
122 my $obj = $self;
123 $self = __PACKAGE__->new;
124 $self->object($obj);
125 }
126 return $self->{'form'} if $self->{'form'};
127
128 ### get the info out of the object
129 my $obj = shift || $self->object;
130 my %hash = ();
131 foreach my $key ($obj->param) {
132 my @val = $obj->param($key);
133 $hash{$key} = ($#val <= 0) ? $val[0] : \@val;
134 }
135 return $self->{'form'} = \%hash;
136 }
137
138 ### allow for a setter
139 ### $cgix->set_form(\%form);
140 sub set_form {
141 my $self = shift || die 'Usage: $cgix_obj->set_form(\%form)';
142 return $self->{'form'} = shift || {};
143 }
144
145 ### Combined get and set form
146 # my $hash = $cgix->form;
147 # $cgix->form(\%form);
148 sub form {
149 my $self = shift;
150 return $self->set_form(shift) if @_ == 1;
151 return $self->get_form;
152 }
153
154 ### allow for creating a url encoded key value sequence
155 # my $str = $cgix->make_form(\%form);
156 # my $str = $cgix->make_form(\%form, \@keys_to_include);
157 sub make_form {
158 my $self = shift || die 'Usage: $cgix_obj->make_form(\%form)';
159 my $form = shift || $self->get_form;
160 my $keys = ref($_[0]) ? shift : [sort keys %$form];
161 my $str = '';
162 foreach (@$keys) {
163 my $key = $_; # make a copy
164 my $val = $form->{$key};
165 $key =~ s/([^\w.\-\ ])/sprintf('%%%02X', ord $1)/eg;
166 $key =~ y/ /+/;
167 foreach (ref($val) eq 'ARRAY' ? @$val : $val) {
168 my $_val = $_; # make a copy
169 $_val =~ s/([^\w.\-\ ])/sprintf('%%%02X', ord $1)/eg;
170 $_val =~ y/ /+/;
171 $str .= "$key=$_val&"; # intentionally not using join
172 }
173 }
174 chop $str;
175 return $str;
176 }
177
178 ###----------------------------------------------------------------###
179
180 ### like get_form - but a hashref of cookies
181 ### cookies are parsed depending upon the functionality of ->cookie
182 # my $hash = $cgix->get_cookies;
183 # my $hash = $cgix->get_cookies(CGI->new);
184 # my $hash = get_cookies();
185 # my $hash = get_cookies(CGI->new);
186 sub get_cookies {
187 my $self = shift || __PACKAGE__->new;
188 if (! $self->isa(__PACKAGE__)) { # get_cookies(CGI->new) syntax
189 my $obj = $self;
190 $self = __PACKAGE__->new;
191 $self->object($obj);
192 }
193 return $self->{'cookies'} if $self->{'cookies'};
194
195 my $obj = shift || $self->object;
196 my %hash = ();
197 foreach my $key ($obj->cookie) {
198 my @val = $obj->cookie($key);
199 $hash{$key} = ($#val == -1) ? "" : ($#val == 0) ? $val[0] : \@val;
200 }
201 return $self->{'cookies'} = \%hash;
202 }
203
204 ### Allow for a setter
205 ### $cgix->set_cookies(\%cookies);
206 sub set_cookies {
207 my $self = shift || die 'Usage: $cgix_obj->set_cookies(\%cookies)';
208 return $self->{'cookies'} = shift || {};
209 }
210
211 ### Combined get and set cookies
212 # my $hash = $cgix->cookies;
213 # $cgix->cookies(\%cookies);
214 sub cookies {
215 my $self = shift;
216 return $self->set_cookies(shift) if @_ == 1;
217 return $self->get_cookies;
218 }
219
220 ###----------------------------------------------------------------###
221
222 ### Get whether or not we are running as a PSGI app
223 # my $app = CGI::Ex::App::PSGI->psgi_app('Foo::Bar::App');
224 # $app->is_psgi; # is true
225 sub is_psgi { shift->object->isa('CGI::PSGI') }
226
227 ### Allow for generating a PSGI response
228 sub psgi_response {
229 my $self = shift;
230
231 $self->{psgi_responded} = 1;
232 $self->print_content_type;
233
234 if (my $location = $self->{psgi_location}) {
235 return [302, ['Content-Type' => 'text/html', Location => $location], ["Bounced to $location\n"]];
236 } else {
237 return [$self->{psgi_status} || 200, $self->{psgi_headers} || [], $self->{psgi_body} || ['']];
238 }
239 }
240
241 ### Allow for sending a PSGI streaming/delayed response
242 sub psgi_respond {
243 my $self = shift;
244 if ($self->{psgi_responder}) {
245 my $response = $self->psgi_response;
246 delete $response->[2];
247 $self->{psgi_writer} = $self->{psgi_responder}->($response);
248 delete $self->{psgi_responder};
249 }
250 $self->{psgi_writer};
251 }
252
253 ###----------------------------------------------------------------###
254
255 ### Allow for shared apache request object
256 # my $r = $cgix->apache_request
257 # $cgix->apache_request($r);
258 sub apache_request {
259 my $self = shift || die 'Usage: $cgix_obj->apache_request';
260 $self->{'apache_request'} = shift if $#_ != -1;
261
262 return $self->{'apache_request'} ||= apache_request_sub()->();
263 }
264
265 ### Get the version of mod_perl running (0 if not mod_perl)
266 # my $version = $cgix->mod_perl_version;
267 sub mod_perl_version { _mod_perl_version }
268 sub is_mod_perl_1 { _is_mod_perl_1 }
269 sub is_mod_perl_2 { _is_mod_perl_2 }
270
271 ### Allow for a setter
272 # $cgix->set_apache_request($r)
273 sub set_apache_request { shift->apache_request(shift) }
274
275 ###----------------------------------------------------------------###
276
277 ### Portable method for printing the document content
278 sub print_body {
279 my $self = shift || __PACKAGE__->new;
280
281 if ($self->is_psgi) {
282 if (my $writer = $self->psgi_respond) {
283 $writer->write($_) for (@_);
284 } else {
285 push @{$self->{psgi_body} ||= []}, $_ for (@_);
286 }
287 } else {
288 print <FH>;
289 }
290 }
291
292 ### Portable method for getting environment variables
293 sub env {
294 my $self = shift || __PACKAGE__->new;
295
296 $self->is_psgi ? $self->object->env : \%ENV;
297 }
298
299 ###----------------------------------------------------------------###
300
301 ### same signature as print_content_type
302 sub content_type { &print_content_type }
303
304 ### will send the Content-type header
305 # $cgix->print_content_type;
306 # $cgix->print_content_type('text/plain');
307 # print_content_type();
308 # print_content_type('text/plain);
309 sub print_content_type {
310 my ($self, $type, $charset) = (@_ && ref $_[0]) ? @_ : (undef, @_);
311 $self = __PACKAGE__->new if ! $self;
312
313 if ($type) {
314 die "Invalid type: $type" if $type !~ m|^[\w\-\.]+/[\w\-\.\+]+$|; # image/vid.x-foo
315 } else {
316 $type = 'text/html';
317 }
318 $type .= "; charset=$charset" if $charset && $charset =~ m|^[\w\-\.\:\+]+$|;
319
320 if ($self->is_psgi) {
321 if (! $self->env->{'cgix.content_typed'}) {
322 push @{$self->{psgi_headers} ||= []}, ('Content-Type' => $type);
323 $self->env->{'cgix.content_typed'} = '';
324 }
325 $self->env->{'cgix.content_typed'} .= sprintf("%s, %d\n", (caller)[1,2]);
326 } elsif (my $r = $self->apache_request) {
327 return if $r->bytes_sent;
328 $r->content_type($type);
329 $r->send_http_header if $self->is_mod_perl_1;
330 } else {
331 if (! $ENV{'CONTENT_TYPED'}) {
332 print "Content-Type: $type\r\n\r\n";
333 $ENV{'CONTENT_TYPED'} = '';
334 }
335 $ENV{'CONTENT_TYPED'} .= sprintf("%s, %d\n", (caller)[1,2]);
336 }
337 }
338
339 ### Boolean check if content has been typed
340 # $cgix->content_typed;
341 # content_typed();
342 sub content_typed {
343 my $self = shift || __PACKAGE__->new;
344
345 if ($self->is_psgi) {
346 return $self->{psgi_responded};
347 } elsif (my $r = $self->apache_request) {
348 return $r->bytes_sent;
349 } else {
350 return $ENV{'CONTENT_TYPED'} ? 1 : undef;
351 }
352 }
353
354 ###----------------------------------------------------------------###
355
356 ### location bounce nicely - even if we have already sent content
357 ### may be called as function or a method
358 # $cgix->location_bounce($url);
359 # location_bounce($url);
360 sub location_bounce {
361 my ($self, $loc) = ($#_ == 1) ? (@_) : (undef, shift);
362 $self = __PACKAGE__->new if ! $self;
363
364 if ($self->content_typed) {
365 if ($DEBUG_LOCATION_BOUNCE) {
366 $self->print_body("<a class=debug href=\"$loc\">Location: $loc</a><br />\n");
367 } else {
368 $self->print_body("<meta http-equiv=\"refresh\" content=\"0;url=$loc\" />\n");
369 }
370
371 } elsif ($self->is_psgi) {
372 $self->{psgi_location} = $loc;
373
374 } elsif (my $r = $self->apache_request) {
375 $r->status(302);
376 if ($self->is_mod_perl_1) {
377 $r->header_out("Location", $loc);
378 $r->content_type('text/html');
379 $r->send_http_header;
380 $r->print("Bounced to $loc\n");
381 } else {
382 $r->headers_out->add("Location", $loc);
383 $r->content_type('text/html');
384 $r->rflush;
385 }
386
387 } else {
388 print "Location: $loc\r\n",
389 "Status: 302 Bounce\r\n",
390 "Content-Type: text/html\r\n\r\n",
391 "Bounced to $loc\r\n";
392 }
393 }
394
395 ### set a cookie nicely - even if we have already sent content
396 ### may be called as function or a method - fancy algo to allow for first argument of args hash
397 # $cgix->set_cookie({name => $name, ...});
398 # $cgix->set_cookie( name => $name, ... );
399 # set_cookie({name => $name, ...});
400 # set_cookie( name => $name, ... );
401 sub set_cookie {
402 my $self = UNIVERSAL::isa($_[0], __PACKAGE__) ? shift : __PACKAGE__->new;
403
404 my $args = ref($_[0]) ? shift : {@_};
405 foreach (keys %$args) {
406 next if /^-/;
407 $args->{"-$_"} = delete $args->{$_};
408 }
409
410 ### default path to / and allow for 1hour instead of 1h
411 $args->{-path} ||= '/';
412 $args->{-expires} = time_calc($args->{-expires}) if $args->{-expires};
413
414 my $obj = $self->object;
415 my $cookie = "" . $obj->cookie(%$args);
416
417 if ($self->content_typed) {
418 $self->print_body("<meta http-equiv=\"Set-Cookie\" content=\"$cookie\" />\n");
419 } elsif ($self->is_psgi) {
420 push @{$self->{psgi_headers} ||= []}, ('Set-Cookie' => $cookie);
421 } elsif (my $r = $self->apache_request) {
422 if ($self->is_mod_perl_1) {
423 $r->header_out("Set-cookie", $cookie);
424 } else {
425 $r->headers_out->add("Set-Cookie", $cookie);
426 }
427 } else {
428 print "Set-Cookie: $cookie\r\n";
429 }
430 }
431
432 ### print the last modified time
433 ### takes a time or filename and an optional keyname
434 # $cgix->last_modified; # now
435 # $cgix->last_modified((stat $file)[9]); # file's time
436 # $cgix->last_modified(time, 'Expires'); # different header
437 sub last_modified {
438 my $self = shift || die 'Usage: $cgix_obj->last_modified($time)'; # may be called as function or method
439 my $time = shift || time;
440 my $key = shift || 'Last-Modified';
441
442 ### get a time string - looks like:
443 ### Mon Dec 9 18:03:21 2002
444 ### valid RFC (although not prefered)
445 $time = scalar gmtime time_calc($time);
446
447 if ($self->content_typed) {
448 $self->print_body("<meta http-equiv=\"$key\" content=\"$time\" />\n");
449 } elsif ($self->is_psgi) {
450 push @{$self->{psgi_headers} ||= []}, ($key => $time);
451 } elsif (my $r = $self->apache_request) {
452 if ($self->is_mod_perl_1) {
453 $r->header_out($key, $time);
454 } else {
455 $r->headers_out->add($key, $time);
456 }
457 } else {
458 print "$key: $time\r\n";
459 }
460 }
461
462 ### add expires header
463 sub expires {
464 my $self = ref($_[0]) ? shift : __PACKAGE__->new; # may be called as a function or method
465 my $time = shift || time;
466 return $self->last_modified($time, 'Expires');
467 }
468
469 ### similar to expires_calc from CGI::Util
470 ### allows for lenient calling, hour instead of just h, etc
471 ### takes time or 0 or now or filename or types of -23minutes
472 sub time_calc {
473 my $time = shift; # may only be called as a function
474 if (! $time || lc($time) eq 'now') {
475 return time;
476 } elsif ($time =~ m/^\d+$/) {
477 return $time;
478 } elsif ($time =~ m/^([+-]?)\s*(\d+|\d*\.\d+)\s*([a-z])[a-z]*$/i) {
479 my $m = {
480 's' => 1,
481 'm' => 60,
482 'h' => 60 * 60,
483 'd' => 60 * 60 * 24,
484 'w' => 60 * 60 * 24 * 7,
485 'M' => 60 * 60 * 24 * 30,
486 'y' => 60 * 60 * 24 * 365,
487 };
488 return time + ($m->{lc($3)} || 1) * "$1$2";
489 } else {
490 my @stat = stat $time;
491 die "Could not find file \"$time\" for time_calc. You should pass one of \"now\", time(), \"[+-] \\d+ [smhdwMy]\" or a filename." if $#stat == -1;
492 return $stat[9];
493 }
494 }
495
496
497 ### allow for generic status send
498 sub send_status {
499 my $self = shift || die 'Usage: $cgix_obj->send_status(302 => "Bounced")';
500 my $code = shift || die "Missing status";
501 my $mesg = shift;
502 if (! defined $mesg) {
503 $mesg = "HTTP Status of $code received\n";
504 }
505 if ($self->content_typed) {
506 die "Cannot send a status ($code - $mesg) after content has been sent";
507 }
508 if ($self->is_psgi) {
509 $self->{psgi_status} = $code;
510 $self->print_body($mesg);
511 } elsif (my $r = $self->apache_request) {
512 $r->status($code);
513 if ($self->is_mod_perl_1) {
514 $r->content_type('text/html');
515 $r->send_http_header;
516 $r->print($mesg);
517 } else {
518 $r->content_type('text/html');
519 $r->print($mesg);
520 $r->rflush;
521 }
522 } else {
523 print "Status: $code\r\n";
524 $self->print_content_type;
525 print $mesg;
526 }
527 }
528
529 ### allow for sending a simple header
530 sub send_header {
531 my $self = shift || die 'Usage: $cgix_obj->send_header';
532 my $key = shift;
533 my $val = shift;
534 if ($self->content_typed) {
535 die "Cannot send a header ($key - $val) after content has been sent";
536 }
537 if ($self->is_psgi) {
538 push @{$self->{psgi_headers} ||= []}, ($key => $val);
539 } elsif (my $r = $self->apache_request) {
540 if ($self->is_mod_perl_1) {
541 $r->header_out($key, $val);
542 } else {
543 $r->headers_out->add($key, $val);
544 }
545 } else {
546 print "$key: $val\r\n";
547 }
548 }
549
550 ###----------------------------------------------------------------###
551
552 ### allow for printing out a static javascript file
553 ### for example $self->print_js("CGI::Ex::validate.js");
554 sub print_js {
555 my $self = shift || die 'Usage: $cgix_obj->print_js($js_file)';
556 my $js_file = shift || '';
557 $self = $self->new if ! ref $self;
558
559 ### fix up the file - force .js on the end
560 $js_file .= '.js' if $js_file && $js_file !~ /\.js$/i;
561 $js_file =~ s|::|/|g;
562
563 ### get file info
564 my $stat;
565 if ($js_file && $js_file =~ m|^/*(\w+(?:/+\w+)*\.js)$|i) {
566 foreach my $path (@INC) {
567 my $_file = "$path/$1";
568 next if ! -f $_file;
569 $js_file = $_file;
570 $stat = [stat _];
571 last;
572 }
573 }
574
575 ### no file = 404
576 if (! $stat) {
577 if (! $self->content_typed) {
578 $self->send_status(404, "JS File not found for print_js\n");
579 } else {
580 $self->print_body("<h1>JS File not found for print_js</h1>\n");
581 }
582 return;
583 }
584
585 ### do headers
586 if (! $self->content_typed) {
587 $self->last_modified($stat->[9]);
588 $self->expires('+ 1 year');
589 $self->print_content_type('application/x-javascript');
590 }
591
592 return if $self->env->{'REQUEST_METHOD'} && $self->env->{'REQUEST_METHOD'} eq 'HEAD';
593
594 ### send the contents
595 local *FH;
596 open(FH, "<$js_file") || die "Couldn't open file $js_file: $!";
597 local $/ = undef;
598 $self->print_body(<FH>);
599 close FH;
600 }
601
602 ###----------------------------------------------------------------###
603
604 ### form filler that will use either HTML::FillInForm, CGI::Ex::Fill
605 ### or another specified filler. Argument style is similar to
606 ### HTML::FillInForm. May be called as a method or a function.
607 sub fill {
608 my $self = shift;
609 my $args = shift;
610 if (ref($args)) {
611 if (! UNIVERSAL::isa($args, 'HASH')) {
612 $args = {text => $args};
613 @$args{'form','target','fill_password','ignore_fields'} = @_;
614 }
615 } else {
616 $args = {$args, @_};
617 }
618
619 my $module = $self->{'fill_module'} || 'CGI::Ex::Fill';
620
621 ### allow for using the standard HTML::FillInForm
622 ### too bad it won't modify our file in place for us
623 if ($module eq 'HTML::FillInForm') {
624 eval { require HTML::FillInForm };
625 if ($@) {
626 die "Couldn't require HTML::FillInForm: $@";
627 }
628 $args->{scalarref} = $args->{text} if $args->{text};
629 $args->{fdat} = $args->{form} if $args->{form};
630 my $filled = HTML::FillInForm->new->fill(%$args);
631 if ($args->{text}) {
632 my $ref = $args->{text};
633 $$ref = $filled;
634 return 1;
635 }
636 return $filled;
637
638 } else {
639 require CGI::Ex::Fill;
640
641 ### get the text to work on
642 my $ref;
643 if ($args->{text}) { # preferred method - gets modified in place
644 $ref = $args->{text};
645 } elsif ($args->{scalarref}) { # copy to mimic HTML::FillInForm
646 my $str = ${ $args->{scalarref} };
647 $ref = \$str;
648 } elsif ($args->{arrayref}) { # joined together (copy)
649 my $str = join "", @{ $args->{arrayref} };
650 $ref = \$str;
651 } elsif ($args->{file}) { # read it in
652 open (IN, $args->{file}) || die "Couldn't open $args->{file}: $!";
653 my $str = '';
654 read(IN, $str, -s _) || die "Couldn't read $args->{file}: $!";
655 close IN;
656 $ref = \$str;
657 } else {
658 die "No suitable text found for fill.";
659 }
660
661 ### allow for data to be passed many ways
662 my $form = $args->{form} || $args->{fobject}
663 || $args->{fdat} || $self->object;
664
665 CGI::Ex::Fill::form_fill($ref,
666 $form,
667 $args->{target},
668 $args->{fill_password},
669 $args->{ignore_fields},
670 );
671 return ! $args->{text} ? $$ref : 1;
672 }
673
674 }
675
676 ###----------------------------------------------------------------###
677
678 sub validate {
679 my $self = shift || die 'Usage: my $er = $cgix_obj->validate($form, $val_hash_or_file)';
680 my ($form, $file) = (@_ == 2) ? (shift, shift) : ($self->object, shift);
681
682 require CGI::Ex::Validate;
683
684 my $args = {};
685 $args->{raise_error} = 1 if $self->{raise_error};
686 return CGI::Ex::Validate->new($args)->validate($form, $file);
687 }
688
689 ###----------------------------------------------------------------###
690
691 sub conf_obj {
692 my $self = shift || die 'Usage: my $ob = $cgix_obj->conf_obj($args)';
693 return $self->{conf_obj} ||= do {
694 require CGI::Ex::Conf;
695 CGI::Ex::Conf->new(@_);
696 };
697 }
698
699 sub conf_read {
700 my $self = shift || die 'Usage: my $conf = $cgix_obj->conf_read($file)';
701 return $self->conf_obj->read(@_);
702 }
703
704 ###----------------------------------------------------------------###
705
706 sub swap_template {
707 my $self = shift || die 'Usage: my $out = $cgix_obj->swap_template($file, \%vars, $template_args)';
708 my $str = shift;
709 my $form = shift;
710 my $args = shift || {};
711 $form = $self if ! $form && ref($self);
712 $form = $self->get_form if UNIVERSAL::isa($form, __PACKAGE__);
713
714 my ($ref, $return) = ref($str) ? ($str, 0) : (\$str, 1);
715
716 ### look up the module
717 my $module = $self->{'template_module'} || 'CGI::Ex::Template';
718 my $pkg = "$module.pm";
719 $pkg =~ s|::|/|g;
720 require $pkg;
721
722 ### swap it
723 my $out = '';
724 $module->new($args)->process($ref, $form, \$out);
725
726 if (! $return) {
727 $$ref = $out;
728 return 1;
729 } else {
730 return $out;
731 }
732 }
733
734 ###----------------------------------------------------------------###
735
736 1;
737
738 __END__
739
740 =head1 CGI::Ex SYNOPSIS
741
742 ### You probably don't want to use CGI::Ex directly
743 ### You probably should use CGI::Ex::App instead.
744
745 my $cgix = CGI::Ex->new;
746
747 $cgix->print_content_type;
748
749 my $hash = $cgix->form;
750
751 if ($hash->{'bounce'}) {
752
753 $cgix->set_cookie({
754 name => ...,
755 value => ...,
756 });
757
758 $cgix->location_bounce($new_url_location);
759 exit;
760 }
761
762 if (scalar keys %$form) {
763 my $val_hash = $cgix->conf_read($pathtovalidation);
764 my $err_obj = $cgix->validate($hash, $val_hash);
765 if ($err_obj) {
766 my $errors = $err_obj->as_hash;
767 my $input = "Some content";
768 my $content = "";
769 $cgix->swap_template(\$input, $errors, $content);
770 $cgix->fill({text => \$content, form => $hashref});
771 print $content;
772 exit;
773 } else {
774 print "Success";
775 }
776 } else {
777 print "Main page";
778 }
779
780 =head1 DESCRIPTION
781
782 CGI::Ex provides a suite of utilities to make writing CGI scripts
783 more enjoyable. Although they can all be used separately, the
784 main functionality of each of the modules is best represented in
785 the CGI::Ex::App module. CGI::Ex::App takes CGI application building
786 to the next step. CGI::Ex::App is not quite a framework (which normally
787 includes pre-built html) instead CGI::Ex::App is an extended application
788 flow that dramatically reduces CGI build time in most cases. It does so
789 using as little magic as possible. See L<CGI::Ex::App>.
790
791 The main functionality is provided by several other modules that
792 may be used separately, or together through the CGI::Ex interface.
793
794 =over 4
795
796 =item C<CGI::Ex::Template>
797
798 A Template::Toolkit compatible processing engine. With a few limitations,
799 CGI::Ex::Template can be a drop in replacement for Template::Toolkit.
800
801 =item C<CGI::Ex::Fill>
802
803 A regular expression based form filler inner (accessed through B<-E<gt>fill>
804 or directly via its own functions). Can be a drop in replacement for
805 HTML::FillInForm. See L<CGI::Ex::Fill> for more information.
806
807 =item C<CGI::Ex::Validate>
808
809 A form field / cgi parameter / any parameter validator (accessed through
810 B<-E<gt>validate> or directly via its own methods). Not quite a drop in
811 for most validators, although it has most of the functionality of most
812 of the validators but with the key additions of conditional validation.
813 Has a tightly integrated JavaScript portion that allows for duplicate client
814 side validation. See L<CGI::Ex::Validate> for more information.
815
816 =item C<CGI::Ex::Conf>
817
818 A general use configuration, or settings, or key / value file reader. Has
819 ability for providing key fallback as well as immutable key definitions. Has
820 default support for yaml, storable, perl, ini, and xml and open architecture
821 for definition of others. See L<CGI::Ex::Conf> for more information.
822
823 =item C<CGI::Ex::Auth>
824
825 A highly configurable web based authentication system. See L<CGI::Ex::Auth> for
826 more information.
827
828 =back
829
830 =head1 CGI::Ex METHODS
831
832 =over 4
833
834 =item C<-E<gt>fill>
835
836 fill is used for filling hash or cgi object values into an existing
837 html document (it doesn't deal at all with how you got the document).
838 Arguments may be given as a hash, or a hashref or positional. Some
839 of the following arguments will only work using CGI::Ex::Fill - most
840 will work with either CGI::Ex::Fill or HTML::FillInForm (assume they
841 are available unless specified otherwise). (See L<CGI::Ex::Fill> for
842 a full explanation of functionality). The arguments to fill are as
843 follows (and in order of position):
844
845 =over 4
846
847 =item C<text>
848
849 Text should be a reference to a scalar string containing the html to
850 be modified (actually it could be any reference or object reference
851 that can be modified as a string). It will be modified in place.
852 Another named argument B<scalarref> is available if you would like to
853 copy rather than modify.
854
855 =item C<form>
856
857 Form may be a hashref, a cgi style object, a coderef, or an array of
858 multiple hashrefs, cgi objects, and coderefs. Hashes should be key
859 value pairs. CGI objects should be able
860 to call the method B<param> (This can be overrided). Coderefs should
861 expect the field name as an argument and should return a value.
862 Values returned by form may be undef, scalar, arrayref, or coderef
863 (coderef values should expect an argument of field name and should
864 return a value). The code ref options are available to delay or add
865 options to the bringing in of form information - without having to
866 tie the hash. Coderefs are not available in HTML::FillInForm. Also
867 HTML::FillInForm only allows CGI objects if an arrayref is used.
868
869 NOTE: Only one of the form, fdat, and fobject arguments are allowed at
870 a time.
871
872 =item C<target>
873
874 The name of the form that the fields should be filled to. The default
875 value of undef, means to fill in all forms in the html.
876
877 =item C<fill_passwords>
878
879 Boolean value defaults to 1. If set to zero - password fields will
880 not be filled.
881
882 =item C<ignore_fields>
883
884 Specify which fields to not fill in. It takes either array ref of
885 names, or a hashref with the names as keys. The hashref option is
886 not available in CGI::Ex::Fill.
887
888 =back
889
890 Other named arguments are available for compatibility with HTML::FillInForm.
891 They may only be used as named arguments.
892
893 =over 4
894
895 =item C<scalarref>
896
897 Almost the same as the argument text. If scalarref is used, the filled
898 html will be returned. If text is used the html passed is filled in place.
899
900 =item C<arrayref>
901
902 An array ref of lines of the document. Forces a returned filled html
903 document.
904
905 =item C<file>
906
907 An filename that will be opened, filled, and returned.
908
909 =item C<fdat>
910
911 A hashref of key value pairs.
912
913 =item C<fobject>
914
915 A cgi style object or arrayref of cgi style objects used for getting
916 the key value pairs. Should be capable of the ->param method and
917 ->cookie method as document in L<CGI>.
918
919 =back
920
921 See L<CGI::Ex::Fill> for more information about the filling process.
922
923 =item C<-E<gt>object>
924
925 Returns the CGI object that is currently being used by CGI::Ex. If none
926 has been set it will automatically generate an object of type
927 $PREFERRED_CGI_MODULE which defaults to B<CGI>.
928
929 =item C<-E<gt>validate>
930
931 Validate has a wide range of options available. (See L<CGI::Ex::Validate>
932 for a full explanation of functionality). Validate has two arguments:
933
934 =over 4
935
936 =item C<form>
937
938 Can be either a hashref to be validated, or a CGI style object (which
939 has the param method).
940
941 =item C<val_hash>
942
943 The val_hash can be one of three items. First, it can be a straight
944 perl hashref containing the validation to be done. Second, it can
945 be a YAML document string. Third, it can be the path to a file
946 containing the validation. The validation in a validation file will
947 be read in depending upon file extension.
948
949 =back
950
951 =item C<-E<gt>get_form>
952
953 Very similar to CGI->new->Vars except that arrays are returned as
954 arrays. Not sure why CGI didn't do this anyway (well - yes -
955 legacy Perl 4 - but at some point things need to be updated).
956
957 my $hash = $cgix->get_form;
958 my $hash = $cgix->get_form(CGI->new);
959 my $hash = get_form();
960 my $hash = get_form(CGI->new);
961
962 =item C<-E<gt>set_form>
963
964 Allow for setting a custom form hash. Useful for testing, or other
965 purposes.
966
967 $cgix->set_form(\%new_form);
968
969 =item C<-E<gt>get_cookies>
970
971 Returns a hash of all cookies.
972
973 my $hash = $cgix->get_cookies;
974 my $hash = $cgix->get_cookies(CGI->new);
975 my $hash = get_cookies();
976 my $hash = get_cookies(CGI->new);
977
978 =item C<-E<gt>set_cookies>
979
980 Allow for setting a custom cookies hash. Useful for testing, or other
981 purposes.
982
983 $cgix->set_cookies(\%new_cookies);
984
985 =item C<-E<gt>make_form>
986
987 Takes a hash and returns a query_string. A second optional argument
988 may contain an arrayref of keys to use from the hash in building the
989 query_string. First argument is undef, it will use the form stored
990 in itself as the hash.
991
992 =item C<-E<gt>content_type>
993
994 Can be called multiple times during the same session. Will only
995 print content-type once. (Useful if you don't know if something
996 else already printed content-type). Calling this sends the Content-type
997 header. Trying to print -E<gt>content_type is an error. For clarity,
998 the method -E<gt>print_content_type is available.
999
1000 $cgix->print_content_type;
1001
1002 # OR
1003 $cgix->print_content_type('text/html');
1004
1005 # OR
1006 $cgix->print_content_type('text/html', 'utf-8');
1007
1008 =item C<-E<gt>set_cookie>
1009
1010 Arguments are the same as those to CGI->new->cookie({}).
1011 Uses CGI's cookie method to create a cookie, but then, depending on
1012 if content has already been sent to the browser will either print
1013 a Set-cookie header, or will add a <meta http-equiv='set-cookie'>
1014 tag (this is supported on most major browsers). This is useful if
1015 you don't know if something else already printed content-type.
1016
1017 =item C<-E<gt>location_bounce>
1018
1019 Depending on if content has already been sent to the browser will either print
1020 a Location header, or will add a <meta http-equiv='refresh'>
1021 tag (this is supported on all major browsers). This is useful if
1022 you don't know if something else already printed content-type. Takes
1023 single argument of a url.
1024
1025 =item C<-E<gt>last_modified>
1026
1027 Depending on if content has already been sent to the browser will either print
1028 a Last-Modified header, or will add a <meta http-equiv='Last-Modified'>
1029 tag (this is supported on most major browsers). This is useful if
1030 you don't know if something else already printed content-type. Takes an
1031 argument of either a time (may be a CGI -expires style time) or a filename.
1032
1033 =item C<-E<gt>expires>
1034
1035 Depending on if content has already been sent to the browser will either print
1036 a Expires header, or will add a <meta http-equiv='Expires'>
1037 tag (this is supported on most major browsers). This is useful if
1038 you don't know if something else already printed content-type. Takes an
1039 argument of a time (may be a CGI -expires style time).
1040
1041 =item C<-E<gt>send_status>
1042
1043 Send a custom status. Works in both CGI and mod_perl. Arguments are
1044 a status code and the content (optional).
1045
1046 =item C<-E<gt>send_header>
1047
1048 Send a http header. Works in both CGI and mod_perl. Arguments are
1049 a header name and the value for that header.
1050
1051 =item C<-E<gt>print_js>
1052
1053 Prints out a javascript file. Does everything it can to make sure
1054 that the javascript will cache. Takes either a full filename,
1055 or a shortened name which will be looked for in @INC. (ie /full/path/to/my.js
1056 or CGI/Ex/validate.js or CGI::Ex::validate)
1057
1058 #!/usr/bin/perl
1059 use CGI::Ex;
1060 CGI::Ex->print_js($ENV{'PATH_INFO'});
1061
1062 =item C<-E<gt>swap_template>
1063
1064 This is intended as a simple yet strong subroutine to swap
1065 in tags to a document. It is intended to be very basic
1066 for those who may not want the full features of a Templating
1067 system such as Template::Toolkit (even though they should
1068 investigate them because they are pretty nice). The default allows
1069 for basic template toolkit variable swapping. There are two arguments.
1070 First is a string or a reference to a string. If a string is passed,
1071 a copy of that string is swapped and returned. If a reference to a
1072 string is passed, it is modified in place. The second argument is
1073 a form, or a CGI object, or a cgiex object, or a coderef (if the second
1074 argument is missing, the cgiex object which called the method will be
1075 used). If it is a coderef, it should accept key as its only argument and
1076 return the proper value.
1077
1078 my $cgix = CGI::Ex->new;
1079 my $form = {foo => 'bar',
1080 this => {is => {nested => ['wow', 'wee']}}
1081 };
1082
1083 my $str = $cgix->swap_template("<html>[% foo %]<br>[% foo %]</html>", $form));
1084 # $str eq '<html>bar<br>bar</html>'
1085
1086 $str = $cgix->swap_template("[% this.is.nested.1 %]", $form));
1087 # $str eq 'wee'
1088
1089 $str = "[% this.is.nested.0 %]";
1090 $cgix->swap_template(\$str, $form);
1091 # $str eq 'wow'
1092
1093 # may also be called with only one argument as follows:
1094 # assuming $cgix had a query string of ?foo=bar&baz=wow&this=wee
1095 $str = "<html>([% foo %]) <br>
1096 ([% baz %]) <br>
1097 ([% this %]) </html>";
1098 $cgix->swap_template(\$str);
1099 #$str eq "<html>(bar) <br>
1100 # (wow) <br>
1101 # (wee) </html>";
1102
1103 For further examples, please see the code contained in t/samples/cgi_ex_*
1104 of this distribution.
1105
1106 If at a later date, the developer upgrades to Template::Toolkit, the
1107 templates that were being swapped by CGI::Ex::swap_template should
1108 be compatible with Template::Toolkit.
1109
1110 =back
1111
1112 =head1 MODULES
1113
1114 See also L<CGI::Ex::App>.
1115
1116 See also L<CGI::Ex::Auth>.
1117
1118 See also L<CGI::Ex::Conf>.
1119
1120 See also L<CGI::Ex::Die>.
1121
1122 See also L<CGI::Ex::Dump>.
1123
1124 See also L<CGI::Ex::Fill>.
1125
1126 See also L<CGI::Ex::Template>.
1127
1128 See also L<CGI::Ex::Validate>.
1129
1130 =head1 LICENSE
1131
1132 This module may be distributed under the same terms as Perl itself.
1133
1134 =head1 AUTHOR
1135
1136 Paul Seamons <perl at seamons dot com>
1137
1138 =cut
This page took 0.110863 seconds and 4 git commands to generate.