view release on metacpan or  search on metacpan

lib/CGI/Ex.pm  view on Meta::CPAN

        $html_loc =~ s/\"/"/g;
    }

    if ($self->content_typed) {
        if ($DEBUG_LOCATION_BOUNCE) {
            print "<a class=debug href=\"$html_loc\">Location: $html_loc</a><br />\n";
        } else {
            print "<meta http-equiv=\"refresh\" content=\"0;url=$html_loc\" />\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->rflush;
            $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 "<script>document.cookie = '$cookie'</script>\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 "<meta http-equiv=\"$key\" content=\"$time\" />\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 {