File Coverage

blib/lib/AnyEvent/HTTP/Message.pm

Criterion	Covered	Total	%
statement	49	49	100.0
branch	12	12	100.0
condition	5	8	62.5
subroutine	16	16	100.0
pod	7	7	100.0
total	89	92	96.7

# vim: set ts=2 sts=2 sw=2 expandtab smarttab:
#
# This file is part of AnyEvent-HTTP-Message
#
# This software is copyright (c) 2012 by Randy Stauner.
#
# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
#
use strict;
use warnings;

package AnyEvent::HTTP::Message;
{
  $AnyEvent::HTTP::Message::VERSION = '0.302';
}
# git description: v0.301-3-ge92f3a7

BEGIN {
  $AnyEvent::HTTP::Message::AUTHORITY = 'cpan:RWSTAUNER';
}
# ABSTRACT: Lightweight objects for AnyEvent::HTTP Request/Response

use Carp ();
use Scalar::Util ();


sub new {
  my $class = shift;

  my $self;
  if( ref($_[0]) eq 'HASH' ){
    # if passed a single hashref take a shallow copy
    $self = { %{ $_[0] } };
  }
  elsif( Scalar::Util::blessed($_[0]) && $_[0]->isa('HTTP::Message') ){
    # allow an optional second hashref for extra params
    $self = $class->from_http_message(@_);
  }
  else {
      # otherwise it's the argument list for http_request()
    $self = $class->parse_args(@_);
  }

  # accept 'content' as an alias for 'body', but store as 'body'
  $self->{body} = delete $self->{content}
    if exists $self->{content};

  $self->{body} = ''
    if !defined $self->{body};

  $self->{headers} = $self->{headers}
    ? $class->_normalize_headers($self->{headers})
    : {};

  bless $self, $class;
}

sub _error {
  my $self = shift;
  @_ = join ' ', (ref($self) || $self), 'error:', @_;
  goto &Carp::croak;
}


sub parse_args {
  $_[0]->_error('parse_args() is not defined');
}


sub from_http_message {
  $_[0]->_error('from_http_message() is not defined');
}

# turn HTTP::Headers into a hashref
sub _hash_http_headers {
  my ($self, $headers) = @_;
  my $aeh = {};
  $headers->scan(sub {
    my ($k, $v) = @_;
    my $l = lc $k;
    $aeh->{$l} = exists($aeh->{$l}) ? $aeh->{$l} . ',' . $v : $v;
  });
  return $aeh;
}


# stubs for read-only accessors
sub body    { $_[0]->{body}           }
sub headers { $_[0]->{headers} ||= {} }

# alias
sub content { $_[0]->body }


sub header {
  my ($self, $h) = @_;
  $h =~ tr/_/-/;
  return $self->headers->{ lc $h };
}

# ensure keys are stored with dashes (not underscores) and lower-cased
sub _normalize_headers {
  my ($self, $headers) = @_;
  my $norm = {};
  while( my ($k, $v) = each %$headers ){
    my $n = $k;
    $n =~ tr/_/-/;
    $norm->{ lc $n } = $v;
  }
  return $norm;
}

1;

__END__