t/000_recipes/basics/005_coercion.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More;
   7
   8 BEGIN {
   9     eval "use HTTP::Headers; use Params::Coerce; use URI;";
  10     plan skip_all => "HTTP::Headers & Params::Coerce & URI required for this test" if $@;
  11     plan tests => 17;
  12 }
  13
  14 use Test::Exception;
  15
  16 {
  17     package Request;
  18     use Moose;
  19     use Moose::Util::TypeConstraints;
  20
  21     use HTTP::Headers  ();
  22     use Params::Coerce ();
  23     use URI            ();
  24
  25     subtype 'My.HTTP::Headers' => as class_type('HTTP::Headers');
  26
  27     coerce 'My.HTTP::Headers'
  28         => from 'ArrayRef'
  29             => via { HTTP::Headers->new( @{$_} ) }
  30         => from 'HashRef'
  31             => via { HTTP::Headers->new( %{$_} ) };
  32
  33     subtype 'My.URI' => as class_type('HTTP::Headers');
  34
  35     coerce 'My.URI'
  36         => from 'Object'
  37             => via { $_->isa('URI')
  38                      ? $_
  39                      : Params::Coerce::coerce( 'URI', $_ ); }
  40         => from 'Str'
  41             => via { URI->new( $_, 'http' ) };
  42
  43     subtype 'Protocol'
  44         => as 'Str'
  45         => where { /^HTTP\/[0-9]\.[0-9]$/ };
  46
  47     has 'base' => ( is => 'rw', isa => 'My.URI', coerce => 1 );
  48     has 'uri'  => ( is => 'rw', isa => 'My.URI', coerce => 1 );
  49     has 'method'   => ( is => 'rw', isa => 'Str' );
  50     has 'protocol' => ( is => 'rw', isa => 'Protocol' );
  51     has 'headers'  => (
  52         is      => 'rw',
  53         isa     => 'My.HTTP::Headers',
  54         coerce  => 1,
  55         default => sub { HTTP::Headers->new }
  56     );
  57 }
  58
  59 my $r = Request->new;
  60 isa_ok($r, 'Request');
  61
  62 {
  63     my $header = $r->headers;
  64     isa_ok($header, 'HTTP::Headers');
  65
  66     is($r->headers->content_type, '', '... got no content type in the header');
  67
  68     $r->headers( { content_type => 'text/plain' } );
  69
  70     my $header2 = $r->headers;
  71     isa_ok($header2, 'HTTP::Headers');
  72     isnt($header, $header2, '... created a new HTTP::Header object');
  73
  74     is($header2->content_type, 'text/plain', '... got the right content type in the header');
  75
  76     $r->headers( [ content_type => 'text/html' ] );
  77
  78     my $header3 = $r->headers;
  79     isa_ok($header3, 'HTTP::Headers');
  80     isnt($header2, $header3, '... created a new HTTP::Header object');
  81
  82     is($header3->content_type, 'text/html', '... got the right content type in the header');
  83
  84     $r->headers( HTTP::Headers->new(content_type => 'application/pdf') );
  85
  86     my $header4 = $r->headers;
  87     isa_ok($header4, 'HTTP::Headers');
  88     isnt($header3, $header4, '... created a new HTTP::Header object');
  89
  90     is($header4->content_type, 'application/pdf', '... got the right content type in the header');
  91
  92     dies_ok {
  93         $r->headers('Foo')
  94     } '... dies when it gets bad params';
  95 }
  96
  97 {
  98     is($r->protocol, undef, '... got nothing by default');
  99
 100     lives_ok {
 101         $r->protocol('HTTP/1.0');
 102     } '... set the protocol correctly';
 103     is($r->protocol, 'HTTP/1.0', '... got nothing by default');
 104
 105     dies_ok {
 106         $r->protocol('http/1.0');
 107     } '... the protocol died with bar params correctly';
 108 }
 109