1 # This module is part of debbugs, and is released
2 # under the terms of the GPL version 2, or any later
3 # version at your option.
4 # See the file README and COPYING for more information.
6 # [Other people have contributed to this file; their copyrights should
8 # Copyright 2007,2008,2009 by Don Armstrong <don@donarmstrong.com>.
10 package Debbugs::Control::Service;
14 Debbugs::Control::Service -- Handles the modification parts of scripts/service by calling Debbugs::Control
18 use Debbugs::Control::Service;
23 This module contains the code to implement the grammar of control@. It
24 is abstracted here so that it can be called from process at submit
27 All of the public functions take the following options:
31 =item debug -- scalar reference to which debbuging information is
34 =item transcript -- scalar reference to which transcript information
37 =item affected_bugs -- hashref which is updated with bugs affected by
43 Functions which should (probably) append to the .log file take the
48 =item requester -- Email address of the individual who requested the change
50 =item request_addr -- Address to which the request was sent
52 =item request_nn -- Name of queue file which caused this request
54 =item request_msgid -- Message id of message which caused this request
56 =item location -- Optional location; currently ignored but may be
57 supported in the future for updating archived bugs upon archival
59 =item message -- The original message which caused the action to be taken
61 =item append_log -- Whether or not to append information to the log.
65 B<append_log> (for most functions) is a special option. When set to
66 false, no appending to the log is done at all. When it is not present,
67 the above information is faked, and appended to the log file. When it
68 is true, the above options must be present, and their values are used.
71 =head1 GENERAL FUNCTIONS
77 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
78 use base qw(Exporter);
82 $DEBUG = 0 unless defined $DEBUG;
85 %EXPORT_TAGS = (control => [qw(control_line valid_control)],
88 Exporter::export_ok_tags(keys %EXPORT_TAGS);
89 $EXPORT_TAGS{all} = [@EXPORT_OK];
92 use Debbugs::Config qw(:config);
93 use Debbugs::Common qw(cleanup_eval_fail);
94 use Debbugs::Control qw(:all);
95 use Debbugs::Status qw(splitpackages);
96 use Params::Validate qw(:types validate_with);
97 use List::Util qw(first);
100 (close => qr/(?i)^close\s+\#?(-?\d+)(?:\s+(\d.*))?$/,
101 reassign => qr/(?i)^reassign\s+\#?(-?\d+)\s+ # bug and command
102 (?:(?:((?:src:|source:)?$config{package_name_re}) # new package
103 (?:\s+((?:$config{package_name_re}\/)?
104 $config{package_version_re}))?)| # optional version
105 ((?:src:|source:)?$config{package_name_re} # multiple package form
106 (?:\s*\,\s*(?:src:|source:)?$config{package_name_re})+))
108 reopen => qr/(?i)^reopen\s+\#?(-?\d+)(?:\s+([\=\!]|(?:\S.*\S)))?$/,
109 found => qr{^(?:(?i)found)\s+\#?(-?\d+)
110 (?:\s+((?:$config{package_name_re}\/)?
111 $config{package_version_re}
112 # allow for multiple packages
113 (?:\s*,\s*(?:$config{package_name_re}\/)?
114 $config{package_version_re})*)
116 notfound => qr{^(?:(?i)notfound)\s+\#?(-?\d+)
117 \s+((?:$config{package_name_re}\/)?
118 $config{package_version_re}
119 # allow for multiple packages
120 (?:\s*,\s*(?:$config{package_name_re}\/)?
121 $config{package_version_re})*
123 fixed => qr{^(?:(?i)fixed)\s+\#?(-?\d+)
124 \s+((?:$config{package_name_re}\/)?
125 $config{package_version_re}
126 # allow for multiple packages
127 (?:\s*,\s*(?:$config{package_name_re}\/)?
128 $config{package_version_re})*)
130 notfixed => qr{^(?:(?i)notfixed)\s+\#?(-?\d+)
131 \s+((?:$config{package_name_re}\/)?
132 $config{package_version_re}
133 # allow for multiple packages
134 (?:\s*,\s*(?:$config{package_name_re}\/)?
135 $config{package_version_re})*)
137 submitter => qr/(?i)^submitter\s+\#?(-?\d+)\s+(\!|\S.*\S)$/,
138 forwarded => qr/(?i)^forwarded\s+\#?(-?\d+)\s+(\S.*\S)$/,
139 notforwarded => qr/(?i)^notforwarded\s+\#?(-?\d+)$/,
140 severity => qr/(?i)^(?:severity|priority)\s+\#?(-?\d+)\s+([-0-9a-z]+)$/,
141 tag => qr/(?i)^tags?\s+\#?(-?\d+)\s+(\S.*)$/,
142 block => qr/(?i)^(un)?block\s+\#?(-?\d+)\s+(?:by|with)\s+(\S.*)?$/,
143 retitle => qr/(?i)^retitle\s+\#?(-?\d+)\s+(\S.*\S)\s*$/,
144 unmerge => qr/(?i)^unmerge\s+\#?(-?\d+)$/,
145 merge => qr/(?i)^merge\s+#?(-?\d+(\s+#?-?\d+)+)\s*$/,
146 forcemerge => qr/(?i)^forcemerge\s+\#?(-?\d+(?:\s+\#?-?\d+)+)\s*$/,
147 clone => qr/(?i)^clone\s+#?(\d+)\s+((-\d+\s+)*-\d+)\s*$/,
148 package => qr/(?i)^package\:?\s+(\S.*\S)?\s*$/,
149 limit => qr/(?i)^limit\:?\s+(\S.*\S)\s*$/,
150 affects => qr/(?i)^affects?\s+\#?(-?\d+)(?:\s+((?:[=+-])?)\s*(\S.*)?)?\s*$/,
151 summary => qr/(?i)^summary\s+\#?(-?\d+)\s*(\d+|)\s*$/,
152 outlook => qr/(?i)^outlook\s+\#?(-?\d+)\s*(\d+|)\s*$/,
153 owner => qr/(?i)^owner\s+\#?(-?\d+)\s+((?:\S.*\S)|\!)\s*$/,
154 noowner => qr/(?i)^noowner\s+\#?(-?\d+)\s*$/,
155 unarchive => qr/(?i)^unarchive\s+#?(\d+)$/,
156 archive => qr/(?i)^archive\s+#?(\d+)$/,
160 my ($line,$matches) = @_;
162 for my $ctl (keys %control_grammar) {
163 if (@matches = $line =~ $control_grammar{$ctl}) {
164 @{$matches} = @matches if defined $matches and ref($matches) eq 'ARRAY';
168 @{$matches} = () if defined $matches and ref($matches) eq 'ARRAY';
174 validate_with(params => \@_,
175 spec => {line => {type => SCALAR,
177 clonebugs => {type => HASHREF,
179 common_control_options => {type => ARRAYREF,
181 errors => {type => SCALARREF,
183 transcript => {type => HANDLE,
185 debug => {type => SCALAR,
188 ok => {type => SCALARREF,
190 limit => {type => HASHREF,
194 my $line = $param{line};
196 my $ctl = valid_control($line,\@matches);
197 my $transcript = $param{transcript};
198 my $debug = $param{debug};
199 if (not defined $ctl) {
201 print {$param{transcript}} "Unknown command or invalid options to control\n";
204 # in almost all cases, the first match is the bug; the exception
206 my $ref = $matches[0];
208 $ref = $param{clonebugs}{$ref} if exists $param{clonebugs}{$ref};
212 my $terminate_control = 0;
214 if ($ctl eq 'close') {
215 if (defined $matches[1]) {
217 set_fixed(@{$param{common_control_options}},
219 fixed => $matches[1],
225 print {$transcript} "Failed to add fixed version '$matches[1]' to $ref: ".cleanup_eval_fail($@,$debug)."\n";
229 set_done(@{$param{common_control_options}},
233 notify_submitter => 1,
239 print {$transcript} "Failed to mark $ref as done: ".cleanup_eval_fail($@,$debug)."\n";
241 } elsif ($ctl eq 'reassign') {
243 if (not defined $matches[1]) {
244 push @new_packages, split /\s*\,\s*/,$matches[3];
247 push @new_packages, $matches[1];
249 @new_packages = map {y/A-Z/a-z/; s/^(?:src|source):/src:/; $_;} @new_packages;
250 my $version= $matches[2];
252 set_package(@{$param{common_control_options}},
254 package => \@new_packages,
256 # if there is a version passed, we make an internal call
258 if (defined($version) && length $version) {
259 set_found(@{$param{common_control_options}},
267 print {$transcript} "Failed to clear fixed versions and reopen on $ref: ".cleanup_eval_fail($@,$debug)."\n";
269 } elsif ($ctl eq 'reopen') {
270 my $new_submitter = $matches[1];
271 if (defined $new_submitter) {
272 if ($new_submitter eq '=') {
273 undef $new_submitter;
275 elsif ($new_submitter eq '!') {
276 $new_submitter = $param{replyto};
280 set_done(@{$param{common_control_options}},
283 defined $new_submitter? (submitter => $new_submitter):(),
288 print {$transcript} "Failed to reopen $ref: ".cleanup_eval_fail($@,$debug)."\n";
290 } elsif ($ctl eq 'found') {
292 if (defined $matches[1]) {
293 @versions = split /\s*,\s*/,$matches[1];
295 set_found(@{$param{common_control_options}},
303 print {$transcript} "Failed to add found on $ref: ".cleanup_eval_fail($@,$debug)."\n";
308 set_fixed(@{$param{common_control_options}},
316 print {$transcript} "Failed to clear fixed versions and reopen on $ref: ".cleanup_eval_fail($@,$debug)."\n";
320 elsif ($ctl eq 'notfound') {
322 @versions = split /\s*,\s*/,$matches[1];
324 set_found(@{$param{common_control_options}},
332 print {$transcript} "Failed to remove found on $ref: ".cleanup_eval_fail($@,$debug)."\n";
335 elsif ($ctl eq 'fixed') {
337 @versions = split /\s*,\s*/,$matches[1];
339 set_fixed(@{$param{common_control_options}},
347 print {$transcript} "Failed to add fixed on $ref: ".cleanup_eval_fail($@,$debug)."\n";
350 elsif ($ctl eq 'notfixed') {
352 @versions = split /\s*,\s*/,$matches[1];
354 set_fixed(@{$param{common_control_options}},
362 print {$transcript} "Failed to remove fixed on $ref: ".cleanup_eval_fail($@,$debug)."\n";
365 elsif ($ctl eq 'submitter') {
366 my $newsubmitter = $matches[1] eq '!' ? $param{replyto} : $matches[1];
367 if (not Mail::RFC822::Address::valid($newsubmitter)) {
368 print {$transcript} "$newsubmitter is not a valid e-mail address; not changing submitter\n";
373 set_submitter(@{$param{common_control_options}},
375 submitter => $newsubmitter,
380 print {$transcript} "Failed to set submitter on $ref: ".cleanup_eval_fail($@,$debug)."\n";
383 } elsif ($ctl eq 'forwarded') {
384 my $forward_to= $matches[1];
386 set_forwarded(@{$param{common_control_options}},
388 forwarded => $forward_to,
393 print {$transcript} "Failed to set the forwarded-to-address of $ref: ".cleanup_eval_fail($@,$debug)."\n";
395 } elsif ($ctl eq 'notforwarded') {
397 set_forwarded(@{$param{common_control_options}},
404 print {$transcript} "Failed to clear the forwarded-to-address of $ref: ".cleanup_eval_fail($@,$debug)."\n";
406 } elsif ($ctl eq 'severity') {
407 my $newseverity= $matches[1];
408 if (exists $config{obsolete_severities}{$newseverity}) {
409 print {$transcript} "Severity level \`$newseverity' is obsolete. " .
410 "Use $config{obsolete_severities}{$newseverity} instead.\n\n";
412 } elsif (not defined first {$_ eq $newseverity}
413 (@{$config{severity_list}}, $config{default_severity})) {
414 print {$transcript} "Severity level \`$newseverity' is not known.\n".
415 "Recognized are: $config{show_severities}.\n\n";
419 set_severity(@{$param{common_control_options}},
421 severity => $newseverity,
426 print {$transcript} "Failed to set severity of $config{bug} $ref to $newseverity: ".cleanup_eval_fail($@,$debug)."\n";
429 } elsif ($ctl eq 'tag') {
430 my $tags = $matches[1];
431 my @tags = map {m/^([+=-])(.+)/ ? ($1,$2):($_)} split /[\s,]+/, $tags;
432 # this is an array of hashrefs which contain two elements, the
433 # first of which is the array of tags, the second is the
434 # option to pass to set_tag (we use a hashref here to make it
435 # more obvious what is happening)
438 for my $tag (@tags) {
439 if ($tag =~ /^[=+-]$/) {
441 @tag_operations = {tags => [],
445 elsif ($tag eq '-') {
446 push @tag_operations,
448 option => [remove => 1],
451 elsif ($tag eq '+') {
452 push @tag_operations,
454 option => [add => 1],
459 if (not defined first {$_ eq $tag} @{$config{tags}}) {
463 if (not @tag_operations) {
464 @tag_operations = {tags => [],
465 option => [add => 1],
468 push @{$tag_operations[-1]{tags}},$tag;
471 print {$transcript} "Unknown tag/s: ".join(', ', @badtags).".\n".
472 "Recognized are: ".join(' ', @{$config{tags}}).".\n\n";
476 for my $operation (@tag_operations) {
477 set_tag(@{$param{common_control_options}},
479 tag => [@{$operation->{tags}}],
480 warn_on_bad_tags => 0, # don't warn on bad tags,
481 # 'cause we do that above
482 @{$operation->{option}},
487 # we intentionally have two errors here if there is a bad
488 # tag and the above fails for some reason
490 print {$transcript} "Failed to alter tags of $config{bug} $ref: ".cleanup_eval_fail($@,$debug)."\n";
492 } elsif ($ctl eq 'block') {
493 my $add_remove = defined $matches[0] && $matches[0] eq 'un';
495 $ref = exists $param{clonebugs}{$ref} ? $param{clonebugs}{$ref} : $ref;
496 my @blockers = map {exists $param{clonebugs}{$_}?$param{clonebugs}{$_}:$_} split /[\s,]+/, $matches[2];
498 set_blocks(@{$param{common_control_options}},
501 $add_remove ? (remove => 1):(add => 1),
506 print {$transcript} "Failed to set blocking bugs of $ref: ".cleanup_eval_fail($@,$debug)."\n";
508 } elsif ($ctl eq 'retitle') {
509 my $newtitle= $matches[1];
511 set_title(@{$param{common_control_options}},
518 print {$transcript} "Failed to set the title of $ref: ".cleanup_eval_fail($@,$debug)."\n";
520 } elsif ($ctl eq 'unmerge') {
522 set_merged(@{$param{common_control_options}},
528 print {$transcript} "Failed to unmerge $ref: ".cleanup_eval_fail($@,$debug)."\n";
530 } elsif ($ctl eq 'merge') {
532 ($ref,@tomerge) = map {exists $param{clonebugs}{$_}?$param{clonebugs}{$_}:$_}
533 split(/\s+#?/,$matches[0]);
535 set_merged(@{$param{common_control_options}},
537 merge_with => \@tomerge,
542 print {$transcript} "Failed to merge $ref: ".cleanup_eval_fail($@,$debug)."\n";
544 } elsif ($ctl eq 'forcemerge') {
546 ($ref,@tomerge) = map {exists $param{clonebugs}{$_}?$param{clonebugs}{$_}:$_}
547 split(/\s+#?/,$matches[0]);
549 set_merged(@{$param{common_control_options}},
551 merge_with => \@tomerge,
558 print {$transcript} "Failed to forcibly merge $ref: ".cleanup_eval_fail($@,$debug)."\n";
560 } elsif ($ctl eq 'clone') {
561 my $origref = $matches[0];
562 my @newclonedids = split /\s+/, $matches[1];
563 my $newbugsneeded = scalar(@newclonedids);
567 clone_bug(@{$param{common_control_options}},
569 new_bugs => \@newclonedids,
570 new_clones => \%new_clones,
572 %{$param{clonebugs}} = (%{$param{clonebugs}},
577 print {$transcript} "Failed to clone $ref: ".cleanup_eval_fail($@,$debug)."\n";
579 } elsif ($ctl eq 'package') {
580 my @pkgs = split /\s+/, $matches[0];
581 if (scalar(@pkgs) > 0) {
582 $param{limit}{package} = [@pkgs];
583 print {$transcript} "Limiting to bugs with field 'package' containing at least one of ".join(', ',map {qq('$_')} @pkgs)."\n";
584 print {$transcript} "Limit currently set to";
585 for my $limit_field (keys %{$param{limit}}) {
586 print {$transcript} " '$limit_field':".join(', ',map {qq('$_')} @{$param{limit}{$limit_field}})."\n";
588 print {$transcript} "\n";
590 $param{limit}{package} = [];
591 print {$transcript} "Limit cleared.\n\n";
593 } elsif ($ctl eq 'limit') {
594 my ($field,@options) = split /\s+/, $matches[0];
596 if ($field =~ /^(?:clear|unset|blank)$/) {
597 %{$param{limit}} = ();
598 print {$transcript} "Limit cleared.\n\n";
600 elsif (exists $Debbugs::Status::fields{$field} or $field eq 'source') {
601 # %{$param{limit}} can actually contain regexes, but because they're
602 # not evaluated in Safe, DO NOT allow them through without
604 $param{limit}{$field} = [@options];
605 print {$transcript} "Limiting to bugs with field '$field' containing at least one of ".join(', ',map {qq('$_')} @options)."\n";
606 print {$transcript} "Limit currently set to";
607 for my $limit_field (keys %{$param{limit}}) {
608 print {$transcript} " '$limit_field':".join(', ',map {qq('$_')} @{$param{limit}{$limit_field}})."\n";
610 print {$transcript} "\n";
613 print {$transcript} "Limit key $field not understood. Stopping processing here.\n\n";
615 # this needs to be fixed
616 syntax error for fixing it
619 } elsif ($ctl eq 'affects') {
620 my $add_remove = $matches[1];
621 my $packages = $matches[2];
622 # if there isn't a package given, assume that we should unset
623 # affects; otherwise default to adding
624 if (not defined $packages or
625 not length $packages) {
629 elsif (not defined $add_remove or
630 not length $add_remove) {
634 affects(@{$param{common_control_options}},
636 package => [splitpackages($packages)],
637 ($add_remove eq '+'?(add => 1):()),
638 ($add_remove eq '-'?(remove => 1):()),
643 print {$transcript} "Failed to mark $ref as affecting package(s): ".cleanup_eval_fail($@,$debug)."\n";
646 } elsif ($ctl eq 'summary') {
647 my $summary_msg = length($matches[1])?$matches[1]:undef;
649 summary(@{$param{common_control_options}},
651 summary => $summary_msg,
656 print {$transcript} "Failed to give $ref a summary: ".cleanup_eval_fail($@,$debug)."\n";
659 } elsif ($ctl eq 'outlook') {
660 my $outlook_msg = length($matches[1])?$matches[1]:undef;
662 outlook(@{$param{common_control_options}},
664 outlook => $outlook_msg,
669 print {$transcript} "Failed to give $ref a outlook: ".cleanup_eval_fail($@,$debug)."\n";
672 } elsif ($ctl eq 'owner') {
673 my $newowner = $matches[1];
674 if ($newowner eq '!') {
675 $newowner = $param{replyto};
678 owner(@{$param{common_control_options}},
685 print {$transcript} "Failed to mark $ref as having an owner: ".cleanup_eval_fail($@,$debug)."\n";
687 } elsif ($ctl eq 'noowner') {
689 owner(@{$param{common_control_options}},
696 print {$transcript} "Failed to mark $ref as not having an owner: ".cleanup_eval_fail($@,$debug)."\n";
698 } elsif ($ctl eq 'unarchive') {
700 bug_unarchive(@{$param{common_control_options}},
707 } elsif ($ctl eq 'archive') {
709 bug_archive(@{$param{common_control_options}},
712 archive_unarchived => 0,
720 ${$param{errors}}+=$errors;
722 return($errors,$terminate_control);