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