File Coverage

blib/lib/Net/SeedServe/Server.pm
Criterion Covered Total %
statement 75 79 94.9
branch 10 16 62.5
condition 2 3 66.6
subroutine 13 13 100.0
pod 6 6 100.0
total 106 117 90.6


line stmt bran cond sub pod time code
1             package Net::SeedServe::Server;
2              
3 6     6   58236 use strict;
  6         9  
  6         131  
4 6     6   18 use warnings;
  6         6  
  6         108  
5              
6 6     6   16 use Net::SeedServe;
  6         6  
  6         70  
7 6     6   17 use IO::All;
  6         29  
  6         29  
8 6     6   2761 use Time::HiRes qw(usleep);
  6         5610  
  6         18  
9              
10             =head1 NAME
11              
12             Net::SeedServe::Server - Perl module for implementing a seed server.
13              
14             =head1 DESCRIPTION
15              
16             None yet. Consult the code, and the examples in the tests directory.
17              
18             =head1 METHODS
19              
20             =head2 $obj = Net::SeedServe::Server->new(status_file => $status_filename);
21              
22             Initialises a new object with the status filename.
23              
24             =cut
25              
26             sub new
27             {
28 7     7 1 3119 my $class = shift;
29 7         19 my $self = {};
30 7         12 bless $self, $class;
31 7         25 $self->_init(@_);
32 7         14 return $self;
33             }
34              
35             sub _init
36             {
37 7     7   7 my $self = shift;
38 7         15 my %args = (@_);
39 7 50       35 $self->{'status_file'} = $args{'status_file'} or
40             die "Unknown status file!";
41              
42 7         10 return 0;
43             }
44              
45             =head2 $server->start()
46              
47             Starts the server on a port starting from port 3,000. Returns a hash ref
48             containing the port.
49              
50             =cut
51              
52             sub start
53             {
54 6     6 1 20 my $self = shift;
55 6         10 my $status_file = $self->{'status_file'};
56              
57 6         9 for(my $port = 3000; ; $port++)
58             {
59 10         531 unlink($status_file);
60 10         5836 my $fork_pid = fork();
61 10 50       236 if (!defined($fork_pid))
62             {
63 0         0 die "Fork was not successful!";
64             }
65 10 100       200 if (! $fork_pid)
66             {
67             # The child will start the service.
68 3         256 my $server =
69             Net::SeedServe->new(
70             'status_file' => $status_file,
71             'port' => $port,
72             );
73              
74             eval
75 3         26 {
76 3         27 $server->loop();
77             };
78 3 50       295 if ($@)
79             {
80 3         367 exit(-1);
81             }
82             }
83             else
84             {
85             # The parent will try to find the child's status
86 7         122 my $text;
87              
88 7   66     147 while (! ( defined($text) and $text =~ /\n\z/) )
89             {
90 7         185 while (! -f $status_file)
91             {
92 12         61387 usleep(5000);
93             }
94 7         35704 usleep(5000);
95 7         160 $text = io()->file($status_file)->getline();
96             }
97 7 100       32626 if ($text eq "Status:Success\tPort:$port\tPID:$fork_pid\n")
98             {
99             # The game is on - the service is running and everything's OK.
100 3         24 $self->{'port'} = $port;
101 3         94 $self->{'server_pid'} = $fork_pid;
102 3         51 return +{ 'port' => $port };
103             }
104             else
105             {
106 4         1986358 waitpid($fork_pid, 0);
107             }
108             }
109             }
110             }
111              
112             =head2 $server->connect(status_file => $status_filename)
113              
114             Connects to an existing Server whose status file is $status_filename.
115              
116             =cut
117              
118             sub connect
119             {
120 1     1 1 6 my $self = shift;
121              
122 1         3 my $status_file = $self->{'status_file'};
123              
124 1         6 my $text = io()->file($status_file)->getline();
125              
126 1 50       274 if ($text !~ /^Status:Success\tPort:(\d+)\tPID:(\d+)$/)
127             {
128 0         0 die "Invalid status file.";
129             }
130              
131 1         51 my $port = $1;
132 1         8 $self->{'server_pid'} = $2;
133             # TODO ?
134             # Add sanity checks.
135              
136 1         2 $self->{'port'} = $port;
137              
138 1         6 return { 'port' => $port, };
139             }
140              
141             =head2 $server->stop()
142              
143             Stops the service by killing the listening process.
144              
145             =cut
146              
147             sub stop
148             {
149 3     3 1 46759 my $self = shift;
150              
151 3         11 my $pid = $self->{'server_pid'};
152 3         3137 kill("TERM", $pid);
153              
154 3         815 waitpid($pid, 0);
155             }
156              
157             sub _ok_transact
158             {
159 10     10   12 my $self = shift;
160 10         14 my $msg = shift;
161 10         16 my $port = $self->{'port'};
162 10         23 my $conn = io("localhost:$port");
163 10         958 $conn->print("$msg\n");
164 10         5219 my $response = $conn->getline();
165 10 50       1027 if ($response eq "OK\n")
166             {
167 10         24 return 0;
168             }
169             else
170             {
171 0         0 die "Invalid response - $response.";
172             }
173             }
174              
175             =head2 $server->clear();
176              
177             Sends a clear transaction that clears the seeds of the seed server.
178              
179             =cut
180              
181             sub clear
182             {
183 2     2 1 25462 my $self = shift;
184 2         6 return $self->_ok_transact("CLEAR");
185             }
186              
187             =head2 $server->enqueue(\@seeds);
188              
189             Enqueues several seeds in the server to be served next.
190              
191             =cut
192              
193             sub enqueue
194             {
195 8     8 1 22431 my $self = shift;
196 8         29 my $seeds = shift;
197 8 50       13 if (grep { $_ !~ /^\d+$/ } @$seeds)
  14         66  
198             {
199 0         0 die "Invalid seed.";
200             }
201 8         12 return $self->_ok_transact("ENQUEUE " . join("", map { "$_," } @$seeds));
  14         40  
202             }
203              
204             1;
205              
206             __END__