File Coverage

blib/lib/Net/Gnats/Session.pm
Criterion Covered Total %
statement 136 152 89.4
branch 56 76 73.6
condition 4 9 44.4
subroutine 30 33 90.9
pod 14 19 73.6
total 240 289 83.0


line stmt bran cond sub pod time code
1             package Net::Gnats::Session;
2 40     40   27832 use v5.10.00;
  40         112  
  40         1658  
3 40     40   812 use strictures;
  40         986  
  40         208  
4             BEGIN {
5 40     40   3367 $Net::Gnats::Session::VERSION = '0.20';
6             }
7 40     40   189 use vars qw($VERSION);
  40         74  
  40         2131  
8              
9 40     40   768 use Net::Gnats qw(verbose_level);
  40         59  
  40         1071  
10 40     40   43555 use IO::Socket::INET;
  40         790582  
  40         261  
11 40     40   40908 use Net::Gnats::Command qw(user quit);
  40         124  
  40         1834  
12 40     40   723 use Net::Gnats::Constants qw(LF CODE_GREETING CODE_PR_READY CODE_SEND_PR CODE_SEND_TEXT CODE_SEND_CHANGE_REASON CODE_INFORMATION);
  40         62  
  40         2980  
13 40     40   16458 use Net::Gnats::Schema;
  40         125  
  40         55966  
