File Coverage

blib/lib/Metabrik/String/Http.pm

Criterion	Covered	Total	%
statement	9	43	20.9
branch	0	8	0.0
condition			n/a
subroutine	3	6	50.0
pod	1	3	33.3
total	13	60	21.6

#
# $Id$
#
# string::http Brik
#
package Metabrik::String::Http;
use strict;
use warnings;

use base qw(Metabrik);

sub brik_properties {
   return {
      revision => '$Revision$',
      tags => [ qw(unstable) ],
      author => 'GomoR ',
      license => 'http://opensource.org/licenses/BSD-3-Clause',
      attributes => {
      },
      attributes_default => {
      },
      commands => {
         decode => [ qw(string) ],
         encode => [ qw(hash) ],
      },
      require_modules => {
         'HTTP::Headers' => [ ],
         'HTTP::Request' => [ ],
         'HTTP::Response' => [ ],
      },
   };
}

sub encode {
   my $self = shift;
   my ($hash) = @_;

   $self->brik_help_run_undef_arg('encode', $hash) or return;

   my $protocol = $hash->{protocol};
   my $headers = HTTP::Headers->new(%{$hash->{headers}})->as_string;
   my $content = $hash->{content};

   my @lines = ();

   # Probably a response
   if (exists($hash->{code})) {
      my $code = $hash->{code};
      my $message = $hash->{message};

      @lines = ( "$protocol $code $message" );
   }
   # Probably a request
   else {
      my $method = $hash->{method};
      my $uri = $hash->{uri};

      @lines = ( "$method $uri $protocol" );
   }

   push @lines, $headers;
   push @lines, $content;

   return join("\n", @lines);
}

sub decode {
   my $self = shift;
   my ($string) = @_;

   $self->brik_help_run_undef_arg('decode', $string) or return;

   my $r;
   my $h;
   # Probably a response
   if ($string =~ m{^HTTP/}) {
      $r = HTTP::Response->parse($string);
      $h = {
         code => $r->code,
         message => $r->message,
      };
   }
   # Probably a request
   else {
      $r = HTTP::Request->parse($string);
      $h = {
         method => $r->method,
         uri => $r->uri->as_string,
      };
   }

   my @list = $r->headers->flatten;

   $h->{headers} = { @list };
   $h->{protocol} = $r->protocol;
   $h->{content} = $r->content;
   $h->{decoded_content} = $r->decoded_content;

   return $h;
}

1;

__END__