File Coverage

blib/lib/Net/Gnats.pm
Criterion Covered Total %
statement 132 212 62.2
branch 32 94 34.0
condition 6 25 24.0
subroutine 42 59 71.1
pod 40 48 83.3
total 252 438 57.5


line stmt bran cond sub pod time code
1             package Net::Gnats;
2             BEGIN {
3 40     40   1012848 $Net::Gnats::VERSION = '0.21';
4             }
5 40     40   1405 use 5.010_000;
  40         168  
  40         1522  
6 40     40   26933 use utf8;
  40         382  
  40         200  
7 40     40   20371 use strictures;
  40         26875  
  40         238  
8 40     40   25135 use English '-no_match_vars';
  40         163831  
  40         286  
9 40     40   35494 use Net::Gnats::Session;
  40         130  
  40         2097  
10             require Exporter;
11 40     40   817 use Net::Gnats::PR qw(deserialize serialize);
  40         73  
  40         2889  
12 40     40   726 use Net::Gnats::Response;
  40         67  
  40         931  
13 40     40   638 use Net::Gnats::Command;
  40         80  
  40         1931  
14 40         6644 use Net::Gnats::Constants qw(CODE_OK CODE_GREETING CODE_INFORMATION CODE_TEXT_READY
15             CODE_INVALID_FTYPE_PROPERTY CODE_ERROR
16             CODE_GNATS_LOCKED CODE_CMD_ERROR CODE_ERROR
17             CODE_GNATS_NOT_LOCKED CODE_NONEXISTENT_PR CODE_LOCKED_PR
18             CODE_PR_NOT_LOCKED CODE_OK CODE_NO_ACCESS
19             CODE_SEND_PR CODE_SEND_TEXT CODE_FILE_ERROR
20             RESTART_CHECK_THRESHOLD
21             CODE_INFORMATION_FILLER
22             CODE_NO_PRS_MATCHED
23             CODE_INVALID_EXPR CODE_INVALID_QUERY_FORMAT
24             CODE_PR_READY CODE_INVALID_DATABASE
25 40     40   196 LF CR CRLF DOT CONT MAX_NEW_PRS);
  40         59  
26 40     40   212 use vars qw($VERSION);
  40         66  
  40         128134  