14              
15             $| = 1;
16              
17             =head1 NAME
18              
19             Net::Gnats::Session
20              
21             =head1 DESCRIPTION
22              
23             Represents a specific connection to Gnats.
24              
25             When constructing a new session, it resets $Net::Gnats::current_session.
26              
27             =cut
28              
29             sub new {
30 44     44 0 15899 my ($class, %o ) = @_;
31 44         81 my ($self);
32 44 100       307 $self = bless {}, $class if not %o;
33 44         177 $self = bless \%o, $class;
34              
35             #set the current session to Net::Gnats so we can ref it throughout
36 44         254 Net::Gnats->current_session($self);
37              
38 44         210 return $self;
39             }
40              
41             =head1 ACCESSORS
42              
43             =head2 name
44              
45             The name is a combination of database and username, a friendly handle.
46              
47             It does not mean anything to GNATS.
48              
49             =cut
50              
51             sub name {
52 0     0 1 0 my $self = shift;
53 0         0 return $self->hostname . '-' . $self->username;
54             }
55              
56              
57             =head2 access
58              
59             Retrieves the access for the current database.
60              
61             =cut
62              
63 82     82 1 452 sub access { shift->{access}; }
64              
65             =head2 database
66              
67             Sets and retrieves the current database. If a value is given then
68             a change to the given database is made.
69              
70             =cut
71              
72             sub database {
73 23     23 1 38 my ($self, $value) = @_;
74 23 100       78 $self->{database} = 'default' if not defined $self->{database};
75 23 50       55 if ( defined $value ) {
76 0 0       0 return $self->{database} if $self->{database} eq $value;
77 0 0       0 $self->{database} = $value if
78             $self->issue(Net::Gnats::Command->chdb( database => $value))
79             ->is_ok;
80              
81             # initialize schema for changed database
82 0         0 $self->{schema} = Net::Gnats::Schema->new($self);
83             }
84 23         124 return $self->{database};
85             }
86              
87             =head2 hostname
88              
89             The hostname of the Gnats daemon process.
90              
91             Default: localhost
92              
93             =cut
94              
95             sub hostname {
96 90     90 1 126 my ( $self, $value ) = @_;
97 90 100       223 $self->{hostname} = $value if defined $value;
98 90 100       281 $self->{hostname} = 'localhost' if not defined $self->{hostname};
99 90         291 $self->{hostname};
100             }
101              
102             sub is_authenticated {
103 45     45 0 83 my ( $self ) = @_;
104 45 100       198 $self->{authenticated} = 0 if not defined $self->{authenticated};
105 45         209 $self->{authenticated};
106             }
107              
108             sub is_connected {
109 16     16 0 27 my ( $self ) = @_;
110 16 50       50 $self->{connected} = 0 if not defined $self->{connected};
111 16         122 $self->{connected};
112             }
113              
114              
115              
116             =head2 password
117              
118             The password for the user connecting to the Gnats daemon process.
119              
120             Most commands require authentication.
121              
122             =cut
123              
124             sub password {
125 51     51 1 999 my ( $self, $value ) = @_;
126 51 100       158 $self->{password} = $value if defined $value;
127 51         341 $self->{password};
128             }
129              
130             =head2 port
131              
132             The port of the Gnats daemon process.
133              
134             Default: 1529
135              
136             =cut
137              
138             sub port {
139 90     90 1 130 my ( $self, $value ) = @_;
140 90 50       200 $self->{port} = $value if defined $value;
141 90 100       252 $self->{port} = 1529 if not defined $self->{port};
142 90         340 $self->{port};
143             }
144              
145             =head2 schema
146              
147             Get the schema for this session. Readonly.
148              
149             =cut
150              
151 166     166 1 1155 sub schema { shift->{schema} }
152              
153             =head2 skip_version
154              
155             Set skip_version to override Gnats version checking. By default,
156             Net::Gnats supports v4 only.
157              
158             You use this at your own risk.
159              
160             =cut
161              
162             sub skip_version {
163 89     89 1 114 my ($self, $value) = @_;
164 89 100       311 $self->{skip_version} = 0 if not defined $self->{skip_version};
165 89 100       199 $self->{skip_version} = $value if defined $value;
166 89         227 $self->{skip_version};
167             }
168              
169             =head2 username
170              
171             The user connecting to the Gnats daemon process.
172              
173             Most commands require authentication.
174              
175             =cut
176              
177             sub username {
178 62     62 1 97 my ( $self, $value ) = @_;
179 62 100       168 $self->{username} = $value if defined $value;
180 62         227 $self->{username};
181             }
182              
183             =head2 version
184              
185             The Gnats daemon process version. The version will only be set after connecting.
186              
187             =cut
188              
189 86     86 1 332 sub version { return shift->{version} }
190              
191             =head1 METHODS
192              
193              
194             =head2 authenticate
195              
196             Return:
197              
198             0 if failue
199             1 if success
200              
201             =cut
202              
203             sub authenticate {
204 38     38 1 73 my ( $self ) = @_;
205 38         58 my ($c);
206              
207 38         142 $c = $self->issue(Net::Gnats::Command->user( username => $self->username,
208             password => $self->password ));
209 38         168 $self->{authenticated} = $c->is_ok;
210 38 50       111 return $self if not $c->is_ok;
211              
212 38 50       135 $self->{schema} = Net::Gnats::Schema->new($self) if not defined $self->schema;
213              
214 38         266 _trace('AUTH: ' . $c->is_ok);
215              
216 38         131 $c->is_ok;
217             }
218              
219             =head2 gconnect
220              
221             Connects to Gnats. If the username and password is set, it will
222             attempt authentication.
223              
224             Connecting an already connected session infers reconnect.
225              
226             =cut
227              
228             sub gconnect {
229 44     44 1 161 my ( $self ) = @_;
230 44         86 my ( $sock, $iaddr, $paddr, $proto );
231              
232 44         178 _trace ('disconnecting sock if it exists');
233 44 50       290 $self->disconnect if defined $self->{gsock};
234              
235 44         420 _trace ('constructing socket');
236 44         183 _trace ('host: ' . $self->hostname);
237 44         184 _trace ('port: ' . $self->port);
238              
239 44         156 $self->{gsock} = IO::Socket::INET->new( PeerAddr => $self->hostname,
240             PeerPort => $self->port,
241             Proto => 'tcp');
242              
243 44 50       257 return $self if not defined $self->{gsock};
244              
245 44         168 my $response = $self->_read;
246              
247 44         198 _trace('Connection response: ' . $response->as_string);
248              
249 44 50       140 return undef if not defined $response->code;
250 44 50       144 return undef if $response->code != CODE_GREETING;
251              
252 44         124 _trace('Is Connected.');
253 44         105 $self->{connected} = 1;
254              
255             # Grab the gnatsd version
256 44         143 $self->gnatsd_version( $response->as_string );
257              
258 44 100       144 print "? Error: GNATS Daemon version $self->{version} at $self->{hostname} $self->{port} is not supported by Net::Gnats\n" if not $self->check_gnatsd_version;
259 44 100       125 if ( not $self->check_gnatsd_version ) {
260 1         5 $self->issue(Net::Gnats::Command->quit);
261 1         4 $self->{connected} = 0;
262 1         4 return undef;
263             }
264              
265             # issue USER to get current access level
266 43         420 $self->{access} = $self->issue(Net::Gnats::Command->user)->level;
267              
268 43 100 66     924 $self->authenticate if defined $self->{username} and defined $self->{password};
269              
270 43 100       187 return $self if not $self->is_authenticated;
271              
272 27 50 33     99 return $self if $self->access eq 'none' or $self->access eq 'deny' or $self->access eq 'listdb';
      33        
273              
274 27         218 return $self;
275             }
276              
277             =head2 disconnect
278              
279             Disconnects from the current session, either authenticated or not.
280              
281             =cut
282              
283             sub disconnect {
284 0     0 1 0 my ( $self ) = @_;
285 0         0 $self->issue( Net::Gnats::Command->quit );
286 0         0 $self->{connected} = 0;
287 0         0 $self->{authenticated} = 0;
288 0         0 $self->{schema} = undef;
289             }
290              
291             =head2 issue
292              
293             Issues a command using a Command object. The Command object is
294             returned to the caller.
295              
296             The Command object composes a Response, whose value(s) carry error
297             codes and the literal values retrived from Gnats.
298              
299             =cut
300              
301             sub issue {
302 531     531 1 852 my ( $self, $command ) = @_;
303              
304             # if the command cannot be formed, the as_string method will return
305             # undef.
306 531 100       1725 return $command if not defined $command->as_string;
307              
308 504         1198 $command->response( $self->_run( $command->as_string ) );
309              
310             # In case we received the an undefined response code, return here.
311             # This could happen when the network response gets broken.
312 504 50       1123 return $command if not defined $command->response->code;
313              
314             # Check CODE_SEND_TEXT or CODE_SEND_PR
315             # This will be a field object value.
316 504 100       1262 if ($command->response->code == CODE_SEND_TEXT) {
    100          
317 7         38 $command->response( $self->_run( $command->field->value . "\n." ) );
318 7 100       23 $command->response( $self->_run( $command->field_change_reason->value . "\n." ))
319             if $command->response->code == CODE_SEND_CHANGE_REASON;
320             }
321             # This will be a whole serialized PR.
322             elsif ($command->response->code == CODE_SEND_PR) {
323 5         34 $command->response( $self->_run( $command->pr->asString . "\n." ) );
324             }
325 504         9938 return $command;
326             }
327              
328             =head2 run
329              
330             Runs a RAW command using this session. Returns RAW output.
331              
332             =cut
333              
334              
335             # PRIVATE METHODS HERE - DO NOT EXPORT
336              
337             sub gnatsd_version {
338 44     44 0 96 my ($self, $value) = @_;
339 44 50       188 if (defined $value) {
340 44         350 $value =~ s/.*(\d+.\d+.\d+).*/$1/;
341 44         153 $self->{version} = $1;
342             }
343 44         171 return $self->{version};
344             }
345              
346             # "legally" use v4 daemon only
347             sub check_gnatsd_version {
348 88     88 0 123 my ($self) = @_;
349 88         111 my $rmajor = 4;
350 88         89 my $min_minor = 1;
351 88 100       206 return 1 if $self->skip_version;
352              
353 86         237 my ($majorv, $minorv, $patchv) = split /\./, $self->version;
354              
355 86 100       293 return 0 if $majorv != $rmajor;
356 84 50       209 return 0 if $minorv < $min_minor;
357 84         304 return 1;
358             }
359              
360              
361             sub _run {
362 518     518   667 my ( $self, $cmd ) = @_;
363              
364             #$self->_clear_error();
365              
366 518         1428 _trace('SENDING: [' . $cmd . ']');
367              
368 518         2376 $self->{gsock}->print( $cmd . LF );
369              
370 518         31530 return $self->_read;
371             }
372              
373             sub _read {
374 562     562   793 my ( $self ) = @_;
375 562         2227 my $response = Net::Gnats::Response->new(type => 0);
376              
377 562         1357 until ( $response->is_finished == 1 ) {
378 5983         13265 my $line = $self->_read_clean($self->{gsock}->getline);
379              
380             # We didn't get anyting from the socket, it could mean a broken
381             # connection or malformed response.
382 5983 50       10294 last if not defined $line;
383              
384             # Process the line normally.
385 5983         13028 $response->raw( $line );
386 5983         12702 _trace('RECV: [' . $line . ']');
387             }
388 562         3464 return $response;
389             }
390              
391             sub _read_clean {
392 5983     5983   297720 my ( $self, $line ) = @_;
393 5983 50       10863 if ( not defined $line ) { return; }
  0         0  
394              
395 5983         32229 $line =~ s/\r|\n//gsm;
396             # $line =~ s/^[.][.]/./gsm;
397 5983         9123 return $line;
398             }
399              
400             sub _read_decompose {
401 0     0   0 my ( $self, $raw ) = @_;
402 0         0 my @result = $raw =~ /^(\d\d\d)([- ]?)(.*$)/sxm;
403 0         0 return \@result;
404             }
405              
406             sub _trace {
407 6803     6803   6493 my ( $message ) = @_;
408 6803 50       11802 return if Net::Gnats->verbose_level() != 3;
409 0           print 'TRACE: [' . $message . ']' . LF;
410 0           return;
411             }
412              
413             1;