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 owner => qr/(?i)^owner\s+\#?(-?\d+)\s+((?:\S.*\S)|\!)\s*$/,
153 noowner => qr/(?i)^noowner\s+\#?(-?\d+)\s*$/,
154 unarchive => qr/(?i)^unarchive\s+#?(\d+)$/,
155 archive => qr/(?i)^archive\s+#?(\d+)$/,
159 my ($line,$matches) = @_;
161 for my $ctl (keys %control_grammar) {
162 if (@matches = $line =~ $control_grammar{$ctl}) {
163 @{$matches} = @matches if defined $matches and ref($matches) eq 'ARRAY';
167 @{$matches} = () if defined $matches and ref($matches) eq 'ARRAY';
173 validate_with(params => \@_,
174 spec => {line => {type => SCALAR,
176 clonebugs => {type => HASHREF,
178 common_control_options => {type => ARRAYREF,
180 errors => {type => SCALARREF,
182 transcript => {type => HANDLE,
184 debug => {type => SCALAR,
187 ok => {type => SCALARREF,
189 limit => {type => HASHREF,
193 my $line = $param{line};
195 my $ctl = valid_control($line,\@matches);
196 my $transcript = $param{transcript};
197 my $debug = $param{debug};
198 if (not defined $ctl) {
200 print {$param{transcript}} "Unknown command or invalid options to control\n";
203 # in almost all cases, the first match is the bug; the exception
205 my $ref = $matches[0];
207 $ref = $param{clonebugs}{$ref} if exists $param{clonebugs}{$ref};
211 my $terminate_control = 0;
213 if ($ctl eq 'close') {
214 if (defined $matches[1]) {
216 set_fixed(@{$param{common_control_options}},
218 fixed => $matches[1],
224 print {$transcript} "Failed to add fixed version '$matches[1]' to $ref: ".cleanup_eval_fail($@,$debug)."\n";
228 set_done(@{$param{common_control_options}},
232 notify_submitter => 1,
238 print {$transcript} "Failed to mark $ref as done: ".cleanup_eval_fail($@,$debug)."\n";
240 } elsif ($ctl eq 'reassign') {
242 if (not defined $matches[1]) {
243 push @new_packages, split /\s*\,\s*/,$matches[3];
246 push @new_packages, $matches[1];
248 @new_packages = map {y/A-Z/a-z/; s/^(?:src|source):/src:/; $_;} @new_packages;
249 my $version= $matches[2];
251 set_package(@{$param{common_control_options}},
253 package => \@new_packages,
255 # if there is a version passed, we make an internal call
257 if (defined($version) && length $version) {
258 set_found(@{$param{common_control_options}},
266 print {$transcript} "Failed to clear fixed versions and reopen on $ref: ".cleanup_eval_fail($@,$debug)."\n";
268 } elsif ($ctl eq 'reopen') {
269 my $new_submitter = $matches[1];
270 if (defined $new_submitter) {
271 if ($new_submitter eq '=') {
272 undef $new_submitter;
274 elsif ($new_submitter eq '!') {
275 $new_submitter = $param{replyto};
279 set_done(@{$param{common_control_options}},
282 defined $new_submitter? (submitter => $new_submitter):(),
287 print {$transcript} "Failed to reopen $ref: ".cleanup_eval_fail($@,$debug)."\n";
289 } elsif ($ctl eq 'found') {
291 if (defined $matches[1]) {
292 @versions = split /\s*,\s*/,$matches[1];
294 set_found(@{$param{common_control_options}},
302 print {$transcript} "Failed to add found on $ref: ".cleanup_eval_fail($@,$debug)."\n";
307 set_fixed(@{$param{common_control_options}},
315 print {$transcript} "Failed to clear fixed versions and reopen on $ref: ".cleanup_eval_fail($@,$debug)."\n";
319 elsif ($ctl eq 'notfound') {
321 @versions = split /\s*,\s*/,$matches[1];
323 set_found(@{$param{common_control_options}},
331 print {$transcript} "Failed to remove found on $ref: ".cleanup_eval_fail($@,$debug)."\n";
334 elsif ($ctl eq 'fixed') {
336 @versions = split /\s*,\s*/,$matches[1];
338 set_fixed(@{$param{common_control_options}},
346 print {$transcript} "Failed to add fixed on $ref: ".cleanup_eval_fail($@,$debug)."\n";
349 elsif ($ctl eq 'notfixed') {
351 @versions = split /\s*,\s*/,$matches[1];
353 set_fixed(@{$param{common_control_options}},
361 print {$transcript} "Failed to remove fixed on $ref: ".cleanup_eval_fail($@,$debug)."\n";
364 elsif ($ctl eq 'submitter') {
365 my $newsubmitter = $matches[1] eq '!' ? $param{replyto} : $matches[1];
366 if (not Mail::RFC822::Address::valid($newsubmitter)) {
367 print {$transcript} "$newsubmitter is not a valid e-mail address; not changing submitter\n";
372 set_submitter(@{$param{common_control_options}},
374 submitter => $newsubmitter,
379 print {$transcript} "Failed to set submitter on $ref: ".cleanup_eval_fail($@,$debug)."\n";
382 } elsif ($ctl eq 'forwarded') {
383 my $forward_to= $matches[1];
385 set_forwarded(@{$param{common_control_options}},
387 forwarded => $forward_to,
392 print {$transcript} "Failed to set the forwarded-to-address of $ref: ".cleanup_eval_fail($@,$debug)."\n";
394 } elsif ($ctl eq 'notforwarded') {
396 set_forwarded(@{$param{common_control_options}},
403 print {$transcript} "Failed to clear the forwarded-to-address of $ref: ".cleanup_eval_fail($@,$debug)."\n";
405 } elsif ($ctl eq 'severity') {
406 my $newseverity= $matches[1];
407 if (exists $config{obsolete_severities}{$newseverity}) {
408 print {$transcript} "Severity level \`$newseverity' is obsolete. " .
409 "Use $config{obsolete_severities}{$newseverity} instead.\n\n";
411 } elsif (not defined first {$_ eq $newseverity}
412 (@{$config{severity_list}}, $config{default_severity})) {
413 print {$transcript} "Severity level \`$newseverity' is not known.\n".
414 "Recognized are: $config{show_severities}.\n\n";
418 set_severity(@{$param{common_control_options}},
420 severity => $newseverity,
425 print {$transcript} "Failed to set severity of $config{bug} $ref to $newseverity: ".cleanup_eval_fail($@,$debug)."\n";
428 } elsif ($ctl eq 'tag') {
429 my $tags = $matches[1];
430 my @tags = map {m/^([+=-])(.+)/ ? ($1,$2):($_)} split /[\s,]+/, $tags;
431 # this is an array of hashrefs which contain two elements, the
432 # first of which is the array of tags, the second is the
433 # option to pass to set_tag (we use a hashref here to make it
434 # more obvious what is happening)
437 for my $tag (@tags) {
438 if ($tag =~ /^[=+-]$/) {
440 @tag_operations = {tags => [],
444 elsif ($tag eq '-') {
445 push @tag_operations,
447 option => [remove => 1],
450 elsif ($tag eq '+') {
451 push @tag_operations,
453 option => [add => 1],
458 if (not defined first {$_ eq $tag} @{$config{tags}}) {
462 if (not @tag_operations) {
463 @tag_operations = {tags => [],
464 option => [add => 1],
467 push @{$tag_operations[-1]{tags}},$tag;
470 print {$transcript} "Unknown tag/s: ".join(', ', @badtags).".\n".
471 "Recognized are: ".join(' ', @{$config{tags}}).".\n\n";
475 for my $operation (@tag_operations) {
476 set_tag(@{$param{common_control_options}},
478 tag => [@{$operation->{tags}}],
479 warn_on_bad_tags => 0, # don't warn on bad tags,
480 # 'cause we do that above
481 @{$operation->{option}},
486 # we intentionally have two errors here if there is a bad
487 # tag and the above fails for some reason
489 print {$transcript} "Failed to alter tags of $config{bug} $ref: ".cleanup_eval_fail($@,$debug)."\n";
491 } elsif (m/^(un)?block\s+\#?(-?\d+)\s+(?:by|with)\s+(\S.*)?$/i) {
492 my $add_remove = defined $matches[0] && $matches[0] eq 'un';
494 $ref = exists $param{clonebugs}{$ref} ? $param{clonebugs}{$ref} : $ref;
495 my @blockers = map {exists $param{clonebugs}{$_}?$param{clonebugs}{$_}:$_} split /[\s,]+/, $matches[2];
497 set_blocks(@{$param{common_control_options}},
500 $add_remove ? (remove => 1):(add => 1),
505 print {$transcript} "Failed to set blocking bugs of $ref: ".cleanup_eval_fail($@,$debug)."\n";
507 } elsif ($ctl eq 'retitle') {
508 my $newtitle= $matches[1];
510 set_title(@{$param{common_control_options}},
517 print {$transcript} "Failed to set the title of $ref: ".cleanup_eval_fail($@,$debug)."\n";
519 } elsif ($ctl eq 'unmerge') {
521 set_merged(@{$param{common_control_options}},
527 print {$transcript} "Failed to unmerge $ref: ".cleanup_eval_fail($@,$debug)."\n";
529 } elsif ($ctl eq 'merge') {
531 ($ref,@tomerge) = map {exists $param{clonebugs}{$_}?$param{clonebugs}{$_}:$_}
532 split(/\s+#?/,$matches[0]);
534 set_merged(@{$param{common_control_options}},
536 merge_with => \@tomerge,
541 print {$transcript} "Failed to merge $ref: ".cleanup_eval_fail($@,$debug)."\n";
543 } elsif ($ctl eq 'forcemerge') {
545 ($ref,@tomerge) = map {exists $param{clonebugs}{$_}?$param{clonebugs}{$_}:$_}
546 split(/\s+#?/,$matches[0]);
548 set_merged(@{$param{common_control_options}},
550 merge_with => \@tomerge,
557 print {$transcript} "Failed to forcibly merge $ref: ".cleanup_eval_fail($@,$debug)."\n";
559 } elsif ($ctl eq 'clone') {
560 my $origref = $matches[0];
561 my @newclonedids = split /\s+/, $matches[1];
562 my $newbugsneeded = scalar(@newclonedids);
566 clone_bug(@{$param{common_control_options}},
568 new_bugs => \@newclonedids,
569 new_clones => \%new_clones,
571 %{$param{clonebugs}} = (%{$param{clonebugs}},
576 print {$transcript} "Failed to clone $ref: ".cleanup_eval_fail($@,$debug)."\n";
578 } elsif ($ctl eq 'package') {
579 my @pkgs = split /\s+/, $matches[0];
580 if (scalar(@pkgs) > 0) {
581 $param{limit}{package} = [@pkgs];
582 print {$transcript} "Limiting to bugs with field 'package' containing at least one of ".join(', ',map {qq('$_')} @pkgs)."\n";
583 print {$transcript} "Limit currently set to";
584 for my $limit_field (keys %{$param{limit}}) {
585 print {$transcript} " '$limit_field':".join(', ',map {qq('$_')} @{$param{limit}{$limit_field}})."\n";
587 print {$transcript} "\n";
589 $param{limit}{package} = [];
590 print {$transcript} "Limit cleared.\n\n";
592 } elsif ($ctl eq 'limit') {
593 my ($field,@options) = split /\s+/, $matches[0];
595 if ($field =~ /^(?:clear|unset|blank)$/) {
596 %{$param{limit}} = ();
597 print {$transcript} "Limit cleared.\n\n";
599 elsif (exists $Debbugs::Status::fields{$field} or $field eq 'source') {
600 # %{$param{limit}} can actually contain regexes, but because they're
601 # not evaluated in Safe, DO NOT allow them through without
603 $param{limit}{$field} = [@options];
604 print {$transcript} "Limiting to bugs with field '$field' containing at least one of ".join(', ',map {qq('$_')} @options)."\n";
605 print {$transcript} "Limit currently set to";
606 for my $limit_field (keys %{$param{limit}}) {
607 print {$transcript} " '$limit_field':".join(', ',map {qq('$_')} @{$param{limit}{$limit_field}})."\n";
609 print {$transcript} "\n";
612 print {$transcript} "Limit key $field not understood. Stopping processing here.\n\n";
614 # this needs to be fixed
615 syntax error for fixing it
618 } elsif ($ctl eq 'affects') {
619 my $add_remove = $matches[1];
620 my $packages = $matches[2];
621 # if there isn't a package given, assume that we should unset
622 # affects; otherwise default to adding
623 if (not defined $packages or
624 not length $packages) {
628 elsif (not defined $add_remove or
629 not length $add_remove) {
633 affects(@{$param{common_control_options}},
635 package => [splitpackages($packages)],
636 ($add_remove eq '+'?(add => 1):()),
637 ($add_remove eq '-'?(remove => 1):()),
642 print {$transcript} "Failed to mark $ref as affecting package(s): ".cleanup_eval_fail($@,$debug)."\n";
645 } elsif ($ctl eq 'summary') {
646 my $summary_msg = length($matches[1])?$matches[1]:undef;
648 summary(@{$param{common_control_options}},
650 summary => $summary_msg,
655 print {$transcript} "Failed to give $ref a summary: ".cleanup_eval_fail($@,$debug)."\n";
658 } elsif ($ctl eq 'owner') {
659 my $newowner = $matches[1];
660 if ($newowner eq '!') {
661 $newowner = $param{replyto};
664 owner(@{$param{common_control_options}},
671 print {$transcript} "Failed to mark $ref as having an owner: ".cleanup_eval_fail($@,$debug)."\n";
673 } elsif ($ctl eq 'noowner') {
675 owner(@{$param{common_control_options}},
682 print {$transcript} "Failed to mark $ref as not having an owner: ".cleanup_eval_fail($@,$debug)."\n";
684 } elsif ($ctl eq 'unarchive') {
686 bug_unarchive(@{$param{common_control_options}},
693 } elsif ($ctl eq 'archive') {
695 bug_archive(@{$param{common_control_options}},
698 archive_unarchived => 0,
706 ${$param{errors}}+=$errors;
708 return($errors,$terminate_control);