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)],
88 Exporter::export_ok_tags(keys %EXPORT_TAGS);
89 $EXPORT_TAGS{all} = [@EXPORT_OK];
92 use Debbugs::Config qw(:config);
93 use Debbugs::Control qw(:all);
96 (close => qr/(?i)^close\s+\#?(-?\d+)(?:\s+(\d.*))?$/,
97 reassign => qr/(?i)^reassign\s+\#?(-?\d+)\s+ # bug and command
98 (?:(?:((?:src:|source:)?$config{package_name_re}) # new package
99 (?:\s+((?:$config{package_name_re}\/)?
100 $config{package_version_re}))?)| # optional version
101 ((?:src:|source:)?$config{package_name_re} # multiple package form
102 (?:\s*\,\s*(?:src:|source:)?$config{package_name_re})+))
104 reopen => qr/(?i)^reopen\s+\#?(-?\d+)(?:\s+([\=\!]|(?:\S.*\S)))?$/,
105 found => qr{^(?:(?i)found)\s+\#?(-?\d+)
106 (?:\s+((?:$config{package_name_re}\/)?
107 $config{package_version_re}
108 # allow for multiple packages
109 (?:\s*,\s*(?:$config{package_name_re}\/)?
110 $config{package_version_re})*)
112 notfound => qr{^(?:(?i)notfound)\s+\#?(-?\d+)
113 \s+((?:$config{package_name_re}\/)?
114 $config{package_version_re}
115 # allow for multiple packages
116 (?:\s*,\s*(?:$config{package_name_re}\/)?
117 $config{package_version_re})*
119 fixed => qr{^(?:(?i)fixed)\s+\#?(-?\d+)
120 \s+((?:$config{package_name_re}\/)?
121 $config{package_version_re}
122 # allow for multiple packages
123 (?:\s*,\s*(?:$config{package_name_re}\/)?
124 $config{package_version_re})*)
126 notfixed => qr{^(?:(?i)notfixed)\s+\#?(-?\d+)
127 \s+((?:$config{package_name_re}\/)?
128 $config{package_version_re}
129 # allow for multiple packages
130 (?:\s*,\s*(?:$config{package_name_re}\/)?
131 $config{package_version_re})*)
133 submitter => qr/(?i)^submitter\s+\#?(-?\d+)\s+(\!|\S.*\S)$/.
134 forwarded => qr/(?i)^forwarded\s+\#?(-?\d+)\s+(\S.*\S)$/,
135 notforwarded => qr/(?i)^notforwarded\s+\#?(-?\d+)$/,
136 severity => qr/(?i)^(?:severity|priority)\s+\#?(-?\d+)\s+([-0-9a-z]+)$/,
137 tag => qr/(?i)^tags?\s+\#?(-?\d+)\s+(\S.*)$/,
138 block => qr/(?i)^(un)?block\s+\#?(-?\d+)\s+(?:by|with)\s+(\S.*)?$/,
139 retitle => qr/(?i)^retitle\s+\#?(-?\d+)\s+(\S.*\S)\s*$/,
140 unmerge => qr/(?i)^unmerge\s+\#?(-?\d+)$/,
141 merge => qr/(?i)^merge\s+#?(-?\d+(\s+#?-?\d+)+)\s*$/,
142 forcemerge => qr/(?i)^forcemerge\s+\#?(-?\d+(?:\s+\#?-?\d+)+)\s*$/,
143 clone => qr/(?i)^clone\s+#?(\d+)\s+((-\d+\s+)*-\d+)\s*$/,
144 package => qr/(?i)^package\:?\s+(\S.*\S)?\s*$/,
145 limit => qr/(?i)^limit\:?\s+(\S.*\S)\s*$/,
146 affects => qr/(?i)^affects?\s+\#?(-?\d+)(?:\s+((?:[=+-])?)\s*(\S.*)?)?\s*$/,
147 summary => qr/(?i)^summary\s+\#?(-?\d+)\s*(\d+|)\s*$/,
148 owner => qr/(?i)^owner\s+\#?(-?\d+)\s+((?:\S.*\S)|\!)\s*$/,
149 noowner => qr/(?i)^noowner\s+\#?(-?\d+)\s*$/,
150 unarchive => qr/(?i)^unarchive\s+#?(\d+)$/,
151 archive => qr/(?i)^archive\s+#?(\d+)$/,
155 my ($line,$matches) = @_;
157 for my $ctl (keys %control_grammar) {
158 if (@matches = $line =~ $control_grammar{$ctl}) {
159 @{$matches} = @matches if defined $matches and ref($matches) eq 'ARRAY';
163 @{$matches} = () if defined $matches and ref($matches) eq 'ARRAY';
169 validate_with(params => \@_,
170 spec => {line => {type => SCALAR,
172 clonebugs => {type => HASHREF,
174 common_control_options => {type => ARRAYREF,
176 errors => {type => SCALARREF,
178 transcript => {type => FILEHANDLE,
180 ok => {type => SCALARREF,
184 my $line = $param{line};
186 my $ctl = valid_control($line,\@matches);
187 my $transcript = $param{transcript};
188 if (not defined $ctl) {
190 print {$param{transcript}} "Unknown command or invalid options to control\n";
193 my $ref = $matches[1];
194 $ref = $param{clonebugs}{$ref} if exists $param{clonebugs}{$ref};
197 my $terminate_control = 0;
199 if ($ctl eq 'close') {
200 if (defined $matches[2]) {
202 set_fixed(@{$param{common_control_options}},
204 fixed => $matches[2],
210 print {$transcript} "Failed to add fixed version '$matches[2]' to $ref: ".cleanup_eval_fail($@,$debug)."\n";
214 set_done(@{$param{common_control_options}},
218 notify_submitter => 1,
224 print {$transcript} "Failed to mark $ref as done: ".cleanup_eval_fail($@,$debug)."\n";
226 } elsif ($ctl eq 'reassign') {
228 if (not defined $matches[2]) {
229 push @new_packages, split /\s*\,\s*/,$matches[4];
232 push @new_packages, $matches[2];
234 @new_packages = map {y/A-Z/a-z/; s/^(?:src|source):/src:/; $_;} @new_packages;
235 my $version= $matches[3];
237 set_package(@{$param{common_control_options}},
239 package => \@new_packages,
241 # if there is a version passed, we make an internal call
243 if (defined($version) && length $version) {
244 set_found(@{$param{common_control_options}},
252 print {$transcript} "Failed to clear fixed versions and reopen on $ref: ".cleanup_eval_fail($@,$debug)."\n";
254 } elsif ($ctl eq 'reopen') {
255 my $new_submitter = $matches[2];
256 if (defined $new_submitter) {
257 if ($new_submitter eq '=') {
258 undef $new_submitter;
260 elsif ($new_submitter eq '!') {
261 $new_submitter = $replyto;
265 set_done(@{$param{common_control_options}},
268 defined $new_submitter? (submitter => $new_submitter):(),
273 print {$transcript} "Failed to reopen $ref: ".cleanup_eval_fail($@,$debug)."\n";
275 } elsif ($ctl eq 'found') {
277 if (defined $matches[2]) {
278 @versions = split /\s*,\s*/,$matches[2];
280 set_found(@{$param{common_control_options}},
288 print {$transcript} "Failed to add found on $ref: ".cleanup_eval_fail($@,$debug)."\n";
293 set_fixed(@{$param{common_control_options}},
301 print {$transcript} "Failed to clear fixed versions and reopen on $ref: ".cleanup_eval_fail($@,$debug)."\n";
305 elsif ($ctl eq 'notfound') {
307 @versions = split /\s*,\s*/,$matches[2];
309 set_found(@{$param{common_control_options}},
317 print {$transcript} "Failed to remove found on $ref: ".cleanup_eval_fail($@,$debug)."\n";
320 elsif ($ctl eq 'fixed') {
322 @versions = split /\s*,\s*/,$matches[2];
324 set_fixed(@{$param{common_control_options}},
332 print {$transcript} "Failed to add fixed on $ref: ".cleanup_eval_fail($@,$debug)."\n";
335 elsif ($ctl eq 'notfixed') {
337 @versions = split /\s*,\s*/,$matches[2];
339 set_fixed(@{$param{common_control_options}},
347 print {$transcript} "Failed to remove fixed on $ref: ".cleanup_eval_fail($@,$debug)."\n";
350 elsif ($ctl eq 'submitter') {
351 my $newsubmitter = $matches[2] eq '!' ? $replyto : $matches[2];
352 if (not Mail::RFC822::Address::valid($newsubmitter)) {
353 print {$transcript} "$newsubmitter is not a valid e-mail address; not changing submitter\n";
358 set_submitter(@{$param{common_control_options}},
360 submitter => $newsubmitter,
365 print {$transcript} "Failed to set submitter on $ref: ".cleanup_eval_fail($@,$debug)."\n";
368 } elsif ($ctl eq 'forwarded') {
369 my $forward_to= $matches[2];
371 set_forwarded(@{$param{common_control_options}},
373 forwarded => $forward_to,
378 print {$transcript} "Failed to set the forwarded-to-address of $ref: ".cleanup_eval_fail($@,$debug)."\n";
380 } elsif ($ctl eq 'notforwarded') {
382 set_forwarded(@{$param{common_control_options}},
389 print {$transcript} "Failed to clear the forwarded-to-address of $ref: ".cleanup_eval_fail($@,$debug)."\n";
391 } elsif ($ctl eq 'severity') {
392 my $newseverity= $matches[2];
393 if (exists $gObsoleteSeverities{$newseverity}) {
394 print {$transcript} "Severity level \`$newseverity' is obsolete. " .
395 "Use $gObsoleteSeverities{$newseverity} instead.\n\n";
397 } elsif (not defined first {$_ eq $newseverity}
398 (@gSeverityList, "$gDefaultSeverity")) {
399 print {$transcript} "Severity level \`$newseverity' is not known.\n".
400 "Recognized are: $gShowSeverities.\n\n";
404 set_severity(@{$param{common_control_options}},
406 severity => $newseverity,
411 print {$transcript} "Failed to set severity of $config{bug} $ref to $newseverity: ".cleanup_eval_fail($@,$debug)."\n";
414 } elsif ($ctl eq 'tag') {
415 my $tags = $matches[2];
416 my @tags = map {m/^([+=-])(.+)/ ? ($1,$2):($_)} split /[\s,]+/, $tags;
417 # this is an array of hashrefs which contain two elements, the
418 # first of which is the array of tags, the second is the
419 # option to pass to set_tag (we use a hashref here to make it
420 # more obvious what is happening)
423 for my $tag (@tags) {
424 if ($tag =~ /^[=+-]$/) {
426 @tag_operations = {tags => [],
430 elsif ($tag eq '-') {
431 push @tag_operations,
433 option => [remove => 1],
436 elsif ($tag eq '+') {
437 push @tag_operations,
439 option => [add => 1],
444 if (not defined first {$_ eq $tag} @{$config{tags}}) {
448 if (not @tag_operations) {
449 @tag_operations = {tags => [],
450 option => [add => 1],
453 push @{$tag_operations[-1]{tags}},$tag;
456 print {$transcript} "Unknown tag/s: ".join(', ', @badtags).".\n".
457 "Recognized are: ".join(' ', @gTags).".\n\n";
461 for my $operation (@tag_operations) {
462 set_tag(@{$param{common_control_options}},
464 tag => [@{$operation->{tags}}],
465 warn_on_bad_tags => 0, # don't warn on bad tags,
466 # 'cause we do that above
467 @{$operation->{option}},
472 # we intentionally have two errors here if there is a bad
473 # tag and the above fails for some reason
475 print {$transcript} "Failed to alter tags of $config{bug} $ref: ".cleanup_eval_fail($@,$debug)."\n";
477 } elsif (m/^(un)?block\s+\#?(-?\d+)\s+(?:by|with)\s+(\S.*)?$/i) {
478 my $add_remove = defined $matches[1] && $matches[1] eq 'un';
480 $ref = exists $param{clonebugs}{$ref} ? $param{clonebugs}{$ref};
481 my @blockers = map {exists $param{clonebugs}{$_}?$param{clonebugs}{$_}:$_} split /[\s,]+/, $matches[3];
483 set_blocks(@{$param{common_control_options}},
486 $add_remove ? (remove => 1):(add => 1),
491 print {$transcript} "Failed to set blocking bugs of $ref: ".cleanup_eval_fail($@,$debug)."\n";
493 } elsif ($ctl eq 'retitle') {
494 my $newtitle= $matches[2];
496 set_title(@{$param{common_control_options}},
503 print {$transcript} "Failed to set the title of $ref: ".cleanup_eval_fail($@,$debug)."\n";
505 } elsif ($ctl eq 'unmerge') {
507 set_merged(@{$param{common_control_options}},
513 print {$transcript} "Failed to unmerge $ref: ".cleanup_eval_fail($@,$debug)."\n";
515 } elsif ($ctl eq 'merge') {
517 ($ref,@tomerge) = map {exists $param{clonebugs}{$_}?$param{clonebugs}{$_}:$_}
518 split(/\s+#?/,$matches[1]);
520 set_merged(@{$param{common_control_options}},
522 merge_with => \@tomerge,
527 print {$transcript} "Failed to merge $ref: ".cleanup_eval_fail($@,$debug)."\n";
529 } elsif ($ctl eq 'forcemerge') {
531 ($ref,@tomerge) = map {exists $param{clonebugs}{$_}?$param{clonebugs}{$_}:$_}
532 split(/\s+#?/,$matches[1]);
534 set_merged(@{$param{common_control_options}},
536 merge_with => \@tomerge,
543 print {$transcript} "Failed to forcibly merge $ref: ".cleanup_eval_fail($@,$debug)."\n";
545 } elsif ($ctl eq 'clone') {
546 my $origref = $matches[1];
547 my @newclonedids = split /\s+/, $matches[2];
548 my $newbugsneeded = scalar(@newclonedids);
550 $bug_affected{$ref} = 1;
553 clone_bug(@{$param{common_control_options}},
555 new_bugs => \@newclonedids,
556 new_clones => \%new_clones,
558 %{$param{clonebugs}} = (%{$param{clonebugs}},
563 print {$transcript} "Failed to clone $ref: ".cleanup_eval_fail($@,$debug)."\n";
565 } elsif ($ctl eq 'package') {
566 my @pkgs = split /\s+/, $matches[1];
567 if (scalar(@pkgs) > 0) {
568 %limit_pkgs = map { ($_, 1) } @pkgs;
569 $limit{package} = [@pkgs];
570 print {$transcript} "Limiting to bugs with field 'package' containing at least one of ".join(', ',map {qq('$_')} @pkgs)."\n";
571 print {$transcript} "Limit currently set to";
572 for my $limit_field (keys %limit) {
573 print {$transcript} " '$limit_field':".join(', ',map {qq('$_')} @{$limit{$limit_field}})."\n";
575 print {$transcript} "\n";
578 $limit{package} = [];
579 print {$transcript} "Limit cleared.\n\n";
581 } elsif ($ctl eq 'limit') {
582 my ($field,@options) = split /\s+/, $matches[1];
584 if ($field =~ /^(?:clear|unset|blank)$/) {
586 print {$transcript} "Limit cleared.\n\n";
588 elsif (exists $Debbugs::Status::fields{$field} or $field eq 'source') {
589 # %limit can actually contain regexes, but because they're
590 # not evaluated in Safe, DO NOT allow them through without
592 $limit{$field} = [@options];
593 print {$transcript} "Limiting to bugs with field '$field' containing at least one of ".join(', ',map {qq('$_')} @options)."\n";
594 print {$transcript} "Limit currently set to";
595 for my $limit_field (keys %limit) {
596 print {$transcript} " '$limit_field':".join(', ',map {qq('$_')} @{$limit{$limit_field}})."\n";
598 print {$transcript} "\n";
601 print {$transcript} "Limit key $field not understood. Stopping processing here.\n\n";
603 # this needs to be fixed
604 syntax error for fixing it
607 } elsif ($ctl eq 'affects') {
608 my $add_remove = $matches[2];
609 my $packages = $matches[3];
610 # if there isn't a package given, assume that we should unset
611 # affects; otherwise default to adding
612 if (not defined $packages or
613 not length $packages) {
617 elsif (not defined $add_remove or
618 not length $add_remove) {
622 affects(@{$param{common_control_options}},
624 package => [splitpackages($matches[3])],
625 ($add_remove eq '+'?(add => 1):()),
626 ($add_remove eq '-'?(remove => 1):()),
631 print {$transcript} "Failed to mark $ref as affecting package(s): ".cleanup_eval_fail($@,$debug)."\n";
634 } elsif ($ctl eq 'summary') {
635 my $summary_msg = length($matches[2])?$matches[2]:undef;
637 summary(@{$param{common_control_options}},
639 summary => $summary_msg,
644 print {$transcript} "Failed to give $ref a summary: ".cleanup_eval_fail($@,$debug)."\n";
647 } elsif ($ctl eq 'owner') {
648 my $newowner = $matches[2];
649 if ($newowner eq '!') {
650 $newowner = $replyto;
653 owner(@{$param{common_control_options}},
660 print {$transcript} "Failed to mark $ref as having an owner: ".cleanup_eval_fail($@,$debug)."\n";
662 } elsif ($ctl eq 'noowner') {
664 owner(@{$param{common_control_options}},
671 print {$transcript} "Failed to mark $ref as not having an owner: ".cleanup_eval_fail($@,$debug)."\n";
673 } elsif ($ctl eq 'unarchive') {
675 bug_unarchive(@{$param{common_control_options}},
677 recipients => \%recipients,
683 } elsif ($ctl eq 'archive') {
685 bug_archive(@{$param{common_control_options}},
688 archive_unarchived => 0,
696 ${$param{errors}}+=$errors;
698 return($errors,$terminate_control);