X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2F000_recipes%2Fmoose_cookbook_basics_recipe5.t;fp=t%2F000_recipes%2Fmoose_cookbook_basics_recipe5.t;h=8364a3823f15f805e5c034ee6ddff145e224f706;hb=deb956b335075f0bd0c41be54c01e5ac309592f1;hp=0000000000000000000000000000000000000000;hpb=a55f82bae0f11abaab7932c4deee4f924dec647a;p=gitmo%2FMouse.git

diff --git a/t/000_recipes/moose_cookbook_basics_recipe5.t b/t/000_recipes/moose_cookbook_basics_recipe5.t
new file mode 100644
index 0000000..8364a38
--- /dev/null
+++ b/t/000_recipes/moose_cookbook_basics_recipe5.t
@@ -0,0 +1,141 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More 'no_plan';
+use Test::Exception;
+$| = 1;
+
+
+
+# =begin testing SETUP
+BEGIN {
+    eval 'use HTTP::Headers; use Params::Coerce; use URI;';
+    if ($@) {
+        diag 'HTTP::Headers, Params::Coerce & URI required for this test';
+        ok(1);
+        exit 0;
+    }
+}
+
+
+
+# =begin testing SETUP
+{
+
+  package Request;
+  use Mouse;
+  use Mouse::Util::TypeConstraints;
+
+  use HTTP::Headers  ();
+  use Params::Coerce ();
+  use URI            ();
+
+  subtype 'My::Types::HTTP::Headers' => as class_type('HTTP::Headers');
+
+  coerce 'My::Types::HTTP::Headers'
+      => from 'ArrayRef'
+          => via { HTTP::Headers->new( @{$_} ) }
+      => from 'HashRef'
+          => via { HTTP::Headers->new( %{$_} ) };
+
+  subtype 'My::Types::URI' => as class_type('URI');
+
+  coerce 'My::Types::URI'
+      => from 'Object'
+          => via { $_->isa('URI')
+                   ? $_
+                   : Params::Coerce::coerce( 'URI', $_ ); }
+      => from 'Str'
+          => via { URI->new( $_, 'http' ) };
+
+  subtype 'Protocol'
+      => as 'Str'
+      => where { /^HTTP\/[0-9]\.[0-9]$/ };
+
+  has 'base' => ( is => 'rw', isa => 'My::Types::URI', coerce => 1 );
+  has 'uri'  => ( is => 'rw', isa => 'My::Types::URI', coerce => 1 );
+  has 'method'   => ( is => 'rw', isa => 'Str' );
+  has 'protocol' => ( is => 'rw', isa => 'Protocol' );
+  has 'headers'  => (
+      is      => 'rw',
+      isa     => 'My::Types::HTTP::Headers',
+      coerce  => 1,
+      default => sub { HTTP::Headers->new }
+  );
+}
+
+
+
+# =begin testing
+{
+my $r = Request->new;
+isa_ok( $r, 'Request' );
+
+{
+    my $header = $r->headers;
+    isa_ok( $header, 'HTTP::Headers' );
+
+    is( $r->headers->content_type, '',
+        '... got no content type in the header' );
+
+    $r->headers( { content_type => 'text/plain' } );
+
+    my $header2 = $r->headers;
+    isa_ok( $header2, 'HTTP::Headers' );
+    isnt( $header, $header2, '... created a new HTTP::Header object' );
+
+    is( $header2->content_type, 'text/plain',
+        '... got the right content type in the header' );
+
+    $r->headers( [ content_type => 'text/html' ] );
+
+    my $header3 = $r->headers;
+    isa_ok( $header3, 'HTTP::Headers' );
+    isnt( $header2, $header3, '... created a new HTTP::Header object' );
+
+    is( $header3->content_type, 'text/html',
+        '... got the right content type in the header' );
+
+    $r->headers( HTTP::Headers->new( content_type => 'application/pdf' ) );
+
+    my $header4 = $r->headers;
+    isa_ok( $header4, 'HTTP::Headers' );
+    isnt( $header3, $header4, '... created a new HTTP::Header object' );
+
+    is( $header4->content_type, 'application/pdf',
+        '... got the right content type in the header' );
+
+    dies_ok {
+        $r->headers('Foo');
+    }
+    '... dies when it gets bad params';
+}
+
+{
+    is( $r->protocol, undef, '... got nothing by default' );
+
+    lives_ok {
+        $r->protocol('HTTP/1.0');
+    }
+    '... set the protocol correctly';
+    is( $r->protocol, 'HTTP/1.0', '... got nothing by default' );
+
+    dies_ok {
+        $r->protocol('http/1.0');
+    }
+    '... the protocol died with bar params correctly';
+}
+
+{
+    $r->base('http://localhost/');
+    isa_ok( $r->base, 'URI' );
+
+    $r->uri('http://localhost/');
+    isa_ok( $r->uri, 'URI' );
+}
+}
+
+
+
+
+1;