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