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*(.*)\s*$/,
152 outlook => qr/(?i)^outlook\s+\#?(-?\d+)\s*(.*)\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,
192 replyto => {type => SCALAR,
196 my $line = $param{line};
198 my $ctl = valid_control($line,\@matches);
199 my $transcript = $param{transcript};
200 my $debug = $param{debug};
201 if (not defined $ctl) {
203 print {$param{transcript}} "Unknown command or invalid options to control\n";
206 # in almost all cases, the first match is the bug; the exception
208 my $ref = $matches[0];
210 $ref = $param{clonebugs}{$ref} if exists $param{clonebugs}{$ref};
214 my $terminate_control = 0;
216 if ($ctl eq 'close') {
217 if (defined $matches[1]) {
219 set_fixed(@{$param{common_control_options}},
221 fixed => $matches[1],
227 print {$transcript} "Failed to add fixed version '$matches[1]' to $ref: ".cleanup_eval_fail($@,$debug)."\n";
231 set_done(@{$param{common_control_options}},
235 notify_submitter => 1,
241 print {$transcript} "Failed to mark $ref as done: ".cleanup_eval_fail($@,$debug)."\n";
243 } elsif ($ctl eq 'reassign') {
245 if (not defined $matches[1]) {
246 push @new_packages, split /\s*\,\s*/,$matches[3];
249 push @new_packages, $matches[1];
251 @new_packages = map {y/A-Z/a-z/; s/^(?:src|source):/src:/; $_;} @new_packages;
252 my $version= $matches[2];
254 set_package(@{$param{common_control_options}},
256 package => \@new_packages,
258 # if there is a version passed, we make an internal call
260 if (defined($version) && length $version) {
261 set_found(@{$param{common_control_options}},
269 print {$transcript} "Failed to clear fixed versions and reopen on $ref: ".cleanup_eval_fail($@,$debug)."\n";
271 } elsif ($ctl eq 'reopen') {
272 my $new_submitter = $matches[1];
273 if (defined $new_submitter) {
274 if ($new_submitter eq '=') {
275 undef $new_submitter;
277 elsif ($new_submitter eq '!') {
278 $new_submitter = $param{replyto};
282 set_done(@{$param{common_control_options}},
285 defined $new_submitter? (submitter => $new_submitter):(),
290 print {$transcript} "Failed to reopen $ref: ".cleanup_eval_fail($@,$debug)."\n";
292 } elsif ($ctl eq 'found') {
294 if (defined $matches[1]) {
295 @versions = split /\s*,\s*/,$matches[1];
297 set_found(@{$param{common_control_options}},
305 print {$transcript} "Failed to add found on $ref: ".cleanup_eval_fail($@,$debug)."\n";
310 set_fixed(@{$param{common_control_options}},
318 print {$transcript} "Failed to clear fixed versions and reopen on $ref: ".cleanup_eval_fail($@,$debug)."\n";
322 elsif ($ctl eq 'notfound') {
324 @versions = split /\s*,\s*/,$matches[1];
326 set_found(@{$param{common_control_options}},
334 print {$transcript} "Failed to remove found on $ref: ".cleanup_eval_fail($@,$debug)."\n";
337 elsif ($ctl eq 'fixed') {
339 @versions = split /\s*,\s*/,$matches[1];
341 set_fixed(@{$param{common_control_options}},
349 print {$transcript} "Failed to add fixed on $ref: ".cleanup_eval_fail($@,$debug)."\n";
352 elsif ($ctl eq 'notfixed') {
354 @versions = split /\s*,\s*/,$matches[1];
356 set_fixed(@{$param{common_control_options}},
364 print {$transcript} "Failed to remove fixed on $ref: ".cleanup_eval_fail($@,$debug)."\n";
367 elsif ($ctl eq 'submitter') {
368 my $newsubmitter = $matches[1] eq '!' ? $param{replyto} : $matches[1];
369 if (not Mail::RFC822::Address::valid($newsubmitter)) {
370 print {$transcript} "$newsubmitter is not a valid e-mail address; not changing submitter\n";
375 set_submitter(@{$param{common_control_options}},
377 submitter => $newsubmitter,
382 print {$transcript} "Failed to set submitter on $ref: ".cleanup_eval_fail($@,$debug)."\n";
385 } elsif ($ctl eq 'forwarded') {
386 my $forward_to= $matches[1];
388 set_forwarded(@{$param{common_control_options}},
390 forwarded => $forward_to,
395 print {$transcript} "Failed to set the forwarded-to-address of $ref: ".cleanup_eval_fail($@,$debug)."\n";
397 } elsif ($ctl eq 'notforwarded') {
399 set_forwarded(@{$param{common_control_options}},
406 print {$transcript} "Failed to clear the forwarded-to-address of $ref: ".cleanup_eval_fail($@,$debug)."\n";
408 } elsif ($ctl eq 'severity') {
409 my $newseverity= $matches[1];
410 if (exists $config{obsolete_severities}{$newseverity}) {
411 print {$transcript} "Severity level \`$newseverity' is obsolete. " .
412 "Use $config{obsolete_severities}{$newseverity} instead.\n\n";
414 } elsif (not defined first {$_ eq $newseverity}
415 (@{$config{severity_list}}, $config{default_severity})) {
416 print {$transcript} "Severity level \`$newseverity' is not known.\n".
417 "Recognized are: $config{show_severities}.\n\n";
421 set_severity(@{$param{common_control_options}},
423 severity => $newseverity,
428 print {$transcript} "Failed to set severity of $config{bug} $ref to $newseverity: ".cleanup_eval_fail($@,$debug)."\n";
431 } elsif ($ctl eq 'tag') {
432 my $tags = $matches[1];
433 my @tags = map {m/^([+=-])(.+)/ ? ($1,$2):($_)} split /[\s,]+/, $tags;
434 # this is an array of hashrefs which contain two elements, the
435 # first of which is the array of tags, the second is the
436 # option to pass to set_tag (we use a hashref here to make it
437 # more obvious what is happening)
440 for my $tag (@tags) {
441 if ($tag =~ /^[=+-]$/) {
443 @tag_operations = {tags => [],
447 elsif ($tag eq '-') {
448 push @tag_operations,
450 option => [remove => 1],
453 elsif ($tag eq '+') {
454 push @tag_operations,
456 option => [add => 1],
461 if (not defined first {$_ eq $tag} @{$config{tags}}) {
465 if (not @tag_operations) {
466 @tag_operations = {tags => [],
467 option => [add => 1],
470 push @{$tag_operations[-1]{tags}},$tag;
473 print {$transcript} "Unknown tag/s: ".join(', ', @badtags).".\n".
474 "Recognized are: ".join(' ', @{$config{tags}}).".\n\n";
478 for my $operation (@tag_operations) {
479 set_tag(@{$param{common_control_options}},
481 tag => [@{$operation->{tags}}],
482 warn_on_bad_tags => 0, # don't warn on bad tags,
483 # 'cause we do that above
484 @{$operation->{option}},
489 # we intentionally have two errors here if there is a bad
490 # tag and the above fails for some reason
492 print {$transcript} "Failed to alter tags of $config{bug} $ref: ".cleanup_eval_fail($@,$debug)."\n";
494 } elsif ($ctl eq 'block') {
495 my $add_remove = defined $matches[0] && $matches[0] eq 'un';
497 $ref = exists $param{clonebugs}{$ref} ? $param{clonebugs}{$ref} : $ref;
498 my @blockers = map {exists $param{clonebugs}{$_}?$param{clonebugs}{$_}:$_} split /[\s,]+/, $matches[2];
500 set_blocks(@{$param{common_control_options}},
503 $add_remove ? (remove => 1):(add => 1),
508 print {$transcript} "Failed to set blocking bugs of $ref: ".cleanup_eval_fail($@,$debug)."\n";
510 } elsif ($ctl eq 'retitle') {
511 my $newtitle= $matches[1];
513 set_title(@{$param{common_control_options}},
520 print {$transcript} "Failed to set the title of $ref: ".cleanup_eval_fail($@,$debug)."\n";
522 } elsif ($ctl eq 'unmerge') {
524 set_merged(@{$param{common_control_options}},
530 print {$transcript} "Failed to unmerge $ref: ".cleanup_eval_fail($@,$debug)."\n";
532 } elsif ($ctl eq 'merge') {
534 ($ref,@tomerge) = map {exists $param{clonebugs}{$_}?$param{clonebugs}{$_}:$_}
535 split(/\s+#?/,$matches[0]);
537 set_merged(@{$param{common_control_options}},
539 merge_with => \@tomerge,
544 print {$transcript} "Failed to merge $ref: ".cleanup_eval_fail($@,$debug)."\n";
546 } elsif ($ctl eq 'forcemerge') {
548 ($ref,@tomerge) = map {exists $param{clonebugs}{$_}?$param{clonebugs}{$_}:$_}
549 split(/\s+#?/,$matches[0]);
551 set_merged(@{$param{common_control_options}},
553 merge_with => \@tomerge,
560 print {$transcript} "Failed to forcibly merge $ref: ".cleanup_eval_fail($@,$debug)."\n";
562 } elsif ($ctl eq 'clone') {
563 my $origref = $matches[0];
564 my @newclonedids = split /\s+/, $matches[1];
565 my $newbugsneeded = scalar(@newclonedids);
569 clone_bug(@{$param{common_control_options}},
571 new_bugs => \@newclonedids,
572 new_clones => \%new_clones,
574 %{$param{clonebugs}} = (%{$param{clonebugs}},
579 print {$transcript} "Failed to clone $ref: ".cleanup_eval_fail($@,$debug)."\n";
581 } elsif ($ctl eq 'package') {
582 my @pkgs = split /\s+/, $matches[0];
583 if (scalar(@pkgs) > 0) {
584 $param{limit}{package} = [@pkgs];
585 print {$transcript} "Limiting to bugs with field 'package' containing at least one of ".join(', ',map {qq('$_')} @pkgs)."\n";
586 print {$transcript} "Limit currently set to";
587 for my $limit_field (keys %{$param{limit}}) {
588 print {$transcript} " '$limit_field':".join(', ',map {qq('$_')} @{$param{limit}{$limit_field}})."\n";
590 print {$transcript} "\n";
592 $param{limit}{package} = [];
593 print {$transcript} "Limit cleared.\n\n";
595 } elsif ($ctl eq 'limit') {
596 my ($field,@options) = split /\s+/, $matches[0];
598 if ($field =~ /^(?:clear|unset|blank)$/) {
599 %{$param{limit}} = ();
600 print {$transcript} "Limit cleared.\n\n";
602 elsif (exists $Debbugs::Status::fields{$field} or $field eq 'source') {
603 # %{$param{limit}} can actually contain regexes, but because they're
604 # not evaluated in Safe, DO NOT allow them through without
606 $param{limit}{$field} = [@options];
607 print {$transcript} "Limiting to bugs with field '$field' containing at least one of ".join(', ',map {qq('$_')} @options)."\n";
608 print {$transcript} "Limit currently set to";
609 for my $limit_field (keys %{$param{limit}}) {
610 print {$transcript} " '$limit_field':".join(', ',map {qq('$_')} @{$param{limit}{$limit_field}})."\n";
612 print {$transcript} "\n";
615 print {$transcript} "Limit key $field not understood. Stopping processing here.\n\n";
617 # this needs to be fixed
618 syntax error for fixing it
621 } elsif ($ctl eq 'affects') {
622 my $add_remove = $matches[1];
623 my $packages = $matches[2];
624 # if there isn't a package given, assume that we should unset
625 # affects; otherwise default to adding
626 if (not defined $packages or
627 not length $packages) {
631 elsif (not defined $add_remove or
632 not length $add_remove) {
636 affects(@{$param{common_control_options}},
638 package => [splitpackages($packages)],
639 ($add_remove eq '+'?(add => 1):()),
640 ($add_remove eq '-'?(remove => 1):()),
645 print {$transcript} "Failed to mark $ref as affecting package(s): ".cleanup_eval_fail($@,$debug)."\n";
648 } elsif ($ctl eq 'summary') {
649 my $summary_msg = length($matches[1])?$matches[1]:undef;
651 summary(@{$param{common_control_options}},
653 summary => $summary_msg,
658 print {$transcript} "Failed to give $ref a summary: ".cleanup_eval_fail($@,$debug)."\n";
661 } elsif ($ctl eq 'outlook') {
662 my $outlook_msg = length($matches[1])?$matches[1]:undef;
664 outlook(@{$param{common_control_options}},
666 outlook => $outlook_msg,
671 print {$transcript} "Failed to give $ref a outlook: ".cleanup_eval_fail($@,$debug)."\n";
674 } elsif ($ctl eq 'owner') {
675 my $newowner = $matches[1];
676 if ($newowner eq '!') {
677 $newowner = $param{replyto};
680 owner(@{$param{common_control_options}},
687 print {$transcript} "Failed to mark $ref as having an owner: ".cleanup_eval_fail($@,$debug)."\n";
689 } elsif ($ctl eq 'noowner') {
691 owner(@{$param{common_control_options}},
698 print {$transcript} "Failed to mark $ref as not having an owner: ".cleanup_eval_fail($@,$debug)."\n";
700 } elsif ($ctl eq 'unarchive') {
702 bug_unarchive(@{$param{common_control_options}},
709 } elsif ($ctl eq 'archive') {
711 bug_archive(@{$param{common_control_options}},
714 archive_unarchived => 0,
722 ${$param{errors}}+=$errors;
724 return($errors,$terminate_control);