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