Dogcows Code - chaz/p5-CGI-Ex/blob - 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