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 Exporter qw(import);
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 Debbugs::MIME qw(encode_rfc1522);
97 use Params::Validate qw(:types validate_with);
98 use List::AllUtils qw(first);
100 my $bug_num_re = '-?\d+';
101 my %control_grammar =
102 (close => qr/(?i)^close\s+\#?($bug_num_re)(?:\s+(\d.*))?$/,
103 reassign => qr/(?i)^reassign\s+\#?($bug_num_re)\s+ # bug and command
104 (?:(?:((?:src:|source:)?$config{package_name_re}) # new package
105 (?:\s+((?:$config{package_name_re}\/)?
106 $config{package_version_re}))?)| # optional version
107 ((?:src:|source:)?$config{package_name_re} # multiple package form
108 (?:\s*\,\s*(?:src:|source:)?$config{package_name_re})+))
110 reopen => qr/(?i)^reopen\s+\#?($bug_num_re)(?:\s+([\=\!]|(?:\S.*\S)))?$/,
111 found => qr{^(?:(?i)found)\s+\#?($bug_num_re)
112 (?:\s+((?:$config{package_name_re}\/)?
113 $config{package_version_re}
114 # allow for multiple packages
115 (?:\s*,\s*(?:$config{package_name_re}\/)?
116 $config{package_version_re})*)
118 notfound => qr{^(?:(?i)notfound)\s+\#?($bug_num_re)
119 \s+((?:$config{package_name_re}\/)?
120 $config{package_version_re}
121 # allow for multiple packages
122 (?:\s*,\s*(?:$config{package_name_re}\/)?
123 $config{package_version_re})*
125 fixed => qr{^(?:(?i)fixed)\s+\#?($bug_num_re)
126 \s+((?:$config{package_name_re}\/)?
127 $config{package_version_re}
128 # allow for multiple packages
129 (?:\s*,\s*(?:$config{package_name_re}\/)?
130 $config{package_version_re})*)
132 notfixed => qr{^(?:(?i)notfixed)\s+\#?($bug_num_re)
133 \s+((?:$config{package_name_re}\/)?
134 $config{package_version_re}
135 # allow for multiple packages
136 (?:\s*,\s*(?:$config{package_name_re}\/)?
137 $config{package_version_re})*)
139 submitter => qr/(?i)^submitter\s+\#?($bug_num_re)\s+(\!|\S.*\S)$/,
140 forwarded => qr/(?i)^forwarded\s+\#?($bug_num_re)\s+(\S.*\S)$/,
141 notforwarded => qr/(?i)^notforwarded\s+\#?($bug_num_re)$/,
142 severity => qr/(?i)^(?:severity|priority)\s+\#?($bug_num_re)\s+([-0-9a-z]+)$/,
143 tag => qr/(?i)^tags?\s+\#?($bug_num_re)\s+(\S.*)$/,
144 block => qr/(?i)^(un)?block\s+\#?($bug_num_re)\s+(?:by|with)\s+(\S.*)?$/,
145 retitle => qr/(?i)^retitle\s+\#?($bug_num_re)\s+(\S.*\S)\s*$/,
146 unmerge => qr/(?i)^unmerge\s+\#?($bug_num_re)$/,
147 merge => qr/(?i)^merge\s+#?($bug_num_re(\s+#?$bug_num_re)+)\s*$/,
148 forcemerge => qr/(?i)^forcemerge\s+\#?($bug_num_re(?:\s+\#?$bug_num_re)+)\s*$/,
149 clone => qr/(?i)^clone\s+#?($bug_num_re)\s+((?:$bug_num_re\s+)*$bug_num_re)\s*$/,
150 package => qr/(?i)^package\:?\s+(\S.*\S)?\s*$/,
151 limit => qr/(?i)^limit\:?\s+(\S.*\S)\s*$/,
152 affects => qr/(?i)^affects?\s+\#?($bug_num_re)(?:\s+((?:[=+-])?)\s*(\S.*)?)?\s*$/,
153 summary => qr/(?i)^summary\s+\#?($bug_num_re)\s*(.*)\s*$/,
154 outlook => qr/(?i)^outlook\s+\#?($bug_num_re)\s*(.*)\s*$/,
155 owner => qr/(?i)^owner\s+\#?($bug_num_re)\s+((?:\S.*\S)|\!)\s*$/,
156 noowner => qr/(?i)^noowner\s+\#?($bug_num_re)\s*$/,
157 unarchive => qr/(?i)^unarchive\s+#?($bug_num_re)$/,
158 archive => qr/(?i)^archive\s+#?($bug_num_re)$/,
162 my ($line,$matches) = @_;
164 for my $ctl (keys %control_grammar) {
165 if (@matches = $line =~ $control_grammar{$ctl}) {
166 @{$matches} = @matches if defined $matches and ref($matches) eq 'ARRAY';
170 @{$matches} = () if defined $matches and ref($matches) eq 'ARRAY';
176 validate_with(params => \@_,
177 spec => {line => {type => SCALAR,
179 clonebugs => {type => HASHREF,
181 common_control_options => {type => ARRAYREF,
183 errors => {type => SCALARREF,
185 transcript => {type => HANDLE,
187 debug => {type => SCALAR,
190 ok => {type => SCALARREF,
192 limit => {type => HASHREF,
194 replyto => {type => SCALAR,
198 my $line = $param{line};
200 my $ctl = valid_control($line,\@matches);
201 my $transcript = $param{transcript};
202 my $debug = $param{debug};
203 if (not defined $ctl) {
205 print {$param{transcript}} "Unknown command or invalid options to control\n";
208 # in almost all cases, the first match is the bug; the exception
210 my $ref = $matches[0];
212 $ref = $param{clonebugs}{$ref} if exists $param{clonebugs}{$ref};
216 my $terminate_control = 0;
218 if ($ctl eq 'close') {
219 if (defined $matches[1]) {
221 set_fixed(@{$param{common_control_options}},
223 fixed => $matches[1],
229 print {$transcript} "Failed to add fixed version '$matches[1]' to $ref: ".cleanup_eval_fail($@,$debug)."\n";
233 set_done(@{$param{common_control_options}},
237 notify_submitter => 1,
243 print {$transcript} "Failed to mark $ref as done: ".cleanup_eval_fail($@,$debug)."\n";
245 } elsif ($ctl eq 'reassign') {
247 if (not defined $matches[1]) {
248 push @new_packages, split /\s*\,\s*/,$matches[3];
251 push @new_packages, $matches[1];
253 @new_packages = map {y/A-Z/a-z/; s/^(?:src|source):/src:/; $_;} @new_packages;
254 my $version= $matches[2];
256 set_package(@{$param{common_control_options}},
258 package => \@new_packages,
260 # if there is a version passed, we make an internal call
262 if (defined($version) && length $version) {
263 set_found(@{$param{common_control_options}},
271 print {$transcript} "Failed to clear fixed versions and reopen on $ref: ".cleanup_eval_fail($@,$debug)."\n";
273 } elsif ($ctl eq 'reopen') {
274 my $new_submitter = $matches[1];
275 if (defined $new_submitter) {
276 if ($new_submitter eq '=') {
277 undef $new_submitter;
279 elsif ($new_submitter eq '!') {
280 $new_submitter = $param{replyto};
284 set_done(@{$param{common_control_options}},
287 defined $new_submitter? (submitter => $new_submitter):(),
292 print {$transcript} "Failed to reopen $ref: ".cleanup_eval_fail($@,$debug)."\n";
294 } elsif ($ctl eq 'found') {
296 if (defined $matches[1]) {
297 @versions = split /\s*,\s*/,$matches[1];
299 set_found(@{$param{common_control_options}},
307 print {$transcript} "Failed to add found on $ref: ".cleanup_eval_fail($@,$debug)."\n";
312 set_fixed(@{$param{common_control_options}},
320 print {$transcript} "Failed to clear fixed versions and reopen on $ref: ".cleanup_eval_fail($@,$debug)."\n";
324 elsif ($ctl eq 'notfound') {
326 @versions = split /\s*,\s*/,$matches[1];
328 set_found(@{$param{common_control_options}},
336 print {$transcript} "Failed to remove found on $ref: ".cleanup_eval_fail($@,$debug)."\n";
339 elsif ($ctl eq 'fixed') {
341 @versions = split /\s*,\s*/,$matches[1];
343 set_fixed(@{$param{common_control_options}},
351 print {$transcript} "Failed to add fixed on $ref: ".cleanup_eval_fail($@,$debug)."\n";
354 elsif ($ctl eq 'notfixed') {
356 @versions = split /\s*,\s*/,$matches[1];
358 set_fixed(@{$param{common_control_options}},
366 print {$transcript} "Failed to remove fixed on $ref: ".cleanup_eval_fail($@,$debug)."\n";
369 elsif ($ctl eq 'submitter') {
370 my $newsubmitter = $matches[1] eq '!' ? $param{replyto} : $matches[1];
371 if (not Mail::RFC822::Address::valid(encode_rfc1522($newsubmitter))) {
372 print {$transcript} "$newsubmitter is not a valid e-mail address; not changing submitter\n";
377 set_submitter(@{$param{common_control_options}},
379 submitter => $newsubmitter,
384 print {$transcript} "Failed to set submitter on $ref: ".cleanup_eval_fail($@,$debug)."\n";
387 } elsif ($ctl eq 'forwarded') {
388 my $forward_to= $matches[1];
390 set_forwarded(@{$param{common_control_options}},
392 forwarded => $forward_to,
397 print {$transcript} "Failed to set the forwarded-to-address of $ref: ".cleanup_eval_fail($@,$debug)."\n";
399 } elsif ($ctl eq 'notforwarded') {
401 set_forwarded(@{$param{common_control_options}},
408 print {$transcript} "Failed to clear the forwarded-to-address of $ref: ".cleanup_eval_fail($@,$debug)."\n";
410 } elsif ($ctl eq 'severity') {
411 my $newseverity= $matches[1];
412 if (exists $config{obsolete_severities}{$newseverity}) {
413 print {$transcript} "Severity level \`$newseverity' is obsolete. " .
414 "Use $config{obsolete_severities}{$newseverity} instead.\n\n";
416 } elsif (not defined first {$_ eq $newseverity}
417 (@{$config{severity_list}}, $config{default_severity})) {
418 print {$transcript} "Severity level \`$newseverity' is not known.\n".
419 "Recognized are: $config{show_severities}.\n\n";
423 set_severity(@{$param{common_control_options}},
425 severity => $newseverity,
430 print {$transcript} "Failed to set severity of $config{bug} $ref to $newseverity: ".cleanup_eval_fail($@,$debug)."\n";
433 } elsif ($ctl eq 'tag') {
434 my $tags = $matches[1];
435 my @tags = map {m/^([+=-])(.+)/ ? ($1,$2):($_)} split /[\s,]+/, $tags;
436 # this is an array of hashrefs which contain two elements, the
437 # first of which is the array of tags, the second is the
438 # option to pass to set_tag (we use a hashref here to make it
439 # more obvious what is happening)
442 for my $tag (@tags) {
443 if ($tag =~ /^[=+-]$/) {
445 @tag_operations = {tags => [],
449 elsif ($tag eq '-') {
450 push @tag_operations,
452 option => [remove => 1],
455 elsif ($tag eq '+') {
456 push @tag_operations,
458 option => [add => 1],
463 if (not defined first {$_ eq $tag} @{$config{tags}}) {
467 if (not @tag_operations) {
468 @tag_operations = {tags => [],
469 option => [add => 1],
472 push @{$tag_operations[-1]{tags}},$tag;
475 print {$transcript} "Unknown tag/s: ".join(', ', @badtags).".\n".
476 "Recognized are: ".join(' ', @{$config{tags}}).".\n\n";
480 for my $operation (@tag_operations) {
481 set_tag(@{$param{common_control_options}},
483 tag => [@{$operation->{tags}}],
484 warn_on_bad_tags => 0, # don't warn on bad tags,
485 # 'cause we do that above
486 @{$operation->{option}},
491 # we intentionally have two errors here if there is a bad
492 # tag and the above fails for some reason
494 print {$transcript} "Failed to alter tags of $config{bug} $ref: ".cleanup_eval_fail($@,$debug)."\n";
496 } elsif ($ctl eq 'block') {
497 my $add_remove = defined $matches[0] && $matches[0] eq 'un';
499 $ref = exists $param{clonebugs}{$ref} ? $param{clonebugs}{$ref} : $ref;
500 my @blockers = map {exists $param{clonebugs}{$_}?$param{clonebugs}{$_}:$_} split /[\s,]+/, $matches[2];
502 set_blocks(@{$param{common_control_options}},
505 $add_remove ? (remove => 1):(add => 1),
510 print {$transcript} "Failed to set blocking bugs of $ref: ".cleanup_eval_fail($@,$debug)."\n";
512 } elsif ($ctl eq 'retitle') {
513 my $newtitle= $matches[1];
515 set_title(@{$param{common_control_options}},
522 print {$transcript} "Failed to set the title of $ref: ".cleanup_eval_fail($@,$debug)."\n";
524 } elsif ($ctl eq 'unmerge') {
526 set_merged(@{$param{common_control_options}},
532 print {$transcript} "Failed to unmerge $ref: ".cleanup_eval_fail($@,$debug)."\n";
534 } elsif ($ctl eq 'merge') {
536 ($ref,@tomerge) = map {exists $param{clonebugs}{$_}?$param{clonebugs}{$_}:$_}
537 split(/\s+#?/,$matches[0]);
539 set_merged(@{$param{common_control_options}},
541 merge_with => \@tomerge,
546 print {$transcript} "Failed to merge $ref: ".cleanup_eval_fail($@,$debug)."\n";
548 } elsif ($ctl eq 'forcemerge') {
550 ($ref,@tomerge) = map {exists $param{clonebugs}{$_}?$param{clonebugs}{$_}:$_}
551 split(/\s+#?/,$matches[0]);
553 set_merged(@{$param{common_control_options}},
555 merge_with => \@tomerge,
562 print {$transcript} "Failed to forcibly merge $ref: ".cleanup_eval_fail($@,$debug)."\n";
564 } elsif ($ctl eq 'clone') {
565 my @newclonedids = split /\s+/, $matches[1];
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);