27             my $current_session;
28             my $VERBOSE = 0;
29             my $VERBOSE_LEVEL = 0;
30             our @ISA = qw(Exporter);
31             our @EXPORT = qw($VERBOSE $VERBOSE_LEVEL);
32             our @EXPORT_OK = qw(verbose verbose_level current_session);
33             $OUTPUT_AUTOFLUSH = 1;
34              
35             =head1 NAME
36              
37             Net::Gnats - Perl interface to GNU Gnats daemon
38              
39             =head1 VERSION
40              
41             0.19
42              
43             =head1 DESCRIPTION
44              
45             Net::Gnats provides a perl interface to the
46             L command set. Although most of
47             the gnatsd command are present and can be explicitly called through
48             Net::Gnats, common gnats tasks can be accompished through some methods
49             which simplify the process (especially querying the database, editing bugs,
50             etc).
51              
52             =head1 SYNOPSIS
53              
54             use Net::Gnats;
55              
56             # Instantiates object with Gnats hostname 'localhost' and port '1529'.
57             my $g = Net::Gnats->new;
58              
59             # Creates the session between Net::Gnats and the gnatsd process.
60             say 'Connected.' if $g->gnatsd_connect;
61              
62             # Retrieves the list of databases hosted by the server. Typically,
63             # it's the only command that can be performed without logging in.
64             my $db_names = $g->get_dbnames;
65              
66             $g->login("default","somedeveloper","password");
67              
68             # Change field values in Gnats immediately by using the replaceField
69             # method.
70              
71             my $pr = $g->get_pr_by_number(2);
72             $pr->replaceField('Synopsis', 'The New Synopsis String');
73             $pr->replaceField('Responsible', 'joe', q|Because It's Joe's|);
74              
75             # Change field values and submit the PR for update. This is the
76             # preferred method if many fields require updating.
77              
78             my $pr = $g->get_pr_by_number(3);
79             $pr->setField('Synopsis', 'The New Synopsis String');
80             $pr->setField('Responsible', 'joe', q|Because It's Joe's|);
81             $g->update_pr($pr);
82              
83             my $new_pr = $g->new_pr();
84             $new_pr->setField("Submitter-Id","developer");
85             $g->submitPR($new_pr);
86              
87             # Close the session. The session will close abruptly if the program
88             # simply exits.
89              
90             $g->disconnect;
91              
92             =head1 COMMON TASKS
93              
94             =head2 VIEWING DATABASES
95              
96             Fetching database names is the only action that can be done on a Gnats
97             object before logging in via the login() method.
98              
99             my $g = Net::Gnats->new;
100             $g->gnatsd_connect;
101             my @dbNames = $g->getDBNames;
102              
103             Note that getDBNames() is different than listDatabases(), which
104             requires logging in first and gets a little more info than just names.
105              
106             =head2 LOGGING IN TO A DATABASE
107              
108             The Gnats object has to be logged into a database to perform almost
109             all actions.
110              
111             my $g = Net::Gnats->new;
112             $g->gnatsd_connect;
113             $g->login("default","myusername","mypassword");
114              
115             =head2 SUBMITTING A NEW PR
116              
117             The Net::Gnats::PR object acts as a container object to store
118             information about a PR (new or otherwise). A new PR is submitted to
119             gnatsperl by constructing a PR object.
120              
121             my $pr = $g->new_pr;
122             $pr->setField("Submitter-Id","developer");
123             $pr->setField("Originator","Doctor Wifflechumps");
124             $pr->setField("Organization","GNU");
125             $pr->setField("Synopsis","Some bug from perlgnats");
126             $pr->setField("Confidential","no");
127             $pr->setField("Severity","serious");
128             $pr->setField("Priority","low");
129             $pr->setField("Category","gnatsperl");
130             $pr->setField("Class","sw-bug");
131             $pr->setField("Description","Something terrible happened");
132             $pr->setField("How-To-Repeat","Like this. Like this.");
133             $pr->setField("Fix","Who knows");
134             $g->submit_pr($pr);
135              
136             Obviously, fields are dependent on a specific gnats installation,
137             since Gnats administrators can rename fields and add constraints.
138             There are some methods in Net::Gnats to discover field names and
139             constraints, all described below.
140              
141             Instead of setting each field of the PR individually, the
142             setFromString() method is available. The string that is passed to it
143             must be formatted in the way Gnats handles the PRs. This is useful
144             when handling a Gnats email submission ($pr->setFromString($email))
145             or when reading a PR file directly from the database. See
146             Net::Gnats::PR for more details.
147              
148              
149             =head2 QUERYING THE PR DATABASE
150              
151             my $prNums = $g->query('Number>"12"', "Category=\"$thisCat\"");
152             print "Found " . join(":", @$prNums ) . " matching PRs \n";
153              
154             Pass a list of query expressions to query(). A list of PR numbers of
155             matching PRs is returned. You can then pull out each PR as described
156             next.
157              
158              
159             =head2 FETCHING A PR
160              
161             my $prnum = 23;
162             my $PR = $g->get_pr_by_number($prnum);
163             print $PR->getField('synopsis');
164             print $PR->asString();
165              
166             The method get_pr_by_number() will return a Net::Gnats::PR object
167             corresponding to the PR num that was passed to it. The getField() and
168             asString() methods are documented in Net::Gnats::PR, but I will note
169             here that asString() returns a string in the proper Gnats format, and
170             can therefore be submitted directly to Gnats via email or saved to the
171             db directory for instance. Also:
172              
173             $pr->setFromString($oldPR->asString() );
174              
175             works fine and will result in a duplicate of the original PR object.
176              
177              
178             =head2 MODIFYING A PR
179              
180             There are 2 methods of modifying fields in a Net::Gnats::PR object.
181              
182             The first is to use the replaceField() or appendField() methods which
183             uses the gnatsd REPL and APPN commands. This means that the changes
184             to the database happen immediatly.
185              
186             my $prnum = 23;
187             my $PR = $g->get_pr_by_number($prnum);
188             if (! $PR->replaceField('Synopsis','New Synopsis')) {
189             warn "Error replacing field (" . $g->get_error_message . ")\n";
190             }
191              
192             If the field requires a change reason, it must be supplied as the 3rd argument.
193              
194             $PR->replaceField('Responsible','joe',"It's joe's problem");
195              
196             The second is to use the setField() and updatePR() methods which uses
197             the gnatsd EDIT command. This should be used when multiple fields of
198             the same PR are being changed, since the datbase changes occur at the
199             same time.
200              
201             my $prnum = 23;
202             my $PR = $g->get_pr_by_number($prnum);
203             $PR->setField('Synopsis','New Synopsis');
204             $PR->setField('Responsible','joe',"It's joe's problem");
205             if (! $g->updatePR($PR) ) {
206             warn "Error updating $prNum: " . $g->get_error_message . "\n";
207             }
208              
209             =head1 CONSTRUCTOR
210              
211             =head2 new
212              
213             Constructor, optionally taking one or two arguments of hostname and
214             port of the target gnats server. If not supplied, the hostname
215             defaults to localhost and the port to 1529.
216              
217             =cut
218              
219             sub new {
220 15     15 1 3926 my ( $class, $host, $port ) = @_;
221 15         53 my $self = bless {}, $class;
222              
223 15   100     112 $host = $host || 'localhost';
224 15   100     74 $port = $port || '1529';
225 15         115 $self->{session} = Net::Gnats::Session->new(hostname => $host,
226             port => $port);
227              
228             # stash this globally so we can use it in fallback scenarios
229 15         36 $current_session = $self->{session};
230 15         62 return $self;
231             }
232              
233             =head1 ACCESSORS
234              
235             =head2 current_session
236              
237             Exported function.
238              
239             Retrieves the currently used session (last initialized).
240              
241             =cut
242              
243             sub current_session {
244 137     137 1 221 my ($self, $session) = @_;
245 137 100       368 $current_session = $session if defined $session;
246 137         438 return $current_session;
247             }
248              
249             =head2 skip_version_check
250              
251             If you are using a custom gnats daemon, your version number might
252             "not be supported". If you are sure you know what you are doing
253             and am willing to take the consequences:
254              
255             my $g = Net::Gnats->new();
256             $g->skip_version_check(1);
257              
258             =cut
259              
260             sub skip_version_check {
261 1     1 1 3 my ($self, $value) = @_;
262 1         4 $self->session->skip_version(1);
263             }
264              
265             =head2 session
266              
267             Retrieve the session currently in effect. Used for Net::Gnats
268             instantiated objects only.
269              
270             my $session = $g->session;
271              
272             =cut
273              
274 205     205 1 1139 sub session { shift->{session}; }
275              
276             =head2 verbose
277              
278             Sets verbose on. By default, verbose is off. The default setting is
279             optimized for headless execution.
280              
281             To turn verbose on, change to 1.
282              
283             =cut
284              
285             sub verbose {
286 13     13 1 158 my ($class, $value) = @_;
287 13 50       61 $VERBOSE = $value if defined $value;
288 13         33 return $VERBOSE;
289             }
290              
291             =head2 verbose_level
292              
293             Sets the verbose level. The levels are:
294              
295             0: No level (based on verbose being on)
296             1: Brief error, displays Gnats error codes.
297             2: Detailed error, displays Gnats error codes and any messages.
298             3: Trace, full code path walking.
299              
300             =cut
301              
302             sub verbose_level {
303 24927     24927 1 24889 my ($class, $value) = @_;
304 24927 100       38565 $VERBOSE_LEVEL = $value if defined $value;
305 24927         75712 return $VERBOSE * $VERBOSE_LEVEL;
306             }
307              
308             =head1 METHODS
309              
310             =cut
311              
312              
313             =head2 gnatsd_connect
314              
315             Connects to the gnats server. No arguments. Returns true if
316             successfully connected, false otherwise.
317              
318             =cut
319              
320             sub gnatsd_connect {
321 15     15 1 419 my ( $self ) = shift;
322 15         67 my $conn = $self->session->gconnect;
323 15 100       55 return 0 if not defined $conn;
324 14         56 return $conn->is_connected;
325             }
326              
327             =head2 disconnect
328              
329             Issues the QUIT command to the Gnats server, thereby closing the
330             connection.
331              
332             Although the Gnats documentation says there is not a failure case for
333             this command, it responds true/false accordingly.
334              
335             $g->disconnect;
336              
337             =cut
338              
339             sub disconnect {
340 4     4 1 19 return shift->session->issue(Net::Gnats::Command->quit)->is_ok;
341             }
342              
343             =head2 get_dbnames
344              
345             Issues the DBLS command, and returns a list of database names in the
346             gnats server. Unlike listDatabases, one does not need to use the logn
347             method before using this method.
348              
349             my $list = $g->get_dbnames;
350              
351             =cut
352              
353 1     1 0 5 sub getDBNames { shift->get_dbnames; }
354              
355             sub get_dbnames {
356 3     3 1 15 shift->session->issue(Net::Gnats::Command->dbls)
357             ->response
358             ->as_list;
359             }
360              
361             =head2 list_databases
362              
363             Issues the LIST DATABASES command, and returns a list of hashrefs with
364             keys 'name', 'desc', and 'path'.
365              
366             =cut
367              
368             sub list_databases {
369 1     1 1 3 my ( $self ) = @_;
370 1         4 $self->session->issue(Net::Gnats::Command->list(subcommand => 'databases')
371             )->formatted;
372             }
373              
374             =head2 list_categories
375              
376             Issues the LIST CATEGORIES command, and returns a list of hashrefs
377             with keys 'name', 'desc', 'contact', and '?'.
378              
379             =cut
380              
381             sub list_categories {
382 1     1 1 7 my $self = shift;
383 1         4 $self->session->issue(Net::Gnats::Command->list(subcommand => 'categories')
384             )->formatted;
385             }
386              
387             =head2 list_submitters
388              
389             Issues the LIST SUBMITTERS command, and returns a list of hashrefs
390             with keys 'name', 'desc', 'contract', '?', and 'responsible'.
391              
392             my $s = $gnats->list_submitters;
393              
394             =cut
395              
396             sub list_submitters {
397 1     1 1 2 my $self = shift;
398 1         4 $self->session->issue(Net::Gnats::Command->list(subcommand => 'submitters')
399             )->formatted;
400             }
401              
402             =head2 list_responsible
403              
404             Issues the LIST RESPONSIBLE command, and returns a list of hashrefs
405             with keys 'name', 'realname', and 'email'.
406              
407             =cut
408              
409             sub list_responsible {
410 1     1 1 4 my $self = shift;
411 1         5 $self->session->issue(Net::Gnats::Command->list(subcommand => 'responsible')
412             )->formatted;
413             }
414              
415             =head2 list_states
416              
417             Issues the LIST STATES command, and returns a list of hashrefs with
418             keys 'name', 'type', and 'desc'.
419              
420             =cut
421              
422             sub list_states {
423 1     1 1 4 my $self = shift;
424 1         4 $self->session->issue(Net::Gnats::Command->list(subcommand => 'states')
425             )->formatted;
426             }
427              
428             =head2 list_fieldnames
429              
430             Issues the LIST FIELDNAMES command, and returns a list of hashrefs
431             with key 'name'.
432              
433             Protocol: returns an anonymous array of field names.
434              
435             =cut
436              
437             sub list_fieldnames {
438 1     1 1 28 my $self = shift;
439 1         5 $self->session->issue(Net::Gnats::Command->list(subcommand => 'fieldnames')
440             )->response->as_list;
441             }
442              
443             =head2 list_inputfields_initial
444              
445             Issues the LIST INITIALINPUTFIELDS command, and returns a list of
446             hashrefs with key 'name'.
447              
448             =cut
449              
450             sub list_inputfields_initial {
451 1     1 1 3 my $self = shift;
452 1         4 $self
453             ->session
454             ->issue(Net::Gnats::Command->list(subcommand => 'initialinputfields')
455             )->response->as_list;
456             }
457              
458             sub list_inputfields_initial_required {
459 1     1 0 4 my $self = shift;
460 1         5 $self
461             ->session
462             ->issue(Net::Gnats::Command->list(subcommand => 'initialrequiredfields')
463             )->response->as_list;
464             }
465              
466             =head2 get_field_type
467              
468             Expects a single fieldname or an anonymous array of field types.
469              
470             Returns 0 if the type information could not be retrieved.
471              
472             Returns a list of types based on the number of fields passed.
473              
474             =cut
475              
476             sub get_field_type {
477 5     5 1 13 my ( $self, $field ) = @_;
478              
479 5 100       19 return 0 if not defined $field;
480              
481 4         10 my $c = $self->session->issue(Net::Gnats::Command->ftyp(fields => $field));
482              
483 4 100       14 return 0 if not $c->is_ok;
484 3         7 return $c->response->as_list;
485             }
486              
487             =head2 get_field_type_info
488              
489             Expects a fieldname and property as arguments, and issues the FTYPINFO
490             command. Returns text response or undef if error.
491              
492             =cut
493              
494             sub get_field_type_info {
495 0     0 1 0 my ( $self, $field, $property ) = @_;
496 0 0       0 return 0 if not defined $field;
497 0   0     0 $property = $property || 'separators';
498 0         0 $self->session->issue(Net::Gnats::Command->ftypinfo(field => $field,
499             property => $property)
500             )->response->as_string;
501             }
502              
503             =head2 get_field_desc
504              
505             Expects a fieldname as sole argument, and issues the FDSC command.
506             Returns text response or undef if error.
507              
508             =cut
509              
510             sub get_field_desc {
511 0     0 1 0 my ( $self, $field ) = @_;
512 0 0       0 return 0 if not defined $field;
513 0         0 $self->session->issue(Net::Gnats::Command->fdsc(fields => $field)
514             )->response->as_list;
515             }
516              
517             =head2 get_field_flags
518              
519             Expects a fieldname as sole argument, and issues the FIELDFLAGS
520             command. Returns text response or undef if error.
521              
522             =cut
523              
524             sub get_field_flags {
525 0     0 1 0 my ( $self, $field, $flag ) = @_;
526 0 0       0 return 0 if not defined $field;
527 0         0 $self->session->issue(Net::Gnats::Command->fieldflags(fields => $field)
528             )->response->as_list;
529             }
530              
531             =head2 get_field_validators
532              
533             Expects a fieldname as sole argument, and issues the FVLD command.
534             Returns text response or undef if error.
535              
536             =cut
537              
538             sub get_field_validators {
539 0     0 1 0 my ( $self, $field ) = @_;
540 0 0       0 return 0 if not defined $field;
541 0         0 my $c = $self->session->issue(Net::Gnats::Command->fvld(field => $field));
542 0 0       0 return 0 if not $c->is_ok;
543 0         0 $c->response->as_list;
544             }
545              
546             =head2 validate_field
547              
548             Expects a Net::Gnats::FieldInstance object,
549             and issues the VFLD command. Returns true if propose value is
550             acceptable, false otherwise.
551              
552             $g->validate_field(Net::Gnats::FieldInstance->new(name => 'Originator', value => 'rich'));
553              
554             =cut
555              
556             sub validate_field {
557 0     0 1 0 my ( $self, $field ) = @_;
558              
559 0         0 return $self
560             ->session
561             ->issue(Net::Gnats::Command->vfld(field => $field))
562             ->is_ok;
563             }
564              
565             =head2 get_field_default
566              
567             Expects a fieldname as sole argument, and issues the INPUTDEFAULT
568             command. Returns text response or undef if error.
569              
570             =cut
571              
572             sub get_field_default {
573 0     0 1 0 my ( $self, $field ) = @_;
574 0         0 $self->session->issue(Net::Gnats::Command->inputdefault(fields => $field)
575             )->response->as_list;
576             }
577              
578             =head2 reset_server
579              
580             Issues the RSET command, returns true if successful, false otherwise.
581              
582             =cut
583              
584             sub reset_server {
585 5     5 1 13 shift->session->issue(Net::Gnats::Command->rset)->is_ok;
586             }
587              
588             =head2 lock_main_database
589              
590             Issues the LKDB command, returns true if successful, false otherwise.
591              
592             =cut
593              
594             sub lock_main_database {
595 0     0 1 0 shift->session->issue(Net::Gnats::Command->lkdb)->is_ok;
596             }
597              
598              
599             =head2 unlock_main_database
600              
601             Issues the UNDB command, returns true if successful, false otherwise.
602              
603             =cut
604              
605             sub unlock_main_database {
606 0     0 1 0 shift->session->issue(Net::Gnats::Command->undb)->is_ok;
607             }
608              
609             =head2 lock_pr
610              
611             Expects a PR number and user name as arguments, and issues the LOCK
612             command. Returns true if PR is successfully locked, false otherwise.
613              
614             NEW:
615             Note that the response content has the PR. If you would like the PR
616             from this response:
617              
618             my $s = $gnats->session;
619             $s->issue(Net::Gnats::Command->lock_pr( ... ))->response->as_list;
620              
621             =cut
622              
623             sub lock_pr {
624 0     0 1 0 my ( $self, $pr_number, $user ) = @_;
625 0 0 0     0 return 0 if not defined $pr_number or not defined $user;
626 0         0 $self->session->issue(Net::Gnats::Command->lock_pr(pr_number => $pr_number,
627             user => $user))->is_ok;
628             }
629              
630             =head2 unlock_pr
631              
632             Expects a PR number a sole argument, and issues the UNLK command.
633             Returns true if PR is successfully unlocked, false otherwise.
634              
635             =cut
636              
637             sub unlock_pr {
638 0     0 1 0 my ( $self, $pr_number ) = @_;
639 0 0       0 return 0 if not defined $pr_number;
640 0         0 $self->session->issue(Net::Gnats::Command->unlk(pr_number => $pr_number)
641             )->is_ok;
642             }
643              
644             =head2 delete_pr($pr)
645              
646             Expects a PR number a sole argument, and issues the DELETE command.
647             Returns true if PR is successfully deleted, false otherwise.
648              
649             =cut
650              
651             sub delete_pr {
652 2     2 1 6 my ( $self, $pr_number ) = @_;
653 2 100       8 return 0 if not defined $pr_number;
654 1         3 $self->session->issue(Net::Gnats::Command->delete_pr(pr_number => $pr_number)
655             )->is_ok;
656             }
657              
658             sub check_newpr {
659 0     0 0 0 my ( $self, $pr ) = @_;
660 0         0 $self->check_pr($pr, 'initial');
661 0         0 return;
662             }
663              
664              
665             =head2 check_pr
666              
667             Expects the text representation of a PR (see COMMON TASKS above) as
668             input and issues the CHEK initial command. Returns true if the given
669             PR is a valid entry, false otherwise.
670              
671             =cut
672              
673             sub check_pr {
674 0     0 1 0 my ( $self, $pr, $arg ) = @_;
675              
676 0         0 $self->session
677             ->issue(Net::Gnats::Command->chek( pr => $pr, type => $arg))
678             ->is_ok;
679             }
680              
681              
682             =head2 set_workingemail
683              
684             Expects an email address as sole argument, and issues the EDITADDR
685             command. Returns true if email successfully set, false otherwise.
686              
687             =cut
688              
689             sub set_workingemail {
690 0     0 1 0 my ( $self, $email ) = @_;
691 0         0 $self->session
692             ->issue(Net::Gnats::Command->editaddr(address => $email))
693             ->is_ok;
694             }
695              
696             #
697             # TODO: "text" fields are limited to 256 characters. Current gnatsd does
698             # not correctly truncate, if you enter $input is 257 characters, it will
699             # replace with an empty field. We should truncate text $input's correctly.
700              
701             =head2 truncate_field_content
702              
703             Expects a PR number, a fieldname, a replacement value, and optionally
704             a changeReason value as arguments, and issues the REPL command.
705             Returns true if field successfully replaced, false otherwise.
706              
707             If the field has requireChangeReason attribute, then the changeReason
708             must be passed in, otherwise the routine will return false.
709              
710             replaceField changes happen immediatly in the database. To change
711             multiple fields in the same PR it is more efficiant to use updatePR.
712              
713             =cut
714              
715             sub truncate_field_content {
716 0     0 1 0 my ( $self, $pr, $field, $input, $reason ) = @_;
717 0 0       0 logerror('? Error: pr not passed to replaceField')
718             if not defined $pr;
719              
720 0 0       0 logerror('? Error: field passed to replaceField')
721             if not defined $field;
722              
723 0 0       0 logerror('? Error: no input passed to replaceField')
724             if not defined $input;
725              
726             # See if this field requires a change reason.
727             # TODO: We could just enter the $input, and see if gnatsd says
728             # a reason is required, but I could not figure out how to
729             # abort at that point if no reason was given...
730 0         0 my $need_reason = $self->getFieldFlags($field, 'requireChangeReason');
731              
732 0 0 0     0 if ($need_reason and ( not defined $reason or $reason eq q{} )) {
      0        
733 0         0 logerror('No change Reason Specified');
734 0         0 return;
735             }
736              
737 0         0 my $r = $self->_do_gnats_cmd("REPL $pr $field");
738              
739 0 0       0 if ( $r->code == CODE_SEND_TEXT ) {
740 0         0 $r = $self->_do_gnats_cmd($input . LF . DOT);
741              
742 0 0       0 if ($need_reason) {
743             #warn "reason=\"$reason\"";
744             # TODO: This can choke here if we encounter a PR with a bad field like:
745             # _getGnatsdResponse: READ >>411 There is a bad value `unknown' for the field `Category'.
746 0         0 $r = $self->_do_gnats_cmd($reason . LF . DOT)
747             }
748              
749 0 0 0     0 $self->restart($r->code)
750             and return $self->replaceField($pr, $field, $input, $reason)
751             if $r->code == CODE_FILE_ERROR;
752              
753 0 0       0 if ($self->_is_code_ok($r->code)) {
754 0         0 return 1;
755             }
756 0         0 $self->_mark_error($r);
757              
758             }
759              
760 0         0 $self->_mark_error($r );
761 0         0 return;
762             }
763              
764             my $restart_time;
765              
766             sub restart {
767 0     0 0 0 my ( $self, $code ) = @_;
768              
769 0         0 my $ctime = time;
770 0 0       0 if ( defined $restart_time ) {
771 0 0       0 if ( ($ctime - $restart_time) < RESTART_CHECK_THRESHOLD ) {
772 0         0 logerror('! ERROR: Restart attempted twice in a row, 640 error must be real!');
773 0         0 return 0;
774             }
775             }
776              
777 0         0 logerror ( LF
778             . LF . '! ERROR: Recieved GNATSD code ' . $code . ', will now disconnect and'
779             . LF . 'reconnecting to gnatsd, then re-issue the command. This may cause any'
780             . LF . 'following commands to behave differently if you depended on'
781             . LF . 'things like QFMT'
782             . LF . time . LF );
783              
784 0         0 $restart_time = $ctime;
785 0         0 $self->session->gconnect;
786 0         0 return $self->session->is_connected;
787             }
788              
789             =head2 append_field_content
790              
791             Expects a PR number, a fieldname, and a append value as arguments, and
792             issues the APPN command. Returns true if field successfully appended
793             to, false otherwise.
794              
795             =cut
796              
797             sub append_field_content {
798 0     0 1 0 my ( $self, $pr, $field, $input ) = @_;
799              
800 0 0       0 logerror('? Error: pr not passed to appendField')
801             if not defined $pr;
802 0 0       0 logerror('? Error: field passed to appendField')
803             if not defined $field;
804 0 0       0 logerror('? Error: no input passed to appendField')
805             if not defined $input;
806              
807 0         0 my $r = $self->_do_gnats_cmd("APPN $pr $field");
808              
809 0 0       0 if ($self->_is_code_ok($r->code)) {
810 0         0 $r= $self->_do_gnats_cmd( $input . LF . DOT );
811 0 0       0 if ($self->_is_code_ok($r->code)) {
812 0         0 return 1;
813             } else {
814 0         0 $self->_mark_error( $r );
815             }
816             } else {
817 0         0 $self->_mark_error($r);
818             }
819 0 0 0     0 if ($r->code == CODE_FILE_ERROR and $self->restart($r->code)) {
820             # TODO: This can potentially be an infinte loop...
821 0         0 return $self->appendToField($pr, $field, $input);
822             }
823 0         0 return 0;
824             }
825              
826             =head2 submit_pr
827              
828             Expect a Gnats::PR object as sole argument, and issues the SUMB
829             command. Returns true if PR successfully submitted, false otherwise.
830              
831             DEPRECATION NOTICE: This method will be deprecated soon. Please be
832             aware that you can submit a PR from a PR object.
833              
834             $pr = $pr->submit;
835              
836             And $pr will contain the new PR number. See PR.pm for details.
837              
838             =cut
839              
840 1     1 0 5 sub submitPR { shift->submit_pr( shift ); }
841              
842             sub submit_pr {
843 2     2 1 5 my ( $self, $pr ) = @_;
844 2         6 $self->session->issue(Net::Gnats::Command->subm(pr => $pr))->is_ok;
845             }
846              
847             =head2 update_pr
848              
849             Expect a Gnats::PR object as sole argument, and issues the EDIT
850             command. Returns true if PR successfully submitted, false otherwise.
851              
852             Use this instead of replace_field if more than one field has changed.
853              
854             =cut
855              
856 2     2 0 11 sub updatePR { shift->update_pr(shift); }
857              
858             sub update_pr {
859 2     2 1 5 my ( $self, $pr ) = @_;
860 2 50       6 return 0 if not defined $pr;
861              
862 2 50       7 return 0 if not
863             $self->session
864             ->issue(Net::Gnats::Command->editaddr(address => $self->session->username))
865             ->is_ok;
866              
867 2 50       16 return 0 if not
868             $self->session
869             ->issue(Net::Gnats::Command->lock_pr(pr_number => $pr->get_field('Number')->value,
870             user => $self->session->username ))
871             ->is_ok;
872              
873 2         63 my $c = $self->session
874             ->issue(Net::Gnats::Command->edit(pr => $pr));
875              
876 2 50       6 return 0 if not
877             $self->session
878             ->issue(Net::Gnats::Command->unlk(pr_number => $pr->get_field('Number')->value))
879             ->is_ok;
880              
881 2         19 $c->is_ok;
882             }
883              
884             =head2 new_pr
885              
886             returns undef if the session is not initialized.
887              
888             =cut
889              
890             sub new_pr {
891 2     2 1 5 my ( $self ) = @_;
892              
893 2         12 my $pr = Net::Gnats::PR->new;
894              
895             # session not properly initialized, send back empty PR
896 2 50       7 return undef if not defined $self->session->schema;
897              
898 2         3 foreach my $field ( @{ $self->session->schema->fields } ) {
  2         4  
899 48         66 $pr->add_field(Net::Gnats::FieldInstance
900             ->new(schema => $self->session->schema->field($field)));
901             }
902 2         16 return $pr;
903             }
904              
905             =head2 get_pr_by_number()
906              
907             Expects a number as sole argument. Returns a Gnats::PR object.
908              
909             =cut
910              
911             sub get_pr_by_number {
912 7     7 1 1707 my ( $self, $pr_number ) = @_;
913             return undef
914 7 50       28 if not defined $pr_number;
915             return undef
916 7 50       27 if not $self->session->issue(Net::Gnats::Command->rset)->is_ok;
917             return undef
918 7 50       48 if not $self->session->issue(Net::Gnats::Command->qfmt(format => 'full'))->is_ok;
919              
920 7         43 my $raw = $self
921             ->session
922             ->issue(Net::Gnats::Command->quer(pr_numbers => [ $pr_number ]))
923             ->response->as_list;
924              
925 7         73 return Net::Gnats::PR->deserialize( data => $raw,
926             schema => $self->session->schema);
927              
928             }
929              
930              
931              
932             sub expr {
933 9     9 0 26 my $self = shift;
934 9         20 my @exprs = @_;
935 9 100       42 return 1 if scalar( @exprs ) == 0;
936 4         18 return $self
937             ->session
938             ->issue(Net::Gnats::Command->expr(expressions => \@exprs))
939             ->is_ok;
940             }
941              
942             # Because we don't know what's in the dbconfig file, we will only
943             # support FULL, STANDARD, and SUMMARY since those must be defined.
944             # Otherwise, we assume it is a custom format.
945             sub qfmt {
946 5     5 0 10 my ($self, $format) = @_;
947 5   50     11 $format = $format || 'standard';
948 5         10 return $self->session->issue(Net::Gnats::Command->qfmt(format => $format))
949             ->is_ok;
950             }
951              
952             =head2 query()
953              
954             Expects one or more query expressions as argument(s). Returns an
955             anonymous array of PR numbers.
956              
957             If there is an error, then it will return an empty set.
958              
959             =cut
960              
961             sub query {
962 5     5 1 501 my $self = shift;
963 5         12 my @exprs = @_;
964              
965 5 50       13 return [] if not $self->reset_server;
966 5 50       28 return [] if not $self->qfmt('full');
967 5 50       36 return [] if not $self->expr(@exprs);
968              
969 5         20 my $c = $self->session->issue(Net::Gnats::Command->quer);
970 5 100       18 return [] if not $c->is_ok;
971 3         9 my $r = $c->response->as_list;
972 3         5 my @numbers = grep { $_ =~ s/>Number:\s+(.*)/$1/} @{$r};
  6         33  
  3         7  
973 3         23 return \@numbers;
974             }
975              
976             =head2 login
977              
978             Expects a database name, user name, and password as arguments and
979             issues the CHDB command. Returns true if successfully logged in,
980             false otherwise.
981              
982             my $g = Net::Gnats->new;
983             $g->login('mydb', 'joe', 'joepass');
984              
985             =cut
986              
987             sub login {
988 11     11 1 59 my ( $self, $db, $username, $password ) = @_;
989 11 50 33     88 if ( not defined $password or $password eq q{} ) { $password = q{*}; }
  0         0  
990              
991 11         38 $self->session->username($username);
992 11         29 $self->session->password($password);
993 11 50       28 return 0 if not $self->session->authenticate;
994              
995 11 50       56 $self->session->database($db) if $self->session->database ne $db;
996 11 50       37 return 1 if $self->session->database eq $db;
997 0           return 0;
998             }
999              
1000             =head2 get_access_mode
1001              
1002             Returns the current access mode of the gnats database. Either "edit",
1003             "view", or undef;
1004              
1005             =cut
1006              
1007 0     0 1   sub get_access_mode { shift->session->access; }
1008              
1009             1;
1010              
1011             =head1 DIAGNOSTICS
1012              
1013             Most methods will return undef if a major error is encountered.
1014              
1015             The most recent error codes and messages which Net::Gnats encounters
1016             while communcating with gnatsd are stored, and can be accessed with
1017             the get_error_code() and get_error_message() methods.
1018              
1019             =head1 INCOMPATIBILITIES
1020              
1021             This library is not compatible with the Gnats protocol prior to GNATS
1022             4.
1023              
1024             =head1 BUGS AND LIMITATIONS
1025              
1026             Bug reports are very welcome. Please submit to the project page
1027             (noted below).
1028              
1029             =head1 CONFIGURATION AND ENVIRONMENT
1030              
1031             No externalized configuration or environment at this time.
1032              
1033             =head1 DEPENDENCIES
1034              
1035             No runtime dependencies other than the Perl core at this time.
1036              
1037             =head1 AUTHOR
1038              
1039             Current Maintainer:
1040             Richard Elberger riche@cpan.org
1041              
1042             Original Author:
1043             Mike Hoolehan, mike@sycamore.us
1044              
1045             Contributions By:
1046             Jim Searle, jims2@cox.net
1047             Project hosted at sourceforge, at http://gnatsperl.sourceforge.net
1048              
1049             =head1 LICENSE AND COPYRIGHT
1050              
1051             Copyright (c) 2014, Richard Elberger. All Rights Reserved.
1052              
1053             Copyright (c) 1997-2003, Mike Hoolehan. All Rights Reserved.
1054              
1055             This module is free software. It may be used, redistributed,
1056             and/or modified under the same terms as Perl itself.
1057              
1058             =cut