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);
99 my $bug_num_re = '-?\d+';
100 my %control_grammar =
101 (close => qr/(?i)^close\s+\#?($bug_num_re)(?:\s+(\d.*))?$/,
102 reassign => qr/(?i)^reassign\s+\#?($bug_num_re)\s+ # bug and command
103 (?:(?:((?:src:|source:)?$config{package_name_re}) # new package
104 (?:\s+((?:$config{package_name_re}\/)?
105 $config{package_version_re}))?)| # optional version
106 ((?:src:|source:)?$config{package_name_re} # multiple package form
107 (?:\s*\,\s*(?:src:|source:)?$config{package_name_re})+))
109 reopen => qr/(?i)^reopen\s+\#?($bug_num_re)(?:\s+([\=\!]|(?:\S.*\S)))?$/,
110 found => qr{^(?:(?i)found)\s+\#?($bug_num_re)
111 (?:\s+((?:$config{package_name_re}\/)?
112 $config{package_version_re}
113 # allow for multiple packages
114 (?:\s*,\s*(?:$config{package_name_re}\/)?
115 $config{package_version_re})*)
117 notfound => qr{^(?:(?i)notfound)\s+\#?($bug_num_re)
118 \s+((?:$config{package_name_re}\/)?
119 $config{package_version_re}
120 # allow for multiple packages
121 (?:\s*,\s*(?:$config{package_name_re}\/)?
122 $config{package_version_re})*
124 fixed => qr{^(?:(?i)fixed)\s+\#?($bug_num_re)
125 \s+((?:$config{package_name_re}\/)?
126 $config{package_version_re}
127 # allow for multiple packages
128 (?:\s*,\s*(?:$config{package_name_re}\/)?
129 $config{package_version_re})*)
131 notfixed => qr{^(?:(?i)notfixed)\s+\#?($bug_num_re)
132 \s+((?:$config{package_name_re}\/)?
133 $config{package_version_re}
134 # allow for multiple packages
135 (?:\s*,\s*(?:$config{package_name_re}\/)?
136 $config{package_version_re})*)
138 submitter => qr/(?i)^submitter\s+\#?($bug_num_re)\s+(\!|\S.*\S)$/,
139 forwarded => qr/(?i)^forwarded\s+\#?($bug_num_re)\s+(\S.*\S)$/,
140 notforwarded => qr/(?i)^notforwarded\s+\#?($bug_num_re)$/,
141 severity => qr/(?i)^(?:severity|priority)\s+\#?($bug_num_re)\s+([-0-9a-z]+)$/,
142 tag => qr/(?i)^tags?\s+\#?($bug_num_re)\s+(\S.*)$/,
143 block => qr/(?i)^(un)?block\s+\#?($bug_num_re)\s+(?:by|with)\s+(\S.*)?$/,
144 retitle => qr/(?i)^retitle\s+\#?($bug_num_re)\s+(\S.*\S)\s*$/,
145 unmerge => qr/(?i)^unmerge\s+\#?($bug_num_re)$/,
146 merge => qr/(?i)^merge\s+#?($bug_num_re(\s+#?$bug_num_re)+)\s*$/,
147 forcemerge => qr/(?i)^forcemerge\s+\#?($bug_num_re(?:\s+\#?$bug_num_re)+)\s*$/,
148 clone => qr/(?i)^clone\s+#?($bug_num_re)\s+((?:$bug_num_re\s+)*$bug_num_re)\s*$/,
149 package => qr/(?i)^package\:?\s+(\S.*\S)?\s*$/,
150 limit => qr/(?i)^limit\:?\s+(\S.*\S)\s*$/,
151 affects => qr/(?i)^affects?\s+\#?($bug_num_re)(?:\s+((?:[=+-])?)\s*(\S.*)?)?\s*$/,
152 summary => qr/(?i)^summary\s+\#?($bug_num_re)\s*(.*)\s*$/,
153 outlook => qr/(?i)^outlook\s+\#?($bug_num_re)\s*(.*)\s*$/,
154 owner => qr/(?i)^owner\s+\#?($bug_num_re)\s+((?:\S.*\S)|\!)\s*$/,
155 noowner => qr/(?i)^noowner\s+\#?($bug_num_re)\s*$/,
156 unarchive => qr/(?i)^unarchive\s+#?($bug_num_re)$/,
157 archive => qr/(?i)^archive\s+#?($bug_num_re)$/,
161 my ($line,$matches) = @_;
163 for my $ctl (keys %control_grammar) {
164 if (@matches = $line =~ $control_grammar{$ctl}) {
165 @{$matches} = @matches if defined $matches and ref($matches) eq 'ARRAY';
169 @{$matches} = () if defined $matches and ref($matches) eq 'ARRAY';
175 validate_with(params => \@_,
176 spec => {line => {type => SCALAR,
178 clonebugs => {type => HASHREF,
180 common_control_options => {type => ARRAYREF,
182 errors => {type => SCALARREF,
184 transcript => {type => HANDLE,
186 debug => {type => SCALAR,
189 ok => {type => SCALARREF,
191 limit => {type => HASHREF,
193 replyto => {type => SCALAR,
197 my $line = $param{line};
199 my $ctl = valid_control($line,\@matches);
200 my $transcript = $param{transcript};
201 my $debug = $param{debug};
202 if (not defined $ctl) {
204 print {$param{transcript}} "Unknown command or invalid options to control\n";
207 # in almost all cases, the first match is the bug; the exception
209 my $ref = $matches[0];
211 $ref = $param{clonebugs}{$ref} if exists $param{clonebugs}{$ref};
215 my $terminate_control = 0;
217 if ($ctl eq 'close') {
218 if (defined $matches[1]) {
220 set_fixed(@{$param{common_control_options}},
222 fixed => $matches[1],
228 print {$transcript} "Failed to add fixed version '$matches[1]' to $ref: ".cleanup_eval_fail($@,$debug)."\n";
232 set_done(@{$param{common_control_options}},
236 notify_submitter => 1,
242 print {$transcript} "Failed to mark $ref as done: ".cleanup_eval_fail($@,$debug)."\n";
244 } elsif ($ctl eq 'reassign') {
246 if (not defined $matches[1]) {
247 push @new_packages, split /\s*\,\s*/,$matches[3];
250 push @new_packages, $matches[1];
252 @new_packages = map {y/A-Z/a-z/; s/^(?:src|source):/src:/; $_;} @new_packages;
253 my $version= $matches[2];
255 set_package(@{$param{common_control_options}},
257 package => \@new_packages,
259 # if there is a version passed, we make an internal call
261 if (defined($version) && length $version) {
262 set_found(@{$param{common_control_options}},
270 print {$transcript} "Failed to clear fixed versions and reopen on $ref: ".cleanup_eval_fail($@,$debug)."\n";
272 } elsif ($ctl eq 'reopen') {
273 my $new_submitter = $matches[1];
274 if (defined $new_submitter) {
275 if ($new_submitter eq '=') {
276 undef $new_submitter;
278 elsif ($new_submitter eq '!') {
279 $new_submitter = $param{replyto};
283 set_done(@{$param{common_control_options}},
286 defined $new_submitter? (submitter => $new_submitter):(),
291 print {$transcript} "Failed to reopen $ref: ".cleanup_eval_fail($@,$debug)."\n";
293 } elsif ($ctl eq 'found') {
295 if (defined $matches[1]) {
296 @versions = split /\s*,\s*/,$matches[1];
298 set_found(@{$param{common_control_options}},
306 print {$transcript} "Failed to add found on $ref: ".cleanup_eval_fail($@,$debug)."\n";
311 set_fixed(@{$param{common_control_options}},
319 print {$transcript} "Failed to clear fixed versions and reopen on $ref: ".cleanup_eval_fail($@,$debug)."\n";
323 elsif ($ctl eq 'notfound') {
325 @versions = split /\s*,\s*/,$matches[1];
327 set_found(@{$param{common_control_options}},
335 print {$transcript} "Failed to remove found on $ref: ".cleanup_eval_fail($@,$debug)."\n";
338 elsif ($ctl eq 'fixed') {
340 @versions = split /\s*,\s*/,$matches[1];
342 set_fixed(@{$param{common_control_options}},
350 print {$transcript} "Failed to add fixed on $ref: ".cleanup_eval_fail($@,$debug)."\n";
353 elsif ($ctl eq 'notfixed') {
355 @versions = split /\s*,\s*/,$matches[1];
357 set_fixed(@{$param{common_control_options}},
365 print {$transcript} "Failed to remove fixed on $ref: ".cleanup_eval_fail($@,$debug)."\n";
368 elsif ($ctl eq 'submitter') {
369 my $newsubmitter = $matches[1] eq '!' ? $param{replyto} : $matches[1];
370 if (not Mail::RFC822::Address::valid($newsubmitter)) {
371 print {$transcript} "$newsubmitter is not a valid e-mail address; not changing submitter\n";
376 set_submitter(@{$param{common_control_options}},
378 submitter => $newsubmitter,
383 print {$transcript} "Failed to set submitter on $ref: ".cleanup_eval_fail($@,$debug)."\n";
386 } elsif ($ctl eq 'forwarded') {
387 my $forward_to= $matches[1];
389 set_forwarded(@{$param{common_control_options}},
391 forwarded => $forward_to,
396 print {$transcript} "Failed to set the forwarded-to-address of $ref: ".cleanup_eval_fail($@,$debug)."\n";
398 } elsif ($ctl eq 'notforwarded') {
400 set_forwarded(@{$param{common_control_options}},
407 print {$transcript} "Failed to clear the forwarded-to-address of $ref: ".cleanup_eval_fail($@,$debug)."\n";
409 } elsif ($ctl eq 'severity') {
410 my $newseverity= $matches[1];
411 if (exists $config{obsolete_severities}{$newseverity}) {
412 print {$transcript} "Severity level \`$newseverity' is obsolete. " .
413 "Use $config{obsolete_severities}{$newseverity} instead.\n\n";
415 } elsif (not defined first {$_ eq $newseverity}
416 (@{$config{severity_list}}, $config{default_severity})) {
417 print {$transcript} "Severity level \`$newseverity' is not known.\n".
418 "Recognized are: $config{show_severities}.\n\n";
422 set_severity(@{$param{common_control_options}},
424 severity => $newseverity,
429 print {$transcript} "Failed to set severity of $config{bug} $ref to $newseverity: ".cleanup_eval_fail($@,$debug)."\n";
432 } elsif ($ctl eq 'tag') {
433 my $tags = $matches[1];
434 my @tags = map {m/^([+=-])(.+)/ ? ($1,$2):($_)} split /[\s,]+/, $tags;
435 # this is an array of hashrefs which contain two elements, the
436 # first of which is the array of tags, the second is the
437 # option to pass to set_tag (we use a hashref here to make it
438 # more obvious what is happening)
441 for my $tag (@tags) {
442 if ($tag =~ /^[=+-]$/) {
444 @tag_operations = {tags => [],
448 elsif ($tag eq '-') {
449 push @tag_operations,
451 option => [remove => 1],
454 elsif ($tag eq '+') {
455 push @tag_operations,
457 option => [add => 1],
462 if (not defined first {$_ eq $tag} @{$config{tags}}) {
466 if (not @tag_operations) {
467 @tag_operations = {tags => [],
468 option => [add => 1],
471 push @{$tag_operations[-1]{tags}},$tag;
474 print {$transcript} "Unknown tag/s: ".join(', ', @badtags).".\n".
475 "Recognized are: ".join(' ', @{$config{tags}}).".\n\n";
479 for my $operation (@tag_operations) {
480 set_tag(@{$param{common_control_options}},
482 tag => [@{$operation->{tags}}],
483 warn_on_bad_tags => 0, # don't warn on bad tags,
484 # 'cause we do that above
485 @{$operation->{option}},
490 # we intentionally have two errors here if there is a bad
491 # tag and the above fails for some reason
493 print {$transcript} "Failed to alter tags of $config{bug} $ref: ".cleanup_eval_fail($@,$debug)."\n";
495 } elsif ($ctl eq 'block') {
496 my $add_remove = defined $matches[0] && $matches[0] eq 'un';
498 $ref = exists $param{clonebugs}{$ref} ? $param{clonebugs}{$ref} : $ref;
499 my @blockers = map {exists $param{clonebugs}{$_}?$param{clonebugs}{$_}:$_} split /[\s,]+/, $matches[2];
501 set_blocks(@{$param{common_control_options}},
504 $add_remove ? (remove => 1):(add => 1),
509 print {$transcript} "Failed to set blocking bugs of $ref: ".cleanup_eval_fail($@,$debug)."\n";
511 } elsif ($ctl eq 'retitle') {
512 my $newtitle= $matches[1];
514 set_title(@{$param{common_control_options}},
521 print {$transcript} "Failed to set the title of $ref: ".cleanup_eval_fail($@,$debug)."\n";
523 } elsif ($ctl eq 'unmerge') {
525 set_merged(@{$param{common_control_options}},
531 print {$transcript} "Failed to unmerge $ref: ".cleanup_eval_fail($@,$debug)."\n";
533 } elsif ($ctl eq 'merge') {
535 ($ref,@tomerge) = map {exists $param{clonebugs}{$_}?$param{clonebugs}{$_}:$_}
536 split(/\s+#?/,$matches[0]);
538 set_merged(@{$param{common_control_options}},
540 merge_with => \@tomerge,
545 print {$transcript} "Failed to merge $ref: ".cleanup_eval_fail($@,$debug)."\n";
547 } elsif ($ctl eq 'forcemerge') {
549 ($ref,@tomerge) = map {exists $param{clonebugs}{$_}?$param{clonebugs}{$_}:$_}
550 split(/\s+#?/,$matches[0]);
552 set_merged(@{$param{common_control_options}},
554 merge_with => \@tomerge,
561 print {$transcript} "Failed to forcibly merge $ref: ".cleanup_eval_fail($@,$debug)."\n";
563 } elsif ($ctl eq 'clone') {
564 my $origref = $matches[0];
565 my @newclonedids = split /\s+/, $matches[1];
566 my $newbugsneeded = scalar(@newclonedids);
570 clone_bug(@{$param{common_control_options}},
572 new_bugs => \@newclonedids,
573 new_clones => \%new_clones,
575 %{$param{clonebugs}} = (%{$param{clonebugs}},
580 print {$transcript} "Failed to clone $ref: ".cleanup_eval_fail($@,$debug)."\n";
582 } elsif ($ctl eq 'package') {
583 my @pkgs = split /\s+/, $matches[0];
584 if (scalar(@pkgs) > 0) {
585 $param{limit}{package} = [@pkgs];
586 print {$transcript} "Limiting to bugs with field 'package' containing at least one of ".join(', ',map {qq('$_')} @pkgs)."\n";
587 print {$transcript} "Limit currently set to";
588 for my $limit_field (keys %{$param{limit}}) {
589 print {$transcript} " '$limit_field':".join(', ',map {qq('$_')} @{$param{limit}{$limit_field}})."\n";
591 print {$transcript} "\n";
593 $param{limit}{package} = [];
594 print {$transcript} "Limit cleared.\n\n";
596 } elsif ($ctl eq 'limit') {
597 my ($field,@options) = split /\s+/, $matches[0];
599 if ($field =~ /^(?:clear|unset|blank)$/) {
600 %{$param{limit}} = ();
601 print {$transcript} "Limit cleared.\n\n";
603 elsif (exists $Debbugs::Status::fields{$field} or $field eq 'source') {
604 # %{$param{limit}} can actually contain regexes, but because they're
605 # not evaluated in Safe, DO NOT allow them through without
607 $param{limit}{$field} = [@options];
608 print {$transcript} "Limiting to bugs with field '$field' containing at least one of ".join(', ',map {qq('$_')} @options)."\n";
609 print {$transcript} "Limit currently set to";
610 for my $limit_field (keys %{$param{limit}}) {
611 print {$transcript} " '$limit_field':".join(', ',map {qq('$_')} @{$param{limit}{$limit_field}})."\n";
613 print {$transcript} "\n";
616 print {$transcript} "Limit key $field not understood. Stopping processing here.\n\n";
618 # this needs to be fixed
619 syntax error for fixing it
622 } elsif ($ctl eq 'affects') {
623 my $add_remove = $matches[1];
624 my $packages = $matches[2];
625 # if there isn't a package given, assume that we should unset
626 # affects; otherwise default to adding
627 if (not defined $packages or
628 not length $packages) {
632 elsif (not defined $add_remove or
633 not length $add_remove) {
637 affects(@{$param{common_control_options}},
639 package => [splitpackages($packages)],
640 ($add_remove eq '+'?(add => 1):()),
641 ($add_remove eq '-'?(remove => 1):()),
646 print {$transcript} "Failed to mark $ref as affecting package(s): ".cleanup_eval_fail($@,$debug)."\n";
649 } elsif ($ctl eq 'summary') {
650 my $summary_msg = length($matches[1])?$matches[1]:undef;
652 summary(@{$param{common_control_options}},
654 summary => $summary_msg,
659 print {$transcript} "Failed to give $ref a summary: ".cleanup_eval_fail($@,$debug)."\n";
662 } elsif ($ctl eq 'outlook') {
663 my $outlook_msg = length($matches[1])?$matches[1]:undef;
665 outlook(@{$param{common_control_options}},
667 outlook => $outlook_msg,
672 print {$transcript} "Failed to give $ref a outlook: ".cleanup_eval_fail($@,$debug)."\n";
675 } elsif ($ctl eq 'owner') {
676 my $newowner = $matches[1];
677 if ($newowner eq '!') {
678 $newowner = $param{replyto};
681 owner(@{$param{common_control_options}},
688 print {$transcript} "Failed to mark $ref as having an owner: ".cleanup_eval_fail($@,$debug)."\n";
690 } elsif ($ctl eq 'noowner') {
692 owner(@{$param{common_control_options}},
699 print {$transcript} "Failed to mark $ref as not having an owner: ".cleanup_eval_fail($@,$debug)."\n";
701 } elsif ($ctl eq 'unarchive') {
703 bug_unarchive(@{$param{common_control_options}},
710 } elsif ($ctl eq 'archive') {
712 bug_archive(@{$param{common_control_options}},
715 archive_unarchived => 0,
723 ${$param{errors}}+=$errors;
725 return($errors,$terminate_control);