view release on metacpan or  search on metacpan

lib/APR/Emulate/PSGI.pm  view on Meta::CPAN

        $self->headers_out()->add('Pragma' => 'no-cache');
        $self->headers_out()->add('Cache-control' => 'no-cache');
    }
    # Unset headers.
    else {
        $self->headers_out()->unset('Pragma', 'Cache-control');
    }
    return $previous_value;
}

=item status

Emulates L<Apache2::RequestRec/status>.

=cut

sub status {
    my ($self, @value) = @_;
    $self->{'status'} = $value[0] if scalar(@value);
    return $self->{'status'};
}

=item status_line

Emulates L<Apache2::RequestRec/status_line>.

=cut

sub status_line {
    my ($self, @value) = @_;
    $self->{'status_line'} = $value[0] if scalar(@value);
    return $self->{'status_line'};
}

=item content_type

Emulates L<Apache2::RequestRec/content_type>.

If no PSGI enviroment is provided to L</new>, calling this
method with a parameter will cause HTTP headers to be sent.

=cut

sub content_type {
    my ($self, @value) = @_;
    if (scalar(@value)) {
        $self->{'content_type'} = $value[0];

        if ($self->{'cgi_mode'}) {
            $self->_send_http_headers();
        }
    }
    return $self->{'content_type'};
}

sub _send_http_headers {
    my ($self) = @_;
    return if ($self->{'headers_sent'});
    if (my $status = $self->status_line() || $self->status() || '200 OK') {
        my $url_scheme = uc($self->{'psgi_env'}{'psgi.url_scheme'} || 'http');
        print $url_scheme . '/1.1 ' . $status . "\n";
    }
    print 'Content-Type: ' . ($self->{'content_type'} || 'text/html') . "\n";
    $self->headers_out()->do(
        sub {
            my ($key, $value) = @_;
            print join(': ', $key, $value) . "\n";
        }
    );
    print "\n\n";
    $self->{'headers_sent'} = 1;
    return 1;
}

=item print

Emulates L<Apache2::RequestIO/print>.

=cut

sub print {
    my ($self, @content) = @_;
    my $success = CORE::print @content;
    return $success
        ? length(join('', @content))
        : 0;
}

=item rflush

Emulates L<Apache2::RequestIO/rflush>.

=cut

sub rflush {}

=back

=cut

# See APR::Table in mod_perl 2 distribution.
package APR::MyTable;

sub make {
    return bless {}, __PACKAGE__;
}

sub copy {
    my ($self) = @_;
    my %copy = %$self;
    return bless \%copy, ref($self);
}

sub clear {
    my ($self) = @_;
    my (@keys) = keys %$self;
    foreach my $key (@keys) {
        delete $self->{$key};
    }
    return 1;
}

sub set {
    my ($self, @pairs) = @_;
    while (@pairs) {
        my ($key, $value) = splice(@pairs, 0, 2);
        $self->{$key} = $value;
    }
    return 1;
}

sub unset {
    my ($self, @keys) = @_;
    foreach my $key (@keys) {
        delete $self->{$key};
    }
    return 1;
}

sub add {
    # TODO: When implemented properly, this should allow duplicate keys.
    my ($self, $key, $value) = @_;
    $self->{$key} = $value;