File Coverage

blib/lib/Poker/Dealer.pm
Criterion Covered Total %
statement 13 15 86.6
branch n/a
condition n/a
subroutine 5 5 100.0
pod n/a
total 18 20 90.0


line stmt bran cond sub pod time code
1             package Poker::Dealer;
2 1     1   1927 use strict;
  1         2  
  1         30  
3 1     1   5 use warnings FATAL => 'all';
  1         1  
  1         32  
4 1     1   5 use Moo;
  1         1  
  1         5  
5 1     1   268 use List::Util qw(shuffle);
  1         2  
  1         98  
6 1     1   36 use Poker::Deck;
  0            
  0            
7             use Storable qw(dclone);
8              
9             =head1 NAME
10              
11             Poker::Dealer - Simple class to represent a poker dealer
12              
13             =head1 VERSION
14              
15             Version 0.01
16              
17             =cut
18              
19             our $VERSION = '0.01';
20              
21              
22             =head1 SYNOPSIS
23              
24             use Poker::Dealer;
25              
26             my $dealer = Poker::Dealer->new;
27              
28             $dealer->shuffle_deck;
29              
30             # Returns an array_ref of face-up card objects
31             my $cards = $dealer->deal_up(4)
32              
33             # Returns an array_ref of face-down card objects
34             my $cards = $dealer->deal_down(5)
35              
36             =cut
37              
38             has 'id' => (
39             is => 'rw',
40             );
41              
42             has 'master_deck' => (
43             is => 'rw',
44             isa => sub { die "Not a Poker::Deck!" unless $_[0]->isa('Poker::Deck') },
45             builder => '_build_master_deck',
46             );
47              
48             sub _build_master_deck {
49             return Poker::Deck->new;
50             }
51              
52             has 'deck' => (
53             is => 'rw',
54             isa => sub { die "Not a Poker::Deck!" unless $_[0]->isa('Poker::Deck') },
55             lazy => 1,
56             builder => '_build_deck',
57             );
58              
59             sub _build_deck {
60             my $self = shift;
61             return dclone $self->master_deck;
62             }
63              
64             sub shuffle_cards {
65             my ( $self, $cards ) = @_;
66             $cards->cards->Reorder( shuffle $cards->cards->Keys );
67             }
68              
69             =head1 SUBROUTINES/METHODS
70              
71             =head2 shuffle_deck
72              
73             Creates a new deck and randomizes the cards.
74             =cut
75              
76             sub shuffle_deck {
77             my $self = shift;
78             $self->deck( $self->_build_deck );
79             $self->shuffle_cards( $self->deck );
80             }
81              
82             sub deal {
83             my $self = shift;
84             my $count = shift || 1;
85             $self->reshuffle if $count > $self->deck->cards->Length;
86             my %cards = $self->deck->cards->Splice( 0, $count );
87             return [ values %cards ];
88             }
89              
90             =head2 reshuffle
91              
92             Shuffles cards in the discard pile and adds them to the existing deck.
93             =cut
94              
95             sub reshuffle {
96             my $self = shift;
97             while (my $card = shift @{ $self->deck->discards }) {
98             $self->deck->cards->Push( $card->rank . $card->suit => $card )
99             }
100             $self->shuffle_cards( $self->deck );
101             }
102              
103             =head2 deal_down
104              
105             Returns an array_ref of Poker::Card objects face down
106             =cut
107              
108              
109             sub deal_down {
110             my $self = shift;
111             my $count = shift || 1;
112             return [ map { $_->up_flag(0); $_ } @{ $self->deal($count) } ];
113             }
114              
115             =head2 deal_up
116              
117             Returns an array_ref of Poker::Card objects face up
118             =cut
119              
120             sub deal_up {
121             my $self = shift;
122             my $count = shift || 1;
123             return [ map { $_->up_flag(1); $_ } @{ $self->deal($count) } ];
124             }
125              
126             =head2 deal_named
127              
128             Fetch a specific set of cards from the deck.
129             # Deal yourself two aces:
130             $cards = $dealer->deal_named(['As', 'Ah'])
131              
132             =cut
133              
134             sub deal_named {
135             my ( $self, $cards ) = @_;
136             my @hand;
137             for my $card (@$cards) {
138             my $val = $self->deck->cards->FETCH($card) or die "No such card: $card";
139             push @hand, $val;
140             $self->deck->cards->Delete($card);
141             }
142             return [@hand];
143             }
144              
145             =head1 AUTHOR
146              
147             Nathaniel Graham, C<< >>
148              
149             =head1 LICENSE AND COPYRIGHT
150              
151             Copyright 2016 Nathaniel Graham.
152              
153             This program is free software; you can redistribute it and/or modify it
154             under the terms of the the Artistic License (2.0). You may obtain a
155             copy of the full license at:
156              
157             L
158              
159             =cut
160              
161             1;