1#!/usr/local/bin/perl -w 2# 3# Gnatsweb - web front-end to GNATS 4# 5# Copyright 1998, 1999, 2001, 2003 6# - The Free Software Foundation Inc. 7# 8# GNU Gnatsweb is free software; you can redistribute it and/or modify 9# it under the terms of the GNU General Public License as published by 10# the Free Software Foundation; either version 2, or (at your option) 11# any later version. 12# 13# GNU Gnatsweb is distributed in the hope that it will be useful, but 14# WITHOUT ANY WARRANTY; without even the implied warranty of 15# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 16# General Public License for more details. 17# 18# You should have received a copy of the GNU General Public License 19# along with Gnatsweb; see the file COPYING. If not, write to the Free 20# Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 21# 02111-1307, USA. 22# 23# $Id: gnatsweb.pl,v 1.124.2.2 2003/07/29 12:24:22 yngves Exp $ 24# 25 26use strict; 27 28# static global configuration switches and values. set at the top of 29# this program, but overridable in gnatsweb-site.pl 30use vars qw($site_gnats_host $site_gnats_port 31$site_gnatsweb_server_auth $site_no_gnats_passwords 32$no_create_without_access $site_mail_domain $site_post_max 33$description_in_view $help_page_path $site_banner_text 34$site_banner_background $site_banner_foreground 35$site_button_foreground $site_button_background $site_stylesheet 36$include_audit_trail $popup_menu_becomes_obnoxious 37$scrolling_menu_default_size $site_background 38$site_required_field_color $use_temp_db_prefs_cookie 39$global_cookie_expires $global_cookie_path $textwidth 40$site_allow_remote_debug $attachment_delimiter %mark_urls 41$gnats_info_top %site_pr_submission_address $VERSION); 42 43# dynamic configuration switches, set during initial gnatsd 44# communication and general setup 45use vars qw($script_name $global_no_cookies $global_list_of_dbs 46$client_cmd_debug $reply_debug $access_level); 47 48# these vars are used for error handling in communications 49# with gnatsd 50use vars qw($client_would_have_exited $suppress_client_exit); 51 52# the following variable needs to be global in order to make gnatsweb 53# callable from another source file. Used for 'make test...' 54use vars qw($suppress_main); 55 56# global variables containing most of the info from the gnats-adm 57# directory. these should probably be rolled into one giant hash. 58# in fact, this code should be set up so that gnatsweb under mod_perl 59# could cache all this hooey... 60use vars qw(%category_notify @submitter_id %submitter_contact 61%submitter_complete %submitter_notify @responsible 62%responsible_address %category_desc %responsible_complete %fielddata 63@fieldnames %responsible_fullname); 64 65# the information from the user cookies. 66# db_prefs just has username & password 67# global_prefs has email address, default columns for query results 68# SUBMITTER_ID_FIELD default value and ORIGINATOR_FIELD default value 69# i think that the columns info should be moved to db_prefs, and the 70# code suitably munged so that a user could have different column 71# prefs for different databases. 72use vars qw(%global_prefs %db_prefs); 73 74# the CGI object 75use vars '$q'; 76 77# i couldn't manage to get these two beaten into shape as 78# lexical variables. maybe next time... 79use vars qw($pr %fields); 80 81#----------------------------------------------------------------------------- 82# what do you call the file containing the site-specific customizations? 83# you could, i suppose, by dint of creative programming, have different 84# config files for different databases, or some such madness... 85my $gnatsweb_site_file = './gnatsweb-site.pl'; 86 87# Site-specific customization - 88# 89# DO NOT EDIT THESE VARIABLES HERE! 90# 91# Instead, put them in a file called 'gnatsweb-site.pl' in the 92# same directory. That way, when a new version of gnatsweb is 93# released, you won't need to edit them again. 94# 95 96# Info about your gnats host. 97$site_gnats_host = 'localhost'; 98$site_gnats_port = 1529; 99 100# is your installation of gnatsweb set up with server authentication? 101# if you want to set up a more tightly secured installation, you can 102# have the web server do authentication (against an htpasswd file, 103# LDAP server, or some third-party system). this will set the 104# REMOTE_USER environment variable with the correct user id. with 105# this switch set, the "logout" button is replaced by a "change 106# database" button. 107$site_gnatsweb_server_auth = 0; 108 109# or does it merely ignore the gnats password? the gnats network mode 110# is quite cavalier about passwords, and some sites may elect not to 111# use gnats passwords. if so, there's no point in gnatsweb asking for 112# them. if this switch is set, the login page does not prompt for a 113# password. this means that anyone can pretend to be anyone, but 114# since the gnats command line tools are hardly more secure, it's not 115# a big deal... 116$site_no_gnats_passwords = 0; 117 118# set a minimum access level for access to the create function 119# (this is probably only meaningful if gnatsweb is the only interface 120# to your gnats installation, since by default gnats allows *everyone* 121# to submit PRs) 122# value must be a valid gnatsd.h access level, see %LEVEL_TO_CODE below. 123#$no_create_without_access = 'edit'; 124$no_create_without_access = ''; 125 126# mail domain for responsible field -- bare user-ids in responsible 127# fields will have this added to the end to create a sane mailto: link. 128# you must put the '@' sign at the beginning of the string 129$site_mail_domain = '@yourdomain.here'; 130 131# hash of addresses that your site uses for submission of PRs 132# if this is defined for a given database, the edit and view pages 133# will include a link "submit a follup by email" -- a mailto: this 134# address and the Reply-To address of the PR. 135#%site_pr_submission_address = ('default' => 'bugs@example.com', 136# 'other_db' => 'other-bugs@example.com'); 137%site_pr_submission_address = (); 138 139# the maximum size posting we'll accept 140$site_post_max = 1024 * 1024; 141 142# show field descriptions on the view PR page? this tends to look 143# messy, so by default we only show them on the create and edit pages. 144$description_in_view = 0; 145 146# path to the gnatsweb help page. this is the file that will be 147# returned when the user clicks on the Help button. 148$help_page_path = './gnatsweb.html'; 149 150# Name you want in the page banner and banner colors. 151$site_banner_text = 'GNU Gnatsweb'; 152$site_banner_background = '#000000'; 153$site_banner_foreground = '#ffffff'; 154$site_button_background = '#000000'; 155$site_button_foreground = '#ffffff'; 156 157# Uncomment the following line and insert stylesheet URL in order to 158# link all generated pages to an external stylesheet. Both absolute 159# and relative URLs are supported. 160#$site_stylesheet='http://url.of/stylesheet'; 161$site_stylesheet = undef; 162 163# When $include_audit_trail is set to 1, the Audit-Trail will be 164# visible by default in the View PR screen. Sites that expect large 165# Audit-Trails, i.e. lot of mail back and forth etc., will want to set 166# this to 0. 167$include_audit_trail = 1; 168 169# when we have more than this many items, use a scrolling list 170# instead of a popup 171$popup_menu_becomes_obnoxious = 20; 172 173# default size for scrolling lists. overridden for some fields 174$scrolling_menu_default_size = 3; 175 176# Page background color -- not used unless defined. 177#$site_background = '#c0c0c0'; 178$site_background = undef; 179 180# Color to use for marking the names of required fields on the Create 181# PR page. 182$site_required_field_color = '#ff0000'; 183 184# control the mark_urls routine, which "htmlifies" PRs for view_pr. 185# it adds a lot of usability, but can be slow for huge (100K+) fields. 186# urls = make links clickable 187# emails = make addresses mailto: links 188# prs = make PR numbers links to gnatsweb 189# max_length = strings larger than this will not be processed 190%mark_urls = ( 191 'urls' => 1, 192 'emails' => 1, 193 'prs' => 1, 194 'max_length' => 1024*100, 195 ); 196 197# Use temporary cookie for login information? Gnatsweb stores login 198# information in the db_prefs cookie in the user's browser. With 199# $use_temp_db_prefs_cookie set to 1, the cookie is stored in the 200# browser, not on disk. Thus, the cookie gets deleted when the user 201# exits the browser, improving security. Otherwise, the cookie will 202# remain active until the expiration date specified by 203# $global_cookie_expires arrives. 204$use_temp_db_prefs_cookie = 0; 205 206# What to use as the -path argument in cookies. Using '' (or omitting 207# -path) causes CGI.pm to pass the basename of the script. With that 208# setup, moving the location of gnatsweb.pl causes it to see the old 209# cookies but not be able to delete them. 210$global_cookie_path = '/'; 211$global_cookie_expires = '+30d'; 212 213# width of text fields 214$textwidth = 60; 215 216# do we allow users to spy on our communications with gnatsd? 217# if this is set, setting the 'debug' param will display communications 218# with gnatsd to the browser. really only useful to gnats administrators. 219$site_allow_remote_debug = 1; 220 221# delimiter to use within PRs for storage of attachments 222# if you change this, all your old PRs with attachments will 223# break... 224$attachment_delimiter = "----gnatsweb-attachment----\n"; 225 226# where to get help -- a web site with translated info documentation 227$gnats_info_top = 'http://www.gnu.org/software/gnats/gnats_toc.html'; 228 229# end customization 230#----------------------------------------------------------------------------- 231 232# Use CGI::Carp first, so that fatal errors come to the browser, including 233# those caused by old versions of CGI.pm. 234use CGI::Carp qw/fatalsToBrowser/; 235# 8/22/99 kenstir: CGI.pm-2.50's file upload is broken. 236# 9/19/99 kenstir: CGI.pm-2.55's file upload is broken. 237use CGI 2.56 qw/-nosticky/; 238use Socket; 239use IO::Handle; 240use Text::Tabs; 241 242# Version number + RCS revision number 243$VERSION = '4.00'; 244my $REVISION = (split(/ /, '$Revision: 1.124.2.2 $ '))[1]; 245my $GNATS_VERS = '0.0'; 246 247# bits in fieldinfo(field, flags) has (set=yes not-set=no) 248my $SENDINCLUDE = 1; # whether the send command should include the field 249my $REASONCHANGE = 2; # whether change to a field requires reason 250my $READONLY = 4; # if set, can't be edited 251my $AUDITINCLUDE = 8; # if set, save changes in Audit-Trail 252my $SENDREQUIRED = 16; # whether the send command _must_ include this field 253 254# The possible values of a server reply type. $REPLY_CONT means that there 255# are more reply lines that will follow; $REPLY_END Is the final line. 256my $REPLY_CONT = 1; 257my $REPLY_END = 2; 258 259# 260# Various PR field names that should probably not be referenced in here. 261# 262# Actually, the majority of uses are probably OK--but we need to map 263# internal names to external ones. (All of these field names correspond 264# to internal fields that are likely to be around for a long time.) 265# 266my $CATEGORY_FIELD = 'Category'; 267my $SYNOPSIS_FIELD = 'Synopsis'; 268my $SUBMITTER_ID_FIELD = 'Submitter-Id'; 269my $ORIGINATOR_FIELD = 'Originator'; 270my $AUDIT_TRAIL_FIELD = 'Audit-Trail'; 271my $RESPONSIBLE_FIELD = 'Responsible'; 272my $LAST_MODIFIED_FIELD = 'Last-Modified'; 273my $NUMBER_FIELD = 'builtinfield:Number'; 274my $STATE_FIELD = 'State'; 275my $UNFORMATTED_FIELD = 'Unformatted'; 276my $RELEASE_FIELD = 'Release'; 277 278# we use the access levels defined in gnatsd.h to do 279# access level comparisons 280#define ACCESS_UNKNOWN 0x00 281#define ACCESS_DENY 0x01 282#define ACCESS_NONE 0x02 283#define ACCESS_SUBMIT 0x03 284#define ACCESS_VIEW 0x04 285#define ACCESS_VIEWCONF 0x05 286#define ACCESS_EDIT 0x06 287#define ACCESS_ADMIN 0x07 288my %LEVEL_TO_CODE = ('deny' => 1, 289 'none' => 2, 290 'submit' => 3, 291 'view' => 4, 292 'viewconf' => 5, 293 'edit' => 6, 294 'admin' => 7); 295 296 297my $CODE_GREETING = 200; 298my $CODE_CLOSING = 201; 299my $CODE_OK = 210; 300my $CODE_SEND_PR = 211; 301my $CODE_SEND_TEXT = 212; 302my $CODE_NO_PRS_MATCHED = 220; 303my $CODE_NO_ADM_ENTRY = 221; 304my $CODE_PR_READY = 300; 305my $CODE_TEXT_READY = 301; 306my $CODE_INFORMATION = 350; 307my $CODE_INFORMATION_FILLER = 351; 308my $CODE_NONEXISTENT_PR = 400; 309my $CODE_EOF_PR = 401; 310my $CODE_UNREADABLE_PR = 402; 311my $CODE_INVALID_PR_CONTENTS = 403; 312my $CODE_INVALID_FIELD_NAME = 410; 313my $CODE_INVALID_ENUM = 411; 314my $CODE_INVALID_DATE = 412; 315my $CODE_INVALID_FIELD_CONTENTS = 413; 316my $CODE_INVALID_SEARCH_TYPE = 414; 317my $CODE_INVALID_EXPR = 415; 318my $CODE_INVALID_LIST = 416; 319my $CODE_INVALID_DATABASE = 417; 320my $CODE_INVALID_QUERY_FORMAT = 418; 321my $CODE_NO_KERBEROS = 420; 322my $CODE_AUTH_TYPE_UNSUP = 421; 323my $CODE_NO_ACCESS = 422; 324my $CODE_LOCKED_PR = 430; 325my $CODE_GNATS_LOCKED = 431; 326my $CODE_GNATS_NOT_LOCKED = 432; 327my $CODE_PR_NOT_LOCKED = 433; 328my $CODE_CMD_ERROR = 440; 329my $CODE_WRITE_PR_FAILED = 450; 330my $CODE_ERROR = 600; 331my $CODE_TIMEOUT = 610; 332my $CODE_NO_GLOBAL_CONFIG = 620; 333my $CODE_INVALID_GLOBAL_CONFIG = 621; 334my $CODE_NO_INDEX = 630; 335my $CODE_FILE_ERROR = 640; 336 337$| = 1; # flush output after each print 338 339# A couple of internal status variables: 340# Have the HTTP header, start_html, heading already been printed? 341my $print_header_done = 0; 342my $page_start_html_done = 0; 343my $page_heading_done = 0; 344 345sub gerror 346{ 347 my($text) = @_; 348 my $page = 'Error'; 349 print_header(); 350 page_start_html($page); 351 page_heading($page, 'Error'); 352 print "<p>$text\n</p>\n"; 353} 354 355# Close the client socket and exit. The exit can be suppressed by: 356# setting $suppress_client_exit = 1 in the calling routine (using local) 357# [this is only set in edit_pr and the initial login section] 358sub client_exit 359{ 360 if (! defined($suppress_client_exit)) 361 { 362 close(SOCK); 363 exit(); 364 } 365 else 366 { 367 $client_would_have_exited = 1; 368 } 369} 370 371sub server_reply 372{ 373 my($state, $text, $type); 374 my $raw_reply = <SOCK>; 375 if(defined($reply_debug)) 376 { 377 print_header(); 378 print "<tt>server_reply: $raw_reply</tt><br>\n"; 379 } 380 if($raw_reply =~ /(\d+)([- ]?)(.*$)/) 381 { 382 $state = $1; 383 $text = $3; 384 if($2 eq '-') 385 { 386 $type = $REPLY_CONT; 387 } 388 else 389 { 390 if($2 ne ' ') 391 { 392 gerror("bad type of reply from server"); 393 } 394 $type = $REPLY_END; 395 } 396 return ($state, $text, $type); 397 } 398 else 399 { 400 # unparseable reply. send back the raw reply for error reporting 401 return (undef, undef, undef, $raw_reply); 402 } 403} 404 405sub read_server 406{ 407 my(@text); 408 409 while(<SOCK>) 410 { 411 if(defined($reply_debug)) 412 { 413 print_header(); 414 print "<tt>read_server: $_</tt><br>\n"; 415 } 416 if(/^\.\r/) 417 { 418 return @text; 419 } 420 $_ =~ s/[\r\n]//g; 421 # Lines which begin with a '.' are escaped by gnatsd with another '.' 422 $_ =~ s/^\.\././; 423 push(@text, $_); 424 } 425} 426 427sub get_reply 428{ 429 my @rettext = (); 430 my ($state, $text, $type, $raw_reply); 431 432 do { 433 ($state, $text, $type, $raw_reply) = server_reply(); 434 435 unless ($state) { 436 # gnatsd has returned something unparseable 437 if ($reply_debug || $client_cmd_debug) { 438 gerror("unparseable reply from gnatsd: $raw_reply") 439 } else { 440 gerror("Unparseable reply from gnatsd"); 441 } 442 warn("gnatsweb: unparseable gnatsd output: $raw_reply; user=$db_prefs{'user'}, db=$global_prefs{'database'}; stacktrace: ", print_stacktrace()); 443 return; 444 } 445 446 if($state == $CODE_GREETING) 447 { 448 push(@rettext, $text); 449 # nothing 450 } 451 elsif($state == $CODE_OK || $state == $CODE_GREETING 452 || $state == $CODE_CLOSING) 453 { 454 push(@rettext, $text); 455 # nothing 456 } 457 elsif($state == $CODE_PR_READY || $state == $CODE_TEXT_READY) 458 { 459 @rettext = read_server(); 460 } 461 elsif($state == $CODE_SEND_PR || $state == $CODE_SEND_TEXT) 462 { 463 # nothing, tho it would be better... 464 } 465 elsif($state == $CODE_INFORMATION_FILLER) 466 { 467 # nothing 468 } 469 elsif($state == $CODE_INFORMATION) 470 { 471 push(@rettext, $text); 472 } 473 elsif($state == $CODE_NO_PRS_MATCHED) 474 { 475 gerror("Return code: $state - $text"); 476 page_footer('Error'); 477 page_end_html('Error'); 478 client_exit(); 479 push(@rettext, $text); 480 } 481 elsif($state >= 400 && $state <= 799) 482 { 483 if ($state == $CODE_NO_ACCESS) 484 { 485 if ($site_gnatsweb_server_auth) { 486 $text = " You do not have access to database \"$global_prefs{'database'}\""; 487 } else { 488 $text = " Access denied (login again & check usercode/password)"; 489 } 490 } 491 gerror("Return code: $state - $text"); 492 warn("gnatsweb: gnatsd error $state-$text; user=$db_prefs{'user'}, db=$global_prefs{'database'}; stacktrace: ", print_stacktrace()); 493 page_footer('Error'); 494 page_end_html('Error'); 495 client_exit(); 496 push(@rettext, $text); 497 } 498 else 499 { 500 # gnatsd returned a state, but we don't know what it is 501 push(@rettext, $text); 502 gerror("Cannot understand gnatsd output: $state '$text'"); 503 warn("gnatsweb: gnatsd error $state-$text; user=$db_prefs{'user'}, db=$global_prefs{'database'}; stacktrace: ", print_stacktrace()); 504 } 505 } until ($type != $REPLY_CONT); 506 return @rettext; 507} 508 509 510# print a stacktrace 511# used by the various warn() statments to emit useful diagnostics 512# to the web server error logs. 513sub print_stacktrace { 514 my @stacktrace; 515 my $i = 1; 516 while ( my($subroutine) = (caller($i++))[3] ) { 517 push(@stacktrace, $subroutine); 518 } 519 return 'In: ' . join(' <= ', @stacktrace); 520} 521 522sub multiselect_menu 523{ 524 my $size = @{$_[1]} < 4 ? @{$_[1]} : 4; 525 return $q->scrolling_list(-name=>$_[0], -values=>$_[1], -size=>$size, 526 -multiple=>'true', -default=>$_[2]); 527} 528 529sub popup_or_scrolling_menu 530{ 531 my $size=$_[3]; 532 if (!(defined $size)) 533 { 534 $size = $scrolling_menu_default_size; 535 } 536 537# a hack to make responsible field easier to deal with when 538# there are many names in the responsible file 539 if ($_[0] =~ m/responsible/i) { 540 $size = 5; 541 } 542 543 # put human readable values in the popup lists for common 544 # gnats fields 545 my $labels; 546 if ($_[0] eq "Category") { 547 $labels = \%category_desc; 548 } 549 elsif ($_[0] eq "Responsible") { 550 $labels = \%responsible_complete; 551 } 552 elsif ($_[0] eq "Submitter-Id") { 553 $labels = \%submitter_complete; 554 } 555 556 if ($#{$_[1]} >= $popup_menu_becomes_obnoxious) 557 { 558 return $q->scrolling_list (-name=>$_[0], 559 -size=>$size, 560 -values=>$_[1], 561 -labels=>$labels, 562 -default=>$_[2]); 563 } 564 else 565 { 566 return $q->popup_menu (-name=>$_[0], 567 -values=>$_[1], 568 -labels=>$labels, 569 -default=>$_[2]); 570 571 } 572} 573 574# wrapper functions for formstart... 575sub multipart_form_start 576{ 577 formstart(1, @_); 578} 579sub form_start 580{ 581 formstart(0, @_); 582} 583 584# workaround for an exceedingly dumb netscape bug. we hates 585# netscape... this bug manifests if you click on the "create" 586# button bar link (but not the grey button on the main page), submit a 587# PR, then hit the back button (usually because you got an error). 588# you're taken "back" to the same error page -- all the stuff you 589# entered into the submission form is *gone*. this is kind of annoying... 590# (it also manifests if you click the edit link from the query results page.) 591sub formstart 592{ 593 # this bugfix is mostly lifted from the CGI.pm docs. here's what they 594 # have to say: 595 # When you press the "back" button, the same page is loaded, not 596 # the previous one. Netscape's history list gets confused 597 # when processing multipart forms. If the script generates 598 # different pages for the form and the results, hitting the 599 # "back" button doesn't always return you to the previous page; 600 # instead Netscape reloads the current page. This happens even 601 # if you don't use an upload file field in your form. 602 # 603 # A workaround for this is to use additional path information to 604 # trick Netscape into thinking that the form and the response 605 # have different URLs. I recommend giving each form a sequence 606 # number and bumping the sequence up by one each time the form 607 # is accessed: 608 609 # should we do multipart? 610 my $multi = shift; 611 612 # in case the caller has some args to pass... 613 my %args = @_; 614 615 # if the caller has given an "action" arg, we don't do any 616 # subterfuge. let the caller worry about the bug... 617 if (!exists $args{'-action'}) { 618 # get sequence number and increment it 619 my $s = $q->path_info =~ m{/(\d+)/?$}; 620 $s++; 621 # Trick Netscape into thinking it's loading a new script: 622 $args{-action} = $q->script_name . "/$s"; 623 } 624 625 if ($multi) { 626 print $q->start_multipart_form(%args); 627 } else { 628 print $q->start_form(%args); 629 } 630 631 return; 632} 633 634sub fieldinfo 635{ 636 my ($fieldname, $member) = @_; 637 return $fielddata{$fieldname}{$member}; 638} 639 640sub isvalidfield 641{ 642 return exists($fielddata{$_[0]}{'fieldtype'}); 643} 644 645sub init_fieldinfo 646{ 647 my $debug = 0; 648 my $field; 649 650 @fieldnames = client_cmd("list FieldNames"); 651 my @type = client_cmd ("ftyp ". join(" ",@fieldnames)); 652 my @desc = client_cmd ("fdsc ". join(" ",@fieldnames)); 653 my @flgs = client_cmd ("fieldflags ". join(" ",@fieldnames)); 654 my @fdflt = client_cmd ("inputdefault ". join(" ",@fieldnames)); 655 foreach $field (@fieldnames) { 656 $fielddata{$field}{'flags'} = 0; 657 $fielddata{$field}{'fieldtype'} = lc(shift @type); 658 $fielddata{$field}{'desc'} = shift @desc; 659 $fielddata{$field}{'fieldflags'} = lc(shift @flgs); 660 if ($fielddata{$field}{'fieldflags'} =~ /requirechangereason/) 661 { 662 $fielddata{$field}{'flags'} |= $REASONCHANGE; 663 } 664 if ($fielddata{$field}{'fieldflags'} =~ /readonly/) 665 { 666 $fielddata{$field}{'flags'} |= $READONLY; 667 } 668 if ($fielddata{$field}{'fieldtype'} eq 'multienum') 669 { 670 my @response = client_cmd("ftypinfo $field separators"); 671 $response[0] =~ /'(.*)'/; 672 $fielddata{$field}{'separators'} = $1; 673 $fielddata{$field}{'default_sep'} = substr($1, 0, 1); 674 } 675 my @values = client_cmd ("fvld $field"); 676 $fielddata{$field}{'values'} = [@values]; 677 $fielddata{$field}{'default'} = shift (@fdflt); 678 $fielddata{$field}{'default'} =~ s/\\n/\n/g; 679 $fielddata{$field}{'default'} =~ s/\s$//; 680 } 681 foreach $field (client_cmd ("list InitialInputFields")) { 682 $fielddata{$field}{flags} |= $SENDINCLUDE; 683 } 684 foreach $field (client_cmd ("list InitialRequiredFields")) { 685 $fielddata{$field}{flags} |= $SENDREQUIRED; 686 } 687 if ($debug) 688 { 689 foreach $field (@fieldnames) { 690 warn "name = $field\n"; 691 warn " type = $fielddata{$field}{'fieldtype'}\n"; 692 warn " flags = $fielddata{$field}{'flags'}\n"; 693 warn " values = $fielddata{$field}{'values'}\n"; 694 warn "\n"; 695 } 696 } 697} 698 699sub client_init 700{ 701 my($iaddr, $paddr, $proto, $line, $length); 702 if(!($iaddr = inet_aton($site_gnats_host))) 703 { 704 error_page("Unknown GNATS host '$site_gnats_host'", 705 "Check your Gnatsweb configuration."); 706 exit(); 707 } 708 $paddr = sockaddr_in($site_gnats_port, $iaddr); 709 710 $proto = getprotobyname('tcp'); 711 if(!socket(SOCK, PF_INET, SOCK_STREAM, $proto)) 712 { 713 gerror("socket: $!"); 714 warn("gnatsweb: client_init error: $! ; user=$db_prefs{'user'}, db=$global_prefs{'database'}; stacktrace: ", print_stacktrace()); 715 exit(); 716 } 717 if(!connect(SOCK, $paddr)) 718 { 719 gerror("connect: $!"); 720 warn("gnatsweb: client_init error: $! ; user=$db_prefs{'user'}, db=$global_prefs{'database'}; stacktrace: ", print_stacktrace()); 721 exit(); 722 } 723 SOCK->autoflush(1); 724 get_reply(); 725} 726 727# to debug: 728# local($client_cmd_debug) = 1; 729# client_cmd(...); 730sub client_cmd 731{ 732 my($cmd) = @_; 733 my $debug = 0; 734 print SOCK "$cmd\n"; 735 warn "client_cmd: $cmd" if $debug; 736 if(defined($client_cmd_debug)) 737 { 738 print_header(); 739 print "<br><tt>client_cmd: <pre>$cmd</pre></tt><br>\n"; 740 } 741 return get_reply(); 742} 743 744 745 # keep the "cached" value of $can_do_mime lexically scoped 746do { 747 my $can_do_mime; 748 749 # Return true if module MIME::Base64 is available. If available, it's 750 # loaded the first time this sub is called. 751 sub can_do_mime 752 { 753 return $can_do_mime if (defined($can_do_mime)); 754 755 eval 'use MIME::Base64;'; 756 if ($@) { 757 warn "NOTE: Can't use file upload feature without MIME::Base64 module\n"; 758 $can_do_mime = 0; 759 } else { 760 $can_do_mime = 1; 761 } 762 $can_do_mime; 763 } 764}; 765 766# Take the file attachment's file name, and return only the tail. Don't 767# want to store any path information, for security and clarity. Support 768# both DOS-style and Unix-style paths here, because we have both types of 769# clients. 770sub attachment_filename_tail 771{ 772 my($filename) = @_; 773 $filename =~ s,.*/,,; # Remove leading Unix path elements. 774 $filename =~ s,.*\\,,; # Remove leading DOS path elements. 775 776 return $filename; 777} 778 779# Retrieve uploaded file attachment. Return it as 780# ($filename, $content_type, $data). Returns (undef,undef,undef) 781# if not present. 782# 783# See 'perldoc CGI' for details about this code. 784sub get_attachment 785{ 786 my $upload_param_name = shift; 787 my $debug = 0; 788 my $filename = $q->param($upload_param_name); 789 return (undef, undef, undef) unless $filename; 790 791 # 9/6/99 kenstir: My testing reveals that if uploadInfo returns undef, 792 # then you can't read the file either. 793 warn "get_attachment: filename=$filename\n" if $debug; 794 my $hashref = $q->uploadInfo($filename); 795 if (!defined($hashref)) { 796 warn("gnatsweb: attachment filename w/o attachment; user=$db_prefs{'user'}, db=$global_prefs{'database'}; stacktrace: ", print_stacktrace()); 797 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())."; 798 } 799 if ($debug) { 800 my ($k, $v); 801 while (($k, $v) = each %$hashref) { 802 warn "get_attachment: uploadInfo($k)=$v\n"; 803 } 804 } 805 806 # 9/6/99 kenstir: When testing locally on Linux, a .gz file yielded 807 # no Content-Type. Therefore, have to assume binary. Would like to 808 # check (-B $fh) to see if the stream is binary but that doesn't work. 809 my $ctype = $hashref->{'Content-Type'} || 'application/octet-stream'; 810 warn "get_attachment: Content-Type=$ctype\n" if $debug; 811 812 my $data = ''; 813 my $buf; 814 my $fh = $q->upload($upload_param_name); 815 warn "get_attachment: fh=$fh\n" if $debug; 816 while (read($fh, $buf, 1024)) { 817 $data .= $buf; 818 } 819 close $fh; 820 821 return ($filename, $ctype, $data); 822} 823 824# Retrieve uploaded file attachment, and encode it so that it's 825# printable, for inclusion into the PR text. 826# 827# Returns the printable text representing the attachment. Returns '' if 828# the attachment was not present. 829sub encode_attachment 830{ 831 my $upload_param_name = shift; 832 my $debug = 0; 833 834 return '' unless can_do_mime(); 835 836 my ($filename, $ctype, $data) = get_attachment($upload_param_name); 837 return '' unless $filename; 838 839 # Strip off path elements in $filename. 840 $filename = attachment_filename_tail($filename); 841 842 warn "encode_attachment: $filename was ", length($data), " bytes of $ctype\n" 843 if $debug; 844 my $att = ''; 845 846 # Plain text is included inline; all else is encoded. 847 $att .= "Content-Type: $ctype; name=\"$filename\"\n"; 848 if ($ctype eq 'text/plain') { 849 $att .= "Content-Disposition: inline; filename=\"$filename\"\n\n"; 850 $att .= $data; 851 } 852 else { 853 $att .= "Content-Transfer-Encoding: base64\n"; 854 $att .= "Content-Disposition: attachment; filename=\"$filename\"\n\n"; 855 $att .= encode_base64($data); 856 } 857 warn "encode_attachment: done\n" if $debug; 858 859 return $att; 860} 861 862# Takes the encoded file attachment, decodes it and returns it as a hashref. 863sub decode_attachment 864{ 865 my $att = shift; 866 my $debug = 0; 867 my $hash_ref = {'original_attachment' => $att}; 868 869 # Split the envelope from the body. 870 my ($envelope, $body) = split(/\n\n/, $att, 2); 871 return $hash_ref unless ($envelope && $body); 872 873 # Split mbox-like headers into (header, value) pairs, with a leading 874 # "From_" line swallowed into USELESS_LEADING_ENTRY. Junk the leading 875 # entry. Chomp all values. 876 warn "decode_attachment: envelope=>$envelope<=\n" if $debug; 877 %$hash_ref = (USELESS_LEADING_ENTRY => split /^(\S*?):\s*/m, $envelope); 878 delete($hash_ref->{USELESS_LEADING_ENTRY}); 879 for (keys %$hash_ref) { 880 chomp $hash_ref->{$_}; 881 } 882 883 # Keep the original_attachment intact. 884 $$hash_ref{'original_attachment'} = $att; 885 886 if (!$$hash_ref{'Content-Type'} 887 || !$$hash_ref{'Content-Disposition'}) 888 { 889 warn("gnatsweb: unable to parse file attachment; user=$db_prefs{'user'}, db=$global_prefs{'database'}; stacktrace: ", print_stacktrace()); 890 die "Unable to parse file attachment"; 891 } 892 893 # Parse filename. 894 # Note: the extra \ before the " is just so that perl-mode can parse it. 895 if ($$hash_ref{'Content-Disposition'} !~ /(\S+); filename=\"([^\"]+)\"/) { 896 warn("gnatsweb: unable to parse file attachment Content-Disposition; user=$db_prefs{'user'}, db=$global_prefs{'database'}; stacktrace: ", print_stacktrace()); 897 die "Unable to parse file attachment Content-Disposition"; 898 } 899 $$hash_ref{'filename'} = attachment_filename_tail($2); 900 901 # Decode the data if encoded. 902 if (exists($$hash_ref{'Content-Transfer-Encoding'}) 903 && $$hash_ref{'Content-Transfer-Encoding'} eq 'base64') 904 { 905 $$hash_ref{'data'} = decode_base64($body); 906 } 907 else { 908 $$hash_ref{'data'} = $body; 909 } 910 911 return $hash_ref; 912} 913 914# Print file attachment browser and buttons to download the attachments. 915# Which of these appear depend on the mode. 916sub print_attachments 917{ 918 my($fields_hash_ref, $mode) = @_; 919 920 return unless can_do_mime(); 921 922 print "<tr><td valign=top><b>File Attachments:</b></td>\n<td>"; 923 924 # Add file upload button for adding new attachment. 925 if ($mode eq 'sendpr' || $mode eq 'edit') { 926 print "Add a file attachment:<br />", 927 $q->filefield(-name=>'attached_file', 928 -size=>50); 929 # that's all we need to do if this is the sendpr page 930 return if $mode eq 'sendpr'; 931 } 932 933 # Print table of existing attachments. 934 # Add column with delete button in edit mode. 935 my $array_ref = $$fields_hash_ref{'attachments'}; 936 my $table_rows_aref = []; 937 my $i = 0; 938 foreach my $hash_ref (@$array_ref) { 939 my $size = int(length($$hash_ref{'data'}) / 1024.0); 940 $size = 1 if ($size < 1); 941 my $row_data = $q->td( [ $q->submit('cmd', "download attachment $i"), 942 $$hash_ref{'filename'}, 943 "${size}k" ] ); 944 $row_data .= $q->td($q->checkbox(-name=>'delete attachments', 945 -value=>$i, 946 -label=>"delete attachment $i")) 947 if ($mode eq 'edit'); 948 push(@$table_rows_aref, $row_data); 949 $i++; 950 } 951 if (@$table_rows_aref) 952 { 953 my $header_row_data = $q->th( ['download','filename','size' ] ); 954 $header_row_data .= $q->th('delete') 955 if ($mode eq 'edit'); 956 print $q->table({-border=>1}, 957 $q->Tr($header_row_data), 958 $q->Tr($table_rows_aref)); 959 print "</td>\n</tr>\n"; 960 } 961} 962 963# The user has requested download of a particular attachment. 964# Serve it up. 965sub download_attachment 966{ 967 my $attachment_number = shift; 968 my($pr) = $q->param('pr'); 969 970 # strip out leading category (and any other non-digit trash) from $pr 971 $pr =~ s/\D//g; 972 973 if(!$pr) { 974 warn("gnatsweb: download_attachment called with no PR number; user=$db_prefs{'user'}, db=$global_prefs{'database'}; stacktrace: ", print_stacktrace()); 975 die "download_attachment called with no PR number" 976 } 977 978 my(%fields) = readpr($pr); 979 my $array_ref = $fields{'attachments'}; 980 my $hash_ref = $$array_ref[$attachment_number]; 981 my $disp; 982 983 # Internet Explorer 5.5 does not handle "content-disposition: attachment" 984 # in the expected way. It needs a content-disposition of "file". 985 ($ENV{'HTTP_USER_AGENT'} =~ "MSIE 5.5") ? ($disp = 'file') : ($disp = 'attachment'); 986 # Now serve the attachment, with the appropriate headers. 987 print_header(-type => 'application/octet-stream', 988 -content_disposition => "$disp; filename=\"$$hash_ref{'filename'}\""); 989 print $$hash_ref{'data'}; 990} 991 992# Add the given (gnatsweb-encoded) attachment to the %fields hash. 993sub add_encoded_attachment_to_pr 994{ 995 my($fields_hash_ref, $encoded_attachment) = @_; 996 return unless $encoded_attachment; 997 my $ary_ref = $$fields_hash_ref{'attachments'} || []; 998 my $hash_ref = { 'original_attachment' => $encoded_attachment }; 999 push(@$ary_ref, $hash_ref); 1000 $$fields_hash_ref{'attachments'} = $ary_ref; 1001} 1002 1003# Add the given (gnatsweb-decoded) attachment to the %fields hash. 1004sub add_decoded_attachment_to_pr 1005{ 1006 my($fields_hash_ref, $decoded_attachment_hash_ref) = @_; 1007 return unless $decoded_attachment_hash_ref; 1008 my $ary_ref = $$fields_hash_ref{'attachments'} || []; 1009 push(@$ary_ref, $decoded_attachment_hash_ref); 1010 $$fields_hash_ref{'attachments'} = $ary_ref; 1011} 1012 1013# Remove the given attachments from the %fields hash. 1014sub remove_attachments_from_pr 1015{ 1016 my($fields_hash_ref, @attachment_numbers) = @_; 1017 return unless @attachment_numbers; 1018 my $ary_ref = $$fields_hash_ref{'attachments'} || []; 1019 foreach my $attachment_number (@attachment_numbers) 1020 { 1021 # Remove the attachment be replacing it with the empty hash. 1022 # The sub unparsepr skips these. 1023 $$ary_ref[$attachment_number] = {}; 1024 } 1025} 1026 1027# sendpr - 1028# The Create PR page. 1029# 1030sub sendpr 1031{ 1032 my $page = 'Create PR'; 1033 page_start_html($page); 1034 page_heading($page, 'Create Problem Report'); 1035 1036 print multipart_form_start(-name=>'PrForm'), "\n", 1037 hidden_db(), 1038 hidden_debug(), 1039 $q->span($q->submit('cmd', 'submit'), 1040 " or ", 1041 $q->reset(-name=>'reset')), 1042 $q->hidden(-name=>'return_url'), 1043 "<hr />\n", 1044 "<table>"; 1045 my $def_email = $global_prefs{'email'} || ''; 1046 print "<tr>\n<td width=\"20%\"><b>Reporter's email:</b></td>\n<td>", 1047 $q->textfield(-name=>'email', 1048 -default=>$def_email, 1049 -size=>$textwidth), "</td>\n</tr>\n"; 1050 # keep count of field number, so that javascript hooks can 1051 # have a way to access fields with dashes in their names 1052 # they'll need to use PrForm.elements[fieldNumber].value 1053 # instead of the dashed name 1054 # note that this is a zero-based count!! 1055 # there are six fields "hardcoded" into the form above this point. 1056 my $field_number = 5; 1057 1058 foreach (@fieldnames) 1059 { 1060 if (! (fieldinfo ($_, 'flags') & $SENDINCLUDE)) 1061 { 1062 next; 1063 } 1064 1065 $field_number++; 1066 1067 # Get default value(s). 1068 my $default = fieldinfo($_, 'default'); 1069 1070 my $values = fieldinfo($_, 'values'); 1071 1072 # The "intro" provides a way for the site callback to print something 1073 # at the top of a given field. 1074 my $intro = cb("sendpr_intro_$_", $field_number) || ''; 1075 1076 print "<tr><td valign=\"top\" width=\"20%\">"; 1077 fieldinfo ($_, 'flags') & $SENDREQUIRED ? 1078 print "<font color=\"$site_required_field_color\"><b>$_</b></font>" : print "<b>$_</b>"; 1079 print "<br /><small>\n", 1080 fieldinfo($_, 'desc'), 1081 "</small></td><td>\n", $intro, "\n"; 1082 1083 if (fieldinfo($_, 'fieldtype') eq "enum") 1084 { 1085 # Force user to choose a category. 1086 if ($_ eq $CATEGORY_FIELD) 1087 { 1088 push(@$values, "unknown") if (!grep /^unknown$/, @$values); 1089 $default = "unknown"; 1090 } 1091 if ($_ eq $SUBMITTER_ID_FIELD) 1092 { 1093 $default = $global_prefs{$SUBMITTER_ID_FIELD} || ''; 1094 } 1095 print popup_or_scrolling_menu($_, $values, $default), 1096 "</td>\n</tr>\n"; 1097 } 1098 elsif (fieldinfo ($_, 'fieldtype') eq 'multienum') 1099 { 1100 my $defaultsref = parse_multienum($default, $_); 1101 print multiselect_menu($_, $values, $defaultsref), 1102 "</td>\n</tr>\n"; 1103 } 1104 elsif (fieldinfo($_, 'fieldtype') eq "multitext") 1105 { 1106 my $rows = 4; 1107 print $q->textarea(-name=>$_, 1108 -cols=>$textwidth, 1109 -rows=>$rows, 1110 -default=>$default), 1111 "</td>\n</tr>\n"; 1112 # Create file upload button after Description. 1113 if (/Description/) 1114 { 1115 print_attachments(undef, 'sendpr'); 1116 } 1117 } 1118 else 1119 { 1120 print $q->textfield(-name=>$_, 1121 -size=>$textwidth, 1122 -default=>$default), 1123 "</td>\n</tr>\n"; 1124 } 1125 print "\n"; 1126 } 1127 print "</table>", 1128 $q->p($q->submit('cmd', 'submit'), 1129 " or ", 1130 $q->reset(-name=>'reset')), 1131 $q->end_form(); 1132 1133 page_footer($page); 1134 page_end_html($page); 1135} 1136 1137# validate_email_field - 1138# Used by validate_new_pr to check email address fields in a new PR. 1139sub validate_email_field 1140{ 1141 my($fieldname, $fieldval, $required) = @_; 1142 1143 my $blank = ($fieldval =~ /^\s*$/); 1144 if ($required && $blank) 1145 { 1146 return "$fieldname is blank"; 1147 } 1148 # From rkimball@vgi.com, allows @ only if it's followed by what looks 1149 # more or less like a domain name. 1150 my $email = '[^@\s]+(@\S+\.\S+)?'; 1151 if (!$blank && $fieldval !~ /^\s*($email\s*)+$/) 1152 { 1153 return "'$fieldval' doesn't look like a valid email address (xxx\@xxx.xxx)"; 1154 } 1155 return ''; 1156} 1157 1158# validate_new_pr - 1159# Make sure fields have reasonable values before submitting a new PR. 1160sub validate_new_pr 1161{ 1162 my(%fields) = @_; 1163 my(@errors) = (); 1164 my $err; 1165 1166 # validate email fields 1167 $err = validate_email_field('E-mail Address', $fields{'email'}, 'required'); 1168 push(@errors, $err) if $err; 1169 1170 # XXX ??? !!! FIXME 1171 # validate some other fields 1172 if($fields{$CATEGORY_FIELD} =~ /^\s*$/ 1173 || $fields{$CATEGORY_FIELD} eq "unknown") 1174 { 1175 push(@errors, "Category is blank or 'unknown'"); 1176 } 1177 if($fields{$SYNOPSIS_FIELD} =~ /^\s*$/ 1178 || $fields{$SYNOPSIS_FIELD} eq "unknown") 1179 { 1180 push(@errors, "Synopsis is blank or 'unknown'"); 1181 } 1182 if($fields{$SUBMITTER_ID_FIELD} eq 'unknown') 1183 { 1184 push(@errors, "Submitter-Id is 'unknown'"); 1185 } 1186 1187 @errors; 1188} 1189 1190sub submitnewpr 1191{ 1192 my $page = 'Create PR Results'; 1193 1194 my $debug = 0; 1195 my(@values, $key); 1196 my(%fields); 1197 1198 foreach $key ($q->param) 1199 { 1200 my $val = $q->param($key); 1201 if((fieldinfo ($key, 'fieldtype') || '') eq 'multitext') 1202 { 1203 $val = fix_multiline_val($val); 1204 } 1205 elsif((fieldinfo ($key, 'fieldtype') || '') eq 'multienum') 1206 { 1207 my @val = $q->param($key); 1208 $val = unparse_multienum(\@val, $key); 1209 } 1210 $fields{$key} = $val; 1211 } 1212 1213 # Make sure the pr is valid. 1214 my(@errors) = validate_new_pr(%fields); 1215 if (@errors) 1216 { 1217 print_header(-cookie => create_global_cookie()); 1218 page_start_html($page); 1219 page_heading($page, 'Error'); 1220 print "<h3>Your problem report has not been sent.</h3>\n", 1221 "<p>Fix the following problems, then submit the problem report again:</p>", 1222 $q->ul($q->li(\@errors)); 1223 return; 1224 } 1225 1226 my $fullname=$db_prefs{'user'}; 1227 if (exists ($responsible_fullname{$fullname})) 1228 { 1229 $fullname=" (".$responsible_fullname{$fullname}.")"; 1230 } 1231 else 1232 { 1233 $fullname=""; 1234 } 1235 # Supply a default value for Originator 1236 $fields{$ORIGINATOR_FIELD} = $fields{$ORIGINATOR_FIELD} || ($fields{'email'} . $fullname); 1237 1238 # Handle the attached_file, if any. 1239 add_encoded_attachment_to_pr(\%fields, encode_attachment('attached_file')); 1240 1241 # Compose the PR. 1242 my $text = unparsepr('send', %fields); 1243 $text = <<EOT . $text; 1244To: bugs 1245CC: 1246Subject: $fields{$SYNOPSIS_FIELD} 1247From: $fields{'email'} 1248Reply-To: $fields{'email'} 1249X-Send-Pr-Version: gnatsweb-$VERSION ($REVISION) 1250X-GNATS-Notify: $fields{'X-GNATS-Notify'} 1251 1252EOT 1253 1254 # Allow debugging 1255 if($debug) 1256 { 1257 print_header(-cookie => create_global_cookie()); 1258 page_start_html($page); 1259 print "<h3>debugging -- PR NOT SENT</h3>", 1260 $q->pre($q->escapeHTML($text)), 1261 "<hr />"; 1262 page_end_html($page); 1263 return; 1264 } 1265 1266 # Check PR text before submitting 1267 client_cmd ("chek initial"); 1268 # If the check fails, the next call will exit after leaving 1269 # an error message. 1270 client_cmd("$text."); 1271 1272 client_cmd ("subm"); 1273 client_cmd("$text."); 1274 1275 my $return_url = $q->param('return_url') || get_script_name(); 1276 my $refresh = 5; 1277 1278 print_header(-Refresh => "$refresh; URL=$return_url", 1279 -cookie => create_global_cookie()); 1280 1281 # Workaround for MSIE: 1282 my @extra_head_args = (-head => $q->meta({-http_equiv=>'Refresh', 1283 -content=>"$refresh; URL=$return_url"})); 1284 1285 page_start_html($page, 0, \@extra_head_args); 1286 1287 # Give feedback for success 1288 page_heading($page, 'Problem Report Sent'); 1289 print "<p>Thank you for your report. It will take a short while for 1290your report to be processed. When it is, you will receive 1291an automated message about it, containing the Problem Report 1292number, and the developer who has been assigned to 1293investigate the problem.</p>"; 1294 print "<p>You will be returned to <a href=\"$return_url\">your previous page</a> 1295in $refresh seconds...</p>"; 1296 1297 page_footer($page); 1298 page_end_html($page); 1299} 1300 1301# Return a URL which will take one to the specified $pr and with a 1302# specified $cmd. For commands such as 'create' that have no 1303# associated PR number, we pass $pr = 0, and this routine then leaves 1304# out the pr parameter. For ease of use, when the user makes a 1305# successful edit, we want to return to the URL he was looking at 1306# before he decided to edit the PR. The return_url param serves to 1307# store that info, and is included if $include_return_url is 1308# specified. Note that the return_url is saved even when going into 1309# the view page, since the user might go from there to the edit page. 1310# 1311sub get_pr_url 1312{ 1313 my($cmd, $pr, $include_return_url) = @_; 1314 my $url = $q->url() . "?cmd=$cmd&database=$global_prefs{'database'}"; 1315 $url .= "&pr=$pr" if $pr; 1316 $url .= "&return_url=" . $q->escape($q->self_url()) 1317 if $include_return_url; 1318 return $url; 1319} 1320 1321# Return a URL to edit the given pr. See get_pr_url(). 1322# 1323sub get_editpr_url 1324{ 1325 return get_pr_url('edit', @_); 1326} 1327 1328# Return a URL to view the given pr. See get_pr_url(). 1329# 1330sub get_viewpr_url 1331{ 1332 my $viewcmd = $include_audit_trail ? 'view%20audit-trail' : 'view'; 1333 return get_pr_url($viewcmd, @_); 1334} 1335 1336# Same as script_name(), but includes 'database=xxx' param. 1337# 1338sub get_script_name 1339{ 1340 my $url = $q->script_name(); 1341 $url .= "?database=$global_prefs{'database'}" 1342 if defined($global_prefs{'database'}); 1343 return $url; 1344} 1345 1346# Return links which send email regarding the current PR. 1347# first link goes to interested parties, second link goes to 1348# PR submission address and Reply-To (ie. it gets tacked on to 1349# the audit trail). 1350sub get_mailto_link 1351{ 1352 my $sub_mailto = ''; 1353 my($pr,%fields) = @_; 1354 my $int_mailto = $q->escape(scalar(interested_parties($pr, %fields))); 1355 if (defined($site_pr_submission_address{ $global_prefs{'database'} })) 1356 { 1357 $sub_mailto = $q->escape($site_pr_submission_address{$global_prefs{'database'}} . 1358 ',' . $fields{'Reply-To'}); 1359 } 1360 my $subject = $q->escape("Re: $fields{$CATEGORY_FIELD}/$pr: $fields{$SYNOPSIS_FIELD}"); 1361 my $body = $q->escape(get_viewpr_url($pr)); 1362 1363 # Netscape Navigator up to and including 4.x should get the URL in 1364 # the body encoded only once -- and so should Opera 1365 unless ( ($ENV{'HTTP_USER_AGENT'} =~ "Mozilla\/(.)(.*)") && ($1 < 5) 1366 && ($2 !~ "compatible") || $ENV{'HTTP_USER_AGENT'} =~ "Opera\/" ) 1367 { 1368 $body = $q->escape($body); 1369 } 1370 1371 my $reply = "<a href=\"mailto:$int_mailto?Subject=$subject&Body=$body\">" . 1372 "send email to interested parties</a>\n"; 1373 1374 if ($sub_mailto) { 1375 # include a link to email followup 1376 $reply .= "or <a href=\"mailto:$sub_mailto" . 1377 "?subject=$subject\">send email followup to audit-trail</a>\n"; 1378 } 1379 1380 return $reply; 1381} 1382 1383sub view 1384{ 1385 my($viewaudit, $tmp) = @_; 1386 1387 # $pr must be 'local' to be available to site callback 1388 local($pr) = $q->param('pr'); 1389 # strip out leading category (and any other non-digit trash) from $pr 1390 $pr =~ s/\D//g; 1391 1392 my $page = "View PR $pr"; 1393 page_start_html($page); 1394 1395 if(!$pr) 1396 { 1397 error_page("You must specify a problem report number"); 1398 return; 1399 } 1400 1401 # %fields must be 'local' to be available to site callback 1402 local(%fields) = readpr($pr); 1403 1404 if (scalar(keys(%fields)) < 4) { 1405 # looks like there is no such PR, complain to the customer 1406 # (readpr() hardcodes 3 fields, even if there's no PR) 1407 gerror("PR $pr does not exist"); 1408 page_end_html($page); 1409 return; 1410 } 1411 1412 page_heading($page, "View Problem Report: $pr"); 1413 1414 print $q->start_form(-method=>'get'), 1415 hidden_db(), 1416 hidden_debug(), 1417 $q->hidden('pr', $pr), 1418 $q->hidden('return_url'); 1419 1420 # print 'edit' and 'view audit-trail' buttons as appropriate, mailto link 1421 print "<span>"; 1422 print $q->submit('cmd', 'edit'), ' or ' if (can_edit()); 1423 print $q->submit('cmd', 'view audit-trail'), ' or ' if (!$viewaudit); 1424 print get_mailto_link($pr, %fields); 1425 print "</span>"; 1426 print $q->hr(), 1427 "\n<table>"; 1428 print "\n<tr>\n<td><b>Reporter's email:</b></td>\n<td>", 1429 $q->tt(make_mailto($fields{'Reply-To'})), "</td>\n</tr>\n"; 1430 1431 foreach (@fieldnames) 1432 { 1433 # XXX ??? !!! FIXME 1434 if ($_ eq $AUDIT_TRAIL_FIELD) 1435 { 1436 next; 1437 } 1438 my $val = $q->escapeHTML($fields{$_}) || ''; # to avoid -w warning 1439 my $valign = ''; 1440 if (fieldinfo($_, 'fieldtype') eq 'multitext') 1441 { 1442 $valign = ' valign="top"'; 1443 $val = expand($val); 1444 $val =~ s/$/<br>/gm; 1445 $val =~ s/<br>$//; # previous substitution added one too many <br>'s 1446 $val =~ s/ / /g; 1447 $val =~ s/ / /g; 1448 } 1449 1450 # make links in various fields 1451 if ($_ =~ /responsible/i) { 1452 # values in the responsible field are likely to be bare usernames, 1453 # so mark_urls won't work on them. 1454 $val = make_mailto($val); 1455 } elsif ($_ =~ /related-prs/i) { 1456 # make the Related-PRs field show links to the PRs 1457# dtb - this is juniper specific, but i think it's a good field to have in 1458# the dbconfig... 1459 $val =~ s{(\b|PR)(\d+)\b}{'<a href="'.get_viewpr_url($2)."\">$1$2</a>"}egi; 1460 } else { 1461 # make urls and email addresses into live hrefs 1462 $val = mark_urls($val); 1463 } 1464 1465 if ($description_in_view) { 1466 print "<tr><td width=\"20%\"$valign><b>$_:</b><br /><font size=\"-1\" color=\"#999999\">\n", 1467 fieldinfo($_, 'desc'), 1468 "</font></td>\n<td>"; 1469 } else { 1470 print "<tr><td nowrap$valign><b>$_:</b></td>\n<td>"; 1471 } 1472 print $q->tt($val), "</td></tr>\n"; 1473 1474 # Print attachments after Description. 1475 print_attachments(\%fields, 'view') if /Description/; 1476 } 1477 print "</table>", 1478 $q->hr(); 1479 1480 # print 'edit' and 'view audit-trail' buttons as appropriate, mailto link 1481 print "<p>"; 1482 print $q->submit('cmd', 'edit'), ' or ' if (can_edit()); 1483 print $q->submit('cmd', 'view audit-trail'), ' or ' if (!$viewaudit); 1484 print get_mailto_link($pr, %fields); 1485 print "</p>"; 1486 print $q->end_form(); 1487 1488 # Footer comes before the audit-trail. 1489 page_footer($page); 1490 1491 if($viewaudit) 1492 { 1493 print "\n<h3>Audit Trail:</h3>\n<pre>\n", 1494 mark_urls($q->escapeHTML($fields{$AUDIT_TRAIL_FIELD})), 1495 "\n</pre>\n"; 1496 } 1497 1498 page_end_html($page); 1499} 1500 1501# edit - 1502# The Edit PR page. 1503# 1504sub edit 1505{ 1506 my($pr) = $q->param('pr'); 1507 # strip out leading category (and any other non-digit trash) from 1508 # $pr, since it will unduly confuse gnats when we try to submit the 1509 # edit 1510 $pr =~ s/\D//g; 1511 my $page = "Edit PR $pr"; 1512 page_start_html($page); 1513 1514 #my $debug = 0; 1515 1516 1517 if(!$pr) 1518 { 1519 error_page("You must specify a problem report number"); 1520 return; 1521 } 1522 1523 my(%fields) = readpr($pr); 1524 1525 page_heading($page, "Edit Problem Report: $pr"); 1526 1527 # Trim Responsible for compatibility. XXX ??? !!! FIXME 1528 $fields{$RESPONSIBLE_FIELD} = trim_responsible($fields{$RESPONSIBLE_FIELD}); 1529 1530 print multipart_form_start(-name=>'PrForm'), "\n", 1531 hidden_db(), 1532 hidden_debug(), 1533 $q->span($q->submit('cmd', 'submit edit'), 1534 " or ", 1535 $q->reset(-name=>'reset'), 1536 " or ", 1537 get_mailto_link($pr, %fields)), 1538 $q->hidden(-name=>'Editor', 1539 -value=>$db_prefs{'user'}, 1540 -override=>1), "\n", 1541 $q->hidden(-name=>'Last-Modified', 1542 -value=>$fields{$LAST_MODIFIED_FIELD}, 1543 -override=>1), "\n", 1544 $q->hidden(-name=>'pr', -value=>$pr, -override=>1), 1545 $q->hidden(-name=>'return_url'), 1546 "<hr>\n"; 1547 1548 print "<table>\n"; 1549 print "<tr>\n<td><b>Reporter's email:</b></td>\n<td>", 1550 $q->textfield(-name=>'Reply-To', 1551 -default=>$fields{'Reply-To'}, 1552 -size=>$textwidth), 1553 "</td>\n</tr>\n"; 1554 1555 # keep count of field number, so that javascript hooks can 1556 # have a way to access fields with dashes in their names 1557 # they'll need to use PrForm.elements[fieldNumber].value 1558 # instead of the dashed name 1559 # note that this is a zero-based count!! 1560 # there are nine fields "hardcoded" into the form above this point. 1561 my $field_number = 8; 1562 1563 foreach (@fieldnames) 1564 { 1565 if (fieldinfo ($_, 'flags') & $READONLY) 1566 { 1567 next; 1568 } 1569 1570 $field_number++; 1571 1572 my $values = fieldinfo($_, 'values'); 1573 1574 # The "intro" provides a way for the site callback to print something 1575 # at the top of a given field. 1576 my $intro = cb("edit_intro_$_", $field_number) || ''; 1577 print "<tr><td valign=\"top\" width=\"20%\"><b>$_:</b><br /><small>\n", 1578 fieldinfo($_, 'desc'), 1579 "</small><td>\n", $intro, "\n"; 1580 1581 if (fieldinfo ($_, 'fieldtype') eq 'enum') 1582 { 1583 my $default = $fields{$_}; 1584 my $found = 0; 1585 my $nopush = 0; 1586 # Check whether field value is a known enumeration value. 1587 foreach(@$values) 1588 { 1589 $found = 1 if $_ eq $default; 1590 $nopush = 1 if $_ eq 'unknown'; 1591 } 1592 unless ($found) 1593 { 1594 push(@$values, 'unknown') unless $nopush; 1595 $default = 'unknown'; 1596 } 1597 print popup_or_scrolling_menu($_, $values, $default), 1598 "</td>\n</tr>\n"; 1599 } 1600 elsif (fieldinfo ($_, 'fieldtype') eq 'multienum') 1601 { 1602 my $defaultsref = parse_multienum($fields{$_}, $_); 1603 print multiselect_menu($_, $values, $defaultsref), 1604 "</td>\n</tr>\n"; 1605 } 1606 elsif (fieldinfo ($_, 'fieldtype') eq 'multitext') 1607 { 1608 my $rows = 4; 1609 $rows = 8 if /Description/; 1610 $rows = 2 if /Environment/; 1611 print $q->textarea(-name=>$_, 1612 -cols=>$textwidth, 1613 -rows=>$rows, 1614 -default=>$fields{$_}), 1615 "</td>\n</tr>\n"; 1616 # Print attachments after Description. 1617 print_attachments(\%fields, 'edit') if /Description/; 1618 } 1619 else 1620 { 1621 print $q->textfield(-name=>$_, 1622 -size=>$textwidth, 1623 -default=>$fields{$_}), 1624 "</td>\n</tr>\n"; 1625 } 1626 if (fieldinfo ($_, 'flags') & $REASONCHANGE) 1627 { 1628 print "<tr><td valign=\"top\"><b>Reason Changed:</b></td>\n<td>", 1629 $q->textarea(-name=>"$_-Changed-Why", 1630 -default=>'', 1631 -override=>1, 1632 -cols=>$textwidth, 1633 -rows=>2, 1634 -wrap=>'hard'), 1635 "</td>\n</tr>\n"; 1636 } 1637 print "\n"; 1638 } 1639 print "</table>", 1640 $q->p($q->submit('cmd', 'submit edit'), 1641 " or ", 1642 $q->reset(-name=>'reset'), 1643 " or ", 1644 get_mailto_link($pr, %fields)), "\n", 1645 $q->end_form(), "\n", 1646 $q->hr(), "\n"; 1647 1648 # Footer comes before the audit-trail. 1649 page_footer($page); 1650 1651 print "\n<h3>Audit Trail:</h3>\n<pre>\n", 1652 mark_urls($q->escapeHTML($fields{$AUDIT_TRAIL_FIELD})), 1653 "\n</pre>\n"; 1654 page_end_html($page); 1655} 1656 1657# Print out the %fields hash for debugging. 1658sub debug_print_fields 1659{ 1660 my $fields_hash_ref = shift; 1661 foreach my $f (sort keys %$fields_hash_ref) 1662 { 1663 print "<tr valign=top><td>$f</td><td>", 1664 $q->pre($q->escapeHTML($$fields_hash_ref{$f})), 1665 "</td></tr>\n"; 1666 } 1667 my $aref = $$fields_hash_ref{'attachments'} || []; 1668 my $i=0; 1669 foreach my $href (@$aref) { 1670 print "<tr valign=top><td>attachment $i<td>", 1671 ($$href{'original_attachment'} 1672 ? $$href{'original_attachment'} : "--- empty ---"); 1673 $i++; 1674 } 1675 print "</table></font><hr>\n"; 1676} 1677 1678sub submitedit 1679{ 1680 my $page = 'Edit PR Results'; 1681 1682 my $debug = 0; 1683 my $lock_end_reached; 1684 1685 my($pr) = $q->param('pr'); 1686 1687 # strip out leading category (and any other non-digit trash) from 1688 # $pr, since it will unduly confuse gnats when we try to submit the 1689 # edit 1690 $pr =~ s/\D//g; 1691 1692 if(!$pr) 1693 { 1694 error_page("You must specify a problem report number"); 1695 return; 1696 } 1697 1698 my(%fields, %mailto, $adr); 1699 my $audittrail = ''; 1700 my $err = ''; 1701 1702 # Retrieve new attachment (if any) before locking PR, in case it fails. 1703 my $encoded_attachment = encode_attachment('attached_file'); 1704 1705 my(%oldfields) = lockpr($pr, $db_prefs{'user'}); 1706 LOCKED: 1707 { 1708 # Trim Responsible for compatibility. 1709 $oldfields{$RESPONSIBLE_FIELD} = trim_responsible($oldfields{$RESPONSIBLE_FIELD}); 1710 1711 # Merge %oldfields and CGI params to get %fields. Not all gnats 1712 # fields have to be present in the CGI params; the ones which are 1713 # not specified default to their old values. 1714 %fields = %oldfields; 1715 foreach my $key ($q->param) 1716 { 1717 my $val = $q->param($key); 1718 my $ftype = fieldinfo($key, 'fieldtype') || ''; 1719 if($key =~ /-Changed-Why/ 1720 || ($ftype eq 'multitext')) 1721 { 1722 $val = fix_multiline_val($val); 1723 } 1724 elsif($ftype eq 'multienum') 1725 { 1726 my @val = $q->param($key); 1727 $val = unparse_multienum(\@val, $key); 1728 } 1729 $fields{$key} = $val; 1730 } 1731 1732 # Add the attached file, if any, to the new PR. 1733 add_encoded_attachment_to_pr(\%fields, $encoded_attachment); 1734 1735 # Delete any attachments, if directed. 1736 my(@deleted_attachments) = $q->param('delete attachments'); 1737 remove_attachments_from_pr(\%fields, @deleted_attachments); 1738 1739 if ($debug) 1740 { 1741 print "<h3>debugging -- PR edits not submitted</h3><font size=1><table>"; 1742 debug_print_fields(\%fields); 1743 last LOCKED; 1744 } 1745 1746 my $newlastmod = $fields{$LAST_MODIFIED_FIELD} || ''; 1747 my $oldlastmod = $oldfields{$LAST_MODIFIED_FIELD} || ''; 1748 1749 if($newlastmod ne $oldlastmod) 1750 { 1751 error_page("Sorry, PR $pr has been modified since you started editing it.", 1752 "Please return to the edit form, press the Reload button, " . 1753 "then make your edits again.\n" . 1754 "<pre>Last-Modified was '$newlastmod'\n" . 1755 "Last-Modified is now '$oldlastmod'</pre>"); 1756 last LOCKED; 1757 } 1758 1759 my (@errors) = (); 1760 if ($fields{$RESPONSIBLE_FIELD} eq "unknown") 1761 { 1762 push(@errors, "$RESPONSIBLE_FIELD is 'unknown'"); 1763 } 1764 if ($fields{$CATEGORY_FIELD} eq "unknown") 1765 { 1766 push(@errors, "$CATEGORY_FIELD is 'unknown'."); 1767 } 1768 if($fields{$SUBMITTER_ID_FIELD} eq "unknown") 1769 { 1770 push(@errors, "$SUBMITTER_ID_FIELD is 'unknown'."); 1771 } 1772 if (@errors) 1773 { 1774 push(@errors, 1775 "Go back to the edit form, correct the errors and submit again."); 1776 error_page("The PR has not been submitted.", \@errors); 1777 last LOCKED; 1778 } 1779 1780 # If Reply-To changed, we need to splice the change into the envelope. 1781 if($fields{'Reply-To'} ne $oldfields{'Reply-To'}) 1782 { 1783 if ($fields{'envelope'} =~ /^'Reply-To':/m) 1784 { 1785 # Replace existing header with new one. 1786 $fields{'envelope'} =~ s/^'Reply-To':.*$/'Reply-To': $fields{'Reply-To'}/m; 1787 } 1788 else 1789 { 1790 # Insert new header at end (blank line). Keep blank line at end. 1791 $fields{'envelope'} =~ s/^$/'Reply-To': $fields{'Reply-To'}\n/m; 1792 } 1793 } 1794 1795 # Check whether fields that are specified in dbconfig as requiring a 1796 # 'Reason Changed' have the reason specified: 1797 foreach my $fieldname (keys %fields) 1798 { 1799 my $newvalue = $fields{$fieldname} || ''; 1800 my $oldvalue = $oldfields{$fieldname} || ''; 1801 my $fieldflags = fieldinfo($fieldname, 'flags') || 0; 1802 if ( ($newvalue ne $oldvalue) && ( $fieldflags & $REASONCHANGE) ) 1803 { 1804 if($fields{$fieldname."-Changed-Why"} =~ /^\s*$/) 1805 { 1806 error_page("Field '$fieldname' must have a reason for change", 1807 "Please press the 'Back' button of you browser, correct the problem and resubmit."); 1808 last LOCKED; 1809 } 1810 } 1811 if ($newvalue eq $oldvalue && exists $fields{$fieldname."-Changed-Why"} ) 1812 { 1813 delete $fields{$fieldname."-Changed-Why"}; 1814 } 1815 } 1816 1817 my($newpr) = unparsepr('gnatsd', %fields); 1818 $newpr =~ s/\r//g; 1819 1820 # Submit the edits. We need to unlock the PR even if the edit fails 1821 local($suppress_client_exit) = 1; 1822 client_cmd("editaddr $db_prefs{'user'}"); 1823 last LOCKED if ($client_would_have_exited); 1824 client_cmd("edit $pr"); 1825 last LOCKED if ($client_would_have_exited); 1826 client_cmd("$newpr."); 1827 1828 $lock_end_reached = 1; 1829 } 1830 unlockpr($pr); 1831 1832 if ( (! $client_would_have_exited) && $lock_end_reached) { 1833 # We print out the "Edit successful" message after unlocking the PR. If the user hits 1834 # the Stop button of the browser while submitting, the web server won't terminate the 1835 # script until the next time the server attempts to output something to the browser. 1836 # Since this is the first output after the PR was locked, we print it after the unlocking. 1837 # Let user know the edit was successful. After a 2s delay, refresh back 1838 # to where the user was before the edit. Internet Explorer does not honor the 1839 # HTTP Refresh header, so we have to complement the "clean" CGI.pm method 1840 # with the ugly hack below, with a HTTP-EQUIV in the HEAD to make things work. 1841 my $return_url = $q->param('return_url') || get_script_name(); 1842 # the refresh header chokes on the query-string if the 1843 # params are separated by semicolons... 1844 $return_url =~ s/\;/&/g; 1845 1846 my $refresh = 2; 1847 print_header(-Refresh => "$refresh; URL=$return_url"); 1848 1849 # Workaround for MSIE: 1850 my @extra_head_args = (-head => $q->meta({-http_equiv=>'Refresh', 1851 -content=>"$refresh; URL=$return_url"})); 1852 1853 page_start_html($page, 0, \@extra_head_args); 1854 page_heading($page, 'Edit successful'); 1855 print <<EOM; 1856<p>You will be returned to <a href="$return_url">your previous page</a> 1857in $refresh seconds...</p> 1858EOM 1859 } 1860 1861 page_footer($page); 1862 page_end_html($page); 1863} 1864 1865sub query_page 1866{ 1867 my $page = 'Query PR'; 1868 page_start_html($page); 1869 page_heading($page, 'Query Problem Reports'); 1870 print_stored_queries(); 1871 print $q->start_form(), 1872 hidden_db(), 1873 hidden_debug(), 1874 $q->submit('cmd', 'submit query'), 1875 "<hr>", 1876 "<table>"; 1877 1878 foreach (@fieldnames) 1879 { 1880 if (fieldinfo($_, 'fieldtype') =~ /enum/) 1881 { 1882 print "<tr><td valign=top>$_:</td>\n<td>"; 1883 my $value_list=fieldinfo($_, 'values'); 1884 my @values=('any', @$value_list); 1885 if (fieldinfo($_, 'fieldtype') eq 'enum') 1886 { 1887 print popup_or_scrolling_menu ($_, \@values, $values[0]); 1888 } 1889 elsif (fieldinfo($_, 'fieldtype') eq 'multienum') 1890 { 1891 my $size = @values < 4 ? @values : 4; 1892 print $q->scrolling_list(-name=>$_, -values=>\@values, -size=>$size, 1893 -multiple=>'true', -defaults=>$values[0]); 1894 } 1895 if ($_ eq $STATE_FIELD) 1896 { 1897 print "<br />", 1898 $q->checkbox_group(-name=>'ignoreclosed', 1899 -values=>['Ignore Closed'], 1900 -defaults=>['Ignore Closed']); 1901 } 1902 elsif ($_ eq $SUBMITTER_ID_FIELD) 1903 { 1904 print "<br />", 1905 $q->checkbox_group(-name=>'originatedbyme', 1906 -values=>['Originated by You'], 1907 -defaults=>[]); 1908 } 1909 print "</td>\n</tr>\n"; 1910 } 1911 } 1912 1913 print 1914 "<tr>\n<td>$SYNOPSIS_FIELD Search:</td>\n<td>", 1915 $q->textfield(-name=>$SYNOPSIS_FIELD,-size=>25), 1916 "</td>\n</tr>\n", 1917 "<tr>\n<td>Multi-line Text Search:</td>\n<td>", 1918 $q->textfield(-name=>'multitext',-size=>25), 1919 "</td>\n</tr>\n", 1920 "<tr valign=top>\n<td>Column Display:</td>\n<td>"; 1921 1922 my @allcolumns; 1923 foreach (@fieldnames) { 1924 if (fieldinfo($_, 'fieldtype') ne 'multitext') { 1925 push (@allcolumns, $_); 1926 } 1927 } 1928 # The 'number' field is always first in the @allcolumns array. If 1929 # users were allowed to select it in this list, the PR number would 1930 # appear twice in the Query Results table. We prevent this by 1931 # shifting 'number' out of the array. 1932 shift(@allcolumns); 1933 1934 my(@columns) = split(' ', $global_prefs{'columns'} || ''); 1935 @columns = @allcolumns unless @columns; 1936 1937 print $q->scrolling_list(-name=>'columns', 1938 -values=>\@allcolumns, 1939 -defaults=>\@columns, 1940 -multiple=>1, 1941 -size=>5), 1942 "</td>\n</tr>\n"; 1943 1944 print "<tr valign=top>\n<td>Sort By:</td>\n<td>", 1945 $q->scrolling_list(-name=>'sortby', 1946 -values=>\@fieldnames, 1947 -multiple=>0, 1948 -size=>1), 1949 "<br />", 1950 $q->checkbox_group(-name=>'reversesort', 1951 -values=>['Reverse Order'], 1952 -defaults=>[]), 1953 "</td>\n</tr>\n"; 1954 1955 print "<tr valign=top>\n<td>Display:</td>\n<td>", 1956 $q->checkbox_group(-name=>'displaydate', 1957 -values=>['Current Date'], 1958 -defaults=>['Current Date']), 1959 "</td>\n</tr>\n", 1960 "</table>\n", 1961 "<hr>\n", 1962 $q->submit('cmd', 'submit query'), 1963 $q->end_form(); 1964 1965 page_footer($page); 1966 page_end_html($page); 1967} 1968 1969sub advanced_query_page 1970{ 1971 my $page = 'Advanced Query'; 1972 page_start_html($page); 1973 page_heading($page, 'Query Problem Reports'); 1974 print_stored_queries(); 1975 print $q->start_form(), 1976 hidden_debug(), 1977 hidden_db(); 1978 1979 my $width = 30; 1980 my $heading_bg = '#9fbdf9'; 1981 my $cell_bg = '#d0d0d0'; 1982 1983 print $q->span($q->submit('cmd', 'submit query'), 1984 " or ", 1985 $q->reset(-name=>'reset')); 1986 print "<hr>"; 1987 print "<center>"; 1988 1989 ### Text and multitext queries 1990 1991 print "<table border=1 cellspacing=0 bgcolor=$cell_bg>\n", 1992 "<caption>Search All Text</caption>\n", 1993 "<tr bgcolor=$heading_bg>\n", 1994 "<th nowrap>Search these text fields</th>\n", 1995 "<th nowrap>using regular expression</th>\n", 1996 "</tr>\n"; 1997 print "<tr>\n<td>Single-line text fields:</td>\n<td>", 1998 $q->textfield(-name=>'text', -size=>$width), 1999 "</td>\n</tr>\n", 2000 "<tr>\n<td>Multi-line text fields:</td>\n<td>", 2001 $q->textfield(-name=>'multitext', -size=>$width), 2002 "</td>\n</tr>\n", 2003 "</table>\n"; 2004 print "<div> </div>\n"; 2005 2006 ### Date queries 2007 2008 print "<table border=1 cellspacing=0 bgcolor=$cell_bg>\n", 2009 "<caption>Search By Date</caption>\n", 2010 "<tr bgcolor=$heading_bg>\n", 2011 "<th nowrap>Date Search</th>\n", 2012 "<th nowrap>Example: <tt>1999-04-01 05:00 GMT</tt></th>\n", 2013 "</tr>\n"; 2014 2015 foreach (@fieldnames) 2016 { 2017 if (fieldinfo ($_, 'fieldtype') eq 'date') 2018 { 2019 print "<tr>\n<td>$_ after:</td>\n<td>", 2020 $q->textfield(-name=>$_."_after", -size=>$width), 2021 "</td>\n</tr>\n"; 2022 print "<tr>\n<td>$_ before:</td>\n<td>", 2023 $q->textfield(-name=>$_."_before", -size=>$width), 2024 "</td>\n</tr>\n"; 2025 } 2026 } 2027 print $q->Tr( $q->td({-colspan=>2}, 2028 $q->small( $q->b("NOTE:"), "If your search includes 'Closed After' 2029 or 'Closed Before', uncheck 'Ignore Closed' below."))); 2030 print "</table>\n"; 2031 print "<div> </div>\n"; 2032 2033 ### Field queries 2034 2035 print "<table border=1 cellspacing=0 bgcolor=$cell_bg>\n", 2036 "<caption>Search Individual Fields</caption>\n", 2037 "<tr bgcolor=$heading_bg>\n", 2038 "<th nowrap>Search this field</th>\n", 2039 "<th nowrap>using regular expression, or</th>\n", 2040 "<th nowrap>using multi-selection</th>\n", 2041 "</tr>\n"; 2042 foreach (@fieldnames) 2043 { 2044 print "<tr valign=top>\n"; 2045 2046 # 1st column is field name 2047 print "<td>$_:</td>\n"; 2048 2049 # 2nd column is regexp search field 2050 print "<td>", 2051 $q->textfield(-name=>$_, 2052 -size=>$width); 2053 print "\n"; 2054 # XXX ??? !!! FIXME 2055 # This should be fixed by allowing a 'not' in front of the fields, so 2056 # one can simply say "not closed". 2057 if ($_ eq $STATE_FIELD) 2058 { 2059 print "<br />", 2060 $q->checkbox_group(-name=>'ignoreclosed', 2061 -values=>['Ignore Closed'], 2062 -defaults=>['Ignore Closed']), 2063 } 2064 print "</td>\n"; 2065 2066 # 3rd column is blank or scrolling multi-select list 2067 print "<td>"; 2068 if (fieldinfo($_, 'fieldtype') =~ 'enum') 2069 { 2070 my $ary_ref = fieldinfo($_, 'values'); 2071 my $size = scalar(@$ary_ref); 2072 $size = 4 if $size > 4; 2073 print $q->scrolling_list(-name=>$_, 2074 -values=>$ary_ref, 2075 -multiple=>1, 2076 -size=>$size); 2077 } 2078 else 2079 { 2080 print " "; 2081 } 2082 print "</td>\n</tr>\n"; 2083 } 2084 print "</table>\n"; 2085 print "<div> </div>\n"; 2086 2087 print "<table border=1 cellspacing=0 bgcolor=$cell_bg>\n", 2088 "<caption>Display</caption>\n", 2089 "<tr valign=top>\n<td>Display these columns:</td>\n<td>"; 2090 2091 my @allcolumns; 2092 foreach (@fieldnames) { 2093 if (fieldinfo($_, 'fieldtype') ne 'multitext') { 2094 push (@allcolumns, $_); 2095 } 2096 } 2097 # The 'number' field is always first in the @allcolumns array. If 2098 # users were allowed to select it in this list, the PR number would 2099 # appear twice in the Query Results table. We prevent this by 2100 # shifting 'number' out of the array. 2101 shift(@allcolumns); 2102 2103 my(@columns) = split(' ', $global_prefs{'columns'} || ''); 2104 @columns = @allcolumns unless @columns; 2105 2106 print $q->scrolling_list(-name=>'columns', 2107 -values=>\@allcolumns, 2108 -defaults=>\@columns, 2109 -multiple=>1, 2110 -size=>5), 2111 "</td>\n</tr>\n"; 2112 2113 print "<tr valign=top>\n<td>Sort By:</td>\n<td>", 2114 $q->scrolling_list(-name=>'sortby', 2115 -values=>\@fieldnames, 2116 -multiple=>0, 2117 -size=>1), 2118 "<br />", 2119 $q->checkbox_group(-name=>'reversesort', 2120 -values=>['Reverse Order'], 2121 -defaults=>[]), 2122 "</td>\n</tr>\n"; 2123 print "<tr valign=top>\n<td>Display:</td>\n<td>", 2124 $q->checkbox_group(-name=>'displaydate', 2125 -values=>['Current Date'], 2126 -defaults=>['Current Date']), 2127 "</td>\n</tr>\n", 2128 "</td>\n</tr>\n</table>\n"; 2129 print "<div> </div>\n"; 2130 ### Wrapup 2131 2132 print "</center>\n"; 2133 print "<hr>", 2134 $q->p($q->submit('cmd', 'submit query'), 2135 " or ", 2136 $q->reset(-name=>'reset')), 2137 $q->end_form(); 2138 page_footer($page); 2139 page_end_html($page); 2140} 2141 2142 2143# takes a string, and turns it into a mailto: link 2144# if it's not a full address, $site_mail_domain is appended first 2145sub make_mailto { 2146 my $string = shift; 2147 if ($string !~ /@/) { 2148 $string = qq*<a href="mailto:${string}${site_mail_domain}">$string</a>*; 2149 } else { 2150 $string = qq*<a href="mailto:$string">$string</a>*; 2151 } 2152 return $string; 2153} 2154 2155# takes a string, attempts to make urls, PR references and email 2156# addresses in that string into links: 2157# 'foo bar baz@quux.com flibbet PR# 1234 and furthermore 2158# http://www.abc.com/whatever.html' 2159# is returned as: 2160# 'foo bar <a href="mailto:baz@quux.com">baz@quux.com</a> flibbet 2161# <a href="http://site.com/cgi-bin/gnats?cmd=view;pr=1234;database=default">PR# 1234</a> 2162# <a href="http://www.abc.com/whatever.html" target="showdoc"> 2163# http://www.abc.com/whatever.html</a>' 2164# returns the (possibly) modified string 2165# behavior can be modified by twiddling knobs in the %mark_urls hash. 2166sub mark_urls { 2167 my $string = shift || ''; 2168 2169 # skip empty strings, or strings longer than the limit 2170 return $string if ($string =~ /^\s*$/ || 2171 length($string) > $mark_urls{'max_length'}); 2172 2173 if ($mark_urls{'urls'}) 2174 { 2175 # make URLs live 2176 $string =~ s{ 2177 \b 2178 ( 2179 (http|telnet|gopher|file|wais|ftp): 2180 [\w/#~+=&%@!.:;?\-]+? 2181 ) 2182 (?= 2183 [.:?\-]* 2184 [^\w/#~+=&%@!.;:?\-] 2185 | 2186 $ 2187 ) 2188 } 2189 {<a href="$1" target="showdoc">$1</a>}igx; 2190 } 2191 2192 if ($mark_urls{'prs'}) 2193 { 2194 # make "PR: 12345" into a link to "/cgi-bin/gnats?cmd=view;pr=12345" 2195 $string =~ s{ 2196 (\WPR[:s#]?\s?) # PR followed by :|s|whitespace 2197 (\s[a-z0-9-]+\/)? # a category name & a slash (optional) 2198 ([0-9]+) # the PR number 2199 } 2200 {$1.'<a href="'.get_viewpr_url($3).'">'.$2.$3.'</a>'}egix; 2201 } 2202 2203 if ($mark_urls{'emails'}) 2204 { 2205 # make email addresses live 2206 $string =~ s{ 2207 \b 2208 ( 2209 (?<!ftp://) 2210 [\w+=%!.\-]+? 2211 @ 2212 (?: 2213 [\w\-_]+? 2214 \. 2215 )+ 2216 [\w\-_]+? 2217 ) 2218 (?= 2219 [.:?\-]* 2220 (?: 2221 [^\w\-_] 2222 | 2223 \s 2224 ) 2225 | 2226 $ 2227 ) 2228 } 2229 {<a href="mailto:$1">$1</a>}igx; 2230 } 2231 2232 return $string; 2233} 2234 2235 2236sub appendexpr 2237{ 2238 my $lhs = shift; 2239 my $op = shift; 2240 my $rhs = shift; 2241 2242 if ($lhs eq "") 2243 { 2244 return $rhs; 2245 } 2246 if ($rhs eq "") 2247 { 2248 return $lhs; 2249 } 2250 return "($lhs) $op ($rhs)"; 2251} 2252 2253sub submitquery 2254{ 2255 my $page = 'Query Results'; 2256 my $queryname = $q->param('queryname'); 2257 2258 my $heading = 'Query Results'; 2259 $heading .= ": $queryname" if $queryname; 2260 page_start_html($page); 2261 page_heading($page, $heading); 2262 my $debug = 0; 2263 2264 my $originatedbyme = $q->param('originatedbyme'); 2265 my $ignoreclosed = $q->param('ignoreclosed'); 2266 2267 local($client_cmd_debug) = 1 if $debug; 2268 client_cmd("rset"); 2269 2270 my $expr = ""; 2271 if ($originatedbyme) 2272 { 2273 $expr = 'builtinfield:originator="'.$db_prefs{'user'}.'"'; 2274 } 2275 if ($ignoreclosed) 2276 { 2277 $expr = appendexpr ('(! builtinfield:State[type]="closed")', '&', $expr); 2278 } 2279 2280 ### Construct expression for each param which specifies a query. 2281 my $field; 2282 foreach $field ($q->param()) 2283 { 2284 my @val = $q->param($field); 2285 my $stringval = join(" ", @val); 2286 2287 # Bleah. XXX ??? !!! 2288 if ($stringval ne '') 2289 { 2290 if (isvalidfield ($field)) 2291 { 2292 my $subexp = ""; 2293 my $sval; 2294 2295 # Turn multiple param values into ORs. 2296 foreach $sval (@val) 2297 { 2298 if ($sval ne 'any' && $sval ne '') 2299 { 2300 # Most (?) people expect queries on enums to be of the 2301 # exact, not the substring type. 2302 # Hence, provide explicit anchoring for enums. This 2303 # still leaves the user the possibility of inserting 2304 # ".*" before and/or after regular expression searches 2305 # on the advanced query page. 2306 if (fieldinfo($field, 'fieldtype') =~ "enum|multienum") 2307 { 2308 $subexp = appendexpr ($subexp, '|', "$field~\"^$sval\$\""); 2309 } 2310 else 2311 { 2312 $subexp = appendexpr ($subexp, '|', "$field~\"$sval\""); 2313 } 2314 } 2315 } 2316 $expr = appendexpr ($expr, '&', $subexp); 2317 } 2318 elsif ($field eq 'text' || $field eq 'multitext') 2319 { 2320 $expr = appendexpr ($expr, '&', "fieldtype:$field~\"$stringval\""); 2321 } 2322 elsif ($field =~ /_after$/ || $field =~ /_before$/) 2323 { 2324 my $op; 2325 # Waaah, nasty. XXX ??? !!! 2326 if ($field =~ /_after$/) 2327 { 2328 $op = '>'; 2329 } 2330 else 2331 { 2332 $op = '<'; 2333 } 2334 # Whack off the trailing _after or _before. 2335 $field =~ s/_[^_]*$//; 2336 $expr = appendexpr ($expr, '&', $field.$op.'"'.$stringval.'"'); 2337 } 2338 } 2339 } 2340 2341 my $format="\"%s"; 2342 2343 my @columns = $q->param('columns'); 2344 # We are using ASCII octal 037 (unit separator) to separate the 2345 # fields in the query output. Note that the format strings are 2346 # interpolated (quoted with ""'s), so make sure to escape any $ or @ 2347 # signs. 2348 foreach (@columns) { 2349 if (fieldinfo ($_, 'fieldtype') eq 'date') { 2350 $format .= "\037%{%Y-%m-%d %H:%M:%S %Z}D"; 2351 } elsif (fieldinfo ($_, 'fieldtype') eq 'enum') { 2352 $format .= "\037%d"; 2353 } else { 2354 $format .= "\037%s"; 2355 } 2356 } 2357 2358 $format .= "\" ".${NUMBER_FIELD}." ".join (" ", @columns); 2359 2360 client_cmd("expr $expr") if $expr; 2361 client_cmd("qfmt $format"); 2362 2363 my(@query_results) = client_cmd("quer"); 2364 2365 display_query_results(@query_results); 2366 page_footer($page); 2367 page_end_html($page); 2368} 2369 2370# nonempty - 2371# Turn empty strings into " " so that Netscape tables won't 2372# look funny. 2373# 2374sub nonempty 2375{ 2376 my $str = shift; 2377 $str = ' ' if !$str; 2378 return $str; 2379} 2380 2381 2382# display_query_results - 2383# Display the query results, and the "store query" form. 2384# The results only have the set of fields that we requested, although 2385# the first field is always the PR number. 2386sub display_query_results 2387{ 2388 my(@query_results) = @_; 2389 my $displaydate = $q->param('displaydate'); 2390 my $reversesort = $q->param('reversesort'); 2391 2392 my $num_matches = scalar(@query_results); 2393 my $heading = sprintf("%s %s found", 2394 $num_matches ? $num_matches : "No", 2395 ($num_matches == 1) ? "match" : "matches"); 2396 my $heading2 = $displaydate ? $q->small("( Query executed ", 2397 (scalar localtime), ")") : ''; 2398 print $q->table({cellpadding=>0, cellspacing=>0, border=>0}, 2399 $q->Tr($q->td($q->font({size=>'+2'}, 2400 $q->strong($heading)))), $q->Tr($q->td($heading2))); 2401 print $q->start_form(), 2402 hidden_debug(), 2403 $q->hidden(name=>'cmd', -value=>'view', -override=>1), 2404 "<table border=1 cellspacing=0 cellpadding=1><tr>\n"; 2405 2406 # By default sort by PR number. 2407 my($sortby) = $q->param('sortby') || $fieldnames[0]; 2408 2409 my $whichfield = 0; 2410 my ($sortbyfieldnum) = 0; 2411 my @columns = $q->param('columns'); 2412 my $noofcolumns = @columns; 2413 # Print table header which allows sorting by columns. 2414 # While printing the headers, temporarily override the 'sortby' param 2415 # so that self_url() works right. 2416 for ($fieldnames[0], @columns) 2417 { 2418 $q->param(-name=>'sortby', -value=>$_); 2419 if ($_ eq $sortby) { 2420 $sortbyfieldnum = $whichfield; 2421 } 2422 $whichfield++; 2423 2424 # strip empty params out of self_url(). in a gnats db with many 2425 # fields, the url query-string will become very long. this is a 2426 # problem, since IE5 truncates query-strings at ~2048 characters. 2427 my ($query_string) = $q->self_url() =~ m/^[^?]*\?(.*)$/; 2428 $query_string =~ s/(\w|-)+=;//g; 2429 2430 my $href = $script_name . '?' . $query_string; 2431 print "\n<th><a href=\"$href\">$_</a></th>\n"; 2432 } 2433 # finished the header row 2434 print "</tr>\n"; 2435 2436 # Reset param 'sortby' to its original value, so that 'store query' works. 2437 $q->param(-name=>'sortby', -value=>$sortby); 2438 2439 # Sort @query_results according to the rules in by_field(). 2440 # Using the "map, sort" idiom allows us to perform the expensive 2441 # split() only once per item, as opposed to during every comparison. 2442 my(@presplit_prs) = map { [ (split /\037/) ] } @query_results; 2443 my(@sorted_prs); 2444 my $sortby_fieldtype = fieldinfo ($sortby, 'fieldtype') || ''; 2445 if ($sortby_fieldtype eq 'enum' || $sortby_fieldtype eq 'integer') { 2446 # sort numerically 2447 @sorted_prs = sort({$a->[$sortbyfieldnum] <=> $b->[$sortbyfieldnum]} 2448 @presplit_prs); 2449 } else { 2450 # sort alphabetically 2451 @sorted_prs = sort({lc($a->[$sortbyfieldnum] || '') cmp lc($b->[$sortbyfieldnum] ||'')} 2452 @presplit_prs); 2453 } 2454 2455 @sorted_prs = reverse @sorted_prs if $reversesort; 2456 2457 # Print the PR's. 2458 my @fieldtypes = map { fieldinfo ($_, 'fieldtype') } @columns; 2459 foreach (@sorted_prs) 2460 { 2461 print "<tr valign=top>\n"; 2462 my $id = shift @{$_}; 2463 2464 print "<td nowrap><a href=\"" . get_viewpr_url($id, 1) . "\">$id</a>"; 2465 if (can_edit()) 2466 { 2467 print " <a href=\"" . get_editpr_url($id, 1) . "\"><font size=-1>edit</font></a>"; 2468 } 2469 print "</td>"; 2470 2471 my $fieldcontents; 2472 my $whichfield = 0; 2473 foreach $fieldcontents (@{$_}) 2474 { 2475 # The query returned the enums as numeric values, now we have to 2476 # map them back into strings. 2477 if ($fieldtypes[$whichfield] eq 'enum') 2478 { 2479 my $enumvals = fieldinfo($columns[$whichfield], 'values'); 2480 # A zero means that the string is absent from the enumeration type. 2481 $fieldcontents = $fieldcontents ? $$enumvals[$fieldcontents - 1] : 'unknown'; 2482 } 2483 $fieldcontents = $q->escapeHTML($fieldcontents); 2484 $fieldcontents = nonempty($fieldcontents); 2485 2486 if ($columns[$whichfield] =~ /responsible/i) { 2487 $fieldcontents = make_mailto($fieldcontents); 2488 } else { 2489 # make urls and email addresses into live hrefs 2490 $fieldcontents = mark_urls($fieldcontents); 2491 } 2492 2493 print "<td nowrap>$fieldcontents</td>"; 2494 $whichfield++; 2495 } 2496 # Pad the remaining, empty columns with 's 2497 my $n = @{$_}; 2498 while ($noofcolumns - $n > 0) 2499 { 2500 print "<td> </td>"; 2501 $n++; 2502 } 2503 print "\n</tr>\n"; 2504 } 2505 print "</table>", 2506 $q->end_form(); 2507 2508 # Provide a URL which someone can use to bookmark this query. 2509 my $url = $q->self_url(); 2510 # strip empty params out of $url. in a gnats db with many 2511 # fields, the url query-string will become very long. this is a 2512 # problem, since IE5 truncates query-strings at ~2048 characters. 2513 $url =~ s/(\w|-)+=;//g; 2514 2515 print "\n<p>", 2516 qq{<a href="$url">View for bookmarking</a>}, 2517 "<br />"; 2518 if ($reversesort) { 2519 $url =~ s/[&;]reversesort=[^&;]*//; 2520 } else { 2521 $url .= $q->escapeHTML(";reversesort=Descending Order"); 2522 } 2523 print qq{<a href="$url">Reverse sort order</a>}, 2524 "</p>"; 2525 2526 # Allow the user to store this query. Need to repeat params as hidden 2527 # fields so they are available to the 'store query' handler. 2528 print $q->start_form(), hidden_debug(); 2529 foreach ($q->param()) 2530 { 2531 # Ignore certain params. 2532 next if /^(cmd|queryname)$/; 2533 print $q->hidden($_), "\n"; 2534 } 2535 print "\n<table>\n", 2536 "<tr>\n", 2537 "<td>Remember this query as:</td>\n", 2538 "<td>", 2539 $q->textfield(-name=>'queryname', -size=>25), 2540 "</td>\n<td>"; 2541 # Note: include hidden 'cmd' so user can simply press Enter w/o clicking. 2542 print $q->hidden(-name=>'cmd', -value=>'store query', -override=>1), 2543 $q->submit('cmd', 'store query'), 2544 $q->hidden('return_url', $q->self_url()), 2545 "\n</td>\n</tr>\n</table>", 2546 $q->end_form(); 2547} 2548 2549# store_query - 2550# Save the current query in a cookie. 2551# 2552# Queries are stored as individual cookies named 2553# 'gnatsweb-query-$queryname'. 2554# 2555sub store_query 2556{ 2557 my $debug = 0; 2558 my $queryname = $q->param('queryname'); 2559 if (!$queryname || ($queryname =~ /[;|,|\s]+/) ) { 2560 error_page('Illegal query name', 2561 "You tried to store the query with an illegal name. " 2562 . "Legal names are not blank and do not contain the symbols " 2563 . "';' (semicolon), ',' (comma) or the space character."); 2564 exit(); 2565 } 2566 # First make sure we don't already have too many cookies. 2567 # See http://home.netscape.com/newsref/std/cookie_spec.html for 2568 # limitations -- 20 cookies; 4k per cookie. 2569 my(@cookie_names) = $q->cookie(); 2570 if (@cookie_names >= 20) { 2571 error_page('Cannot store query -- too many cookies', 2572 "Gnatsweb cannot store this query as another cookie because" 2573 . "there already are " 2574 . scalar(@cookie_names) 2575 . " cookies being passed to gnatsweb. There is a maximum" 2576 . " of 20 cookies per server or domain as specified in" 2577 . " <a href=\"http://home.netscape.com/newsref/std/cookie_spec.html\">" 2578 . "http://home.netscape.com/newsref/std/cookie_spec.html</a>"); 2579 exit(); 2580 } 2581 2582 # Don't save certain params. 2583 $q->delete('cmd'); 2584 my $query_string = $q->query_string(); 2585 2586 # strip empty params out of $query_string. in a gnats db with many 2587 # fields, the query-string will become very long, and may exceed the 2588 # 4K limit for cookies. 2589 $query_string =~ s/\w+=;//g; 2590 2591 if (length($query_string . $global_cookie_path . "gnatsweb-query-$queryname") > 4050) { 2592 # this cookie is going to be longer than 4K, so we'll have to punt 2593 error_page('Cannot store query -- cookie too large', 2594 "Gnatsweb cannot store this query as a cookie because" 2595 . " it would exceed the maximum of 4K per cookie, as specified in" 2596 . " <a href=\"http://home.netscape.com/newsref/std/cookie_spec.html\">" 2597 . "http://home.netscape.com/newsref/std/cookie_spec.html</a>"); 2598 exit(); 2599 } 2600 2601 # Have to generate the cookie before printing the header. 2602 my $new_cookie = $q->cookie(-name => "gnatsweb-query-$queryname", 2603 -value => $query_string, 2604 -path => $global_cookie_path, 2605 -expires => '+10y'); 2606 2607 # Now print the page. 2608 my $page = 'Query Saved'; 2609 my $return_url = $q->param('return_url') || get_script_name(); 2610 my $refresh = 5; 2611 2612 print_header(-Refresh => "$refresh; URL=$return_url", 2613 -cookie => $new_cookie); 2614 2615 # Workaround for MSIE: 2616 my @extra_head_args = (-head => $q->meta({-http_equiv=>'Refresh', 2617 -content=>"$refresh; URL=$return_url"})); 2618 2619 page_start_html($page, 0, \@extra_head_args); 2620 2621 page_heading($page, 'Query Saved'); 2622 print "<h2>debugging</h2><pre>", 2623 "query_string: $query_string", 2624 "cookie: $new_cookie\n", 2625 "</pre><hr>\n" 2626 if $debug; 2627 print "<p>Your query \"$queryname\" has been saved. It will be available ", 2628 "the next time you reload the Query page.</p>"; 2629 print "<p>You will be returned to <a href=\"$return_url\">your previous page ", 2630 "</a> in $refresh seconds...</p>"; 2631 page_footer($page); 2632 page_end_html($page); 2633} 2634 2635# print_stored_queries - 2636# Retrieve any stored queries and print out a short form allowing 2637# the submission of these queries. 2638# 2639# Queries are stored as individual cookies named 2640# 'gnatsweb-query-$queryname'. 2641# 2642# side effects: 2643# Sets global %stored_queries. 2644# 2645sub print_stored_queries 2646{ 2647 my %stored_queries = (); 2648 foreach my $cookie ($q->cookie()) 2649 { 2650 if ($cookie =~ /gnatsweb-query-(.*)/) 2651 { 2652 my $query_key = $1; 2653 my $query_param = $q->cookie($cookie); 2654 # extract queries relevant to the current database: 2655 if ($query_param =~ /database=$global_prefs{'database'}/ ) 2656 { 2657 $stored_queries{$query_key} = $query_param; 2658 } 2659 } 2660 } 2661 if (%stored_queries) 2662 { 2663 print "<table cellspacing=0 cellpadding=0 border=0>", 2664 "<tr valign=top>", 2665 $q->start_form(), 2666 hidden_debug(), 2667 "<td>", 2668 hidden_db(), 2669 $q->submit('cmd', 'submit stored query'), 2670 "<td> <td>", 2671 $q->popup_menu(-name=>'queryname', 2672 -values=>[ sort(keys %stored_queries) ]), 2673 $q->end_form(), 2674 $q->start_form(), 2675 hidden_debug(), 2676 "<td>", 2677 $q->hidden('return_url', $q->self_url()), 2678 hidden_db(), 2679 $q->submit('cmd', 'delete stored query'), 2680 "<td> <td>", 2681 $q->popup_menu(-name=>'queryname', 2682 -values=>[ sort(keys %stored_queries) ]), 2683 $q->end_form(), 2684 "</tr></table>"; 2685 } 2686} 2687 2688# submit_stored_query - 2689# Submit the query named in the param 'queryname'. 2690# 2691# Queries are stored as individual cookies named 2692# 'gnatsweb-query-$queryname'. 2693# 2694sub submit_stored_query 2695{ 2696 my $debug = 0; 2697 my $queryname = $q->param('queryname'); 2698 my $query_string; 2699 my $err = ''; 2700 if (!$queryname) 2701 { 2702 $err = "Internal error: no 'queryname' parameter"; 2703 } 2704 elsif (!($query_string = $q->cookie("gnatsweb-query-$queryname"))) 2705 { 2706 $err = "No such named query: $queryname"; 2707 } 2708 if ($err) 2709 { 2710 error_page($err); 2711 } 2712 else 2713 { 2714 # 9/10/99 kenstir: Must use full (not relative) URL in redirect. 2715 # Patch by Elgin Lee <ehl@terisa.com>. 2716 my $query_url = $q->url() . '?cmd=' . $q->escape('submit query') 2717 . ';' . $query_string; 2718 if ($debug) 2719 { 2720 print_header(), 2721 $q->start_html(), 2722 $q->pre("debug: query_url: $query_url\n"); 2723 } 2724 else 2725 { 2726 print $q->redirect($query_url); 2727 } 2728 } 2729} 2730 2731# delete_stored_query - 2732# Delete the query named in the param 'queryname'. 2733# 2734# Queries are stored as individual cookies named 2735# 'gnatsweb-query-$queryname'. 2736# 2737sub delete_stored_query 2738{ 2739 my $debug = 0; 2740 my $queryname = $q->param('queryname'); 2741 my $query_string; 2742 my $err = ''; 2743 if (!$queryname) 2744 { 2745 $err = "Internal error: no 'queryname' parameter"; 2746 } 2747 elsif (!($query_string = $q->cookie("gnatsweb-query-$queryname"))) 2748 { 2749 $err = "No such named query: $queryname"; 2750 } 2751 if ($err) 2752 { 2753 error_page($err); 2754 } 2755 else 2756 { 2757 # The negative -expire causes the old cookie to expire immediately. 2758 my $expire_cookie_with_path = 2759 $q->cookie(-name => "gnatsweb-query-$queryname", 2760 -value => 'does not matter', 2761 -path => $global_cookie_path, 2762 -expires => '-1d'); 2763 my $expire_cookies = $expire_cookie_with_path; 2764 2765 # If we're using a non-empty $global_cookie_path, then we need to 2766 # create two expire cookies. One or the other will delete the stored 2767 # query, depending on whether the query was created with this version 2768 # of gnatsweb, or with an older version. 2769 if ($global_cookie_path) 2770 { 2771 my $expire_cookie_no_path = 2772 $q->cookie(-name => "gnatsweb-query-$queryname", 2773 -value => 'does not matter', 2774 # No -path here! 2775 -expires => '-1d'); 2776 $expire_cookies = [ $expire_cookie_with_path, $expire_cookie_no_path ]; 2777 } 2778 2779 # Return the user to the page they were viewing when they pressed 2780 # 'delete stored query'. 2781 my $return_url = $q->param('return_url') || get_script_name(); 2782 my $refresh = 0; 2783 2784 print_header(-Refresh => "$refresh; URL=$return_url", 2785 -cookie => $expire_cookies); 2786 2787 # Workaround for MSIE: 2788 print $q->start_html(-head => $q->meta({-http_equiv=>'Refresh', 2789 -content=>"$refresh; URL=$return_url"})); 2790 } 2791} 2792 2793# send_html - 2794# Send HTML help file, after first trimming out everything but 2795# <body>..</body>. This is done in this way for convenience of 2796# installation. If the gnatsweb.html is installed into the cgi-bin 2797# directory along with the gnatsweb.pl file, then it can't be loaded 2798# directly by Apache. So, we send it indirectly through gnatsweb.pl. 2799# This approach has the benefit that the resulting page has the 2800# customized gnatsweb look. 2801# 2802sub send_html 2803{ 2804 my $file = shift; 2805 open(HTML, "<$file") || return; 2806 local $/ = undef; # slurp file whole 2807 my $html = <HTML>; 2808 close(HTML); 2809 2810 # send just the stuff inside <body>..</body> 2811 $html =~ s/.*<body>//is; 2812 $html =~ s/<\/body>.*//is; 2813 2814 print $html; 2815} 2816 2817sub error_page 2818{ 2819 my($err_heading, $err_text) = @_; 2820 my $page = 'Error'; 2821 print_header(); 2822 page_start_html($page); 2823 page_heading($page, 'Error'); 2824 print $q->h3($err_heading); 2825 print $q->p($err_text) if $err_text; 2826 page_footer($page); 2827 page_end_html($page); 2828} 2829 2830sub help_page 2831{ 2832 my $html_file = $help_page_path; 2833 my $page = $q->param('help_title') || 'Help'; 2834 my $heading = $page; 2835 page_start_html($page); 2836 page_heading($page, $heading); 2837 2838 # If send_html doesn't work, print some default, very limited, help text. 2839 if (!send_html($html_file)) 2840 { 2841 print $q->p('Welcome to our problem report database. ', 2842 'You\'ll notice that here we call them "problem reports" ', 2843 'or "PR\'s", not "bugs".'); 2844 print $q->p('This web interface is called "gnatsweb". ', 2845 'The database system itself is called "gnats".', 2846 'You may want to peruse ', 2847 $q->a({-href=>"$gnats_info_top"}, 'the gnats manual'), 2848 'to read about bug lifecycles and the like, ', 2849 'but then again, you may not.'); 2850 } 2851 2852 page_footer($page); 2853 page_end_html($page); 2854} 2855 2856# hidden_db - 2857# Return hidden form element to maintain current database. This 2858# enables people to keep two browser windows open to two databases. 2859# 2860sub hidden_db 2861{ 2862 return $q->hidden(-name=>'database', -value=>$global_prefs{'database'}, -override=>1); 2863} 2864 2865# hidden_debug - 2866# Return hidden form element to maintain state of debug params 2867# 2868sub hidden_debug 2869{ 2870 if ($site_allow_remote_debug) { 2871 return $q->hidden(-name=>'debug'); 2872 } else { 2873 return; 2874 } 2875} 2876 2877# one_line_form - 2878# One line, two column form used for main page. 2879# 2880sub one_line_form 2881{ 2882 my($label, @form_body) = @_; 2883 my $valign = 'baseline'; 2884 return $q->Tr({-valign=>$valign}, 2885 $q->td($q->b($label)), 2886 $q->td($q->start_form(-method=>'get'), hidden_debug(), 2887 hidden_db(), @form_body, $q->end_form())); 2888} 2889 2890# can_create - 2891# If $no_create_without_access is set to a defined gnats 2892# access_level, return false unless user's access_level is >= to 2893# level set in $no_create_without_access 2894sub can_create 2895{ 2896 if (exists($LEVEL_TO_CODE{$no_create_without_access})) { 2897 return ($LEVEL_TO_CODE{$access_level} >= $LEVEL_TO_CODE{$no_create_without_access}); 2898 } else { 2899 return 1; 2900 } 2901} 2902 2903# can_edit - 2904# Return true if the user has edit privileges or better. 2905sub can_edit 2906{ 2907 return ($LEVEL_TO_CODE{$access_level} >= $LEVEL_TO_CODE{'edit'}); 2908} 2909 2910sub main_page 2911{ 2912 my $page = 'Main'; 2913 2914 my $viewcmd = $include_audit_trail ? 'view audit-trail' : 'view'; 2915 2916 page_start_html($page); 2917 page_heading($page, 'Main Page'); 2918 2919 print '<table>'; 2920 2921 my $top_buttons_html = cb('main_page_top_buttons') || ''; 2922 print $top_buttons_html; 2923 2924 # Only include Create action if user is allowed to create PRs. 2925 # (only applicable if $no_create_without_edit flag is set) 2926 print one_line_form('Create Problem Report:', 2927 $q->submit('cmd', 'create')) 2928 if can_create(); 2929 # Only include Edit action if user is allowed to edit PRs. 2930 # Note: include hidden 'cmd' so user can simply type into the textfield 2931 # and press Enter w/o clicking. 2932 print one_line_form('Edit Problem Report:', 2933 $q->hidden(-name=>'cmd', -value=>'edit', -override=>1), 2934 $q->submit('cmd', 'edit'), 2935 '#', 2936 $q->textfield(-size=>6, -name=>'pr')) 2937 if can_edit(); 2938 print one_line_form('View Problem Report:', 2939 $q->hidden(-name=>'cmd', -value=>$viewcmd, -override=>1), 2940 $q->submit('cmd', 'view'), 2941 '#', 2942 $q->textfield(-size=>6, -name=>'pr')); 2943 print one_line_form('Query Problem Reports:', 2944 $q->submit('cmd', 'query'), 2945 ' ', $q->submit('cmd', 'advanced query')); 2946 if ($site_gnatsweb_server_auth) 2947 { 2948 print one_line_form('Change Database:', 2949 $q->scrolling_list(-name=>'new_db', 2950 -values=>$global_list_of_dbs, 2951 -default=>$global_prefs{'database'}, 2952 -multiple=>0, 2953 -size=>1), 2954 $q->submit('cmd', 'change database') ); 2955 } 2956 else 2957 { 2958 print one_line_form("Log Out / Change Database: ", 2959 $q->submit('cmd', 'logout')); 2960 } 2961 print one_line_form('Get Help:', 2962 $q->submit('cmd', 'help')); 2963 2964 my $bot_buttons_html = cb('main_page_bottom_buttons') || ''; 2965 print $bot_buttons_html; 2966 2967 print '</table>'; 2968 page_footer($page); 2969 print '<hr><small>' 2970 . "Gnatsweb v$VERSION, Gnats v$GNATS_VERS" 2971 . '</small>'; 2972 page_end_html($page); 2973 exit; 2974} 2975 2976# cb - 2977# 2978# Calls site_callback subroutine if defined. 2979# 2980# usage: 2981# $something = cb($reason, @args) || 'default_value'; 2982# # -or- 2983# $something = cb($reason, @args) 2984# $something = 'default_value' unless defined($something); 2985# 2986# arguments: 2987# $reason - reason for the call. Each reason is unique. 2988# @args - additional parameters may be provided in @args. 2989# 2990# returns: 2991# undef if &site_callback is not defined, 2992# else value returned by &site_callback. 2993# 2994sub cb 2995{ 2996 my($reason, @args) = @_; 2997 my $val = undef; 2998 if (defined &site_callback) 2999 { 3000 $val = site_callback($reason, @args); 3001 } 3002 $val; 3003} 3004 3005# print_header - 3006# Print HTTP header unless it's been printed already. 3007# 3008sub print_header 3009{ 3010 # Protect against multiple calls. 3011 return if $print_header_done; 3012 $print_header_done = 1; 3013 3014 print $q->header(@_); 3015} 3016 3017# page_start_html - 3018# 3019# Print the HTML which starts off each page (<html><head>...</head>). 3020# 3021# By default, print a banner containing $site_banner_text, followed 3022# by the given page $title. 3023# 3024# The starting HTML can be overridden by &site_callback. 3025# 3026# Supports debugging. 3027# 3028# arguments: 3029# $title - title of page 3030# 3031sub page_start_html 3032{ 3033 my $title = $_[0]; 3034 my $no_button_bar = $_[1]; 3035 my @extra_head_args = @{$_[2]} if defined $_[2]; 3036 my $debug = 0; 3037 3038 # Protect against multiple calls. 3039 return if $page_start_html_done; 3040 $page_start_html_done = 1; 3041 3042 # Allow site callback to override html. 3043 my $html = cb('page_start_html', $title); 3044 if ($html) 3045 { 3046 print $html; 3047 return; 3048 } 3049 3050 # Call start_html, with -bgcolor if we need to override that. 3051 my @args = (-title=>"$title - $site_banner_text"); 3052 push(@args, -bgcolor=>$site_background) 3053 if defined($site_background); 3054 push(@args, -style=>{-src=>$site_stylesheet}) 3055 if defined($site_stylesheet); 3056 push(@args, @extra_head_args); 3057 print $q->start_html(@args); 3058 3059 # Add the page banner. The $site_banner_text is linked back to the 3060 # main page. 3061 # 3062 # Note that the banner uses inline style, rather than a GIF; this 3063 # makes installation easier by eliminating the need to install GIFs 3064 # into a separate directory. At least for Apache, you can't serve 3065 # GIFs out of your CGI directory. 3066 # 3067 my $bannerstyle = <<EOF; 3068 color: $site_banner_foreground; 3069 font-family: 'Verdana', 'Arial', 'Helvetica', 'sans'; 3070 font-weight: light; 3071 text-decoration: none; 3072EOF 3073 3074 my $buttonstyle = <<EOF; 3075 color: $site_button_foreground; 3076 font-family: 'Verdana', 'Arial', 'Helvetica', 'sans'; 3077 font-size: 8pt; 3078 font-weight: normal; 3079 text-decoration: none; 3080EOF 3081 3082 my $banner_fontsize1 = "font-size: 14pt; "; 3083 my $banner_fontsize2 = "font-size: 8pt; "; 3084 3085 my($row, $row2, $banner); 3086 my $url = "$script_name"; 3087 $url .= "?database=$global_prefs{'database'}" 3088 if defined($global_prefs{'database'}); 3089 3090 my $createurl = get_pr_url('create', 0, 1); 3091 3092 $row = qq(<tr>\n<td><table border="0" cellspacing="0" cellpadding="3" width="100%">); 3093 $row .= qq(<tr style="background-color: $site_banner_background">\n<td align="left">); 3094 $row .= qq(<span style="$bannerstyle $banner_fontsize1">$global_prefs{'database'} </span>) 3095 if $global_prefs{'database'}; 3096 $row .= qq(<span style="$bannerstyle $banner_fontsize2">User: $db_prefs{'user'} </span>) 3097 if $db_prefs{'user'}; 3098 $row .= qq(<span style="$bannerstyle $banner_fontsize2">Access: $access_level</span>) 3099 if $access_level; 3100 $row .= qq(\n</td>\n<td align="right"> 3101 <a href="$url" style="$bannerstyle $banner_fontsize1">$site_banner_text</a> 3102 </td>\n</tr>\n</table></td></tr>\n); 3103 3104 $row2 = qq(<tr>\n<td colspan="2">); 3105 $row2 .= qq(<table border="1" cellspacing="0" bgcolor="$site_button_background" cellpadding="3">); 3106 $row2 .= qq(<tr>\n); 3107 $row2 .= qq(<td><a href="$url" style="$buttonstyle">MAIN PAGE</A></TD>); 3108 $row2 .= qq(<td><a href="$createurl" style="$buttonstyle">CREATE</a></td>) 3109 if can_create(); 3110 $row2 .= qq(<td><a href="$url&cmd=query" style="$buttonstyle">QUERY</a></td>); 3111 $row2 .= qq(<td><a href="$url&cmd=advanced%20query" style="$buttonstyle">ADV. QUERY</a></td>); 3112 $row2 .= qq(<td><a href="$url&cmd=logout" style="$buttonstyle">LOG OUT</a></td>) 3113 unless ($site_gnatsweb_server_auth); 3114 $row2 .= qq(<td><a href="$url&cmd=help" style="$buttonstyle">HELP</a></td>); 3115 $row2 .= qq(</tr>\n); 3116 $row2 .= qq(</table>\n</td>\n</tr>); 3117 3118 $banner = qq(<table width="100%" border="0" cellpadding="0" cellspacing="0">$row); 3119 $banner .= qq($row2) unless $no_button_bar; 3120 $banner .= qq(</table>); 3121 3122 print $banner; 3123 3124 # debugging 3125 if ($debug) 3126 { 3127 print "<h3>debugging params</h3><font size=1><pre>"; 3128 my($param,@val); 3129 foreach $param (sort $q->param()) 3130 { 3131 @val = $q->param($param); 3132 printf "%-12s %s\n", $param, $q->escapeHTML(join(' ', @val)); 3133 } 3134 print "</pre></font><hr>\n"; 3135 } 3136} 3137 3138# page_heading - 3139# 3140# Print the HTML which starts off a page. Basically a fancy <h1> 3141# plus user + database names. 3142# 3143sub page_heading 3144{ 3145 my($title, $heading) = @_; 3146 3147 # Protect against multiple calls. 3148 return if $page_heading_done; 3149 $page_heading_done = 1; 3150 3151 # Allow site callback to override html. 3152 my $html = cb('page_heading', $title, $heading); 3153 if ($html) 3154 { 3155 print $html; 3156 return; 3157 } 3158 print $q->h1({-style=>'font-weight: normal'}, $heading); 3159} 3160 3161# page_footer - 3162# 3163# Allow the site_callback to take control before the end of the 3164# page. 3165# 3166sub page_footer 3167{ 3168 my $title = shift; 3169 3170 my $html = cb('page_footer', $title); 3171 print $html if ($html); 3172} 3173 3174# page_end_html - 3175# 3176# Print the HTML which ends a page. Allow the site_callback to 3177# take control here too. 3178# 3179sub page_end_html 3180{ 3181 my $title = shift; 3182 3183 # Allow site callback to override html. 3184 my $html = cb('page_end_html', $title); 3185 if ($html) 3186 { 3187 print $html; 3188 return; 3189 } 3190 3191 print $q->end_html(); 3192} 3193 3194# fix_multiline_val - 3195# Modify text of multitext field so that it contains \n separators 3196# (not \r\n or \n as some platforms use), and so that it has a \n 3197# at the end. 3198# 3199sub fix_multiline_val 3200{ 3201 my $val = shift; 3202 $val =~ s/\r\n?/\n/g; 3203 $val .= "\n" unless $val =~ /\n$/; 3204 # Prevent a field value of all-blank characters 3205 $val = "" if ($val =~ /^\s*$/); 3206 return $val; 3207} 3208 3209# unparse_multienum - 3210# Multienum field values arrive from the form as an array. We 3211# need to put all values into one string, values separated by the 3212# multienum separator specified in the field config. 3213sub unparse_multienum 3214{ 3215 my @values = @{$_[0]}; 3216 my $field = $_[1]; 3217 my $valstring; 3218 3219 # Prepare the string of separated values. 3220 $valstring = join($fielddata{$field}{'default_sep'}, @values); 3221 3222 return $valstring; 3223} 3224 3225# parse_multienum 3226# Passed a properly separated Multienum value string, we parse it 3227# by splitting on the multienum separator(s) specified in the 3228# field config and return the result as an array ref. 3229sub parse_multienum 3230{ 3231 my $valstring = $_[0]; 3232 my $field = $_[1]; 3233 3234 # Split and return array ref. 3235 my @values = split /[$fielddata{$field}{'separators'}]/, $valstring; 3236 return \@values; 3237} 3238 3239# parse_categories - 3240# Parse the categories file. 3241sub parse_categories 3242{ 3243 my(@lines) = @_; 3244 3245# dtb - it looks to me like @category is only used within this sub 3246# so why is it used at all? 3247 my @category = (); 3248 %category_notify = (); 3249 %category_desc = (); 3250 3251 foreach $_ (sort @lines) 3252 { 3253 my($cat, $desc, $resp, $notify) = split(/:/); 3254 $category_desc{$cat} = $cat . ' - ' . $desc; 3255 push(@category, $cat); 3256 $category_notify{$cat} = $notify; 3257 } 3258} 3259 3260# parse_submitters - 3261# Parse the submitters file. 3262sub parse_submitters 3263{ 3264 my(@lines) = @_; 3265 3266 @submitter_id = (); 3267 %submitter_complete = (); 3268 %submitter_contact = (); 3269 %submitter_notify = (); 3270 3271 foreach $_ (sort @lines) 3272 { 3273 my($submitter, $fullname, $type, $response_time, $contact, $notify) 3274 = split(/:/); 3275 push(@submitter_id, $submitter); 3276 $submitter_complete{$submitter} = $submitter .' - ' . $fullname; 3277 $submitter_contact{$submitter} = $contact; 3278 $submitter_notify{$submitter} = $notify; 3279 } 3280} 3281 3282# parse_responsible - 3283# Parse the responsible file. 3284sub parse_responsible 3285{ 3286 my(@lines) = @_; 3287 3288 @responsible = (); 3289 %responsible_fullname = (); 3290 %responsible_address = (); 3291 3292 foreach $_ (sort @lines) 3293 { 3294 my($person, $fullname, $address) = split(/:/); 3295 push(@responsible, $person); 3296 $responsible_fullname{$person} = $fullname; 3297 $responsible_complete{$person} = $person . ' - ' . $fullname; 3298 $responsible_address{$person} = $address || $person; 3299 } 3300} 3301 3302# initialize - 3303# Initialize gnatsd-related globals and login to gnatsd. 3304# 3305sub initialize 3306{ 3307 my $regression_testing = shift; 3308 3309 my(@lines); 3310 my $response; 3311 3312 ($response) = client_init(); 3313 3314 # Get gnatsd version from initial server connection text. 3315 if ($response =~ /GNATS server (.*) ready/) 3316 { 3317 $GNATS_VERS = $1; 3318 } 3319 3320 # Suppress fatal exit while issuing CHDB and USER commands. Otherwise 3321 # an error in the user or database cookie values can cause a user to 3322 # get in a bad state. 3323 LOGIN: 3324 { 3325 local($suppress_client_exit) = 1 3326 unless $regression_testing; 3327 3328 # Issue DBLS command, so that we have a list of databases, in case 3329 # the user has tried to get into a db they don't have access to, 3330 # after which we won't be able to do this 3331 3332 my (@db_list) = client_cmd("dbls"); 3333 if (length($db_list[0]) == 0 || $client_would_have_exited) { 3334 login_page($q->url()); 3335 exit(); 3336 } else { 3337 # store the list of databases for later use 3338 $global_list_of_dbs = \@db_list; 3339 } 3340 3341 # Issue CHDB command; revert to login page if it fails. 3342 # use the three-arg version, to authenticate at the same time 3343 my (@chdb_response) = client_cmd("chdb $global_prefs{'database'} $db_prefs{'user'} $db_prefs{'password'}"); 3344 if (length($chdb_response[0]) == 0 || $client_would_have_exited) { 3345 login_page($q->url()); 3346 exit(); 3347 } 3348 3349 # Get user permission level from the return value of CHDB 3350 # three arg CHDB should return something like this: 3351 # 210-Now accessing GNATS database 'foo' 3352 # 210 User access level set to 'edit' 3353 if ($chdb_response[1] =~ /User access level set to '(\w*)'/) { 3354 $access_level = lc($1); 3355 } else { 3356 $access_level = 'view'; 3357 } 3358 3359 # check access level. if < view, make them log in again. 3360 # it might be better to allow "create-only" access for users 3361 # with 'submit' access. 3362 if ($LEVEL_TO_CODE{$access_level} < $LEVEL_TO_CODE{'view'}) { 3363 login_page(undef, "You do not have access to database: $global_prefs{'database'}.<br />\nPlease log in to another database<br /><br />\n"); 3364 undef($suppress_client_exit); 3365 client_exit(); 3366 } 3367 } 3368 3369 # Now initialize our metadata from the database. 3370 init_fieldinfo (); 3371 3372 # List various gnats-adm files, and parse their contents for data we 3373 # will need later. Each parse subroutine stashes information away in 3374 # its own global vars. The call to client_cmd() happens here to 3375 # enable regression testing of the parse subs using fixed files. 3376 @lines = client_cmd("LIST Categories"); 3377 parse_categories(@lines); 3378 @lines = client_cmd("LIST Submitters"); 3379 parse_submitters(@lines); 3380 @lines = client_cmd("LIST Responsible"); 3381 parse_responsible(@lines); 3382 3383 # Now that everything's all set up, let the site_callback have at it. 3384 # It's return value doesn't matter, but here it can muck with our defaults. 3385 cb('initialize'); 3386} 3387 3388# trim_responsible - 3389# Trim the value of the Responsible field to get a 3390# valid responsible person. This exists here, and in gnats itself 3391# (modify_pr(), check_pr(), gnats(), append_report()), for 3392# compatibility with old databases, which had 'person (Full Name)' 3393# in the Responsible field. 3394sub trim_responsible 3395{ 3396 my $resp = shift; 3397 $resp =~ s/ .*//; 3398 $resp; 3399} 3400 3401# fix_email_addrs - 3402# Trim email addresses as they appear in an email From or Reply-To 3403# header into a comma separated list of just the addresses. 3404# 3405# Delete everything inside ()'s and outside <>'s, inclusive. 3406# 3407sub fix_email_addrs 3408{ 3409 my $addrs = shift; 3410 my @addrs = split_csl ($addrs); 3411 my @trimmed_addrs; 3412 my $addr; 3413 foreach $addr (@addrs) 3414 { 3415 $addr =~ s/\(.*\)//; 3416 $addr =~ s/.*<(.*)>.*/$1/; 3417 $addr =~ s/^\s+//; 3418 $addr =~ s/\s+$//; 3419 push(@trimmed_addrs, $addr); 3420 } 3421 $addrs = join(', ', @trimmed_addrs); 3422 $addrs; 3423} 3424 3425sub parsepr 3426{ 3427 # 9/18/99 kenstir: This two-liner can almost replace the next 30 or so 3428 # lines of code, but not quite. It strips leading spaces from multiline 3429 # fields. 3430 #my $prtext = join("\n", @_); 3431 #my(%fields) = ('envelope' => split /^>(\S*?):\s*/m, $prtext); 3432 # my $prtext = join("\n", @_); 3433 # my(%fields) = ('envelope' => split /^>(\S*?):(?: *|\n)/m, $prtext); 3434 3435 my $debug = 0; 3436 3437 my($hdrmulti) = "envelope"; 3438 my(%fields); 3439 foreach (@_) 3440 { 3441 chomp($_); 3442 $_ .= "\n"; 3443 if(!/^([>\w\-]+):\s*(.*)\s*$/) 3444 { 3445 if($hdrmulti ne "") 3446 { 3447 $fields{$hdrmulti} .= $_; 3448 } 3449 next; 3450 } 3451 my ($hdr, $arg, $ghdr) = ($1, $2, "*not valid*"); 3452 if($hdr =~ /^>(.*)$/) 3453 { 3454 $ghdr = $1; 3455 } 3456 3457 my $cleanhdr = $ghdr; 3458 $cleanhdr =~ s/^>([^:]*).*$/$1/; 3459 3460 if(isvalidfield ($cleanhdr)) 3461 { 3462 if(fieldinfo($cleanhdr, 'fieldtype') eq 'multitext') 3463 { 3464 $hdrmulti = $ghdr; 3465 $fields{$ghdr} = ""; 3466 } 3467 else 3468 { 3469 $hdrmulti = ""; 3470 $fields{$ghdr} = $arg; 3471 } 3472 } 3473 elsif($hdrmulti ne "") 3474 { 3475 $fields{$hdrmulti} .= $_; 3476 } 3477 3478 # Grab a few fields out of the envelope as it flies by 3479 # 8/25/99 ehl: Grab these fields only out of the envelope, not 3480 # any other multiline field. 3481 if($hdrmulti eq "envelope" && 3482 ($hdr eq "Reply-To" || $hdr eq "From")) 3483 { 3484 $arg = fix_email_addrs($arg); 3485 $fields{$hdr} = $arg; 3486 #print "storing, hdr = $hdr, arg = $arg\n"; 3487 } 3488 } 3489 3490 # 5/8/99 kenstir: To get the reporter's email address, only 3491 # $fields{'Reply-to'} is consulted. Initialized it from the 'From' 3492 # header if it's not set, then discard the 'From' header. 3493 $fields{'Reply-To'} = $fields{'Reply-To'} || $fields{'From'}; 3494 delete $fields{'From'}; 3495 3496 # Ensure that the pseudo-fields are initialized to avoid perl warnings. 3497 $fields{'X-GNATS-Notify'} ||= ''; 3498 3499 # 3/30/99 kenstir: For some reason Unformatted always ends up with an 3500 # extra newline here. 3501 $fields{$UNFORMATTED_FIELD} ||= ''; # Default to empty value 3502 $fields{$UNFORMATTED_FIELD} =~ s/\n$//; 3503 3504 # Decode attachments stored in Unformatted field. 3505 my $any_attachments = 0; 3506 if (can_do_mime()) { 3507 my(@attachments) = split(/$attachment_delimiter/, $fields{$UNFORMATTED_FIELD}); 3508 # First element is any random text which precedes delimited attachments. 3509 $fields{$UNFORMATTED_FIELD} = shift(@attachments); 3510 foreach my $attachment (@attachments) { 3511 warn "att=>$attachment<=\n" if $debug; 3512 $any_attachments = 1; 3513 # Strip leading spaces on each line of the attachment 3514 $attachment =~ s/^[ ]//mg; 3515 add_decoded_attachment_to_pr(\%fields, decode_attachment($attachment)); 3516 } 3517 } 3518 3519 if ($debug) { 3520 warn "--- parsepr fields ----\n"; 3521 my %fields_copy = %fields; 3522 foreach (@fieldnames) 3523 { 3524 warn "$_ =>$fields_copy{$_}<=\n"; 3525 delete $fields_copy{$_} 3526 } 3527 warn "--- parsepr pseudo-fields ----\n"; 3528 foreach (sort keys %fields_copy) { 3529 warn "$_ =>$fields_copy{$_}<=\n"; 3530 } 3531 warn "--- parsepr attachments ---\n"; 3532 my $aref = $fields{'attachments'} || []; 3533 foreach my $href (@$aref) { 3534 warn " ----\n"; 3535 my ($k,$v); 3536 while (($k,$v) = each %$href) { 3537 warn " $k =>$v<=\n"; 3538 } 3539 } 3540 } 3541 3542 return %fields; 3543} 3544 3545# unparsepr - 3546# Turn PR fields hash into a multi-line string. 3547# 3548# The $purpose arg controls how things are done. The possible values 3549# are: 3550# 'gnatsd' - PR will be filed using gnatsd; proper '.' escaping done 3551# 'send' - PR will be field using gnatsd, and is an initial PR. 3552# 'test' - we're being called from the regression tests 3553sub unparsepr 3554{ 3555 my($purpose, %fields) = @_; 3556 my($tmp, $text); 3557 my $debug = 0; 3558 3559 # First create or reconstruct the Unformatted field containing the 3560 # attachments, if any. 3561 $fields{$UNFORMATTED_FIELD} ||= ''; # Default to empty. 3562 warn "unparsepr 1 =>$fields{$UNFORMATTED_FIELD}<=\n" if $debug; 3563 my $array_ref = $fields{'attachments'}; 3564 foreach my $hash_ref (@$array_ref) { 3565 my $attachment_data = $$hash_ref{'original_attachment'}; 3566 # Deleted attachments leave empty hashes behind. 3567 next unless defined($attachment_data); 3568 $fields{$UNFORMATTED_FIELD} .= $attachment_delimiter . $attachment_data . "\n"; 3569 } 3570 warn "unparsepr 2 =>$fields{$UNFORMATTED_FIELD}<=\n" if $debug; 3571 3572 # Reconstruct the text of the PR into $text. 3573 $text = $fields{'envelope'}; 3574 foreach (@fieldnames) 3575 { 3576 # Do include Unformatted field in 'send' operation, even though 3577 # it's excluded. We need it to hold the file attachment. 3578 # XXX ??? !!! FIXME 3579 if(($purpose eq 'send') 3580 && (! (fieldinfo ($_, 'flags') & $SENDINCLUDE)) 3581 && ($_ ne $UNFORMATTED_FIELD)) 3582 { 3583 next; 3584 } 3585 if(fieldinfo($_, 'fieldtype') eq 'multitext') 3586 { 3587 # Lines which begin with a '.' need to be escaped by another '.' 3588 # if we're feeding it to gnatsd. 3589 $tmp = $fields{$_}; 3590 $tmp =~ s/^[.]/../gm 3591 if ($purpose ne 'test'); 3592 $text .= sprintf(">$_:\n%s", $tmp); 3593 } 3594 else 3595 { 3596 # Format string derived from gnats/pr.c. 3597 $fields{$_} ||= ''; # Default to empty 3598 $text .= sprintf("%-16s %s\n", ">$_:", $fields{$_}); 3599 } 3600 if (exists ($fields{$_."-Changed-Why"})) 3601 { 3602 # Lines which begin with a '.' need to be escaped by another '.' 3603 # if we're feeding it to gnatsd. 3604 $tmp = $fields{$_."-Changed-Why"}; 3605 $tmp =~ s/^[.]/../gm 3606 if ($purpose ne 'test'); 3607 $text .= sprintf(">$_-Changed-Why:\n%s\n", $tmp); 3608 } 3609 } 3610 return $text; 3611} 3612 3613sub lockpr 3614{ 3615 my($pr, $user) = @_; 3616 #print "<pre>locking $pr $user\n</pre>"; 3617 return parsepr(client_cmd("lock $pr $user")); 3618} 3619 3620sub unlockpr 3621{ 3622 my($pr) = @_; 3623 #print "<pre>unlocking $pr\n</pre>"; 3624 client_cmd("unlk $pr"); 3625} 3626 3627sub readpr 3628{ 3629 my($pr) = @_; 3630 3631 # Not sure if we want to do a RSET here but it probably won't hurt. 3632 client_cmd ("rset"); 3633 client_cmd ("QFMT full"); 3634 return parsepr(client_cmd("quer $pr")); 3635} 3636 3637# interested_parties - 3638# Get list of parties to notify about a PR change. 3639# 3640# Returns hash in array context; string of email addrs otherwise. 3641sub interested_parties 3642{ 3643 my($pr, %fields) = @_; 3644 3645 my(@people); 3646 my $person; 3647 my $list; 3648 3649 # Get list of people by constructing it ourselves. 3650 @people = (); 3651 foreach $list ($fields{'Reply-To'}, 3652 $fields{$RESPONSIBLE_FIELD}, 3653 $category_notify{$fields{$CATEGORY_FIELD}}, 3654 $submitter_contact{$fields{$SUBMITTER_ID_FIELD}}, 3655 $submitter_notify{$fields{$SUBMITTER_ID_FIELD}}) 3656 { 3657 if (defined($list)) { 3658 foreach $person (split_csl ($list)) 3659 { 3660 push(@people, $person) if $person; 3661 } 3662 } 3663 } 3664 3665 # Expand any unexpanded addresses, and build up the %addrs hash. 3666 my(%addrs) = (); 3667 my $addr; 3668 foreach $person (@people) 3669 { 3670 $addr = praddr($person) || $person; 3671 $addrs{$addr} = 1; 3672 } 3673 return wantarray ? %addrs : join(', ', keys(%addrs)); 3674} 3675 3676# Split comma-separated list. 3677# Commas in quotes are not separators! 3678sub split_csl 3679{ 3680 my ($list) = @_; 3681 3682 # Substitute commas in quotes with \002. 3683 while ($list =~ m~"([^"]*)"~g) 3684 { 3685 my $pos = pos($list); 3686 my $str = $1; 3687 $str =~ s~,~\002~g; 3688 $list =~ s~"[^"]*"~"$str"~; 3689 pos($list) = $pos; 3690 } 3691 3692 my @res; 3693 foreach my $person (split(/\s*,\s*/, $list)) 3694 { 3695 $person =~ s/\002/,/g; 3696 push(@res, $person) if $person; 3697 } 3698 return @res; 3699} 3700 3701# praddr - 3702# Return email address of responsible person, or undef if not found. 3703sub praddr 3704{ 3705 my $person = shift; 3706 # Done this way to avoid -w warning 3707 my $addr = exists($responsible_address{$person}) 3708 ? $responsible_address{$person} : undef; 3709} 3710 3711# login_page_javascript - 3712# Returns some Javascript code to test if cookies are being accepted. 3713# 3714sub login_page_javascript 3715{ 3716 my $ret = q{ 3717<SCRIPT LANGUAGE="JavaScript" TYPE="text/javascript"> 3718//<!-- 3719// JavaScript courtesy of webcoder.com. 3720 3721function getCookie(name) { 3722 var cname = name + "="; 3723 var dc = document.cookie; 3724 if (dc.length > 0) { 3725 begin = dc.indexOf(cname); 3726 if (begin != -1) { 3727 begin += cname.length; 3728 end = dc.indexOf(";", begin); 3729 if (end == -1) end = dc.length; 3730 return unescape(dc.substring(begin, end)); 3731 } 3732 } 3733 return null; 3734} 3735 3736function setCookie(name, value, expires) { 3737 document.cookie = name + "=" + escape(value) + "; path=/" + 3738 ((expires == null) ? "" : "; expires=" + expires.toGMTString()); 3739} 3740 3741function delCookie(name) { 3742 document.cookie = name + "=; path=/; expires=Thu, 01-Jan-70 00:00:01 GMT"; 3743} 3744 3745exp = new Date(); 3746exp.setTime(exp.getTime() + (1000 * 60 * 60)); // +1 hour 3747setCookie("gnatsweb-test-cookie", "whatever", exp); 3748val = getCookie("gnatsweb-test-cookie"); 3749delCookie("gnatsweb-test-cookie"); 3750if (val == null) { 3751 document.write( 3752 "<p><strong>Warning: your browser is not accepting cookies!</strong> " 3753 +"Unfortunately, Gnatsweb requires cookies to keep track of your " 3754 +"login and other information. " 3755 +"Please enable cookies before logging in.</p>"); 3756} 3757 3758//--> 3759</SCRIPT> 3760<noscript> 3761<p>(Due to the fact that your browser does not support Javascript, 3762there is no way of telling whether it can accept cookies.) 3763 3764Unfortunately, Gnatsweb requires cookies to keep track of your 3765login and other information. 3766Please enable cookies before logging in.</p> 3767</noscript> 3768 }; 3769} 3770 3771 3772# change the database in the global cookie 3773# 3774sub change_database 3775{ 3776 $global_prefs{'database'} = $q->param('new_db'); 3777 my $global_cookie = create_global_cookie(); 3778 my $url = $q->url(); 3779 # the refresh header chokes on the query-string if the 3780 # params are separated by semicolons... 3781 $url =~ s/\;/&/g; 3782 3783 print_header(-Refresh => "0; URL=$url", 3784 -cookie => [$global_cookie]), 3785 $q->start_html(); 3786 print $q->h3("Hold on... Redirecting...<br />". 3787 "In case it does not work automatically, please follow ". 3788 "<a href=\"$url\">this link</a>."), 3789 $q->end_html(); 3790} 3791 3792# clear the db_prefs cookie containing username and password and take 3793# the user back to the login page 3794sub cmd_logout 3795{ 3796 my $db = $global_prefs{'database'}; 3797 my $db_cookie = $q->cookie(-name => "gnatsweb-db-$db", 3798 -value => 'does not matter', 3799 -path => $global_cookie_path, 3800 -expires => '-1d'); 3801 my $url = $q->url(); 3802 # the refresh header chokes on the query-string if the 3803 # params are separated by semicolons... 3804 $url =~ s/\;/&/g; 3805 3806 print_header(-Refresh => "0; URL=$url", 3807 -cookie => [$db_cookie]), 3808 $q->start_html(); 3809 print $q->h3("Hold on... Redirecting...<br />". 3810 "In case it does not work automatically, please follow ". 3811 "<a href=\"$url\">this link</a>."), 3812 $q->end_html(); 3813} 3814 3815# execute the login, after the user submits from the login page 3816# 3817sub cmd_login { 3818 unless ($site_gnatsweb_server_auth) { 3819 # first, do some sanity checking on the username 3820 # user name must be something reasonable 3821 # and must not be all digits (like a PR number...) 3822 my $user = $q->param('user'); 3823 if ($user !~ /^[\w-]+$/ || $user !~ /[a-z]/i) { 3824 if ($user =~ /\s/) { 3825 $user = $user . ' (contains whitespace)'; 3826 } 3827 print_header(); 3828 login_page(undef, 'Invalid User Name: "'.$user.'", please log in again'); 3829 exit(); 3830 } 3831 } 3832 3833 my $global_cookie = create_global_cookie(); 3834 my $db = $global_prefs{'database'}; 3835 3836 # Have to generate the cookie before printing the header. 3837 my %cookie_hash = ( 3838 -name => "gnatsweb-db-$db", 3839 -value => camouflage(\%db_prefs), 3840 -path => $global_cookie_path 3841 ); 3842 %cookie_hash = (%cookie_hash, -expires => $global_cookie_expires) 3843 unless $use_temp_db_prefs_cookie; 3844 my $db_cookie = $q->cookie(%cookie_hash); 3845 3846 my $expire_old_cookie = $q->cookie(-name => 'gnatsweb', 3847 -value => 'does not matter', 3848 #-path was not used for gnatsweb 2.5 cookies 3849 -expires => '-1d'); 3850 my $url = $q->param('return_url'); 3851 # the refresh header chokes on the query-string if the 3852 # params are separated by semicolons... 3853 $url =~ s/\;/&/g; 3854 3855 # 11/27/99 kenstir: Try zero-delay refresh all the time. 3856 $url = $q->url() if (!defined($url)); 3857 # 11/14/99 kenstir: For some reason doing cookies + redirect didn't 3858 # work; got a 'page contained no data' error from NS 4.7. This cookie 3859 # + redirect technique did work for me in a small test case. 3860 #print $q->redirect(-location => $url, 3861 # -cookie => [$global_cookie, $db_cookie]); 3862 # So, this is sort of a lame replacement; a zero-delay refresh. 3863 print_header(-Refresh => "0; URL=$url", 3864 -cookie => [$global_cookie, $db_cookie, $expire_old_cookie]), 3865 $q->start_html(); 3866 my $debug = 0; 3867 if ($debug) { 3868 print "<h3>debugging params</h3><font size=1><pre>"; 3869 my($param,@val); 3870 foreach $param (sort $q->param()) { 3871 @val = $q->param($param); 3872 printf "%-12s %s\n", $param, $q->escapeHTML(join(' ', @val)); 3873 } 3874 print "</pre></font><hr>\n"; 3875 } 3876 # Add a link to the new URL. In case the refresh/redirect above did not 3877 # work, at least the user can select the link manually. 3878 print $q->h3("Hold on... Redirecting...<br />". 3879 "In case it does not work automatically, please follow ". 3880 "<a href=\"$url\">this link</a>."), 3881 $q->end_html(); 3882} 3883 3884# login_page - 3885# Show the login page. 3886# 3887# If $return_url passed in, then we are showing the login page because 3888# the user failed to login. In that case, when the login is 3889# successful, we want to redirect to the given url. For example, if a 3890# user follows a ?cmd=view url, but hasn't logged in yet, then we want 3891# to forward him to the originally requested url after logging in. 3892# 3893sub login_page 3894{ 3895 my ($return_url, $message) = @_; 3896 my $page = 'Login'; 3897 page_start_html($page, 1); 3898 page_heading($page, 'Login'); 3899 3900 print login_page_javascript(); 3901 3902 my $html = cb('login_page_text'); 3903 print $html || ''; 3904 3905 if ($message) { 3906 print $message; 3907 } 3908 3909 client_init(); 3910 my(@dbs) = client_cmd("dbls"); 3911 print $q->start_form(), hidden_debug(), "<table>"; 3912 unless($site_gnatsweb_server_auth) { 3913 print "<tr><td><font color=\"red\"><b>User Name</b></font>:</td><td>", 3914 $q->textfield(-name=>'user', 3915 -size=>20, 3916 -default=>$db_prefs{'user'}), 3917 "</td>\n</tr>\n"; 3918 if ($site_no_gnats_passwords) { 3919 # we're not using gnats passwords, so the password input 3920 # is superfluous. put in a hidden field with a bogus value, 3921 # just so other parts of the program don't get confused 3922 print qq*<input type="hidden" name="password" value="not_applicable">*; 3923 } else { 3924 print "<tr>\n<td>Password:</td>\n<td>", 3925 $q->password_field(-name=>'password', 3926 -value=>$db_prefs{'password'}, 3927 -size=>20), 3928 "</td>\n</tr>\n"; 3929 } 3930 } 3931 print "<tr>\n<td>Database:</td>\n<td>", 3932 $q->popup_menu(-name=>'database', 3933 -values=>\@dbs, 3934 -default=>$global_prefs{'database'}), 3935 "</td>\n</tr>\n", 3936 "</table>\n"; 3937 if (defined($return_url)) 3938 { 3939 print $q->hidden('return_url', $return_url); 3940 } 3941 # we need this extra hidden field in case users 3942 # just type in a username and hit return. this will 3943 # ensure that cmd_login() gets called to process the login. 3944 print qq*<input type="hidden" name="cmd" value="login">*; 3945 print $q->submit('cmd','login'), 3946 $q->end_form(); 3947 page_footer($page); 3948 page_end_html($page); 3949} 3950 3951sub debug_print_all_cookies 3952{ 3953 # Debug: print all our cookies into server log. 3954 warn "================= all cookies ===================================\n"; 3955 my @c; 3956 my $i = 0; 3957 foreach my $y ($q->cookie()) 3958 { 3959 @c = $q->cookie($y); 3960 warn "got cookie: length=", scalar(@c), ": $y =>@c<=\n"; 3961 $i += length($y); 3962 } 3963# @c = $q->raw_cookie(); 3964# warn "debug 0.5: @c:\n"; 3965# warn "debug 0.5: total size of raw cookies: ", length("@c"), "\n"; 3966} 3967 3968# set_pref - 3969# Set the named preference. Param values override cookie values, and 3970# don't set it if we end up with an undefined value. 3971# 3972sub set_pref 3973{ 3974 my($pref_name, $pref_hashref, $cval_hashref) = @_; 3975 my $val = $q->param($pref_name) || ($pref_name eq "password" ? 3976 uncamouflage($$cval_hashref{$pref_name}) : 3977 $$cval_hashref{$pref_name} 3978 ); 3979 3980 $$pref_hashref{$pref_name} = $val 3981 if defined($val); 3982} 3983 3984# init_prefs - 3985# Initialize global_prefs and db_prefs from cookies and params. 3986# 3987sub init_prefs 3988{ 3989 my $debug = 0; 3990 3991 if ($debug) { 3992 debug_print_all_cookies(); 3993 use Data::Dumper; 3994 $Data::Dumper::Terse = 1; 3995 warn "-------------- init_prefs -------------------\n"; 3996 } 3997 3998 # Global prefs. 3999 my %cvals = $q->cookie('gnatsweb-global'); 4000 if (! %cvals) { 4001 $global_no_cookies = 1; 4002 } 4003 4004 # deal with legacy cookies, which used email_addr 4005 if ($cvals{'email_addr'}) 4006 { 4007 $cvals{'email'} = $cvals{'email_addr'}; 4008 } 4009 4010 %global_prefs = (); 4011 set_pref('database', \%global_prefs, \%cvals); 4012 set_pref('email', \%global_prefs, \%cvals); 4013 set_pref($ORIGINATOR_FIELD, \%global_prefs, \%cvals); 4014 set_pref($SUBMITTER_ID_FIELD, \%global_prefs, \%cvals); 4015 4016 # columns is treated differently because it's an array which is stored 4017 # in the cookie as a joined string. 4018 if ($q->param('columns')) { 4019 my(@columns) = $q->param('columns'); 4020 $global_prefs{'columns'} = join(' ', @columns); 4021 } 4022 elsif (defined($cvals{'columns'})) { 4023 $global_prefs{'columns'} = $cvals{'columns'}; 4024 } 4025 4026 if (!$cvals{'email'}) { 4027 $global_prefs{'email'} = $q->param('email') || ''; 4028 } 4029 4030 # DB prefs. 4031 my $database = $global_prefs{'database'} || ''; 4032 if ($site_gnatsweb_server_auth) 4033 { 4034 # we're not using cookies for user/password 4035 # since the server is doing authentication 4036 %cvals = ( 'password' => $ENV{REMOTE_USER}, 4037 'user' => $ENV{REMOTE_USER} ); 4038 } 4039 else 4040 { 4041 %cvals = $q->cookie("gnatsweb-db-$database"); 4042 } 4043 %db_prefs = (); 4044 set_pref('user', \%db_prefs, \%cvals); 4045 set_pref('password', \%db_prefs, \%cvals); 4046 4047 # Debug. 4048 warn "global_prefs = ", Dumper(\%global_prefs) if $debug; 4049 warn "db_prefs = ", Dumper(\%db_prefs) if $debug; 4050} 4051 4052# create_global_cookie - 4053# Create cookie from %global_prefs. 4054# 4055sub create_global_cookie 4056{ 4057 my $debug = 0; 4058 # As of gnatsweb-2.6beta, the name of this cookie changed. This was 4059 # done so that the old cookie would not be read. 4060 my $cookie = $q->cookie(-name => 'gnatsweb-global', 4061 -value => \%global_prefs, 4062 -path => $global_cookie_path, 4063 -expires => $global_cookie_expires); 4064 warn "storing cookie: $cookie\n" if $debug; 4065 return $cookie; 4066} 4067 4068# camouflage - 4069# If passed a scalar, camouflages it by XORing it with 19 and 4070# reversing the string. If passed a hash reference with key 4071# "password", it camouflages the values of this key using the 4072# same algorithm. 4073# 4074sub camouflage 4075{ 4076 my $clear = shift || ''; 4077 if (ref($clear) =~ "HASH") 4078 { 4079 my $res = {}; 4080 foreach my $key (keys %$clear) 4081 { 4082 $$res{$key} = ( $key eq "password" ? 4083 camouflage($$clear{$key}) : $$clear{$key} ); 4084 } 4085 return $res; 4086 } 4087 $clear =~ s/(.)/chr(19 ^ ord $1)/eg; 4088 return (reverse $clear) || ''; 4089} 4090 4091# uncamouflage 4092# Since the camouflage algorithm employed is symmetric... 4093# 4094sub uncamouflage 4095{ 4096 return camouflage(@_); 4097} 4098 4099# 4100# MAIN starts here: 4101# 4102sub main 4103{ 4104 # Load $gnatsweb_site_file if present. Die if there are errors; 4105 # otherwise the person who wrote $gnatsweb_site_file will never know it. 4106 if (-e $gnatsweb_site_file && -r $gnatsweb_site_file) { 4107 open(GWSP, "<$gnatsweb_site_file"); 4108 local $/ = undef; 4109 my $gnatsweb_site_pl = <GWSP>; 4110 eval($gnatsweb_site_pl); 4111 if ($@) { 4112 warn("gnatsweb: error in eval of $gnatsweb_site_file: $@; user=$db_prefs{'user'}, db=$global_prefs{'database'}; stacktrace: ", print_stacktrace()); 4113 die $@ 4114 } 4115 } 4116 4117 # Make sure nobody tries to swamp our server with a huge file attachment. 4118 # Has to happen before 'new CGI'. 4119 $CGI::POST_MAX = $site_post_max if defined($site_post_max); 4120 4121 # Create the query object. Check to see if there was an error, which 4122 # happens if the post exceeds POST_MAX. 4123 $q = new CGI; 4124 if ($q->cgi_error()) 4125 { 4126 print_header(-status=>$q->cgi_error()); 4127 $q->start_html('Error'); 4128 page_heading('Initialization failed', 'Error'); 4129 print $q->h3('Request not processed: ', $q->cgi_error()); 4130 warn("gnatsweb: cgi error: ", $q->cgi_error(), " ; user=$db_prefs{'user'}, db=$global_prefs{'database'}; stacktrace: ", print_stacktrace()); 4131 exit(); 4132 } 4133 4134 if ($site_allow_remote_debug) { 4135 my $debugparam = $q->param('debug') || ''; 4136 # check for debug flag in query string. 4137 if ($debugparam eq 'cmd') { 4138 $client_cmd_debug = 1; 4139 } 4140 if ($debugparam eq 'reply') { 4141 $reply_debug = 1; 4142 } 4143 if ($debugparam eq 'all') { 4144 $reply_debug = 1; 4145 $client_cmd_debug = 1; 4146 } 4147 } 4148 4149 $script_name = $q->script_name; 4150 my $cmd = $q->param('cmd') || ''; # avoid perl -w warning 4151 4152 ### Cookie-related code must happen before we print the HTML header. 4153 init_prefs(); 4154 4155 if(!$global_prefs{'database'} 4156 || !$db_prefs{'user'}) 4157 { 4158 # We don't have username/database; give login page then 4159 # redirect to the url they really want (self_url). 4160 print_header(); 4161 login_page($q->self_url()); 4162 exit(); 4163 } 4164 4165 # Big old switch to handle commands. 4166 if($cmd eq 'store query') 4167 { 4168 store_query(); 4169 exit(); 4170 } 4171 elsif($cmd eq 'delete stored query') 4172 { 4173 delete_stored_query(); 4174 exit(); 4175 } 4176 elsif($cmd eq 'change database') 4177 { 4178 # change the user's database in global cookie 4179 change_database(); 4180 exit(); 4181 } 4182 elsif($cmd eq 'submit stored query') 4183 { 4184 submit_stored_query(); 4185 exit(); 4186 } 4187 elsif($cmd eq 'login') 4188 { 4189 cmd_login(); 4190 } 4191 elsif($cmd eq 'logout') 4192 { 4193 # User is logging out. 4194 cmd_logout(); 4195 exit(); 4196 } 4197 elsif($cmd eq 'submit') 4198 { 4199 initialize(); 4200 4201 # Only include Create action if user is allowed to create PRs. 4202 # (only applicable if $no_create_without_edit flag is set) 4203 main_page() unless can_create(); 4204 4205 submitnewpr(); 4206 exit(); 4207 } 4208 elsif($cmd eq 'submit query') 4209 { 4210 # User is querying. Store cookie because column display list may 4211 # have changed. 4212 print_header(-cookie => create_global_cookie()); 4213 initialize(); 4214 submitquery(); 4215 exit(); 4216 } 4217 elsif($cmd =~ /download attachment (\d+)/) 4218 { 4219 # User is downloading an attachment. Must initialize but not print header. 4220 initialize(); 4221 download_attachment($1); 4222 exit(); 4223 } 4224 elsif($cmd eq 'create') 4225 { 4226 print_header(); 4227 initialize(); 4228 4229 # Only include Create action if user is allowed to create PRs. 4230 # (only applicable if $no_create_without_edit flag is set) 4231 main_page() unless can_create(); 4232 4233 sendpr(); 4234 } 4235 elsif($cmd eq 'view') 4236 { 4237 print_header(); 4238 initialize(); 4239 view(0); 4240 } 4241 elsif($cmd eq 'view audit-trail') 4242 { 4243 print_header(); 4244 initialize(); 4245 view(1); 4246 } 4247 elsif($cmd eq 'edit') 4248 { 4249 print_header(); 4250 initialize(); 4251 4252 # Only include Edit action if user is allowed to Edit PRs. 4253 main_page() unless can_edit(); 4254 4255 edit(); 4256 } 4257 elsif($cmd eq 'submit edit') 4258 { 4259 initialize(); 4260 4261 # Only include Edit action if user is allowed to Edit PRs. 4262 main_page() unless can_edit(); 4263 4264 submitedit(); 4265 } 4266 elsif($cmd eq 'query') 4267 { 4268 print_header(); 4269 initialize(); 4270 query_page(); 4271 } 4272 elsif($cmd eq 'advanced query') 4273 { 4274 print_header(); 4275 initialize(); 4276 advanced_query_page(); 4277 } 4278 elsif($cmd eq 'store query') 4279 { 4280 print_header(); 4281 initialize(); 4282 store_query(); 4283 } 4284 elsif($cmd eq 'help') 4285 { 4286 print_header(); 4287 initialize(); 4288 help_page(); 4289 } 4290 elsif (cb('cmd', $cmd)) { 4291 ; # cmd was handled by callback 4292 } 4293 else 4294 { 4295 print_header(); 4296 initialize(); 4297 main_page(); 4298 } 4299 4300 client_exit(); 4301 exit(); 4302} 4303 4304# To make this code callable from another source file, set $suppress_main. 4305$suppress_main ||= 0; 4306main() unless $suppress_main; 4307 4308# Emacs stuff - 4309# 4310# Local Variables: 4311# perl-indent-level:2 4312# perl-continued-brace-offset:-6 4313# perl-continued-statement-offset:6 4314# End: 4315