File Coverage

blib/lib/Games/Tournament/Swiss/Config.pm
Criterion Covered Total %
statement 19 60 31.6
branch 6 30 20.0
condition 6 26 23.0
subroutine 5 9 55.5
pod 7 7 100.0
total 43 132 32.5


line stmt bran cond sub pod time code
1             package Games::Tournament::Swiss::Config;
2             $Games::Tournament::Swiss::Config::VERSION = '0.20';
3             # Last Edit: 2016 Jan 01, 13:44:43
4             # $Id: $
5              
6 30     30   147 use warnings;
  30         54  
  30         1982  
7 30     30   146 use strict;
  30         1102  
  30         23521  
8              
9             =head1 NAME
10              
11             Games::Tournament::Swiss::Config - Swiss Competition Configuration
12              
13             =cut
14              
15             =head1 SYNOPSIS
16              
17             use constant ROLES => @Games::Tournament::Swiss::Config::roles = qw/Black White/;
18             use constant ROLES => @Games::Tournament::Swiss::Config::ROLES;
19             $Games::Tournament::Swiss::Config::firstRound = 11;
20              
21             =head1 DESCRIPTION
22              
23             Actually, a swiss tournament is not just one kind of tournament, but a whole genre of tournaments. If you are using Games::Tournament::Swiss for other than chess tournaments, where the players take black and white roles, and score 0,0.5, or 1, for example, you probably want to configure it. You also might want to start swiss pairing at a random round in the tournament, in which case you will set firstround.
24              
25             The roles, scores, firstround, algorithm methods in this module are here just to stop perl warning about 'only one use, possible typo' warnings, with the use of fully qualified Games::Tournament::Swiss::Config package variables. (Is that actually true? Anyway I want the methods (class and object) to return values, default and assigned.)
26              
27             =head1 METHODS
28              
29             =head2 new
30              
31             Getter/setter of the genre of competition, eg chess, basketball, football, school exam, etc, the tournament is being held as.
32              
33             =cut
34              
35             sub new {
36 0     0 1 0 my $self = shift;
37 0         0 my %args = @_;
38 0   0     0 $args{roles} ||= [ Games::Tournament::Swiss::Config->roles ];
39 0         0 return bless \%args, $self;
40             }
41              
42              
43             =head2 frisk
44              
45             Die if the configuration contains anything but [A-Za-z0-9:,.]
46              
47             =cut
48              
49             sub frisk {
50 0     0 1 0 my $self = shift;
51 0         0 my @suspects = @_;
52 0         0 for my $suspect ( @suspects )
53             {
54 0 0       0 unless ( ref $suspect ) {
    0          
    0          
55 0 0       0 die "We are afraid you may be importing nasty characters with
56             $suspect. Please use only [A-Za-z0-9:.,] in your configuration files"
57             unless $suspect =~ m/^[A-Za-z0-9:.,]*$/;
58             }
59             elsif ( ref($suspect) eq "ARRAY" ) {
60 0         0 for (@$suspect) { $self->frisk($_); }
  0         0  
61             }
62             elsif ( ref($suspect) eq 'HASH' ) {
63 0         0 for ( keys %$suspect ) { $self->frisk( $suspect->{$_} ); }
  0         0  
64             }
65             else {
66 0         0 die "We are afraid you may be importing nasty objects with $suspect.
67             Please use only arrays and hashes in your configuration files";
68             }
69             }
70 0         0 return;
71             }
72              
73              
74             =head2 roles
75              
76             Getter/setter of the roles the 2 players take, eg Black, White, or Home, Away. The default is White, Black. Both object and class method.
77              
78             =cut
79              
80             sub roles {
81 25     25 1 49 my $self = shift;
82 25         42 my $roles = shift;
83 25 50 33     130 if (ref $self eq "Games::Tournament::Swiss::Config" and $roles) {
84 0         0 $self->{roles} = $roles; return;
  0         0  
85             }
86 25 50 33     88 if ( ref $self eq "Games::Tournament::Swiss::Config" and $self->{roles} )
87 0         0 { return @{ $self->{roles} }; }
  0         0  
88 25         8102 else { return qw/White Black/; }
89             }
90              
91              
92             =head2 scores
93              
94             Getter/setter of the scores the 2 players can get, eg win: 1, loss: 0, draw: 0.5, absent: 0, bye: 1, which is the default. Both object and class method.
95              
96             =cut
97              
98             sub scores {
99 9     9 1 21 my $self = shift;
100 9         17 my $scores = shift;
101 9 50 33     70 if (ref $self eq "Games::Tournament::Swiss::Config" and $scores)
    50 33        
102 0         0 { $self->{scores} = $scores; }
103             elsif (ref $self eq "Games::Tournament::Swiss::Config" and $self->{scores})
104 0         0 { return %{ $self->{scores} }; }
  0         0  
105 9         16691 else { return ( win => 1, loss => 0, draw => 0.5, absent => 0, bye => 1,
106             unpaired => 0, tardy => 0.5, forfeit => 0 ) }
107             }
108              
109              
110             =head2 abbreviation
111              
112             Getter/setter of the abbreviations used and their full translations. The default is W: White, B: Black, 1: Win, 0: Loss, '0.5': Draw, '=': Draw. Both object and class method. Also Absolute, Strong and Mild preferences, and Down, Up, and Not floats.
113              
114             =cut
115              
116             sub abbreviation {
117 2     2 1 3355 my $self = shift;
118 2         4 my $abbreviation = shift;
119 2 50 33     39 if (ref $self eq "Games::Tournament::Swiss::Config" and $abbreviation)
    50 33        
120 0         0 { $self->{abbreviation} = $abbreviation; return; }
  0         0  
121             elsif (ref $self eq "Games::Tournament::Swiss::Config" and
122             $self->{abbreviation} )
123 0         0 { return %{ $self->{abbreviation} }; }
  0         0  
124 2         48 else { return ( W => 'White', B => 'Black', 1 => 'Win', 0 => 'Loss',
125             0.5 => 'Draw', '=' => 'Draw', A => 'Absolute', S => 'Strong', M => 'Mild', D => 'Down', U => 'Up', N => 'Not' ); }
126             }
127              
128              
129             =head2 algorithm
130              
131             Getter/setter of the algorithm by which swiss pairing is carried out. There is no default. Pass a name as a string. I recommend Games::Tournament::Swiss::Procedure::FIDE. Make sure something is set.
132              
133             =cut
134              
135             sub algorithm {
136 0     0 1   my $self = shift;
137 0           my $algorithm = shift;
138 0 0         die "$algorithm name is like Games::Tournament::Swiss::Procedure::AlgoName"
139             unless $algorithm =~ m/^Games::Tournament::Swiss::Procedure::\w+$/;
140 0 0         if ($algorithm) { $self->{algorithm} = $algorithm; }
  0 0          
141 0           elsif ( $self->{algorithm} ) { return @{ $self->{algorithm} }; }
  0            
142 0           else { return 'Games::Tournament::Swiss::Procedure::FIDE' };
143             }
144              
145              
146             =head2 firstround
147              
148             Getter/setter of the first round in which swiss pairing started. Perhaps some other pairing method was used in rounds earlier than this. The default is 1. Both object and class method.
149              
150             =cut
151              
152             sub firstround {
153 0     0 1   my $self = shift;
154 0           my $first = shift;
155 0 0 0       if (ref $self eq "Games::Tournament::Swiss::Config" and $first)
    0 0        
156 0           { $self->{firstround} = $first; }
157             elsif (ref $self eq "Games::Tournament::Swiss::Config" and $self->{first} )
158 0           { return @{ $self->{firstround} }; }
  0            
159 0           else { return 1; }
160             }
161              
162             =head1 AUTHOR
163              
164             Dr Bean, C<< >>
165              
166             =head1 BUGS
167              
168             Please report any bugs or feature requests to
169             C, or through the web interface at
170             L.
171             I will be notified, and then you'll automatically be notified of progress on
172             your bug as I make changes.
173              
174             =head1 SUPPORT
175              
176             You can find documentation for this module with the perldoc command.
177              
178             perldoc Games::Tournament::Swiss::Config
179              
180             You can also look for information at:
181              
182             =over 4
183              
184             =item * AnnoCPAN: Annotated CPAN documentation
185              
186             L
187              
188             =item * CPAN Ratings
189              
190             L
191              
192             =item * RT: CPAN's request tracker
193              
194             L
195              
196             =item * Search CPAN
197              
198             L
199              
200             =back
201              
202             =head1 ACKNOWLEDGEMENTS
203              
204             See L for the FIDE's Swiss rules.
205              
206             =head1 COPYRIGHT & LICENSE
207              
208             Copyright 2006 Dr Bean, all rights reserved.
209              
210             This program is free software; you can redistribute it and/or modify it
211             under the same terms as Perl itself.
212              
213             =cut
214              
215             1; # End of Games::Tournament::Swiss::Config
216              
217             # vim: set ts=8 sts=4 sw=4 noet: