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