t/000_recipes/moose_cookbook_basics_recipe5.t

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