/source/cgi-bin/gnatsweb.pl
Perl | 3704 lines | 3589 code | 37 blank | 78 comment | 21 complexity | 895f4fe6a5c5cb8025aefda8bcc093bc MD5 | raw file
Large files files are truncated, but you can click here to view the full file
- #!/usr/bin/perl -w
- #
- # Gnatsweb - web front-end to gnats
- #
- # Copyright 1998-1999 - Matt Gerassimoff
- # and Ken Cox
- #
- # $Id: gnatsweb.pl,v 1.1.1.1.2.31 2001/11/26 10:59:48 yngves Exp $
- #
- #-----------------------------------------------------------------------------
- # Site-specific customization -
- #
- # WE STRONGLY SUGGEST you don't edit these variables here, but instead
- # put them in a file called 'gnatsweb-site.pl' in the same directory.
- # That way, when a new version of gnatsweb is released, you won't
- # need to edit them again.
- #
- # Info about your gnats host.
- $site_gnats_host = 'localhost';
- $site_gnats_port = 1529;
- # Set to true if you compiled gnats with GNATS_RELEASE_BASED defined.
- $site_release_based = 0;
- # Name you want in the page banner and banner color.
- $site_banner_text = 'gnatsweb';
- $site_banner_background = '#000000';
- $site_banner_foreground = '#ffffff';
- $site_button_foreground = '#ffffff';
- $site_button_background = '#000000';
- # Page background color -- not used unless defined.
- #$site_background = '#c0c0c0';
- #GCC-LOCAL begin.
- $site_background = '#ffffff';
- #GCC-LOCAL end.
- # Uncomment the following line and insert stylesheet URL in order to
- # link all generated pages to an external stylesheet. Both absolute
- # and relative URLs are supported.
- #$site_stylesheet='http://url.of/stylesheet';
- # When $include_audit_trail is set to 1, the Audit-Trail will be
- # visible by default in the View PR screen. Sites that expect large
- # Audit-Trails, i.e. lot of mail back and forth etc., will want to set
- # this to 0.
- $include_audit_trail = 1;
- # Have the HTTP header, start_html, heading already been printed?
- my $print_header_done = 0;
- my $page_start_html_done = 0;
- my $page_heading_done = 0;
- # Program to send email notifications.
- if (-x '/usr/sbin/sendmail')
- {
- $site_mailer = '/usr/sbin/sendmail -oi -t';
- }
- elsif (-x '/usr/lib/sendmail')
- {
- $site_mailer = '/usr/lib/sendmail -oi -t';
- }
- else
- {
- die("Can't locate 'sendmail'; must set \$site_mailer in gnats-site.pl");
- }
- # site_callback -
- #
- # If defined, this subroutine gets called at various times. The
- # reason it is being called is indicated by the $reason argument.
- # It can return undef, in which case gnatsweb does its default
- # thing. Or, it can return a piece of HTML to implement
- # site-specific behavior or appearance.
- #
- # Sorry, the reasons are not documented. Either put a call to
- # 'warn' into your gnats-site.pl file, or search this file for 'cb('.
- # For examples of some of the things you can do with the site_callback
- # subroutine, see gnatsweb-site-sente.pl.
- #
- # arguments:
- # $reason - reason for the call. Each reason is unique.
- # @args - additional parameters may be provided in @args.
- #
- # returns:
- # undef - take no special action
- # string - string is used by gnatsweb according to $reason
- #
- # example:
- # See gnatsweb-site-sente.pl for an extended example.
- #
- # sub site_callback {
- # my($reason, @args) = @_;
- # if ($reason eq 'sendpr_description') {
- # return 'default description text used in sendpr form';
- # }
- # undef;
- # }
- #
- # end customization
- #-----------------------------------------------------------------------------
- # Use CGI::Carp first, so that fatal errors come to the browser, including
- # those caused by old versions of CGI.pm.
- use CGI::Carp qw/fatalsToBrowser/;
- # 8/22/99 kenstir: CGI.pm-2.50's file upload is broken.
- # 9/19/99 kenstir: CGI.pm-2.55's file upload is broken.
- use CGI 2.56 qw(-oldstyle_urls :all);
- use gnats qw/client_init client_exit client_cmd/;
- use Text::Tabs;
- # Debugging fresh code.
- #$gnats::DEBUG_LEVEL = 2;
- # Version number + RCS revision number
- $VERSION = '2.9.3';
- $REVISION = (split(/ /, '$Revision: 1.1.1.1.2.31 $ '))[1];
- # width of text fields
- $textwidth = 60;
- # where to get help -- a web site with translated info documentation
- $gnats_info_top = 'http://www.gnu.org/software/gnats/gnats_toc.html';
- #GCC-LOCAL begin.
- $gnats_info_top = '/gnats.html';
- #GCC-LOCAL begin.
- # bits in %fieldnames has (set=yes not-set=no)
- $MULTILINE = 1; # whether field is multi line
- $SENDEXCLUDE = 2; # whether the send command should exclude the field
- $REASONCHANGE = 4; # whether change to a field requires reason
- $ENUM = 8; # whether field should be displayed as enumerated
- $EDITEXCLUDE = 16; # if set, don't display on edit page
- $AUDITINCLUDE = 32; # if set, save changes in Audit-Trail
- $| = 1; # flush output after each print
- # Return true if module MIME::Base64 is available. If available, it's
- # loaded the first time this sub is called.
- sub can_do_mime
- {
- return $can_do_mime if (defined($can_do_mime));
- # Had to basically implement 'require' myself here, otherwise perl craps
- # out into the browser window if you don't have the MIME::Base64 package.
- #$can_do_mime = eval 'require MIME::Base64';
- ITER: {
- foreach my $dir (@INC) {
- my $filename = "$dir/MIME/Base64.pm";
- if (-f $filename) {
- do $filename;
- die $@ if $@;
- $can_do_mime = 1;
- last ITER;
- }
- }
- $can_do_mime = 0;
- }
- #warn "NOTE: Can't use file upload feature without MIME::Base64 module\n";
- return $can_do_mime;
- }
- # Take the file attachment's file name, and return only the tail. Don't
- # want to store any path information, for security and clarity. Support
- # both DOS-style and Unix-style paths here, because we have both types of
- # clients.
- sub attachment_filename_tail
- {
- my($filename) = @_;
- $filename =~ s,.*/,,; # Remove leading Unix path elements.
- $filename =~ s,.*\\,,; # Remove leading DOS path elements.
- return $filename;
- }
- # Retrieve uploaded file attachment. Return it as
- # ($filename, $content_type, $data). Returns (undef,undef,undef)
- # if not present.
- #
- # See 'perldoc CGI' for details about this code.
- sub get_attachment
- {
- my $upload_param_name = shift;
- my $debug = 0;
- my $filename = $q->param($upload_param_name);
- return (undef, undef, undef) unless $filename;
- # 9/6/99 kenstir: My testing reveals that if uploadInfo returns undef,
- # then you can't read the file either.
- warn "get_attachment: filename=$filename\n" if $debug;
- my $hashref = $q->uploadInfo($filename);
- if (!defined($hashref)) {
- die "Got attachment filename ($filename) but no attachment data! Probably this is a programming error -- the form which submitted this data must be multipart/form-data (start_multipart_form()).";
- }
- if ($debug) {
- while (($k, $v) = each %$hashref) {
- warn "get_attachment: uploadInfo($k)=$v\n";
- }
- }
- # 9/6/99 kenstir: When testing locally on Linux, a .gz file yielded
- # no Content-Type. Therefore, have to assume binary. Would like to
- # check (-B $fh) to see if the stream is binary but that doesn't work.
- my $ctype = $hashref->{'Content-Type'} || 'application/octet-stream';
- warn "get_attachment: Content-Type=$ctype\n" if $debug;
- my $data = '';
- my $buf;
- my $fh = $q->upload($upload_param_name);
- warn "get_attachment: fh=$fh\n" if $debug;
- while (read($fh, $buf, 1024)) {
- $data .= $buf;
- }
- close $fh;
- return ($filename, $ctype, $data);
- }
- # Retrieve uploaded file attachment, and encode it so that it's
- # printable, for inclusion into the PR text.
- #
- # Returns the printable text representing the attachment. Returns '' if
- # the attachment was not present.
- sub encode_attachment
- {
- my $upload_param_name = shift;
- my $debug = 0;
- return '' unless can_do_mime();
- my ($filename, $ctype, $data) = get_attachment($upload_param_name);
- return '' unless $filename;
- # Strip off path elements in $filename.
- $filename = attachment_filename_tail($filename);
- warn "encode_attachment: $filename was ", length($data), " bytes of $ctype\n"
- if $debug;
- my $att = '';
- # Plain text is included inline; all else is encoded.
- $att .= "Content-Type: $ctype; name=\"$filename\"\n";
- if ($ctype eq 'text/plain') {
- $att .= "Content-Disposition: inline; filename=\"$filename\"\n\n";
- $att .= $data;
- }
- else {
- $att .= "Content-Transfer-Encoding: base64\n";
- $att .= "Content-Disposition: attachment; filename=\"$filename\"\n\n";
- $att .= MIME::Base64::encode_base64($data);
- }
- warn "encode_attachment: done\n" if $debug;
- return $att;
- }
- # Takes the encoded file attachment, decodes it and returns it as a hashref.
- sub decode_attachment
- {
- my $att = shift;
- my $debug = 0;
- my $hash_ref = {'original_attachment' => $att};
- # Split the envelope from the body.
- my ($envelope, $body) = split(/\n\n/, $att, 2);
- return $hash_ref unless ($envelope && $body);
- # Split mbox-like headers into (header, value) pairs, with a leading
- # "From_" line swallowed into USELESS_LEADING_ENTRY. Junk the leading
- # entry. Chomp all values.
- %$hash_ref = (USELESS_LEADING_ENTRY => split /^(\S*?):\s*/m, $envelope);
- delete($hash_ref->{USELESS_LEADING_ENTRY});
- for (keys %$hash_ref) {
- chomp $hash_ref->{$_};
- }
- # Keep the original_attachment intact.
- $$hash_ref{'original_attachment'} = $att;
- if (!$$hash_ref{'Content-Type'}
- || !$$hash_ref{'Content-Disposition'})
- {
- die "Unable to parse file attachment";
- }
- # Parse filename.
- # Note: the extra \ before the " is just so that perl-mode can parse it.
- if ($$hash_ref{'Content-Disposition'} !~ /(\S+);\s*filename=\"([^\"]+)\"/) {
- die "Unable to parse file attachment Content-Disposition";
- }
- $$hash_ref{'filename'} = attachment_filename_tail($2);
- # Decode the data if encoded.
- if (exists($$hash_ref{'Content-Transfer-Encoding'})
- && $$hash_ref{'Content-Transfer-Encoding'} eq 'base64')
- {
- $$hash_ref{'data'} = MIME::Base64::decode_base64($body);
- }
- else {
- $$hash_ref{'data'} = $body;
- }
- return $hash_ref;
- }
- # Print file attachment browser and buttons to download the attachments.
- # Which of these appear depend on the mode.
- sub print_attachments
- {
- my($fields_hash_ref, $mode) = @_;
- return unless can_do_mime();
- print "<tr><td valign=top><b>File Attachments:</b></td>\n<td>";
- # Add file upload button for adding new attachment.
- if ($mode eq 'sendpr' || $mode eq 'edit') {
- print "Add a file attachment:<br>",
- $q->filefield(-name=>'attached_file',
- -size=>50);
- }
- # Print table of existing attachments.
- # Add column with delete button in edit mode.
- my $array_ref = $$fields_hash_ref{'attachments'};
- my $table_rows_aref = [];
- my $i = 0;
- foreach $hash_ref (@$array_ref) {
- my $size = int(length($$hash_ref{'data'}) / 1024.0);
- $size = 1 if ($size < 1);
- my $row_data = $q->td( [ $q->submit('cmd', "download attachment $i"),
- $$hash_ref{'filename'},
- "${size}k" ] );
- $row_data .= $q->td($q->checkbox(-name=>'delete attachments',
- -value=>$i,
- -label=>"delete attachment $i"))
- if ($mode eq 'edit');
- push(@$table_rows_aref, $row_data);
- $i++;
- }
- if (@$table_rows_aref)
- {
- my $header_row_data = $q->th( ['download','filename','size' ] );
- $header_row_data .= $q->th('delete')
- if ($mode eq 'edit');
- print $q->table({-border=>1},
- $q->Tr($header_row_data),
- $q->Tr($table_rows_aref));
- }
- }
- # The user has requested download of a particular attachment.
- # Serve it up.
- sub download_attachment
- {
- my $attachment_number = shift;
- my($pr) = $q->param('pr');
- die "download_attachment called with no PR number"
- if(!$pr);
- my(%fields) = readpr($pr);
- my $array_ref = $fields{'attachments'};
- my $hash_ref = $$array_ref[$attachment_number];
- # Determine the attachment's content type.
- my $ct = $$hash_ref{'Content-Type'} || 'application/octet-stream';
- $ct =~ s~\s*;.*~~s;
- my $disp;
- # Internet Explorer 5.5 does not handle "content-disposition: attachment"
- # in the expected way. It needs a content-disposition of "file".
- ($ENV{'HTTP_USER_AGENT'} =~ "MSIE 5.5") ? ($disp = 'file') : ($disp = 'attachment');
- # Now serve the attachment, with the appropriate headers.
- print $q->header(-type => $ct,
- -content_disposition => "$disp; filename=\"$$hash_ref{'filename'}\""),
- $$hash_ref{'data'};
- }
- # Add the given (gnatsweb-encoded) attachment to the %fields hash.
- sub add_encoded_attachment_to_pr
- {
- my($fields_hash_ref, $encoded_attachment) = @_;
- return unless $encoded_attachment;
- my $ary_ref = $$fields_hash_ref{'attachments'} || [];
- my $hash_ref = { 'original_attachment' => $encoded_attachment };
- push(@$ary_ref, $hash_ref);
- $$fields_hash_ref{'attachments'} = $ary_ref;
- }
- # Add the given (gnatsweb-decoded) attachment to the %fields hash.
- sub add_decoded_attachment_to_pr
- {
- my($fields_hash_ref, $decoded_attachment_hash_ref) = @_;
- return unless $decoded_attachment_hash_ref;
- my $ary_ref = $$fields_hash_ref{'attachments'} || [];
- push(@$ary_ref, $decoded_attachment_hash_ref);
- $$fields_hash_ref{'attachments'} = $ary_ref;
- }
- # Remove the given attachments from the %fields hash.
- sub remove_attachments_from_pr
- {
- my($fields_hash_ref, @attachment_numbers) = @_;
- return unless @attachment_numbers;
- my $ary_ref = $$fields_hash_ref{'attachments'} || [];
- foreach my $attachment_number (@attachment_numbers)
- {
- # Remove the attachment be replacing it with the empty hash.
- # The sub unparsepr skips these.
- $$ary_ref[$attachment_number] = {};
- }
- }
- # wrapper functions for formstart...
- sub multipart_form_start
- {
- formstart(1, @_);
- }
- sub form_start
- {
- formstart(0, @_);
- }
- # workaround for an exceedingly dumb netscape bug. we hates
- # netscape... this bug manifests if you click on the "create"
- # button bar link (but not the grey button on the main page), submit a
- # PR, then hit the back button (usually because you got an error).
- # you're taken "back" to the same error page -- all the stuff you
- # entered into the submission form is *gone*. this is kind of annoying...
- # (it also manifests if you click the edit link from the query results page.)
- sub formstart
- {
- # this bugfix is mostly lifted from the CGI.pm docs. here's what they
- # have to say:
- # When you press the "back" button, the same page is loaded, not
- # the previous one. Netscape's history list gets confused
- # when processing multipart forms. If the script generates
- # different pages for the form and the results, hitting the
- # "back" button doesn't always return you to the previous page;
- # instead Netscape reloads the current page. This happens even
- # if you don't use an upload file field in your form.
- #
- # A workaround for this is to use additional path information to
- # trick Netscape into thinking that the form and the response
- # have different URLs. I recommend giving each form a sequence
- # number and bumping the sequence up by one each time the form
- # is accessed:
- # should we do multipart?
- my $multi = shift;
-
- # in case the caller has some args to pass...
- my %args = @_;
-
- # if the caller has given an "action" arg, we don't do any
- # subterfuge. let the caller worry about the bug...
- if (!exists $args{'-action'})
- {
- # get sequence number and increment it
- my $s = $q->path_info =~ m{/(\d+)/?$};
- $s++;
- # Trick Netscape into thinking it's loading a new script:
- $args{-action} = $q->script_name . "/$s";
- }
-
- if ($multi)
- {
- print $q->start_multipart_form(%args);
- }
- else
- {
- print $q->start_form(%args);
- }
- return;
- }
- # sendpr -
- # The Create PR page.
- #
- sub sendpr
- {
- my $page = 'Create PR';
- print_header();
- page_start_html($page);
- page_heading($page, 'Create Problem Report', 1);
- # remove "all" from arrays
- shift(@category);
- shift(@severity);
- shift(@priority);
- shift(@class);
- shift(@confidential);
- shift(@responsible);
- shift(@state);
- shift(@submitter_id);
- # Add '<default>' to @responsible, in case the site_callback alows
- # Responsible to be set upon submission. This is filtered out in
- # &submitnewpr.
- unshift(@responsible, '<default>');
- print multipart_form_start(-name=>'sendPrForm'), "\n",
- hidden_db(),
- $q->p($q->submit('cmd', 'submit'),
- " or ",
- $q->reset(-name=>'reset')),
- $q->hidden(-name=>'return_url'),
- "<hr>\n",
- "<table>";
- my $def_email = $global_prefs{'email'}
- || cb('get_default_value', 'email') || '';
- print "<tr>\n<td><b>Reporter's email:</b></td>\n<td>",
- $q->textfield(-name=>'email',
- -default=>$def_email,
- -size=>$textwidth),
- "</td>\n</tr>\n<tr>\n<td><b>CC these people<br>on PR status email:</b></td>\n<td>",
- $q->textfield(-name=>'X-GNATS-Notify',
- -size=>$textwidth),
- # a blank row, to separate header info from PR info
- "</td>\n</tr>\n<tr>\n<td> </td>\n<td> </td>\n</tr>\n";
- foreach (@fieldnames)
- {
- next if ($fieldnames{$_} & $SENDEXCLUDE);
- my $lc_fieldname = field2param($_);
- # Get default value from site_callback if provided, otherwise take
- # our defaults.
- my $default;
- $default = 'serious' if /Severity/;
- $default = 'medium' if /Priority/;
- $default = $global_prefs{'Submitter-Id'} || 'unknown' if /Submitter-Id/;
- #GCC-LOCAL begin.
- $default = 'net' if /Submitter-Id/;
- #GCC-LOCAL end.
- $default = $global_prefs{'Originator'} if /Originator/;
- $default = grep(/^unknown$/i, @category) ? "unknown" : $category[0]
- if /Category/;
- $default = $config{'DEFAULT_RELEASE'} if /Release/;
- $default = '' if /Responsible/;
- $default = cb("sendpr_$lc_fieldname") || $default;
- # The "intro" provides a way for the site callback to print something
- # at the top of a given field.
- my $intro = cb("sendpr_intro_$lc_fieldname") || '';
- if ($fieldnames{$_} & $ENUM)
- {
- if ($lc_fieldname eq "category")
- {
- print "<tr>\n<td><b>$_:</b>\n</td>\n<td>",
- $intro,
- $q->popup_menu(-name=>$_,
- -values=>\@$lc_fieldname,
- -labels=>\%category_desc,
- -default=>$default);
- print "</td>\n</tr>\n";
- }
- elsif ($lc_fieldname eq "responsible")
- {
- print "<tr>\n<td><b>$_:</b>\n</td>\n<td>",
- $intro,
- $q->popup_menu(-name=>$_,
- -values=>\@$lc_fieldname,
- -labels=>\%responsible_fullname,
- -default=>$fields{$_});
- print "</td>\n</tr>\n";
- } else
- {
- print "<tr>\n<td><b>$_:</b>\n</td>\n<td>",
- $intro,
- $q->popup_menu(-name=>$_,
- -values=>\@$lc_fieldname,
- -default=>$default);
- print "</td>\n</tr>\n";
- }
- }
- elsif ($fieldnames{$_} & $MULTILINE)
- {
- my $rows = 4;
- $rows = 8 if /Description/;
- $rows = 2 if /Environment/;
- #GCC-LOCAL begin.
- if ($lc_fieldname eq "description")
- {
- printf "<tr>\n<td></td>\n<td>When you provide (preprocessed) source, "
- ."please only insert it into one of the text fields if it is "
- ."very small, say below 50 lines. Else <em>please</em> attach "
- ."it as a file (see below).";
- }
- #GCC-LOCAL end.
- print "<tr>\n<td valign=top><b>$_:</b></td>\n<td>",
- $intro,
- $q->textarea(-name=>$_,
- -cols=>$textwidth,
- -rows=>$rows,
- -default=>$default);
- # Create file upload button after Description.
- print_attachments(\%fields, 'sendpr') if /Description/;
- print "</td>\n</tr>\n";
- }
- else
- {
- print "<tr>\n<td><b>$_:</b></td>\n<td>",
- $intro,
- $q->textfield(-name=>$_,
- -size=>$textwidth,
- -default=>$default);
- print "</td>\n</tr>\n";
- }
- print "\n";
- }
- print "</table>",
- $q->p($q->submit('cmd', 'submit'),
- " or ",
- $q->reset(-name=>'reset')),
- $q->end_form();
- page_footer($page);
- page_end_html($page);
- }
- # validate_email_field -
- # Used by validate_new_pr to check email address fields in a new PR.
- sub validate_email_field
- {
- my($fieldname, $fieldval, $required) = @_;
- my $blank = ($fieldval =~ /^\s*$/);
- if ($required && $blank)
- {
- return "$fieldname is blank";
- }
- # From rkimball@vgi.com, allows @ only if it's followed by what looks
- # more or less like a domain name.
- my $email_addr = '[^@\s]+(@\S+\.\S+)?';
- if (!$blank && $fieldval !~ /^\s*($email_addr\s*)+$/)
- {
- return "'$fieldval' doesn't look like a valid email address (xxx\@xxx.xxx)";
- }
- return '';
- }
- # validate_new_pr -
- # Make sure fields have reasonable values before submitting a new PR.
- sub validate_new_pr
- {
- my(%fields) = @_;
- my(@errors) = ();
- my $err;
- # validate email fields
- $err = validate_email_field('E-mail Address', $fields{'email'}, 'required');
- push(@errors, $err) if $err;
- # $err = validate_email_field('CC', $fields{'cc'});
- # push(@errors, $err) if $err;
- $err = validate_email_field('X-GNATS-Notify', $fields{'X-GNATS-Notify'});
- push(@errors, $err) if $err;
- # validate some other fields
- push(@errors, "Category is blank or 'unknown'")
- if($fields{'Category'} =~ /^\s*$/ || $fields{'Category'} eq "unknown");
- push(@errors, "Synopsis is blank")
- if($fields{'Synopsis'} =~ /^\s*$/);
- push(@errors, "Release is blank")
- if($fields{'Release'} =~ /^\s*$/);
- push(@errors, "Submitter-Id is 'unknown'")
- if($fields{'Submitter-Id'} eq 'unknown');
- #GCC-LOCAL begin.
- push(@errors, "Priority is 'high'")
- if($fields{'Priority'} eq 'high');
- #GCC-LOCAL end.
- @errors;
- }
- sub submitnewpr
- {
- my $page = 'Create PR Results';
- my $debug = 0;
- my(@values, $key);
- my(%fields);
- foreach $key ($q->param)
- {
- my $val = $q->param($key);
- if($fieldnames{$key} && ($fieldnames{$key} & $MULTILINE))
- {
- $val = fix_multiline_val($val);
- }
- $fields{$key} = $val;
- }
- # If Responsible is '<default>', delete it; gnats handles that. See
- # also &sendpr.
- if(defined($fields{'Responsible'}) && $fields{'Responsible'} eq '<default>') {
- delete $fields{'Responsible'};
- }
- # Make sure the pr is valid.
- my(@errors) = validate_new_pr(%fields);
- if (@errors)
- {
- print_header();
- page_start_html($page);
- page_heading($page, 'Error');
- print "<h3>Your problem report has not been sent.</h3>\n",
- "<p>Fix the following problems, then submit the problem report again:</p>",
- $q->ul($q->li(\@errors));
- return;
- }
- # Supply a default value for Originator
- $fields{'Originator'} = $fields{'Originator'} || $fields{'email'};
- # Handle the attached_file, if any.
- add_encoded_attachment_to_pr(\%fields, encode_attachment('attached_file'));
- # Compose the message
- my $text = unparsepr('send', %fields);
- $text = <<EOT . $text;
- To: $config{'GNATS_ADDR'}
- CC: $fields{'X-GNATS-Notify'}
- Subject: $fields{'Synopsis'}
- From: $fields{'email'}
- Reply-To: $fields{'email'}
- X-Send-Pr-Version: gnatsweb-$VERSION ($REVISION)
- X-GNATS-Notify: $fields{'X-GNATS-Notify'}
- EOT
- # Allow debugging
- if($debug)
- {
- print_header();
- page_start_html($page);
- print "<h3>debugging -- PR NOT SENT</h3>",
- $q->pre($q->escapeHTML($text)),
- "<hr>";
- page_end_html($page);
- return;
- }
- # Send the message
- if(!open(MAIL, "|$site_mailer"))
- {
- print_header();
- page_start_html($page);
- page_heading($page, 'Error');
- print "<h3>Error invoking $site_mailer</h3>";
- return;
- }
- print MAIL $text;
- if(!close(MAIL))
- {
- print_header();
- page_start_html($page);
- page_heading($page, 'Error');
- print "<h3>Bad pipe to $site_mailer</h3>";
- exit;
- }
- # Return the user to the page they were viewing when they pressed
- # 'create'.
- my $return_url = $q->param('return_url') || get_script_name();
- my $refresh = 5;
- print_header(-Refresh => "$refresh; URL=$return_url",
- -cookie => create_global_cookie());
- # Workaround for MSIE:
- my @args = (-title=>"$page - $site_banner_text");
- push(@args, -bgcolor=>$site_background)
- if defined($site_background);
- push(@args, -style=>{-src=>$site_stylesheet})
- if defined($site_stylesheet);
- push(@args, -head=>meta({-http_equiv=>'Refresh',
- -content=>"$refresh; URL=$return_url"}));
- print $q->start_html(@args);
- # Print page banner, with button bar, without the <head> part:
- page_start_html($page, 0, 1);
- page_heading($page, 'Problem Report Sent');
- print "<p>Thank you for your report. It will take a short while for
- your report to be processed. When it is, you will receive
- an automated message about it, containing the Problem Report
- number, and the developer who has been assigned to
- investigate the problem.</p>";
- print "<p>Page will refresh in $refresh seconds...</p>\n";
- page_footer($page);
- page_end_html($page);
- }
- # Return a URL which will take one to the specified $pr and with a
- # specified $cmd. For commands such as 'create' that have no
- # associated PR number, we pass $pr = 0, and this routine then leaves
- # out the pr parameter. For ease of use, when the user makes a
- # successful edit, we want to return to the URL he was looking at
- # before he decided to edit the PR. The return_url param serves to
- # store that info, and is included if $include_return_url is
- # specified. Note that the return_url is saved even when going into
- # the view page, since the user might go from there to the edit page.
- #
- sub get_pr_url
- {
- my($cmd, $pr, $include_return_url) = @_;
- my $url = $q->url() . "?cmd=$cmd&database=$global_prefs{'database'}";
- $url .= "&pr=$pr" if $pr;
- $url .= "&return_url=" . $q->escape($q->self_url())
- if $include_return_url;
- return $url;
- }
- # Return a URL to edit the given pr. See get_pr_url().
- #
- sub get_editpr_url
- {
- return get_pr_url('edit', @_);
- }
- # Return a URL to view the given pr. See get_pr_url().
- #
- sub get_viewpr_url
- {
- my $viewcmd = $include_audit_trail ? 'view%20audit-trail' : 'view';
- return get_pr_url($viewcmd, @_);
- }
- # Return a URL to create a pr. See get_pr_url().
- #
- sub get_createpr_url
- {
- return get_pr_url('create', @_);
- }
- # Same as script_name(), but includes 'database=xxx' param.
- #
- sub get_script_name
- {
- my $url = $q->script_name();
- $url .= "?database=$global_prefs{'database'}"
- if defined($global_prefs{'database'});
- return $url;
- }
- # Return a link which sends email regarding the current PR.
- sub get_mailto_link
- {
- my($pr,%fields) = @_;
- # NOTE: cagney/2003-01-31: Don't escape the interested parties
- # e-mail list. MOZILLA has a nasty bug were it doesn't re-adjust
- # the e-mail list length after de-escaping it. This causes MOZILLA
- # to use "?Sub..." in the list of e-mail addresses.
- # my $mailto = $q->escape(scalar(interested_parties($pr, 1, %fields)));
- my $mailto = interested_parties($pr, 1, %fields);
- my $subject = $q->escape("Re: $fields{'Category'}/$pr: $fields{'Synopsis'}");
- my $body = $q->escape(get_viewpr_url($pr));
- return "<a href=\"mailto:$mailto?Subject=$subject&Body=$body\">"
- . "send email to interested parties</a>\n";
- }
- # Look for text that looks like URLs and turn it into actual links.
- sub mark_urls
- {
- my ($val) = @_;
- # This probably doesn't catch all URLs, but one hopes it catches the
- # majority.
- $val =~ s/\b((s?https?|ftp):\/\/[-a-zA-Z0-9_.]+(:[0-9]+)?[-a-zA-Z0-9_\$.+\!*\(\),;:\@\&\%\x93\x90=?~\#\/]*)/
- \<a href="$1">$1\<\/a\>/g;
- return $val;
- }
- sub view
- {
- my($viewaudit, $tmp) = @_;
- # $pr must be 'local' to be available to site callback
- local($pr) = $q->param('pr');
- if(!$pr)
- {
- error_page('Error', 'You must specify a problem report number');
- return;
- }
- if($pr =~ /\D/)
- {
- error_page('Error', 'Invalid PR number');
- return;
- }
- my $page = "View PR $pr";
- print_header();
- page_start_html($page);
- page_heading($page, "View Problem Report: $pr", 1);
- # %fields must be 'local' to be available to site callback
- local(%fields) = readpr($pr);
- print $q->start_form(),
- hidden_db(),
- $q->hidden('pr'),
- $q->hidden('return_url');
- # print 'edit' and 'view audit-trail' buttons as appropriate, mailto link
- print "<p>";
- print $q->submit('cmd', 'edit') if (can_edit());
- print " or " if (can_edit() && !$viewaudit);
- print $q->submit('cmd', 'view audit-trail') if (!$viewaudit);
- print " or ",
- get_mailto_link($pr, %fields), "</p>";
- print $q->hr(),
- "<table>\n";
- print "<tr>\n<td><b>Reporter's email:</b></td>\n<td>",
- $q->tt($fields{'Reply-To'}),
- # "<tr><td><b>Others to notify<br>of updates to this PR:</b><td>",
- "</td>\n</tr>\n<tr>\n<td><b>CC these people<br>on PR status email:</b></td>\n<td>",
- $q->tt($fields{'X-GNATS-Notify'}),
- # a blank row, to separate header info from PR info
- "</td>\n</tr>\n<tr>\n<td> </td>\n<td> </td>\n</tr>\n";
- foreach (@fieldnames)
- {
- next if $_ eq 'Audit-Trail';
- my $val = $q->escapeHTML($fields{$_}) || ''; # to avoid -w warning
- my $valign = '';
- if ($fieldnames{$_} & $MULTILINE)
- {
- $valign = 'valign=top';
- $val = expand($val);
- $val =~ s/$/<br>/gm;
- $val =~ s/<br>$//; # previous substitution added one too many <br>'s
- $val =~ s/ / /g;
- $val =~ s/ / /g;
- $val = mark_urls($val);
- }
- print "<tr><td $valign nowrap><b>$_:</b></td>\n<td>",
- $q->tt($val), "\n";
- # Print attachments after Description.
- if (/Description/) {
- print "</td>\n</tr>\n";
- print_attachments(\%fields, 'view');
- }
- print "</td>\n</tr>\n"
- }
- print "</table>",
- $q->hr();
- # print 'edit' and 'view audit-trail' buttons as appropriate, mailto link
- print "\n<p>";
- print $q->submit('cmd', 'edit') if (can_edit());
- print " or " if (can_edit() && !$viewaudit);
- print $q->submit('cmd', 'view audit-trail') if (!$viewaudit);
- print " or ",
- get_mailto_link($pr, %fields);
- print "</p>\n";
- print $q->end_form();
- # Footer comes before the audit-trail.
- page_footer($page);
- if($viewaudit)
- {
- print "<h3>Audit Trail:</h3>\n",
- mark_urls($q->pre($q->escapeHTML($fields{'Audit-Trail'})));
- }
- page_end_html($page);
- }
- # edit -
- # The Edit PR page.
- #
- sub edit
- {
- #my $debug = 0; # no debug code in here
- my($pr) = $q->param('pr');
- if(!$pr)
- {
- error_page('Error', 'You must specify a problem report number');
- return;
- }
- if($pr =~ /\D/)
- {
- error_page('Error', 'Invalid PR number');
- return;
- }
- my $page = "Edit PR $pr";
- print_header();
- page_start_html($page);
- page_heading($page, "Edit Problem Report: $pr", 1);
- # Read the PR.
- my(%fields) = readpr($pr);
- # Trim Responsible for compatibility.
- $fields{'Responsible'} = trim_responsible($fields{'Responsible'});
- # remove "all" from arrays
- shift(@category);
- shift(@severity);
- shift(@priority);
- shift(@class);
- shift(@confidential);
- shift(@responsible);
- shift(@state);
- shift(@submitter_id);
- print multipart_form_start(-name=>'editPrForm'), "\n",
- hidden_db(),
- $q->p($q->submit('cmd', 'submit edit'),
- " or ",
- $q->reset(-name=>'reset'),
- " or ",
- get_mailto_link($pr, %fields)),
- $q->hidden(-name=>'Editor',
- -value=>$db_prefs{'user'},
- -override=>1),
- $q->hidden(-name=>'Last-Modified',
- -value=>$fields{'Last-Modified'},
- -override=>1),
- $q->hidden(-name=>'pr'),
- $q->hidden(-name=>'return_url'),
- "<hr>\n";
- print "<table>\n";
- print "<tr>\n<td><b>Reporter's email:</b></td>\n<td>",
- $q->textfield(-name=>'Reply-To',
- -default=>$fields{'Reply-To'},
- -size=>$textwidth),
- # "<tr><td><b>Others to notify<br>of updates to this PR:</b><td>",
- "</td>\n</tr>\n<tr>\n<td><b>CC these people<br>on PR status email:</b></td>\n<td>",
- $q->textfield(-name=>'X-GNATS-Notify',
- -default=>$fields{'X-GNATS-Notify'},
- -size=>$textwidth),
- # a blank row, to separate header info from PR info
- "</td>\n</tr>\n<tr>\n<td> </td>\n<td> </td>\n</tr>\n";
- foreach (@fieldnames)
- {
- next if ($fieldnames{$_} && ($fieldnames{$_} & $EDITEXCLUDE));
- my $lc_fieldname = field2param($_);
- # The "intro" provides a way for the site callback to print something
- # at the top of a given field.
- my $intro = cb("edit_intro_$lc_fieldname") || '';
- if ($fieldnames{$_} && ($fieldnames{$_} & $ENUM))
- {
- my @values = cb('edit_pr', $fields{'Category'}, $lc_fieldname);
- @values = @$lc_fieldname unless (defined($values[0]));
- if ($lc_fieldname eq "category")
- {
- print "<tr>\n<td><b>$_:</b>\n</td>\n<td>",
- $intro,
- $q->popup_menu(-name=>$_,
- -values=>\@values,
- -labels=>\%category_desc,
- -default=>$fields{$_});
- print "</td>\n</tr>\n";
- print "</td>\n</tr>\n";
- }
- elsif ($lc_fieldname eq "responsible")
- {
- print "<tr>\n<td><b>$_:</b>\n</td>\n<td>",
- $intro,
- $q->popup_menu(-name=>$_,
- -values=>\@values,
- -labels=>\%responsible_fullname,
- -default=>$fields{$_});
- print "</td>\n</tr>\n";
- }
- else
- {
- print "<tr>\n<td><b>$_:</b>\n</td>\n<td>",
- $intro,
- $q->popup_menu(-name=>$_,
- -values=>\@$lc_fieldname,
- -default=>$fields{$_});
- print "</td>\n</tr>\n";
- }
- }
- elsif ($fieldnames{$_} && ($fieldnames{$_} & $MULTILINE))
- {
- my $rows = 4;
- $rows = 8 if /Description/;
- $rows = 2 if /Environment/;
- print "<tr>\n<td valign=top><b>$_:</b></td>\n<td>",
- $intro,
- $q->textarea(-name=>$_,
- -cols=>$textwidth,
- -rows=>$rows,
- -default=>$fields{$_});
- # Print attachments after Description.
- if (/Description/) {
- print "</td>\n</tr>\n";
- print_attachments(\%fields, 'edit');
- }
- print "</td>\n</tr>\n";
- }
- else
- {
- print "<tr>\n<td><b>$_:</b></td>\n<td>",
- $intro,
- $q->textfield(-name=>$_,
- -size=>$textwidth,
- -default=>$fields{$_});
- print "</td>\n</tr>\n";
- }
- if ($fieldnames{$_} && $fieldnames{$_} & $REASONCHANGE)
- {
- print "<tr>\n<td valign=top><b>Reason Changed:</b></td>\n<td>",
- $q->textarea(-name=>"$_-Why",
- -default=>'',
- -override=>1,
- -cols=>$textwidth,
- -rows=>2);
- print "</td>\n</tr>\n";
- }
- print "\n";
- }
- print "</table>",
- $q->p($q->submit('cmd', 'submit edit'),
- " or ",
- $q->reset(-name=>'reset'),
- " or ",
- get_mailto_link($pr, %fields)),
- $q->end_form(),
- $q->hr();
- # Footer comes before the audit-trail.
- page_footer($page);
- print "<h3>Audit-Trail:</h3>\n",
- mark_urls($q->pre($q->escapeHTML($fields{'Audit-Trail'})));
- page_end_html($page);
- }
- # Print out the %fields hash for debugging.
- sub debug_print_fields
- {
- my $fields_hash_ref = shift;
- print "<table cellspacing=0 cellpadding=0 border=1>\n";
- foreach my $f (sort keys %$fields_hash_ref)
- {
- print "<tr valign=top><td>$f</td><td>",
- $q->pre($q->escapeHTML($$fields_hash_ref{$f})),
- "</td></tr>\n";
- }
- my $aref = $$fields_hash_ref{'attachments'} || [];
- my $i=0;
- foreach my $href (@$aref) {
- print "<tr valign=top><td>attachment $i</td><td>",
- ($$href{'original_attachment'}
- ? $$href{'original_attachment'} : "--- empty ---"),
- "</td></tr>\n";
- $i++;
- }
- print "</table><hr>\n";
- }
- # submitedit -
- # User pressed 'submit' on the edit page. If the edits are applied
- # successfully, give a message then return the user to the URL
- # specified in param('return_url') so that he can continue doing what
- # he was previously doing (e.g. looking at query results). If the
- # edits are not successful, print and error and stay put.
- #
- sub submitedit
- {
- local($page) = 'Edit PR Results'; # local so visible to &$err_sub
- my $debug = 0;
- my $mail_sent = 0;
- # Local sub to report errors while editing.
- # This allows us to postpone calling print_header().
- my $err_sub = sub {
- my($err_heading, $err_text) = @_;
- print_header();
- page_start_html($page);
- page_heading($page, 'Error');
- print "<h3>$err_heading</h3>";
- print "<p>$err_text</p>" if $err_text;
- page_footer($page);
- page_end_html($page);
- return;
- };
- my($pr) = $q->param('pr');
- if(!$pr)
- {
- &$err_sub("You must specify a problem report number");
- return;
- }
- my(%fields, %mailto, $adr);
- my $audittrail = '';
- my $err = '';
- my $ok = 1;
- # Retrieve new attachment (if any) before locking PR, in case it fails.
- my $encoded_attachment = encode_attachment('attached_file');
- my(%oldfields) = lockpr($pr, $db_prefs{'user'});
- if ($gnats::ERRSTR) {
- &$err_sub("$gnats::ERRSTR", "The PR has not been changed. "
- . "If this problem persists, please contact a "
- . "GNATS administrator.");
- client_exit();
- exit();
- }
- LOCKED:
- {
- # Trim Responsible for compatibility.
- $oldfields{'Responsible'} = trim_responsible($oldfields{'Responsible'});
- # Merge %oldfields and CGI params to get %fields. Not all gnats
- # fields have to be present in the CGI params; the ones which are
- # not specified default to their old values.
- %fields = %oldfields;
- foreach my $key ($q->param)
- {
- my $val = $q->param($key);
- if($key =~ /-Why/
- || ($fieldnames{$key} && ($fieldnames{$key} & $MULTILINE)))
- {
- $val = fix_multiline_val($val);
- }
- $fields{$key} = $val;
- }
- # Add the attached file, if any, to the new PR.
- add_encoded_attachment_to_pr(\%fields, $encoded_attachment);
- # Delete any attachments, if directed.
- my(@deleted_attachments) = $q->param('delete attachments');
- remove_attachments_from_pr(\%fields, @deleted_attachments);
- if($fields{'Last-Modified'} ne $oldfields{'Last-Modified'})
- {
- &$err_sub("PR $pr has been modified since you started editing it.",
- "Please return to the edit form, press the Reload button, "
- . "then make your edits again.\n"
- . "<pre>Last-Modified was '$fields{'Last-Modified'}'\n"
- . "Last-Modified is now '$oldfields{'Last-Modified'}'</pre>\n");
- last LOCKED;
- }
- if($db_prefs{'user'} eq "" || $fields{'Responsible'} eq "")
- {
- &$err_sub("Can't make the edit",
- "Responsible is '$fields{'Responsible'}', user is '$db_prefs{'user'}'");
- last LOCKED;
- }
- # If X-GNATS-Notify or Reply-To changed, we need to splice the
- # change into the envelope.
- foreach ('Reply-To', 'X-GNATS-Notify')
- {
- if($fields{$_} ne $oldfields{$_})
- {
- if ($fields{'envelope'} =~ /^$_:/m)
- {
- # Replace existing header with new one.
- $fields{'envelope'} =~ s/^$_:.*$/$_: $fields{$_}/m;
- }
- else
- {
- # Insert new header at end (blank line). Keep blank line at end.
- $fields{'envelope'} =~ s/^$/$_: $fields{$_}\n/m;
- }
- }
- }
- if ($debug)
- {
- &$err_sub("debugging -- PR edits not submitted");
- debug_print_fields(\%fields);
- last LOCKED;
- }
- # Leave an Audit-Trail
- foreach (@fieldnames)
- {
- if($_ ne "Audit-Trail")
- {
- $oldfields{$_} = '' if !defined($oldfields{$_}); # avoid -w warning
- $fields{$_} = '' if !defined($fields{$_}); # avoid -w warning
- if($fields{$_} ne $oldfields{$_})
- {
- next unless ($fieldnames{$_} & $AUDITINCLUDE);
- if($fieldnames{$_} & $MULTILINE)
- {
- # For multitext fields, indent the values.
- my $tmp = $oldfields{$_};
- $tmp =~ s/^/ /gm;
- $audittrail .= "$_-Changed-From:\n$tmp";
- $tmp = $fields{$_};
- $tmp =~ s/^/ /gm;
- $audittrail .= "$_-Changed-To:\n$tmp";
- }
- else
- {
- $audittrail .= "$_-Changed-From-To: $oldfields{$_}->$fields{$_}\n";
- }
- $audittrail .= "$_-Changed-By: $db_prefs{'user'}\n";
- $audittrail .= "$_-Changed-When: " . scalar(localtime()) . "\n";
- if($fieldnames{$_} & $REASONCHANGE)
- {
- if($fields{"$_-Why"} =~ /^\s*$/)
- {
- if ($ok) {
- $ok = 0;
- print_header();
- page_start_html($page);
- page_heading($page, 'Error');
- }
- print "<h3>Field '$_' must have a reason for change</h3>",
- "Old $_: $oldfields{$_}<br>",
- "New $_: $fields{$_}";
- }
- else
- {
- # Indent the "Why" value.
- my $tmp = $fields{"$_-Why"};
- $tmp =~ s/^/ /gm;
- $audittrail .= "$_-Changed-Why:\n" . $tmp;
- }
- }
- }
- }
- }
- $fields{'Audit-Trail'} = $oldfields{'Audit-Trail'} . $audittrail;
- last LOCKED unless $ok;
- # Get list of people to notify, then add old responsible person.
- # If that person doesn't exist, don't worry about it.
- %mailto = interested_parties($pr, 0, %fields);
- if(defined($adr = praddr($oldfields{'Responsible'})))
- {
- $mailto{$adr} = 1;
- }
- my($newpr) = unparsepr('gnatsd', %fields);
- $newpr =~ s/\r//g;
- #print $q->pre($q->escapeHTML($newpr));
- #last LOCKED; # debug
- # Submit the edits.
- client_cmd("edit $fields{'Number'}");
- my $error = $gnats::ERRSTR;
- client_cmd("$newpr\n.");
- $error ||= $gnats::ERRSTR;
- if ($error) {
- my $page = 'Error';
- print_header();
- page_start_html($page);
- page_heading($page, $page);
- print $q->h2("$error");
- print $q->p("The PR has not been changed. "
- . "If this problem persists, please contact a "
- . "GNATS administrator.");
- last LOCKED;
- }
- # Now send mail to all concerned parties,
- # but only if there's something interesting to say.
- my($mailto);
- delete $mailto{''};
- $mailto = join(", ", sort(keys(%mailto)));
- #print $q->pre($q->escapeHTML("mailto->$mailto<-\n"));
- #last LOCKED; # debug
- if($mailto ne "" && $audittrail ne "")
- {
- # Use email address in responsible file as From, if present.
- my $from = $responsible_address{$db_prefs{'user'}} || $db_prefs{'user'};
- if(!open(MAILER, "|$site_mailer"))
- {
- &$err_sub("Edit successful, but email notification failed",
- "Can't open pipe to $site_mailer: $!");
- last LOCKED;
- }
- else
- {
- print MAILER "To: $mailto\n";
- print MAILER "From: $from\n";
- print MAILER "Reply-To: $from, $mailto, $config{'GNATS_ADDR'}\n";
- print MAILER "X-Mailer: gnatsweb $VERSION\n";
- #GCC-LOCAL begin.
- #print MAILER "Subject: Re: $fields{'Category'}/$pr\n\n";
- print MAILER "Subject: Re: $fields{'Category'}/$pr: $fields{'Synopsis'}\n\n";
- #GCC-LOCAL end.
- if ($oldfields{'Synopsis'} eq $fields{'Synopsis'})
- {
- print MAILER "Synopsis: $fields{'Synopsis'}\n\n";
- }
- else
- {
- print MAILER "Old Synopsis: $oldfields{'Synopsis'}\n";
- print MAILER "New Synopsis: $fields{'Synopsis'}\n\n";
- }
- print MAILER "$audittrail\n";
- # Print URL so that HTML-enabled mail readers can jump to the PR.
- print MAILER get_viewpr_url($pr), "\n";
- if(!close(MAILER))
- {
- &$err_sub("Edit successful, but email notification failed",
- "Can't close pipe to $site_mailer: $!");
- last LOCKED;
- }
- $mail_sent = 1;
- }
- }
- $lock_end_reached = 1;
- }
- unlockpr($fields{'Number'});
- if ($lock_end_reached) {
- # We print out the "Edit successful" message after unlocking the
- # PR. If the user hits the Stop button of the browser while
- # submitting, the web server won't terminate the script until the
- # next time the server attempts to output something to the
- # browser. Since this is the first output after the PR was
- # locked, we print it after the unlocking. Let user know the edit
- # was successful. After a 2s delay, refresh back to where the user
- # was before the edit. Internet Explorer does not honor the HTTP
- # Refresh header, so we have to complement the "clean" CGI.pm
- # method with the ugly hack below, with a HTTP-EQUIV in the HEAD
- # to make things work.
- my $return_url = $q->param('return_url') || get_script_name();
- my $refresh = 2;
- print_header(-Refresh => "$refresh; URL=$return_url",
- -cookie => create_global_cookie());
- # Workaround for MSIE:
- my @args = (-title=>"$page - $site_banner_text");
- push(@args, -bgcolor=>$site_background)
- if defined($site_background);
- push(@args, -style=>{-src=>$site_stylesheet})
- if defined($site_stylesheet);
- push(@args, -head=>meta({-http_equiv=>'Refresh',
- -content=>"$refresh; URL=$return_url"}));
- print $q->start_html(@args);
-
- # Print page banner, with button bar, without the <head> part:
- page_start_html($page, 0, 1);
- page_heading($page, ($mail_sent ? 'Edit successful; mail sent'
- : 'Edit successful'));
- print "<p>Page will refresh in $refresh seconds...</p>\n";
- }
- page_footer($page);
- page_end_html($page);
- }
- sub query_page
- {
- my $page = 'Query PR';
- page_start_html($page);
- page_heading($page, 'Query Problem Reports', 1);
- print_stored_queries();
- print $q->start_form(),
- hidden_db(),
- $q->submit('cmd', 'submit query'),
- "<hr>",
- "<table>\n",
- "<tr>\n<td>Category:</td>\n<td>",
- $q->popup_menu(-name=>'category',
- -values=>\@category,
- -labels=>\%category_desc,
- -default=>$category[0]),
- "</td>\n</tr>\n<tr>\n<td>Severity:</td>\n<td>",
- $q->popup_menu(-name=>'severity',
- -values=>\@severity,
- -default=>$severity[0]),
- "</td>\n</tr>\n<tr>\n<td>Priority:</td>\n<td>",
- $q->popup_menu(-name=>'priority',
- -values=>\@priority,
- -default=>$priority[0]),
- "</td>\n</tr>\n<tr>\n<td>Responsible:</td>\n<td>",
- $q->popup_menu(-name=>'responsible',
- -values=>\@responsible,
- -labels=>\%responsible_fullname,
- -default=>$responsible[0]),
- "</td>\n</tr>\n<tr>\n<td>Submitter-ID:</td>\n<td>",
- $q->popup_menu(-name=>'submitter_id',
- -values=>\@submitter_id,
- -labels=>\%submitter_fullname,
- -default=>$submitter_id[0]),
- "</td>\n</tr>\n<tr>\n<td>State:</td>\n<td>",
- $q->popup_menu(-name=>'state',
- -values=>\@state,
- -default=>$state[0]),
- "</td>\n</tr>\n<tr>\n<td>\n</td>\n<td>",
- $q->checkbox_group(-name=>'ignoreclosed',
- -values=>['Ignore Closed'],
- -defaults=>['Ignore Closed']),
- "</td>\n</tr>\n<tr>\n<td>Class:</td>\n<td>",
- $q->popup_menu(-name=>'class',
- -values=>\@class,
- -default=>$class[0]),
- "</td>\n</tr>\n<tr>\n<td>Synopsis Search:</td>\n<td>",
- $q->textfield(-name=>'synopsis',-size=>25),
- "</td>\n</tr>\n<tr>\n<td>Multi-line Text Search:</td>\n<td>",
- $q->textfield(-name=>'multitext',-size=>25),
- "</td>\n</tr>\n<tr>\n<td>\n</td>\n<td>",
- $q->checkbox_group(-name=>'originatedbyme',
- -values=>['Originated by You'],
- -defaults=>[]),
- "</td>\n</tr>\n<tr valign=top>\n<td>Column Display:</td>\n<td>";
- my(@columns) = split(' ', $global_prefs{'columns'});
- @columns = @deffields unless @columns;
- print $q->scrolling_list(-name=>'columns',
- -values=>\@fields,
- -defaults=>\@columns,
- -multiple=>1,
- -size=>5),
- "</td>\n</tr>\n<tr>\n<td>\n</td>\n<td>",
- $q->checkbox_group(-name=>'displaydate',
- -values=>['Display Current Date'],
- -defaults=>['Display Current Date']),
- "</td>\n</tr>\n</table>",
- "<hr>",
- $q->submit('cmd', 'submit query'),
- $q->end_form();
- page_footer($page);
- page_end_html($page);
- }
- sub advanced_query_page
- {
- my $page = 'Advanced Query';
- page_start_html($page);
- page_heading($page, 'Query Problem Reports', 1);
- print_stored_queries();
- print $q->start_form(),
- hidden_db();
- my $width = 30;
- my $heading_bg = '#9fbdf9';
- my $cell_bg = '#d0d0d0';
- print $q->p($q->submit('cmd', 'submit query'),
- " or ",
- $q->reset(-name=>'reset'));
- print "<hr>";
- print "<center>";
- ### Text and multitext queries
- print "<table border=1 cellspacing=0 bgcolor=$cell_bg>",
- "<caption>Search All Text</caption>",
- "<tr bgcolor=$heading_bg>\n",
- "<th nowrap>Search these text fields</th>\n",
- "<th nowrap>using regular expression</th>\n",
- "</tr>\n";
- print "<tr>\n<td>Single-line text fields:</td>\n<td>",
- $q->textfield(-name=>'text', -size=>$width),
- "</td>\n</tr>\n",
- "<tr>\n<td>Multi-line text fields:</td>\n<td>",
- $q->textfield(-name=>'multitext', -size=>$width),
- "</td>\n</tr>\n",
- "</table>\n";
- print "<div> </div>\n";
- ### Date queries
- print "<table border=1 cellspacing=0 bgcolor=$cell_bg>",
- "<caption>Search By Date</caption>",
- "<tr bgcolor=$heading_bg>\n",
- "<th nowrap>Date Se…
Large files files are truncated, but you can click here to view the full file