+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More tests => 57;
-use Test::Exception;
-
-{
- package Point;
- use Moose;
-
- has 'x' => (isa => 'Int', is => 'rw', required => 1);
- has 'y' => (isa => 'Int', is => 'rw', required => 1);
-
- sub clear {
- my $self = shift;
- $self->x(0);
- $self->y(0);
- }
-
- __PACKAGE__->meta->make_immutable( debug => 0 );
-}
-
-{
- package Point3D;
- use Moose;
-
- extends 'Point';
-
- has 'z' => (isa => 'Int', is => 'rw', required => 1);
-
- after 'clear' => sub {
- my $self = shift;
- $self->z(0);
- };
-
- __PACKAGE__->meta->make_immutable( debug => 0 );
-}
-
-my $point = Point->new(x => 1, y => 2);
-isa_ok($point, 'Point');
-isa_ok($point, 'Moose::Object');
-
-is($point->x, 1, '... got the right value for x');
-is($point->y, 2, '... got the right value for y');
-
-$point->y(10);
-is($point->y, 10, '... got the right (changed) value for y');
-
-dies_ok {
- $point->y('Foo');
-} '... cannot assign a non-Int to y';
-
-dies_ok {
- Point->new();
-} '... must provide required attributes to new';
-
-$point->clear();
-
-is($point->x, 0, '... got the right (cleared) value for x');
-is($point->y, 0, '... got the right (cleared) value for y');
-
-# check the type constraints on the constructor
-
-lives_ok {
- Point->new(x => 0, y => 0);
-} '... can assign a 0 to x and y';
-
-dies_ok {
- Point->new(x => 10, y => 'Foo');
-} '... cannot assign a non-Int to y';
-
-dies_ok {
- Point->new(x => 'Foo', y => 10);
-} '... cannot assign a non-Int to x';
-
-# Point3D
-
-my $point3d = Point3D->new({ x => 10, y => 15, z => 3 });
-isa_ok($point3d, 'Point3D');
-isa_ok($point3d, 'Point');
-isa_ok($point3d, 'Moose::Object');
-
-is($point3d->x, 10, '... got the right value for x');
-is($point3d->y, 15, '... got the right value for y');
-is($point3d->{'z'}, 3, '... got the right value for z');
-
-$point3d->clear();
-
-is($point3d->x, 0, '... got the right (cleared) value for x');
-is($point3d->y, 0, '... got the right (cleared) value for y');
-is($point3d->z, 0, '... got the right (cleared) value for z');
-
-dies_ok {
- Point3D->new(x => 10, y => 'Foo', z => 3);
-} '... cannot assign a non-Int to y';
-
-dies_ok {
- Point3D->new(x => 'Foo', y => 10, z => 3);
-} '... cannot assign a non-Int to x';
-
-dies_ok {
- Point3D->new(x => 0, y => 10, z => 'Bar');
-} '... cannot assign a non-Int to z';
-
-dies_ok {
- Point3D->new(x => 10, y => 3);
-} '... z is a required attribute for Point3D';
-
-# test some class introspection
-
-can_ok('Point', 'meta');
-isa_ok(Point->meta, 'Moose::Meta::Class');
-
-can_ok('Point3D', 'meta');
-isa_ok(Point3D->meta, 'Moose::Meta::Class');
-
-isnt(Point->meta, Point3D->meta, '... they are different metaclasses as well');
-
-# poke at Point
-
-is_deeply(
- [ Point->meta->superclasses ],
- [ 'Moose::Object' ],
- '... Point got the automagic base class');
-
-my @Point_methods = qw(meta new x y clear);
-my @Point_attrs = ('x', 'y');
-
-is_deeply(
- [ sort @Point_methods ],
- [ sort Point->meta->get_method_list() ],
- '... we match the method list for Point');
-
-is_deeply(
- [ sort @Point_attrs ],
- [ sort Point->meta->get_attribute_list() ],
- '... we match the attribute list for Point');
-
-foreach my $method (@Point_methods) {
- ok(Point->meta->has_method($method), '... Point has the method "' . $method . '"');
-}
-
-foreach my $attr_name (@Point_attrs ) {
- ok(Point->meta->has_attribute($attr_name), '... Point has the attribute "' . $attr_name . '"');
- my $attr = Point->meta->get_attribute($attr_name);
- ok($attr->has_type_constraint, '... Attribute ' . $attr_name . ' has a type constraint');
- isa_ok($attr->type_constraint, 'Moose::Meta::TypeConstraint');
- is($attr->type_constraint->name, 'Int', '... Attribute ' . $attr_name . ' has an Int type constraint');
-}
-
-# poke at Point3D
-
-is_deeply(
- [ Point3D->meta->superclasses ],
- [ 'Point' ],
- '... Point3D gets the parent given to it');
-
-my @Point3D_methods = qw(new meta z clear);
-my @Point3D_attrs = ('z');
-
-is_deeply(
- [ sort @Point3D_methods ],
- [ sort Point3D->meta->get_method_list() ],
- '... we match the method list for Point3D');
-
-is_deeply(
- [ sort @Point3D_attrs ],
- [ sort Point3D->meta->get_attribute_list() ],
- '... we match the attribute list for Point3D');
-
-foreach my $method (@Point3D_methods) {
- ok(Point3D->meta->has_method($method), '... Point3D has the method "' . $method . '"');
-}
-
-foreach my $attr_name (@Point3D_attrs ) {
- ok(Point3D->meta->has_attribute($attr_name), '... Point3D has the attribute "' . $attr_name . '"');
- my $attr = Point3D->meta->get_attribute($attr_name);
- ok($attr->has_type_constraint, '... Attribute ' . $attr_name . ' has a type constraint');
- isa_ok($attr->type_constraint, 'Moose::Meta::TypeConstraint');
- is($attr->type_constraint->name, 'Int', '... Attribute ' . $attr_name . ' has an Int type constraint');
-}
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More tests => 23;
-use Test::Exception;
-
-{
- package BankAccount;
- use Moose;
-
- has 'balance' => ( isa => 'Num', is => 'rw', default => 0 );
-
- sub deposit {
- my ( $self, $amount ) = @_;
- $self->balance( $self->balance + $amount );
- }
-
- sub withdraw {
- my ( $self, $amount ) = @_;
- my $current_balance = $self->balance();
- ( $current_balance >= $amount )
- || confess "Account overdrawn";
- $self->balance( $current_balance - $amount );
- }
-
- __PACKAGE__->meta->make_immutable( debug => 0 );
-}
-
-{
- package CheckingAccount;
- use Moose;
-
- extends 'BankAccount';
-
- has 'overdraft_account' => ( isa => 'BankAccount', is => 'rw' );
-
- before 'withdraw' => sub {
- my ( $self, $amount ) = @_;
- my $overdraft_amount = $amount - $self->balance();
- if ( $self->overdraft_account && $overdraft_amount > 0 ) {
- $self->overdraft_account->withdraw($overdraft_amount);
- $self->deposit($overdraft_amount);
- }
- };
-
- __PACKAGE__->meta->make_immutable( debug => 0 );
-}
-
-my $savings_account = BankAccount->new(balance => 250);
-isa_ok($savings_account, 'BankAccount');
-
-is($savings_account->balance, 250, '... got the right savings balance');
-lives_ok {
- $savings_account->withdraw(50);
-} '... withdrew from savings successfully';
-is($savings_account->balance, 200, '... got the right savings balance after withdrawl');
-
-$savings_account->deposit(150);
-is($savings_account->balance, 350, '... got the right savings balance after deposit');
-
-{
- my $checking_account = CheckingAccount->new(
- balance => 100,
- overdraft_account => $savings_account
- );
- isa_ok($checking_account, 'CheckingAccount');
- isa_ok($checking_account, 'BankAccount');
-
- is($checking_account->overdraft_account, $savings_account, '... got the right overdraft account');
-
- is($checking_account->balance, 100, '... got the right checkings balance');
-
- lives_ok {
- $checking_account->withdraw(50);
- } '... withdrew from checking successfully';
- is($checking_account->balance, 50, '... got the right checkings balance after withdrawl');
- is($savings_account->balance, 350, '... got the right savings balance after checking withdrawl (no overdraft)');
-
- lives_ok {
- $checking_account->withdraw(200);
- } '... withdrew from checking successfully';
- is($checking_account->balance, 0, '... got the right checkings balance after withdrawl');
- is($savings_account->balance, 200, '... got the right savings balance after overdraft withdrawl');
-}
-
-{
- my $checking_account = CheckingAccount->new(
- balance => 100
- # no overdraft account
- );
- isa_ok($checking_account, 'CheckingAccount');
- isa_ok($checking_account, 'BankAccount');
-
- is($checking_account->overdraft_account, undef, '... no overdraft account');
-
- is($checking_account->balance, 100, '... got the right checkings balance');
-
- lives_ok {
- $checking_account->withdraw(50);
- } '... withdrew from checking successfully';
- is($checking_account->balance, 50, '... got the right checkings balance after withdrawl');
-
- dies_ok {
- $checking_account->withdraw(200);
- } '... withdrawl failed due to attempted overdraft';
- is($checking_account->balance, 50, '... got the right checkings balance after withdrawl failure');
-}
-
-
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More tests => 41;
-use Test::Exception;
-
-use Scalar::Util 'isweak';
-
-{
- package BinaryTree;
- use Moose;
-
- has 'node' => ( is => 'rw', isa => 'Any' );
-
- has 'parent' => (
- is => 'rw',
- isa => 'BinaryTree',
- predicate => 'has_parent',
- weak_ref => 1,
- );
-
- has 'left' => (
- is => 'rw',
- isa => 'BinaryTree',
- predicate => 'has_left',
- lazy => 1,
- default => sub { BinaryTree->new( parent => $_[0] ) },
- trigger => \&_set_parent_for_child
- );
-
- has 'right' => (
- is => 'rw',
- isa => 'BinaryTree',
- predicate => 'has_right',
- lazy => 1,
- default => sub { BinaryTree->new( parent => $_[0] ) },
- trigger => \&_set_parent_for_child
- );
-
- sub _set_parent_for_child {
- my ( $self, $child ) = @_;
-
- confess "You cannot insert a tree which already has a parent"
- if $child->has_parent;
-
- $child->parent($self);
- }
-}
-
-my $root = BinaryTree->new(node => 'root');
-isa_ok($root, 'BinaryTree');
-
-is($root->node, 'root', '... got the right node value');
-
-ok(!$root->has_left, '... no left node yet');
-ok(!$root->has_right, '... no right node yet');
-
-ok(!$root->has_parent, '... no parent for root node');
-
-# make a left node
-
-my $left = $root->left;
-isa_ok($left, 'BinaryTree');
-
-is($root->left, $left, '... got the same node (and it is $left)');
-ok($root->has_left, '... we have a left node now');
-
-ok($left->has_parent, '... lefts has a parent');
-is($left->parent, $root, '... lefts parent is the root');
-
-ok(isweak($left->{parent}), '... parent is a weakened ref');
-
-ok(!$left->has_left, '... $left no left node yet');
-ok(!$left->has_right, '... $left no right node yet');
-
-is($left->node, undef, '... left has got no node value');
-
-lives_ok {
- $left->node('left')
-} '... assign to lefts node';
-
-is($left->node, 'left', '... left now has a node value');
-
-# make a right node
-
-ok(!$root->has_right, '... still no right node yet');
-
-is($root->right->node, undef, '... right has got no node value');
-
-ok($root->has_right, '... now we have a right node');
-
-my $right = $root->right;
-isa_ok($right, 'BinaryTree');
-
-lives_ok {
- $right->node('right')
-} '... assign to rights node';
-
-is($right->node, 'right', '... left now has a node value');
-
-is($root->right, $right, '... got the same node (and it is $right)');
-ok($root->has_right, '... we have a right node now');
-
-ok($right->has_parent, '... rights has a parent');
-is($right->parent, $root, '... rights parent is the root');
-
-ok(isweak($right->{parent}), '... parent is a weakened ref');
-
-# make a left node of the left node
-
-my $left_left = $left->left;
-isa_ok($left_left, 'BinaryTree');
-
-ok($left_left->has_parent, '... left does have a parent');
-
-is($left_left->parent, $left, '... got a parent node (and it is $left)');
-ok($left->has_left, '... we have a left node now');
-is($left->left, $left_left, '... got a left node (and it is $left_left)');
-
-ok(isweak($left_left->{parent}), '... parent is a weakened ref');
-
-# make a right node of the left node
-
-my $left_right = BinaryTree->new;
-isa_ok($left_right, 'BinaryTree');
-
-lives_ok {
- $left->right($left_right)
-} '... assign to rights node';
-
-ok($left_right->has_parent, '... left does have a parent');
-
-is($left_right->parent, $left, '... got a parent node (and it is $left)');
-ok($left->has_right, '... we have a left node now');
-is($left->right, $left_right, '... got a left node (and it is $left_left)');
-
-ok(isweak($left_right->{parent}), '... parent is a weakened ref');
-
-# and check the error
-
-dies_ok {
- $left_right->right($left_left)
-} '... cant assign a node which already has a parent';
-
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More;
-
-BEGIN {
- eval "use Regexp::Common; use Locale::US;";
- plan skip_all => "Regexp::Common & Locale::US required for this test" if $@;
- plan tests => 65;
-}
-
-use Test::Exception;
-use Scalar::Util 'isweak';
-
-
-
-{
- package Address;
- use Moose;
- use Moose::Util::TypeConstraints;
-
- use Locale::US;
- use Regexp::Common 'zip';
-
- my $STATES = Locale::US->new;
-
- subtype USState
- => as Str
- => where {
- (exists $STATES->{code2state}{uc($_)} || exists $STATES->{state2code}{uc($_)})
- };
-
- subtype USZipCode
- => as Value
- => where {
- /^$RE{zip}{US}{-extended => 'allow'}$/
- };
-
- has 'street' => (is => 'rw', isa => 'Str');
- has 'city' => (is => 'rw', isa => 'Str');
- has 'state' => (is => 'rw', isa => 'USState');
- has 'zip_code' => (is => 'rw', isa => 'USZipCode');
-
- __PACKAGE__->meta->make_immutable(debug => 0);
-}{
-
- package Company;
- use Moose;
- use Moose::Util::TypeConstraints;
-
- has 'name' => (is => 'rw', isa => 'Str', required => 1);
- has 'address' => (is => 'rw', isa => 'Address');
- has 'employees' => (is => 'rw', isa => 'ArrayRef[Employee]');
-
- sub BUILD {
- my ($self, $params) = @_;
- if ($params->{employees}) {
- foreach my $employee (@{$params->{employees}}) {
- $employee->company($self);
- }
- }
- }
-
- sub get_employee_count { scalar @{(shift)->employees} }
-
- after 'employees' => sub {
- my ($self, $employees) = @_;
- # if employees is defined, it
- # has already been type checked
- if (defined $employees) {
- # make sure each gets the
- # weak ref to the company
- foreach my $employee (@{$employees}) {
- $employee->company($self);
- }
- }
- };
-
- __PACKAGE__->meta->make_immutable(debug => 0);
-}{
-
- package Person;
- use Moose;
-
- has 'first_name' => (is => 'rw', isa => 'Str', required => 1);
- has 'last_name' => (is => 'rw', isa => 'Str', required => 1);
- has 'middle_initial' => (is => 'rw', isa => 'Str', predicate => 'has_middle_initial');
- has 'address' => (is => 'rw', isa => 'Address');
-
- sub full_name {
- my $self = shift;
- return $self->first_name .
- ($self->has_middle_initial ? ' ' . $self->middle_initial . '. ' : ' ') .
- $self->last_name;
- }
-
- __PACKAGE__->meta->make_immutable(debug => 0);
-}{
-
- package Employee;
- use Moose;
-
- extends 'Person';
-
- has 'title' => (is => 'rw', isa => 'Str', required => 1);
- has 'company' => (is => 'rw', isa => 'Company', weak_ref => 1);
-
- override 'full_name' => sub {
- my $self = shift;
- super() . ', ' . $self->title
- };
-
- __PACKAGE__->meta->make_immutable(debug => 0);
-}
-
-my $ii;
-lives_ok {
- $ii = Company->new({
- name => 'Infinity Interactive',
- address => Address->new(
- street => '565 Plandome Rd., Suite 307',
- city => 'Manhasset',
- state => 'NY',
- zip_code => '11030'
- ),
- employees => [
- Employee->new(
- first_name => 'Jeremy',
- last_name => 'Shao',
- title => 'President / Senior Consultant',
- address => Address->new(city => 'Manhasset', state => 'NY')
- ),
- Employee->new(
- first_name => 'Tommy',
- last_name => 'Lee',
- title => 'Vice President / Senior Developer',
- address => Address->new(city => 'New York', state => 'NY')
- ),
- Employee->new(
- first_name => 'Stevan',
- middle_initial => 'C',
- last_name => 'Little',
- title => 'Senior Developer',
- address => Address->new(city => 'Madison', state => 'CT')
- ),
- ]
- });
-} '... created the entire company successfully';
-isa_ok($ii, 'Company');
-
-is($ii->name, 'Infinity Interactive', '... got the right name for the company');
-
-isa_ok($ii->address, 'Address');
-is($ii->address->street, '565 Plandome Rd., Suite 307', '... got the right street address');
-is($ii->address->city, 'Manhasset', '... got the right city');
-is($ii->address->state, 'NY', '... got the right state');
-is($ii->address->zip_code, 11030, '... got the zip code');
-
-is($ii->get_employee_count, 3, '... got the right employee count');
-
-# employee #1
-
-isa_ok($ii->employees->[0], 'Employee');
-isa_ok($ii->employees->[0], 'Person');
-
-is($ii->employees->[0]->first_name, 'Jeremy', '... got the right first name');
-is($ii->employees->[0]->last_name, 'Shao', '... got the right last name');
-ok(!$ii->employees->[0]->has_middle_initial, '... no middle initial');
-is($ii->employees->[0]->middle_initial, undef, '... got the right middle initial value');
-is($ii->employees->[0]->full_name, 'Jeremy Shao, President / Senior Consultant', '... got the right full name');
-is($ii->employees->[0]->title, 'President / Senior Consultant', '... got the right title');
-is($ii->employees->[0]->company, $ii, '... got the right company');
-ok(isweak($ii->employees->[0]->{company}), '... the company is a weak-ref');
-
-isa_ok($ii->employees->[0]->address, 'Address');
-is($ii->employees->[0]->address->city, 'Manhasset', '... got the right city');
-is($ii->employees->[0]->address->state, 'NY', '... got the right state');
-
-# employee #2
-
-isa_ok($ii->employees->[1], 'Employee');
-isa_ok($ii->employees->[1], 'Person');
-
-is($ii->employees->[1]->first_name, 'Tommy', '... got the right first name');
-is($ii->employees->[1]->last_name, 'Lee', '... got the right last name');
-ok(!$ii->employees->[1]->has_middle_initial, '... no middle initial');
-is($ii->employees->[1]->middle_initial, undef, '... got the right middle initial value');
-is($ii->employees->[1]->full_name, 'Tommy Lee, Vice President / Senior Developer', '... got the right full name');
-is($ii->employees->[1]->title, 'Vice President / Senior Developer', '... got the right title');
-is($ii->employees->[1]->company, $ii, '... got the right company');
-ok(isweak($ii->employees->[1]->{company}), '... the company is a weak-ref');
-
-isa_ok($ii->employees->[1]->address, 'Address');
-is($ii->employees->[1]->address->city, 'New York', '... got the right city');
-is($ii->employees->[1]->address->state, 'NY', '... got the right state');
-
-# employee #3
-
-isa_ok($ii->employees->[2], 'Employee');
-isa_ok($ii->employees->[2], 'Person');
-
-is($ii->employees->[2]->first_name, 'Stevan', '... got the right first name');
-is($ii->employees->[2]->last_name, 'Little', '... got the right last name');
-ok($ii->employees->[2]->has_middle_initial, '... got middle initial');
-is($ii->employees->[2]->middle_initial, 'C', '... got the right middle initial value');
-is($ii->employees->[2]->full_name, 'Stevan C. Little, Senior Developer', '... got the right full name');
-is($ii->employees->[2]->title, 'Senior Developer', '... got the right title');
-is($ii->employees->[2]->company, $ii, '... got the right company');
-ok(isweak($ii->employees->[2]->{company}), '... the company is a weak-ref');
-
-isa_ok($ii->employees->[2]->address, 'Address');
-is($ii->employees->[2]->address->city, 'Madison', '... got the right city');
-is($ii->employees->[2]->address->state, 'CT', '... got the right state');
-
-# create new company
-
-my $new_company = Company->new(name => 'Infinity Interactive International');
-isa_ok($new_company, 'Company');
-
-my $ii_employees = $ii->employees;
-foreach my $employee (@$ii_employees) {
- is($employee->company, $ii, '... has the ii company');
-}
-
-$new_company->employees($ii_employees);
-
-foreach my $employee (@{$new_company->employees}) {
- is($employee->company, $new_company, '... has the different company now');
-}
-
-## check some error conditions for the subtypes
-
-dies_ok {
- Address->new(street => {}),
-} '... we die correctly with bad args';
-
-dies_ok {
- Address->new(city => {}),
-} '... we die correctly with bad args';
-
-dies_ok {
- Address->new(state => 'British Columbia'),
-} '... we die correctly with bad args';
-
-lives_ok {
- Address->new(state => 'Connecticut'),
-} '... we live correctly with good args';
-
-dies_ok {
- Address->new(zip_code => 'AF5J6$'),
-} '... we die correctly with bad args';
-
-lives_ok {
- Address->new(zip_code => '06443'),
-} '... we live correctly with good args';
-
-dies_ok {
- Company->new(),
-} '... we die correctly without good args';
-
-lives_ok {
- Company->new(name => 'Foo'),
-} '... we live correctly without good args';
-
-dies_ok {
- Company->new(name => 'Foo', employees => [ Person->new ]),
-} '... we die correctly with good args';
-
-lives_ok {
- Company->new(name => 'Foo', employees => []),
-} '... we live correctly with good args';
-
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More;
-
-BEGIN {
- eval "use HTTP::Headers; use Params::Coerce; use URI;";
- plan skip_all => "HTTP::Headers & Params::Coerce & URI required for this test" if $@;
- plan tests => 17;
-}
-
-use Test::Exception;
-
-{
- package Request;
- use Moose;
- use Moose::Util::TypeConstraints;
-
- use HTTP::Headers ();
- use Params::Coerce ();
- use URI ();
-
- subtype 'My.HTTP::Headers' => as class_type('HTTP::Headers');
-
- coerce 'My.HTTP::Headers'
- => from 'ArrayRef'
- => via { HTTP::Headers->new( @{$_} ) }
- => from 'HashRef'
- => via { HTTP::Headers->new( %{$_} ) };
-
- subtype 'My.URI' => as class_type('HTTP::Headers');
-
- coerce 'My.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.URI', coerce => 1 );
- has 'uri' => ( is => 'rw', isa => 'My.URI', coerce => 1 );
- has 'method' => ( is => 'rw', isa => 'Str' );
- has 'protocol' => ( is => 'rw', isa => 'Protocol' );
- has 'headers' => (
- is => 'rw',
- isa => 'My.HTTP::Headers',
- coerce => 1,
- default => sub { HTTP::Headers->new }
- );
-}
-
-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';
-}
-
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More tests => 2;
-use Test::Exception;
-
-
-
-## Augment/Inner
-
-{
- package Document::Page;
- use Moose;
-
- has 'body' => (is => 'rw', isa => 'Str', default => sub {''});
-
- sub create {
- my $self = shift;
- $self->open_page;
- inner();
- $self->close_page;
- }
-
- sub append_body {
- my ($self, $appendage) = @_;
- $self->body($self->body . $appendage);
- }
-
- sub open_page { (shift)->append_body('<page>') }
- sub close_page { (shift)->append_body('</page>') }
-
- package Document::PageWithHeadersAndFooters;
- use Moose;
-
- extends 'Document::Page';
-
- augment 'create' => sub {
- my $self = shift;
- $self->create_header;
- inner();
- $self->create_footer;
- };
-
- sub create_header { (shift)->append_body('<header/>') }
- sub create_footer { (shift)->append_body('<footer/>') }
-
- package TPSReport;
- use Moose;
-
- extends 'Document::PageWithHeadersAndFooters';
-
- augment 'create' => sub {
- my $self = shift;
- $self->create_tps_report;
- inner();
- };
-
- sub create_tps_report {
- (shift)->append_body('<report type="tps"/>')
- }
-}
-
-my $tps_report = TPSReport->new;
-isa_ok($tps_report, 'TPSReport');
-
-is(
-$tps_report->create,
-q{<page><header/><report type="tps"/><footer/></page>},
-'... got the right TPS report');
-
-
-
-
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More;
-use Test::Exception;
-
-BEGIN {
- unless ( eval 'use Test::Warn 0.11; 1' ) {
- plan skip_all => 'These tests require Test::Warn 0.11+';
- }
- else {
- plan tests => 4;
- }
-}
-
-{
- package MyApp::Base;
- use Moose;
-
- extends 'Moose::Object';
-
- before 'new' => sub { warn "Making a new " . $_[0] };
-
- no Moose;
-}
-
-{
- package MyApp::UseMyBase;
- use Moose ();
- use Moose::Exporter;
-
- Moose::Exporter->setup_import_methods( also => 'Moose' );
-
- sub init_meta {
- shift;
- Moose->init_meta( @_, base_class => 'MyApp::Base' );
- }
-}
-
-{
- package Foo;
-
- MyApp::UseMyBase->import;
-
- has( 'size' => ( is => 'rw' ) );
-}
-
-ok( Foo->isa('MyApp::Base'),
- 'Foo isa MyApp::Base' );
-
-ok( Foo->can('size'),
- 'Foo has a size method' );
-
-my $foo;
-warning_is( sub { $foo = Foo->new( size => 2 ) },
- 'Making a new Foo',
- 'got expected warning when calling Foo->new' );
-
-is( $foo->size(), 2, '$foo->size is 2' );
-
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More tests => 3;
-
-
-{
- package MyApp::Meta::Class;
- use Moose;
-
- extends 'Moose::Meta::Class';
-
- has 'table' => ( is => 'rw' );
-
- no Moose;
-
- package MyApp::Mooseish;
-
- use strict;
- use warnings;
-
- use Moose ();
- use Moose::Exporter;
-
- Moose::Exporter->setup_import_methods(
- with_caller => ['has_table'],
- also => 'Moose',
- );
-
- sub init_meta {
- shift;
- Moose->init_meta( @_, metaclass => 'MyApp::Meta::Class' );
- }
-
- sub has_table {
- my $caller = shift;
- $caller->meta()->table(shift);
- }
-}
-
-{
- package MyApp::User;
-
- MyApp::Mooseish->import;
-
- has_table( 'User' );
-
- has( 'username' => ( is => 'ro' ) );
- has( 'password' => ( is => 'ro' ) );
-
- sub login { }
-}
-
-isa_ok( MyApp::User->meta, 'MyApp::Meta::Class' );
-is( MyApp::User->meta->table, 'User',
- 'MyApp::User->meta->table returns User' );
-ok( MyApp::User->can('username'),
- 'MyApp::User has username method' );
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More tests => 1;
-use Test::Exception;
-
-
-
-## meta-attribute example
-{
-
- package MyApp::Meta::Attribute::Labeled;
- use Moose;
- extends 'Moose::Meta::Attribute';
-
- has label => (
- is => 'rw',
- isa => 'Str',
- predicate => 'has_label',
- );
-
- package Moose::Meta::Attribute::Custom::Labeled;
- sub register_implementation { 'MyApp::Meta::Attribute::Labeled' }
-
- package MyApp::Website;
- use Moose;
-
- has url => (
- metaclass => 'Labeled',
- isa => 'Str',
- is => 'rw',
- label => "The site's URL",
- );
-
- has name => (
- is => 'rw',
- isa => 'Str',
- );
-
- sub dump {
- my $self = shift;
-
- my $dump_value = '';
-
- # iterate over all the attributes in $self
- my %attributes = %{ $self->meta->get_attribute_map };
- foreach my $name (sort keys %attributes) {
-
- my $attribute = $attributes{$name};
-
- # print the label if available
- if ($attribute->isa('MyApp::Meta::Attribute::Labeled')
- && $attribute->has_label) {
- $dump_value .= $attribute->label;
- }
- # otherwise print the name
- else {
- $dump_value .= $name;
- }
-
- # print the attribute's value
- my $reader = $attribute->get_read_method;
- $dump_value .= ": " . $self->$reader . "\n";
- }
-
- return $dump_value;
- }
-
-}
-
-my $app = MyApp::Website->new(url => "http://google.com", name => "Google");
-is($app->dump, q{name: Google
-The site's URL: http://google.com
-}, '... got the expected dump value');
-
-
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More tests => 2;
-use Test::Exception;
-
-
-
-## attribute trait example
-{
-
- package MyApp::Meta::Attribute::Trait::Labeled;
- use Moose::Role;
-
- has label => (
- is => 'rw',
- isa => 'Str',
- predicate => 'has_label',
- );
-
- package Moose::Meta::Attribute::Custom::Trait::Labeled;
- sub register_implementation { 'MyApp::Meta::Attribute::Trait::Labeled' }
-
- package MyApp::Website;
- use Moose;
-
- has url => (
- traits => [qw/Labeled/],
- isa => 'Str',
- is => 'rw',
- label => "The site's URL",
- );
-
- has name => (
- is => 'rw',
- isa => 'Str',
- );
-
- sub dump {
- my $self = shift;
-
- my $dump_value = '';
-
- # iterate over all the attributes in $self
- my %attributes = %{ $self->meta->get_attribute_map };
- foreach my $name (sort keys %attributes) {
-
- my $attribute = $attributes{$name};
-
- # print the label if available
- if ($attribute->does('MyApp::Meta::Attribute::Trait::Labeled')
- && $attribute->has_label) {
- $dump_value .= $attribute->label;
- }
- # otherwise print the name
- else {
- $dump_value .= $name;
- }
-
- # print the attribute's value
- my $reader = $attribute->get_read_method;
- $dump_value .= ": " . $self->$reader . "\n";
- }
-
- return $dump_value;
- }
-
-}
-
-my $app = MyApp::Website->new(url => "http://google.com", name => "Google");
-is($app->dump, q{name: Google
-The site's URL: http://google.com
-}, '... got the expected dump value');
-
-# using the trait directly in a regular metaclass
-{
- package MyApp::Meta::Attribute::Labeled;
- use Moose;
- extends 'Moose::Meta::Attribute';
- with 'MyApp::Meta::Attribute::Trait::Labeled';
-
- package Moose::Meta::Attribute::Custom::Labeled;
- sub register_implementation { 'MyApp::Meta::Attribute::Labeled' }
-
- package MyApp::Website2;
- use Moose;
-
- has url => (
- metaclass => 'Labeled',
- isa => 'Str',
- is => 'rw',
- label => "The site's URL",
- );
-
- has name => (
- is => 'rw',
- isa => 'Str',
- );
-
- sub dump {
- my $self = shift;
-
- my $dump_value = '';
-
- # iterate over all the attributes in $self
- my %attributes = %{ $self->meta->get_attribute_map };
- foreach my $name (sort keys %attributes) {
-
- my $attribute = $attributes{$name};
-
- # print the label if available
- if ($attribute->isa('MyApp::Meta::Attribute::Labeled')
- && $attribute->has_label) {
- $dump_value .= $attribute->label;
- }
- # otherwise print the name
- else {
- $dump_value .= $name;
- }
-
- # print the attribute's value
- my $reader = $attribute->get_read_method;
- $dump_value .= ": " . $self->$reader . "\n";
- }
-
- return $dump_value;
- }
-
-}
-
-my $app2 = MyApp::Website2->new(url => "http://google.com", name => "Google");
-is($app2->dump, q{name: Google
-The site's URL: http://google.com
-}, '... got the expected dump value');
-
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More tests => 63;
-use Test::Exception;
-
-
-
-## Roles
-
-{
- package Eq;
- use Moose::Role;
-
- requires 'equal_to';
-
- sub not_equal_to {
- my ($self, $other) = @_;
- not $self->equal_to($other);
- }
-
- package Comparable;
- use Moose::Role;
-
- with 'Eq';
-
- requires 'compare';
-
- sub equal_to {
- my ($self, $other) = @_;
- $self->compare($other) == 0;
- }
-
- sub greater_than {
- my ($self, $other) = @_;
- $self->compare($other) == 1;
- }
-
- sub less_than {
- my ($self, $other) = @_;
- $self->compare($other) == -1;
- }
-
- sub greater_than_or_equal_to {
- my ($self, $other) = @_;
- $self->greater_than($other) || $self->equal_to($other);
- }
-
- sub less_than_or_equal_to {
- my ($self, $other) = @_;
- $self->less_than($other) || $self->equal_to($other);
- }
-
- package Printable;
- use Moose::Role;
-
- requires 'to_string';
-}
-
-## Classes
-
-{
- package US::Currency;
- use Moose;
-
- with 'Comparable', 'Printable';
-
- has 'amount' => (is => 'rw', isa => 'Num', default => 0);
-
- sub compare {
- my ($self, $other) = @_;
- $self->amount <=> $other->amount;
- }
-
- sub to_string {
- my $self = shift;
- sprintf '$%0.2f USD' => $self->amount
- }
-
- __PACKAGE__->meta->make_immutable(debug => 0);
-}
-
-ok(US::Currency->does('Comparable'), '... US::Currency does Comparable');
-ok(US::Currency->does('Eq'), '... US::Currency does Eq');
-ok(US::Currency->does('Printable'), '... US::Currency does Printable');
-
-my $hundred = US::Currency->new(amount => 100.00);
-isa_ok($hundred, 'US::Currency');
-
-ok( $hundred->DOES("US::Currency"), "UNIVERSAL::DOES for class" );
-ok( $hundred->DOES("Comparable"), "UNIVERSAL::DOES for role" );
-
-can_ok($hundred, 'amount');
-is($hundred->amount, 100, '... got the right amount');
-
-can_ok($hundred, 'to_string');
-is($hundred->to_string, '$100.00 USD', '... got the right stringified value');
-
-ok($hundred->does('Comparable'), '... US::Currency does Comparable');
-ok($hundred->does('Eq'), '... US::Currency does Eq');
-ok($hundred->does('Printable'), '... US::Currency does Printable');
-
-my $fifty = US::Currency->new(amount => 50.00);
-isa_ok($fifty, 'US::Currency');
-
-can_ok($fifty, 'amount');
-is($fifty->amount, 50, '... got the right amount');
-
-can_ok($fifty, 'to_string');
-is($fifty->to_string, '$50.00 USD', '... got the right stringified value');
-
-ok($hundred->greater_than($fifty), '... 100 gt 50');
-ok($hundred->greater_than_or_equal_to($fifty), '... 100 ge 50');
-ok(!$hundred->less_than($fifty), '... !100 lt 50');
-ok(!$hundred->less_than_or_equal_to($fifty), '... !100 le 50');
-ok(!$hundred->equal_to($fifty), '... !100 eq 50');
-ok($hundred->not_equal_to($fifty), '... 100 ne 50');
-
-ok(!$fifty->greater_than($hundred), '... !50 gt 100');
-ok(!$fifty->greater_than_or_equal_to($hundred), '... !50 ge 100');
-ok($fifty->less_than($hundred), '... 50 lt 100');
-ok($fifty->less_than_or_equal_to($hundred), '... 50 le 100');
-ok(!$fifty->equal_to($hundred), '... !50 eq 100');
-ok($fifty->not_equal_to($hundred), '... 50 ne 100');
-
-ok(!$fifty->greater_than($fifty), '... !50 gt 50');
-ok($fifty->greater_than_or_equal_to($fifty), '... !50 ge 50');
-ok(!$fifty->less_than($fifty), '... 50 lt 50');
-ok($fifty->less_than_or_equal_to($fifty), '... 50 le 50');
-ok($fifty->equal_to($fifty), '... 50 eq 50');
-ok(!$fifty->not_equal_to($fifty), '... !50 ne 50');
-
-## ... check some meta-stuff
-
-# Eq
-
-my $eq_meta = Eq->meta;
-isa_ok($eq_meta, 'Moose::Meta::Role');
-
-ok($eq_meta->has_method('not_equal_to'), '... Eq has_method not_equal_to');
-ok($eq_meta->requires_method('equal_to'), '... Eq requires_method not_equal_to');
-
-# Comparable
-
-my $comparable_meta = Comparable->meta;
-isa_ok($comparable_meta, 'Moose::Meta::Role');
-
-ok($comparable_meta->does_role('Eq'), '... Comparable does Eq');
-
-foreach my $method_name (qw(
- equal_to not_equal_to
- greater_than greater_than_or_equal_to
- less_than less_than_or_equal_to
- )) {
- ok($comparable_meta->has_method($method_name), '... Comparable has_method ' . $method_name);
-}
-
-ok($comparable_meta->requires_method('compare'), '... Comparable requires_method compare');
-
-# Printable
-
-my $printable_meta = Printable->meta;
-isa_ok($printable_meta, 'Moose::Meta::Role');
-
-ok($printable_meta->requires_method('to_string'), '... Printable requires_method to_string');
-
-# US::Currency
-
-my $currency_meta = US::Currency->meta;
-isa_ok($currency_meta, 'Moose::Meta::Class');
-
-ok($currency_meta->does_role('Comparable'), '... US::Currency does Comparable');
-ok($currency_meta->does_role('Eq'), '... US::Currency does Eq');
-ok($currency_meta->does_role('Printable'), '... US::Currency does Printable');
-
-foreach my $method_name (qw(
- amount
- equal_to not_equal_to
- compare
- greater_than greater_than_or_equal_to
- less_than less_than_or_equal_to
- to_string
- )) {
- ok($currency_meta->has_method($method_name), '... US::Currency has_method ' . $method_name);
-}
-
+++ /dev/null
-use strict;
-use warnings;
-use Test::More tests => 5;
-use Class::MOP;
-
-# This is copied directly from recipe 11
-{
- package Restartable;
- use Moose::Role;
-
- has 'is_paused' => (
- is => 'rw',
- isa => 'Bool',
- default => 0,
- );
-
- requires 'save_state', 'load_state';
-
- sub stop { }
-
- sub start { }
-
- package Restartable::ButUnreliable;
- use Moose::Role;
-
- with 'Restartable' => {
- alias => {
- stop => '_stop',
- start => '_start'
- }
- };
-
- sub stop {
- my $self = shift;
-
- $self->explode() if rand(1) > .5;
-
- $self->_stop();
- }
-
- sub start {
- my $self = shift;
-
- $self->explode() if rand(1) > .5;
-
- $self->_start();
- }
-
- package Restartable::ButBroken;
- use Moose::Role;
-
- with 'Restartable' => { excludes => [ 'stop', 'start' ] };
-
- sub stop {
- my $self = shift;
-
- $self->explode();
- }
-
- sub start {
- my $self = shift;
-
- $self->explode();
- }
-}
-
-# This is the actual tests
-{
- my $unreliable = Moose::Meta::Class->create_anon_class(
- superclasses => [],
- roles => [qw/Restartable::ButUnreliable/],
- methods => {
- explode => sub { }, # nop.
- 'save_state' => sub { },
- 'load_state' => sub { },
- },
- )->new_object();
- ok $unreliable, 'made anon class with Restartable::ButUnreliable role';
- can_ok $unreliable, qw/start stop/;
-}
-
-{
- my $cnt = 0;
- my $broken = Moose::Meta::Class->create_anon_class(
- superclasses => [],
- roles => [qw/Restartable::ButBroken/],
- methods => {
- explode => sub { $cnt++ },
- 'save_state' => sub { },
- 'load_state' => sub { },
- },
- )->new_object();
- ok $broken, 'made anon class with Restartable::ButBroken role';
- $broken->start();
- is $cnt, 1, '... start called explode';
- $broken->stop();
- is $cnt, 2, '... stop also called explode';
-}
+++ /dev/null
-use strict;
-use warnings;
-
-use Test::More tests => 2;
-
-
-{
- # Not in the recipe, but needed for writing tests.
- package Employee;
-
- use Moose;
-
- has 'name' => (
- is => 'ro',
- isa => 'Str',
- required => 1,
- );
-
- has 'work' => (
- is => 'rw',
- isa => 'Str',
- predicate => 'has_work',
- );
-}
-
-{
- package MyApp::Role::Job::Manager;
-
- use List::Util qw( first );
-
- use Moose::Role;
-
- has 'employees' => (
- is => 'rw',
- isa => 'ArrayRef[Employee]',
- );
-
- sub assign_work {
- my $self = shift;
- my $work = shift;
-
- my $employee = first { !$_->has_work } @{ $self->employees };
-
- die 'All my employees have work to do!' unless $employee;
-
- $employee->work($work);
- }
-}
-
-{
- my $lisa = Employee->new( name => 'Lisa' );
- MyApp::Role::Job::Manager->meta->apply($lisa);
-
- ok( $lisa->does('MyApp::Role::Job::Manager'),
- 'lisa now does the manager role' );
-
- my $homer = Employee->new( name => 'Homer' );
- my $bart = Employee->new( name => 'Bart' );
- my $marge = Employee->new( name => 'Marge' );
-
- $lisa->employees( [ $homer, $bart, $marge ] );
- $lisa->assign_work('mow the lawn');
-
- is( $homer->work, 'mow the lawn',
- 'homer was assigned a task by lisa' );
-}
projects / gitmo/Moose.git / commitdiff