File Coverage

blib/lib/CGI/Ex.pm

Criterion	Covered	Total	%
statement	161	317	50.7
branch	76	190	40.0
condition	34	110	30.9
subroutine	24	40	60.0
pod	18	31	58.0
total	313	688	45.4

package CGI::Ex;

=head1 NAME

CGI::Ex - CGI utility suite - makes powerful application writing fun and easy

=head1 VERSION

version 2.53

=for markdown [![master](https://travis-ci.org/ljepson/CGI-Ex.svg?branch=master)](https://travis-ci.org/ljepson/CGI-Ex)

=for HTML

=cut

###----------------------------------------------------------------###
#  Copyright - Paul Seamons                                          #
#  Distributed under the Perl Artistic License without warranty      #
###----------------------------------------------------------------###

### See perldoc at bottom

use 5.006;
use strict;
our $VERSION = '2.53'; # VERSION

our ($PREFERRED_CGI_MODULE,
     $PREFERRED_CGI_REQUIRED,
     $AUTOLOAD,
     $DEBUG_LOCATION_BOUNCE,
     @EXPORT, @EXPORT_OK
     );
use Exporter qw(import);

BEGIN {
    $PREFERRED_CGI_MODULE  ||= 'CGI';
    @EXPORT = ();
    @EXPORT_OK = qw(get_form
                    get_cookies
                    print_content_type
                    content_type
                    content_typed
                    set_cookie
                    location_bounce
                    );

    ### cache mod_perl version (light if or if not mod_perl)
    my $v = (! $ENV{'MOD_PERL'}) ? 0
        # mod_perl/1.27 or mod_perl/1.99_16 or mod_perl/2.0.1
        # if MOD_PERL is set - don't die if regex fails - just assume 1.0
        : ($ENV{'MOD_PERL'} =~ m{ ^ mod_perl / (\d+\.[\d_]+) (?: \.\d+)? $ }x) ? $1
        : '1.0_0';
    sub _mod_perl_version () { $v }
    sub _is_mod_perl_1    () { $v <  1.98 && $v > 0 }
    sub _is_mod_perl_2    () { $v >= 1.98 }

    ### cache apache request getter (light if or if not mod_perl)
    my $sub;
    if (_is_mod_perl_1) { # old mod_perl
        require Apache;
        $sub = sub { Apache->request };
    } elsif (_is_mod_perl_2) {
        if (eval { require Apache2::RequestRec }) { # debian style
            require Apache2::RequestUtil;
            $sub = sub { Apache2::RequestUtil->request };
        } else { # fedora and mandrake style
            require Apache::RequestUtil;
            $sub = sub { Apache->request };
        }
    } else {
        $sub = sub {};
    }
    sub apache_request_sub () { $sub }
}

###----------------------------------------------------------------###

#   my $cgix = CGI::Ex->new;
sub new {
    my $class = shift || die "Missing class name";
    my $self  = ref($_[0]) ? shift : {@_};
    return bless $self, $class;
}

###----------------------------------------------------------------###

### allow for holding another classed CGI style object
#   my $query = $cgix->object;
#   $cgix->object(CGI->new);
sub object {
    my $self = shift || die 'Usage: my $query = $cgix_obj->object';
    $self->{'object'} = shift if $#_ != -1;

    if (! defined $self->{'object'}) {
        $PREFERRED_CGI_REQUIRED ||= do {
            my $file = $self->{'cgi_module'} || $PREFERRED_CGI_MODULE;
            $file .= ".pm";
            $file =~ s|::|/|g;
            eval { require $file };
            die "Couldn't require $PREFERRED_CGI_MODULE: $@" if $@;
            1; # return of do
        };
        $self->{'object'} = $PREFERRED_CGI_MODULE->new;
    }

    return $self->{'object'};
}

### allow for calling CGI MODULE methods
sub AUTOLOAD {
    my $self = shift;
    my $meth = ($AUTOLOAD =~ /(\w+)$/) ? $1 : die "Invalid method $AUTOLOAD";
    return $self->object->$meth(@_);
}

sub DESTROY { }

###----------------------------------------------------------------###

### Form getter that will act like CGI->new->Vars only it will return arrayrefs
### for values that are arrays
#   my $hash = $cgix->get_form;
#   my $hash = $cgix->get_form(CGI->new);
#   my $hash = get_form();
#   my $hash = get_form(CGI->new);
sub get_form {
    my $self = shift || __PACKAGE__->new;
    if (! $self->isa(__PACKAGE__)) { # get_form(CGI->new) syntax
        my $obj = $self;
        $self = __PACKAGE__->new;
        $self->object($obj);
    }
    return $self->{'form'} if $self->{'form'};

    ### get the info out of the object
    my $obj  = shift || $self->object;
    my %hash = ();
    ### this particular use of $cgi->param in list context is safe
    local $CGI::LIST_CONTEXT_WARN = 0;
    my $mp = $obj->can('multi_param') ? 1 : 0;
    foreach my $key ($obj->param) {
        my @val = $mp ? $obj->multi_param($key) : $obj->param($key);
        $hash{$key} = ($#val <= 0) ? $val[0] : \@val;
    }
    return $self->{'form'} = \%hash;
}

### allow for a setter
### $cgix->set_form(\%form);
sub set_form {
    my $self = shift || die 'Usage: $cgix_obj->set_form(\%form)';
    return $self->{'form'} = shift || {};
}

### Combined get and set form
#   my $hash = $cgix->form;
#   $cgix->form(\%form);
sub form {
    my $self = shift;
    return $self->set_form(shift) if @_ == 1;
    return $self->get_form;
}

### allow for creating a url encoded key value sequence
#   my $str = $cgix->make_form(\%form);
#   my $str = $cgix->make_form(\%form, \@keys_to_include);
sub make_form {
    my $self = shift || die 'Usage: $cgix_obj->make_form(\%form)';
    my $form = shift || $self->get_form;
    my $keys = ref($_[0]) ? shift : [sort keys %$form];
    my $str = '';
    foreach (@$keys) {
        my $key = $_; # make a copy
        my $val = $form->{$key};
        $key =~ s/([^\w.\-\ ])/sprintf('%%%02X', ord $1)/eg;
        $key =~ y/ /+/;
        foreach (ref($val) eq 'ARRAY' ? @$val : $val) {
            my $_val = $_; # make a copy
            $_val =~ s/([^\w.\-\ ])/sprintf('%%%02X', ord $1)/eg;
            $_val =~ y/ /+/;
            $str .= "$key=$_val&"; # intentionally not using join
        }
    }
    chop $str;
    return $str;
}

###----------------------------------------------------------------###

### like get_form - but a hashref of cookies
### cookies are parsed depending upon the functionality of ->cookie
#   my $hash = $cgix->get_cookies;
#   my $hash = $cgix->get_cookies(CGI->new);
#   my $hash = get_cookies();
#   my $hash = get_cookies(CGI->new);
sub get_cookies {
    my $self = shift || __PACKAGE__->new;
    if (! $self->isa(__PACKAGE__)) { # get_cookies(CGI->new) syntax
        my $obj = $self;
        $self = __PACKAGE__->new;
        $self->object($obj);
    }
    return $self->{'cookies'} if $self->{'cookies'};

    my $obj  = shift || $self->object;
    my %hash = ();
    foreach my $key ($obj->cookie) {
        my @val = $obj->cookie($key);
        $hash{$key} = ($#val == -1) ? "" : ($#val == 0) ? $val[0] : \@val;
    }
    return $self->{'cookies'} = \%hash;
}

### Allow for a setter
### $cgix->set_cookies(\%cookies);
sub set_cookies {
    my $self = shift || die 'Usage: $cgix_obj->set_cookies(\%cookies)';
    return $self->{'cookies'} = shift || {};
}

### Combined get and set cookies
#   my $hash = $cgix->cookies;
#   $cgix->cookies(\%cookies);
sub cookies {
    my $self = shift;
    return $self->set_cookies(shift) if @_ == 1;
    return $self->get_cookies;
}

###----------------------------------------------------------------###

### Allow for shared apache request object
#   my $r = $cgix->apache_request
#   $cgix->apache_request($r);
sub apache_request {
    my $self = shift || die 'Usage: $cgix_obj->apache_request';
    $self->{'apache_request'} = shift if $#_ != -1;

    return $self->{'apache_request'} ||= apache_request_sub()->();
}

### Get the version of mod_perl running (0 if not mod_perl)
#   my $version = $cgix->mod_perl_version;
sub mod_perl_version { _mod_perl_version }
sub is_mod_perl_1    { _is_mod_perl_1    }
sub is_mod_perl_2    { _is_mod_perl_2    }

### Allow for a setter
#   $cgix->set_apache_request($r)
sub set_apache_request { shift->apache_request(shift) }

###----------------------------------------------------------------###

### same signature as print_content_type
sub content_type { &print_content_type }

### will send the Content-type header
#   $cgix->print_content_type;
#   $cgix->print_content_type('text/plain');
#   print_content_type();
#   print_content_type('text/plain);
sub print_content_type {
    my ($self, $type, $charset) = (@_ && ref $_[0]) ? @_ : (undef, @_);
    $self = __PACKAGE__->new if ! $self;

    if ($type) {
        die "Invalid type: $type" if $type !~ m|^[\w\-\.]+/[\w\-\.\+]+$|; # image/vid.x-foo
    } else {
        $type = 'text/html';
    }
    $type .= "; charset=$charset" if $charset && $charset =~ m|^[\w\-\.\:\+]+$|;

    if (my $r = $self->apache_request) {
        return if $r->bytes_sent;
        $r->content_type($type);
        $r->send_http_header if $self->is_mod_perl_1;
    } else {
        if (! $ENV{'CONTENT_TYPED'}) {
            print "Content-Type: $type\r\n\r\n";
            $ENV{'CONTENT_TYPED'} = '';
        }
        $ENV{'CONTENT_TYPED'} .= sprintf("%s, %d\n", (caller)[1,2]);
    }
}

### Boolean check if content has been typed
#   $cgix->content_typed;
#   content_typed();
sub content_typed {
    my $self = shift || __PACKAGE__->new;

    if (my $r = $self->apache_request) {
        return $r->bytes_sent;
    } else {
        return $ENV{'CONTENT_TYPED'} ? 1 : undef;
    }
}

###----------------------------------------------------------------###

### location bounce nicely - even if we have already sent content
### may be called as function or a method
#   $cgix->location_bounce($url);
#   location_bounce($url);
sub location_bounce {
    my ($self, $loc) = ($#_ == 1) ? (@_) : (undef, shift);
    $self = __PACKAGE__->new if ! $self;
    $loc =~ s{(\s)}{sprintf("%%%02X", ord $1)}xge if $loc;
    my $html_loc = $loc;
    if ($html_loc) {
        $html_loc =~ s/&/&/g;
        $html_loc =~ s/
        $html_loc =~ s/>/>/g;
        $html_loc =~ s/\"/"/g;
    }

    if ($self->content_typed) {
        if ($DEBUG_LOCATION_BOUNCE) {
            print "Location: $html_loc\n";
        } else {
            print "\n";
        }

    } elsif (my $r = $self->apache_request) {
        $r->status(302);
        if ($self->is_mod_perl_1) {
            $r->header_out("Location", $loc);
            $r->content_type('text/html');
            $r->send_http_header;
            $r->print("Bounced to $html_loc\n");
        } else {
            $r->headers_out->add("Location", $loc);
            $r->custom_response(302, "Bounced to $html_loc\n");
        }

    } else {
        print "Location: $loc\r\n",
        "Status: 302 Bounce\r\n",
        "Content-Type: text/html\r\n\r\n",
        "Bounced to $html_loc\r\n";
    }
}

### set a cookie nicely - even if we have already sent content
### may be called as function or a method - fancy algo to allow for first argument of args hash
#   $cgix->set_cookie({name => $name, ...});
#   $cgix->set_cookie( name => $name, ... );
#   set_cookie({name => $name, ...});
#   set_cookie( name => $name, ... );
sub set_cookie {
    my $self = UNIVERSAL::isa($_[0], __PACKAGE__) ? shift : __PACKAGE__->new;

    my $args = ref($_[0]) ? shift : {@_};
    foreach (keys %$args) {
        next if /^-/;
        $args->{"-$_"} = delete $args->{$_};
    }

    ### default path to / and allow for 1hour instead of 1h
    $args->{-path} ||= '/';
    $args->{-expires} = time_calc($args->{-expires}) if $args->{-expires};

    my $obj    = $self->object;
    my $cookie = "" . $obj->cookie(%$args);

    if ($self->content_typed) {
        print "document.cookie = '$cookie'\n";
    } else {
        if (my $r = $self->apache_request) {
            if ($self->is_mod_perl_1) {
                $r->header_out("Set-cookie", $cookie);
            } else {
                $r->headers_out->add("Set-Cookie", $cookie);
            }
        } else {
            print "Set-Cookie: $cookie\r\n";
        }
    }
}

### print the last modified time
### takes a time or filename and an optional keyname
#   $cgix->last_modified; # now
#   $cgix->last_modified((stat $file)[9]); # file's time
#   $cgix->last_modified(time, 'Expires'); # different header
sub last_modified {
    my $self = shift || die 'Usage: $cgix_obj->last_modified($time)'; # may be called as function or method
    my $time = shift || time;
    my $key  = shift || 'Last-Modified';

    ### get a time string - looks like:
    ### Mon Dec  9 18:03:21 2002
    ### valid RFC (although not prefered)
    $time = scalar gmtime time_calc($time);

    if ($self->content_typed) {
        print "\n";
    } elsif (my $r = $self->apache_request) {
        if ($self->is_mod_perl_1) {
            $r->header_out($key, $time);
        } else {
            $r->headers_out->add($key, $time);
        }
    } else {
        print "$key: $time\r\n";
    }
}

### add expires header
sub expires {
    my $self = ref($_[0]) ? shift : __PACKAGE__->new; # may be called as a function or method
    my $time = shift || time;
    return $self->last_modified($time, 'Expires');
}

### similar to expires_calc from CGI::Util
### allows for lenient calling, hour instead of just h, etc
### takes time or 0 or now or filename or types of -23minutes
sub time_calc {
    my $time = shift; # may only be called as a function
    if (! $time || lc($time) eq 'now') {
        return time;
    } elsif ($time =~ m/^\d+$/) {
        return $time;
    } elsif ($time =~ m/^([+-]?)\s*(\d+|\d*\.\d+)\s*([a-z])[a-z]*$/i) {
        my $m = {
            's' => 1,
            'm' => 60,
            'h' => 60 * 60,
            'd' => 60 * 60 * 24,
            'w' => 60 * 60 * 24 * 7,
            'M' => 60 * 60 * 24 * 30,
            'y' => 60 * 60 * 24 * 365,
        };
        return time + ($m->{lc($3)} || 1) * "$1$2";
    } else {
        my @stat = stat $time;
        die "Could not find file \"$time\" for time_calc.  You should pass one of \"now\", time(), \"[+-] \\d+ [smhdwMy]\" or a filename." if $#stat == -1;
        return $stat[9];
    }
}


### allow for generic status send
sub send_status {
    my $self = shift || die 'Usage: $cgix_obj->send_status(302 => "Bounced")';
    my $code = shift || die "Missing status";
    my $mesg = shift;
    if (! defined $mesg) {
        $mesg = "HTTP Status of $code received\n";
    }
    if ($self->content_typed) {
        die "Cannot send a status ($code - $mesg) after content has been sent";
    }
    if (my $r = $self->apache_request) {
        $r->status($code);
        if ($self->is_mod_perl_1) {
            $r->content_type('text/html');
            $r->send_http_header;
            $r->print($mesg);
        } else {
            $r->content_type('text/html');
            $r->print($mesg);
            $r->rflush;
        }
    } else {
        print "Status: $code\r\n";
        $self->print_content_type;
        print $mesg;
    }
}

### allow for sending a simple header
sub send_header {
    my $self = shift || die 'Usage: $cgix_obj->send_header';
    my $key  = shift;
    my $val  = shift;
    if ($self->content_typed) {
        die "Cannot send a header ($key - $val) after content has been sent";
    }
    if (my $r = $self->apache_request) {
        if ($self->is_mod_perl_1) {
            $r->header_out($key, $val);
        } else {
            $r->headers_out->add($key, $val);
        }
    } else {
        print "$key: $val\r\n";
    }
}

###----------------------------------------------------------------###

### allow for printing out a static javascript file
### for example $self->print_js("CGI::Ex::validate.js");
sub print_js {
    my $self    = shift || die 'Usage: $cgix_obj->print_js($js_file)';
    my $js_file = shift || '';
    $self = $self->new if ! ref $self;

    ### fix up the file - force .js on the end
    $js_file .= '.js' if $js_file && $js_file !~ /\.js$/i;
    $js_file =~ s|::|/|g;

    ### get file info
    my $stat;
    if ($js_file && $js_file =~ m|^/*(\w+(?:/+\w+)*\.js)$|i) {
        foreach my $path (@INC) {
            my $_file = "$path/$1";
            next if ! -f $_file;
            $js_file = $_file;
            $stat = [stat _];
            last;
        }
    }

    ### no file = 404
    if (! $stat) {
        if (! $self->content_typed) {
            $self->send_status(404, "JS File not found for print_js\n");
        } else {
            print "JS File not found for print_js\n";
        }
        return;
    }

    ### do headers
    if (! $self->content_typed) {
        $self->last_modified($stat->[9]);
        $self->expires('+ 1 year');
        $self->print_content_type('application/x-javascript');
    }

    return if $ENV{'REQUEST_METHOD'} && $ENV{'REQUEST_METHOD'} eq 'HEAD';

    ### send the contents
    local *FH;
    open(FH, "<$js_file") || die "Couldn't open file  $js_file: $!";
    local $/ = undef;
    print ;
    close FH;
}

###----------------------------------------------------------------###

### form filler that will use either HTML::FillInForm, CGI::Ex::Fill
### or another specified filler.  Argument style is similar to
### HTML::FillInForm.  May be called as a method or a function.
sub fill {
    my $self = shift;
    my $args = shift;
    if (ref($args)) {
        if (! UNIVERSAL::isa($args, 'HASH')) {
            $args = {text => $args};
            @$args{'form','target','fill_password','ignore_fields'} = @_;
        }
    } else {
        $args = {$args, @_};
    }

    my $module = $self->{'fill_module'} || 'CGI::Ex::Fill';

    ### allow for using the standard HTML::FillInForm
    ### too bad it won't modify our file in place for us
    if ($module eq 'HTML::FillInForm') {
        eval { require HTML::FillInForm };
        if ($@) {
            die "Couldn't require HTML::FillInForm: $@";
        }
        $args->{scalarref} = $args->{text} if $args->{text};
        $args->{fdat}      = $args->{form} if $args->{form};
        my $filled = HTML::FillInForm->new->fill(%$args);
        if ($args->{text}) {
            my $ref = $args->{text};
            $$ref = $filled;
            return 1;
        }
        return $filled;

    } else {
        require CGI::Ex::Fill;

        ### get the text to work on
        my $ref;
        if ($args->{text}) {           # preferred method - gets modified in place
            $ref = $args->{text};
        } elsif ($args->{scalarref}) { # copy to mimic HTML::FillInForm
            my $str = ${ $args->{scalarref} };
            $ref = \$str;
        } elsif ($args->{arrayref}) {  # joined together (copy)
            my $str = join "", @{ $args->{arrayref} };
            $ref = \$str;
        } elsif ($args->{file}) {      # read it in
            open (IN, $args->{file}) || die "Couldn't open $args->{file}: $!";
            my $str = '';
            read(IN, $str, -s _) || die "Couldn't read $args->{file}: $!";
            close IN;
            $ref = \$str;
        } else {
            die "No suitable text found for fill.";
        }

        ### allow for data to be passed many ways
        my $form = $args->{form} || $args->{fobject}
        || $args->{fdat} || $self->object;

        CGI::Ex::Fill::form_fill($ref,
                                 $form,
                                 $args->{target},
                                 $args->{fill_password},
                                 $args->{ignore_fields},
                                 );
        return ! $args->{text} ? $$ref : 1;
    }

}

###----------------------------------------------------------------###

sub validate {
    my $self = shift || die 'Usage: my $er = $cgix_obj->validate($form, $val_hash_or_file)';
    my ($form, $file) = (@_ == 2) ? (shift, shift) : ($self->object, shift);

    require CGI::Ex::Validate;

    my $args = {};
    $args->{raise_error} = 1 if $self->{raise_error};
    return CGI::Ex::Validate->new($args)->validate($form, $file);
}

###----------------------------------------------------------------###

sub conf_obj {
    my $self = shift || die 'Usage: my $ob = $cgix_obj->conf_obj($args)';
    return $self->{conf_obj} ||= do {
        require CGI::Ex::Conf;
        CGI::Ex::Conf->new(@_);
    };
}

sub conf_read {
    my $self = shift || die 'Usage: my $conf = $cgix_obj->conf_read($file)';
    return $self->conf_obj->read(@_);
}

###----------------------------------------------------------------###

sub swap_template {
    my $self = shift || die 'Usage: my $out = $cgix_obj->swap_template($file, \%vars, $template_args)';
    my $str  = shift;
    my $form = shift;
    my $args = shift || {};
    $form = $self if ! $form && ref($self);
    $form = $self->get_form if UNIVERSAL::isa($form, __PACKAGE__);

    my ($ref, $return) = ref($str) ? ($str, 0) : (\$str, 1);

    ### look up the module
    my $module = $self->{'template_module'} || 'CGI::Ex::Template';
    my $pkg = "$module.pm";
    $pkg =~ s|::|/|g;
    require $pkg;

    ### swap it
    my $out = '';
    $module->new($args)->process($ref, $form, \$out);

    if (! $return) {
        $$ref = $out;
        return 1;
    } else {
        return $out;
    }
}

###----------------------------------------------------------------###

1;

__END__