view release on metacpan or  search on metacpan

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

#   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/</&lt;/g;
        $html_loc =~ s/>/&gt;/g;
        $html_loc =~ s/\"/&quot;/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";
    }