view release on metacpan or  search on metacpan

lib/AnyEvent/HTTPD/SendMultiHeaderPatch.pm  view on Meta::CPAN

package AnyEvent::HTTPD::SendMultiHeaderPatch;

use 5.006;
use strict;
use warnings FATAL => 'all';
no warnings 'redefine';

use AnyEvent::HTTPD::HTTPConnection;

=head1 NAME

AnyEvent::HTTPD::SendMultiHeaderPatch -
    Patch (hack) of AnyEvent::HTTPD for sending multiple headers with the same field name.

=head1 VERSION

Version 0.1.3

=cut

our $VERSION = '0.001003';

use AnyEvent::HTTPD;
use AnyEvent::HTTPD::Util;
use AnyEvent::HTTPD::HTTPConnection;

use Scalar::Util qw(weaken);

push @AnyEvent::HTTPD::Util::EXPORT, qw(header_add header_gets);

*AnyEvent::HTTPD::Util::header_add = sub {
    my ($hdrs, $name, $value) = @_;
    $name = AnyEvent::HTTPD::Util::_header_transform_case_insens ($hdrs, $name);
    if( exists $hdrs->{$name} ) {
        $hdrs->{$name} .= "\0".$value;
    }
    else {
       $hdrs->{$name} = $value;
    }
};

*AnyEvent::HTTPD::Util::header_gets = sub {
    my ($hdrs, $name) = @_;
    $name = AnyEvent::HTTPD::Util::_header_transform_case_insens ($hdrs, $name);
    exists $hdrs->{$name} ? [split /\0/, $hdrs->{$name}] : []
};

*AnyEvent::HTTPD::HTTPConnection::response = sub {
   my ($self, $code, $msg, $hdr, $content, $no_body) = @_;
   return if $self->{disconnected};
   return unless $self->{hdl};

   my $res = "HTTP/1.0 $code $msg\015\012";
   header_set ($hdr, 'Date' => AnyEvent::HTTPD::HTTPConnection::_time_to_http_date time)
      unless header_exists ($hdr, 'Date');
   header_set ($hdr, 'Expires' => header_get ($hdr, 'Date'))
      unless header_exists ($hdr, 'Expires');
   header_set ($hdr, 'Cache-Control' => "max-age=0")
      unless header_exists ($hdr, 'Cache-Control');
   header_set ($hdr, 'Connection' =>
                    ($self->{keep_alive} ? 'Keep-Alive' : 'close'));

   header_set ($hdr, 'Content-Length' => length "$content")
      unless header_exists ($hdr, 'Content-Length')
             || ref $content;

   unless (defined header_get ($hdr, 'Content-Length')) {
      # keep alive with no content length will NOT work.
      delete $self->{keep_alive};
      header_set ($hdr, 'Connection' => 'close');
   }

   while (my ($h, $v) = each %$hdr) {
      next unless defined $v;
      for my $vv ( split /\0/, $v ) {
          $res .= "$h: $vv\015\012";
      }
   }

   $res .= "\015\012";

   if ($no_body) { # for HEAD requests!
      $self->{hdl}->push_write ($res);
      $self->response_done;
      return;
   }

   if (ref ($content) eq 'CODE') {
      weaken $self;

      my $chunk_cb = sub {
         my ($chunk) = @_;

         return 0 unless defined ($self) && defined ($self->{hdl}) && !$self->{disconnected};

         delete $self->{transport_polled};

         if (defined ($chunk) && length ($chunk) > 0) {
            $self->{hdl}->push_write ($chunk);

         } else {
            $self->response_done;
         }

         return 1;
      };

      $self->{transfer_cb} = $content;

      $self->{hdl}->on_drain (sub {
         return unless $self;

         if (length $res) {
            my $r = $res;
            undef $res;
            $chunk_cb->($r);

         } elsif (not $self->{transport_polled}) {
            $self->{transport_polled} = 1;
            $self->{transfer_cb}->($chunk_cb) if $self;
         }
      });

   } else {
      $res .= $content;
      $self->{hdl}->push_write ($res);
      $self->response_done;
   }
};

=head1 SYNOPSIS

    use AnyEvent::HTTPD; # Optional,
                         # because the patch module will use it first.
    use AnyEvent::HTTPD::SendMultiHeaderPatch;

    # In the http request handler,
    # separate the multiple values of the same field with \0 character.
    sub {
        my($httpd, $req) = @_;
        # ...
        $req->respond(
            200, 'OK', {
                'Set-Cookie' => "a=123; path=/; domain=.example.com\0b=456; path=/; domain=.example.com"
            }, "Set the cookies"
        );
    }

    # Or use the added util function header_add in AnyEvent::HTTPD::Util.