package Blosxom::Header;
use 5.008_001;
use strict;
use warnings;
use Exporter 'import';
use List::Util 'first';

our $VERSION   = '0.01014';
our @EXPORT_OK = qw( get_header set_header remove_header has_header );

sub new {
    require Blosxom::Header::Object;
    my $header_ref = $_[1];

    Blosxom::Header::Object->new(
        get    => sub { get_header( $header_ref, @_ )    },
        set    => sub { set_header( $header_ref, @_ )    },
        has    => sub { has_header( $header_ref, @_ )    },
        remove => sub { remove_header( $header_ref, @_ ) },
    );
}

sub get_header {
    my $header_ref = shift;
    my $key        = _lc( shift );

    # if any key matches $key, returns the value
    while ( my ( $k, $v ) = each %{ $header_ref } ) {
        return $v if _lc( $k ) eq $key;
    }

    return;
}

sub set_header {
    my ( $header_ref, $key, $value ) = @_;

    # if any key matches $key, replaces the value with $value
    my @keys      = keys %{ $header_ref };
    my $first_key = first { _lc( $_ ) eq _lc( $key ) } @keys;
    $header_ref->{ $first_key || $key } = $value;

    return;
}

sub has_header {
    my $header_ref = shift;
    my $key        = _lc( shift );

    # if any key matches $key, returns true
    for my $k ( keys %{ $header_ref } ) {
        return 1 if _lc( $k ) eq $key;
    }

    return 0;
}

sub remove_header {
    my $header_ref = shift;
    my $key        = _lc( shift );

    # deletes an element whose key matches $key
    my @keys = grep { _lc( $_ ) eq $key } keys %{ $header_ref };
    delete @{ $header_ref }{ @keys };

    return;
}

# returns a lowercased version of a given string
sub _lc {
    my $key = lc shift;

    # get rid of an initial dash if exists
    $key =~ s{^\-}{};

    # use dashes instead of underscores
    $key =~ tr{_}{-};

    return $key;
}

1;

__END__

=head1 NAME

Blosxom::Header - Missing interface to modify HTTP headers

=head1 SYNOPSIS

  # blosxom.cgi
  package blosxom;
  our $header = { foo => 'bar' };

  # plugins/foo
  package foo;
  use Blosxom::Header qw(get_header set_header has_header remove_header);

  # Functional interface
  my $value = get_header( $blosxom::header, 'foo' );
  my $bool  = has_header( $blosxom::header, 'foo' );
  set_header( $blosxom::header, 'bar' => 'baz' );
  remove_header( $blosxom::header, 'foo' );

  # OO interface
  my $h     = Blosxom::Header->new( $blosxom::header );
  my $value = $h->get('foo');
  my $bool  = $h->has('foo');
  $h->set( bar => 'baz' );
  $h->remove('foo');

=head1 DESCRIPTION

Blosxom, a weblog application, exports a global variable $header
which is a reference to hash.
This application passes $header L<CGI>::header() to generate
HTTP headers.

When plugin developers modify HTTP headers, they must write as follows:

  package foo;
  $blosxom::header->{'-status'} = '304 Not Modified';

It's obviously bad practice.
Blosxom misses the interface to modify them.

This module provieds you an OO interface:

  use Blosxom::Header;
  my $h = Blosxom::Header->new( $blosxom::header );
  $h->set( 'Status' => '304 Not Modified' );

or a functional one:

  use Blosxom::Header qw(set_header);
  set_header( $blosxom::header, 'Status' => '304 Not Modified' );

You don't need to mind whether to put a hyphen before a key,
nor whether to make a key lowercased or L<camelized|String::CamelCase>.

=head2 SUBROUTINES

The following are exported on demand.

=over 4

=item get_header( $blosxom::header, 'foo' )

Returns a value of the specified HTTP header.

=item set_header( $blosxom::header, 'foo' => 'bar' )

Sets a value of the specified HTTP header.

=item has_header( $blosxom::header, 'foo' )

Returns a Boolean value telling whether the specified HTTP header exists.

=item remove_header( $blosxom::header, 'foo' )

Deletes the specified element from HTTP headers.

=back

=head2 METHODS

=over 4

=item $h = Blosxom::Header->new( $blosxom::header )

Creates a new Blosxom::Header object.

=item $h->has( 'foo' )

A synonym for has_header.

=item $h->get( 'foo' )

A synonym for get_header.

=item $h->remove( 'foo' )

A synonym for remove_header.

=item $h->set( 'foo' => 'bar' )

A synonym for set_header.

=back

=head1 EXAMPLES

L<CGI>::header recognizes the following parameters.

=over 4

=item attachment

Can be used to turn the page into an attachment.
Represents suggested name for the saved file.

  $h->set(attachment => 'foo.png');

In this case, the outgoing header will be formatted as:

  Content-Disposition: attachment; filename="foo.png"

=item charset

Represents the character set sent to the browser.
If not provided, defaults to ISO-8859-1.

  $h->set(charset => 'utf-8');

=item cookie

Represents the Set-Cookie header.
The parameter can be an arrayref or a string.

  $h->set(cookie => [$cookie1, $cookie2]);
  $h->set(cookie => $cookie);

Refer to L<CGI>::cookie.

=item expires

Represents the Expires header.
You can specify an absolute or relative expiration interval.
The following forms are all valid for this field.

  $h->set(expires => '+30s'); # 30 seconds from now
  $h->set(expires => '+10m'); # ten minutes from now
  $h->set(expires => '+1h' ); # one hour from now
  $h->set(expires => '-1d' ); # yesterday
  $h->set(expires => 'now' ); # immediately
  $h->set(expires => '+3M' ); # in three months
  $h->set(expires => '+10y'); # in ten years time

  # at the indicated time & date
  $h->set(expires => 'Thu, 25 Apr 1999 00:40:33 GMT');

=item nph

If set to a true value,
will issue the correct headers to work with
a NPH (no-parse-header) script:

  $h->set(nph => 1);

=item p3p

Will add a P3P tag to the outgoing header.
The parameter can be an arrayref or a space-delimited string.

  $h->set(p3p => [qw(CAO DSP LAW CURa)]);
  $h->set(p3p => 'CAO DSP LAW CURa');

In either case, the outgoing header will be formatted as:

  P3P: policyref="/w3c/p3p.xml" cp="CAO DSP LAW CURa"

=item type

Represents the Content-Type header.

  $h->set(type => 'text/plain');

=back

=head1 DEPENDENCIES

L<Blosxom 2.1.2|http://blosxom.sourceforge.net/>

=head1 SEE ALSO

L<CGI>

=head1 AUTHOR

Ryo Anazawa (anazawa@cpan.org)

=head1 LICENSE AND COPYRIGHT

Copyright (c) 2011 Ryo Anazawa. All rights reserved.

This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself. See L<perlartistic>.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

=cut
