Dogcows Code - chaz/p5-CGI-Ex/blob - lib/CGI/Ex.pm

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