File Coverage

blib/lib/CGI/Easy/Headers.pm

Criterion	Covered	Total	%
statement	55	63	87.3
branch	5	12	41.6
condition	1	3	33.3
subroutine	10	11	90.9
pod	5	5	100.0
total	76	94	80.8

package CGI::Easy::Headers;
use 5.010001;
use warnings;
use strict;
use utf8;
use Carp;

our $VERSION = 'v2.0.1';

use CGI::Easy::Util qw( date_http make_cookie );


sub new {
    my ($class, $opt) = @_;
    my $self = {
        'Status'        => '200 OK',
        'Content-Type'  => 'text/html; charset=utf-8',
        'Date'          => q{},
        'Set-Cookie'    => [],
        $opt ? %{$opt} : (),
    };
    return bless $self, $class;
}

sub add_cookie {
    my ($self, @cookies) = @_;
    push @{ $self->{'Set-Cookie'} }, @cookies;
    return;
}

sub redirect {
    my ($self, $url, $status) = @_;
    $self->{'Location'} = $url;
    if (!defined $status) {
        $status = '302 Found';
    }
    $self->{'Status'} = $status;
    return;
}

sub require_basic_auth {
    my ($self, $realm) = @_;
    if (!defined $realm) {
        $realm = q{};
    }
    $self->{'WWW-Authenticate'} = "Basic realm=\"$realm\"";
    $self->{'Status'} = '401 Authorization Required';
    return;
}

sub compose {
    my ($self) = @_;
    my %h = %{$self};
    for my $header (keys %h) {
        my $expect = join q{-}, map {ucfirst lc} split /-/xms, $header;
        $expect =~ s/\bEtag\b/ETag/xms;
        $expect =~ s/\bWww\b/WWW/xms;
        $expect =~ s/\bMd5\b/MD5/xms;
        if ($header ne $expect) {
            croak "Bad header name '$header' (should be '$expect')";
        }
    }

    my $s =     sprintf "Status: %s\r\n",       delete $h{'Status'};
    $s .=       sprintf "Content-Type: %s\r\n", delete $h{'Content-Type'};
    my $date = delete $h{'Date'};
    if (defined $date) {
        $s .=   sprintf "Date: %s\r\n",         $date || date_http(time);
    }
    for my $cookie (@{ delete $h{'Set-Cookie'} }) {
        $s .=   make_cookie($cookie);
    }
    for my $header (keys %h) {
        if (!ref $h{$header}) {
            $h{$header} = [ $h{$header} ];
        }
        for my $value (@{ $h{$header} }) {
            $s .= sprintf "%s: %s\r\n",         $header, $value;
        }
    }

    return $s . "\r\n";
}


1; # Magic true value required at end of module
__END__