#!/usr/bin/perl -w
#
# gnats.pl - Gnats www perl interface script
#
# Copyright 1998 - Matt Gerassimoff
# and Ken Cox <kenstir@senteinc.com>
#
# $Revision: 1.24 $
# $Header: /system/u/kenstir/cvsroot/gnatsweb/gnatsweb.pl,v 1.24 1999/04/02 05:05:07 kenstir Exp $
#

#-----------------------------------------------------------------------------
# Site-specific customization -
#
#     User serviceable parts - variables and subroutines.
#
#     We suggest you don't edit these variables here, but instead put
#     them in a file called 'gnatsweb-site.pl' in the same directory.
#     That way, when a new version of gnatsweb is released, you won't
#     need to edit them again.
#
#     For an example of what you can do with the site_callback
#     subroutine, see gnatsweb-site-sente.pl.
#

# Info about your gnats host.
$site_gnats_host = 'localhost';
$site_gnats_port = 1529;

# Name you want in the page banner.
$site_banner_text = 'gnatsweb';

# Program to send email notifications.
$site_mailer = '/usr/sbin/sendmail -oi -t';

# site_callback -
#
#     If defined, this subroutine gets called at various times.  The
#     reason it is being called is indicated by the $reason argument.
#     It can return undef, in which case gnatsweb does its default
#     thing.  Or, it can return a piece of HTML to implement
#     site-specific behavior or appearance.
#
# arguments:
#     $reason - reason for the call.  Each reason is unique.
#     @args   - additional parameters may be provided in @args.
#
# returns:
#     undef     - take no special action
#     string    - string is used by gnatsweb according to $reason
#
# example:
#     sub site_callback {
#         my($reason, @args) = @_;
#         if ($reason eq 'sendpr_description') {
#             return 'default description text used in sendpr form';
#         }
#         undef;
#     }
#

# end customization
#-----------------------------------------------------------------------------

use CGI qw/:standard :netscape/;
use CGI::Carp qw/fatalsToBrowser/;
use Socket;
use IO::Handle;
use POSIX;

use Text::Wrap qw(wrap $columns $tabstop fill);
$columns = 500;
$tabstop = 8;

($REVISION  = '$Revision: 1.24 $ ') =~ s/\$\Revision: (.*) \$/$1/;
$textwidth = 60;

# where to get help -- a web site with translated info documentation
$gnats_info_top = "http://www.hyperreal.org/info/gnuinfo/index";

# bits in %fieldnames has (set=yes not-set=no)
$MULTILINE = 1;     # whether field is multi line
$SENDEXCLUDE = 2;   # whether the send command should exclude the field
$REASONCHANGE = 4;  # whether change to a field requires reason
$ENUM = 8;          # whether field should be displayed as enumerated
$EDITEXCLUDE = 16;  # if set, don't display on edit page

$REPLY_CONT = 1;
$REPLY_END = 2;

$CODE_GREETING = 200;
$CODE_OK = 210;
$CODE_PR_READY = 220;
$CODE_CLOSING = 205;
$CODE_INFORMATION = 230;
$CODE_HELLO = 250;

$CODE_INVALID_PR = 410;
$CODE_INVALID_CATEGORY = 420;
$CODE_UNREADABLE_PR = 430;
$CODE_NO_PRS = 440;
$CODE_NO_KERBEROS = 450;
$CODE_INVALID_SUBMITTER = 460;
$CODE_INVALID_STATE = 461;
$CODE_INVALID_RESPONSIBLE = 465;
$CODE_INVALID_DATE = 468;
$CODE_FILE_ERROR = 480;
$CODE_LOCKED_PR = 490;
$CODE_GNATS_LOCKED = 491;
$CODE_PR_NOT_LOCKED = 495;

$CODE_ERROR = 500;
$CODE_NO_ACCESS = 520;

$| = 1; # flush output after each print

sub gerror
{
  my($text) = @_;
  my $prog = $0;
  $prog =~ s@.*/@@;
  print "<pre>$prog: $text\n</pre>\n";
}

sub client_exit
{
  close(SOCK);
  exit();
}

sub server_reply
{
  my($state, $text, $type);
  $_ = <SOCK>;
  if(/(\d+)([- ]?)(.*$)/)
  {
    $state = $1;
    $text = $3;
    if($2 eq '-')
    {
      $type = $REPLY_CONT;
    }
    else
    {
      if($2 ne ' ')
      {
        gerror("bad type of reply from server");
      }
      $type = $REPLY_END;
    }
    return ($state, $text, $type);
  }
  return (undef, undef, undef);
}

sub read_server
{
  my(@text);

  while(<SOCK>)
  {
    if(/^\.\r/)
    {
      return @text;
    }
    $_ =~ s/[\r\n]//g;
    # Lines which begin with a '.' are escaped by gnatsd with another '.'
    $_ =~ s/^\.\././;
    push(@text, $_);
  }
}

sub get_reply
{
  my($state, $text, $type) = server_reply();
  my(@rettext) = ($text);
  if($state == $CODE_GREETING)
  {
    while($type == $REPLY_CONT)
    {
      ($state, $text, $type) = server_reply();
      if(!defined($state))
      {
        gerror("null reply from the server");
      }
      push(@rettext, $text);
    }
  }
  elsif($state == $CODE_OK || $state == $CODE_HELLO)
  {
    # nothing
  }
  elsif($state == $CODE_CLOSING)
  {
    # nothing
  }
  elsif($state == $CODE_PR_READY)
  {
    @rettext = read_server();
  }
  elsif($state == $CODE_INFORMATION)
  {
    ($state, $text, $type) = server_reply();
    while($type == $REPLY_CONT)
    {
      push(@rettext, $text);
      ($state, $text, $type) = server_reply();
    }
  }
  elsif($state == $CODE_INVALID_PR)
  {
    $text =~ / (.*)/;
    gerror("couldn't find $1");
    client_exit();
  }
  elsif($state == $CODE_INVALID_CATEGORY)
  {
    $text =~ / (.*)/;
    gerror("no such category $1");
    client_exit();
  }
  elsif($state == $CODE_INVALID_SUBMITTER)
  {
    $text =~ / (.*)/;
    gerror("no such submitter $1");
    client_exit();
  }
  elsif($state == $CODE_INVALID_STATE)
  {
    $text =~ / (.*)/;
    gerror("no such state $1");
    client_exit();
  }
  elsif($state == $CODE_INVALID_RESPONSIBLE)
  {
    $text =~ / (.*)/;
    gerror("no such responsible named $1");
    client_exit();
  }
  elsif($state == $CODE_INVALID_DATE)
  {
    $text =~ / (.*)/;
    gerror("cannot parse the date: $1.");
    client_exit();
  }
  elsif($state == $CODE_UNREADABLE_PR)
  {
    $text =~ / (.*)/;
    gerror("couldn't read $1");
    client_exit();
  }
  elsif($state == $CODE_PR_NOT_LOCKED)
  {
    gerror("PR is not locked");
    client_exit();
  }
  elsif($state == $CODE_LOCKED_PR ||
        $state == $CODE_FILE_ERROR ||
	$state == $CODE_ERROR)
  {
    $text =~ s/\r//g;
    gerror($text);
    client_exit();
  }
  elsif($state == $CODE_GNATS_LOCKED)
  {
    gerror("lock file exists");
    client_exit();
  }
  elsif($state == $CODE_NO_PRS)
  {
    gerror("no PRs matched");
    client_exit();
  }
  elsif($state == $CODE_NO_KERBEROS)
  {
    gerror("no Kerberos support, authentication failed");
    client_exit();
  }
  elsif($state == $CODE_NO_ACCESS)
  {
    gerror("access denied");
    client_exit();
  }
  else
  {
    gerror("cannot understand $state '$text'");
  }
  return @rettext;
}

sub client_init
{
  my($iaddr, $paddr, $proto, $line, $length);

  $iaddr = inet_aton($site_gnats_host);
  $paddr = sockaddr_in($site_gnats_port, $iaddr);

  $proto = getprotobyname('tcp');
  if(!socket(SOCK, PF_INET, SOCK_STREAM, $proto))
  {
    gerror("socket: $!");
    exit();
  }
  if(!connect(SOCK, $paddr))
  {
    gerror("connect: $!");
    exit();
  }
  SOCK->autoflush(1);
  return get_reply();
}

# to debug:
#     local($client_cmd_debug) = 1;
#     client_cmd(args...);
sub client_cmd
{
  my($cmd) = @_;
  print SOCK "$cmd\n";
  print "<tt>client_cmd: $cmd</tt><br>\n" if defined($client_cmd_debug);
  return get_reply();
}

sub sendpr
{
  page_start_html('Create PR');
  page_heading('Create Problem Report', 1);

  # remove "all" from arrays
  shift(@category);
  shift(@severity);
  shift(@priority);
  shift(@class);
  shift(@confidential);
  $q->delete('Submitter-Id');
  my $default_email = $email || $user;
  print $q->start_form(),
	"<table>",
	"<tr><td><b>E-Mail Address:</b><td>",
	$q->textfield(-name=>'email',
	              -default=>$default_email,
		      -size=>$textwidth),
	"<tr><td><b>CC:</b><td>",
	$q->textfield(-name=>'cc',
	              -default=>$cc,
		      -size=>$textwidth);
  foreach (@fieldnames)
  {
    next if ($fieldnames{$_} & $SENDEXCLUDE);
    my $lc_fieldname = lc $_;

    # Get default value from site_callback if provided, otherwise take
    # our defaults.
    my $default;
    $default = 'serious' if /Severity/;
    $default = 'medium'  if /Priority/;
    $default = cb("sendpr_$lc_fieldname") || $default;

    if ($fieldnames{$_} & $ENUM)
    {
      print "<tr><td><b>$_:</b><td>",
            $q->popup_menu(-name=>$_,
                           -values=>\@$lc_fieldname,
                           -default=>$default);
    }
    elsif ($fieldnames{$_} & $MULTILINE)
    {
      print "<tr><td valign=top><b>$_:</b><td>",
            $q->textarea(-name=>$_,
                         -cols=>$textwidth,
                         -rows=>4,
                         -default=>$default);
    }
    else
    {
      print "<tr><td><b>$_:</b><td>",
            $q->textfield(-name=>$_,
                          -size=>$textwidth,
                          -default=>$default);
    }
  }
  print "</table>",
	$q->submit('cmd', 'submit'),
	" or ",
	$q->reset(-name=>'reset'),
	$q->end_form(),
	$q->end_html();
}

sub submitnewpr
{
  page_start_html('Create PR Results');

  my(@values, $key);
  my(%fields);

  foreach $key ($q->param)
  {
    my $val = $q->param($key);
    if($fieldnames{$key} && ($fieldnames{$key} & $MULTILINE))
    {
      $val = fix_multiline_val($val);
    }
    $fields{$key} = $val;
  }
  if($fields{'email'} eq "")
  {
    page_heading('Error');
    print "<h3>Your problem report has not been sent.</h3>\n";
    print "You must fill in the E-Mail Address field.\n";
    return;
  }
  $fields{'Originator'} = $fields{'email'};
  $text = unparsepr("send", %fields);
  if(!open(MAIL, "|$site_mailer"))
  {
    page_heading('Error');
    print "<h3>Error invoking $site_mailer</h3>";
    return;
  }
  #my $to = 'kenstir@senteinc.com';
  my $to = $GNATS_ADDR;
  $text = <<EOT . $text;
To: $to
CC: $fields{'cc'}
Subject: $fields{'Synopsis'}
From: $fields{'email'}
Reply-To: $fields{'email'}
X-gnatsweb-version: $REVISION

EOT

  print MAIL $text;
  #print "<h3>Report that was sent:</h3><br>";
  #print $q->pre(CGI::escapeHTML($text));
  if(!close(MAIL))
  {
    page_heading('Error');
    print "<h3>Bad pipe to $site_mailer</h3>";
    exit;
  }
  page_heading('Problem Report Sent');
  print "Thank you for your report.  It will take a short while for
your report to be processed.  When it is, you will receive
an automated message about it, containing the Problem Report
number, and the developer who has been assigned to
investigate the problem.";
}

sub view
{
  page_start_html('View PR');

  my($viewaudit, $tmp) = @_;

  # $pr must be 'local' to be available to site callback
  local($pr) = $q->param('pr');
  if(!$pr)
  {
    page_heading('Error');
    print "<h3>You must specify a problem report number</h3>";
    return;
  }
  page_heading("View Problem Report: $pr", 1);

  # %fields must be 'local' to be available to site callback
  local(%fields) = readpr($pr);

  print $q->start_form(),
	$q->hidden('pr', $pr),
        $q->submit('cmd', 'edit');
  #if(!$viewaudit)
  #{
  #  print $q->submit('cmd', 'view audit');
  #}
  print $q->hr(),
        "<table>";
  foreach (@fieldnames)
  {
    my $val = CGI::escapeHTML($fields{$_});
    my $valign = '';
    if ($fieldnames{$_} & $MULTILINE)
    {
      $valign = 'valign=top';
      $val =~ s/$/<br>/gm;
      $val =~ s/<br>$//; # previous substitution added one too many <br>'s
    }
    print "<tr><td nowrap $valign><b>$_:</b><td>",
          $q->tt($val), "\n";
  }
  print "</table>",
        $q->hr(),
        $q->submit('cmd', 'edit');
  #if(!$viewaudit)
  #{
  #  print $q->submit('cmd', 'view audit');
  #}
  print $q->end_form();

  # Allow site callback to print a postlude.
  my $html = cb('view_postlude');
  print $html if $html;

  #if($viewaudit)
  #{
  #  print "<h3>Audit Trail:</h3><br>\n",
  #        $q->pre(CGI::escapeHTML($fields{'Audit-Trail'}));
  #}

  print $q->end_html();
}

sub edit
{
  page_start_html('Edit PR');

  my $debug = 0;

  my($pr) = $q->param('pr');
  if(!$pr)
  {
    page_heading('Error');
    print "<h3>You must specify a problem report number</h3>";
    return;
  }
  page_heading("Edit Problem Report: $pr", 1);

  my(%fields) = readpr($pr);
#  if ($debug)
#  {
#    print "<h3>debugging</h3><font size=1><pre>";
#    foreach my $f (sort keys %fields)
#    {
#      printf "%-16s %s\n", $f, CGI::escapeHTML($fields{$f});
#    }
#    print "</pre></font><hr>\n";
#  }

  # remove "all" from arrays
  shift(@category);
  shift(@severity);
  shift(@priority);
  shift(@class);
  shift(@confidential);

  print $q->start_form(),
        $q->submit('cmd', 'submit edit'),
        " or ",
        $q->reset(-name=>'reset'),
	$q->hidden(-name=>'Editor', -value=>$user, -override=>1),
	$q->hidden(-name=>'Last-Modified',
		   -value=>$fields{'Last-Modified'},
		   -override=>1),
	$q->hidden(-name=>'pr', -value=>$pr, -override=>1),
        "<hr>\n";

  print "<table>";
  foreach (@fieldnames)
  {
    next if ($fieldnames{$_} & $EDITEXCLUDE);
    my $lc_fieldname = lc $_;

    if ($fieldnames{$_} & $ENUM)
    {
      print "<tr><td><b>$_:</b><td>",
            $q->popup_menu(-name=>$_,
                           -values=>\@$lc_fieldname,
                           -default=>$fields{$_});
    }
    elsif ($fieldnames{$_} & $MULTILINE)
    {
      print "<tr><td valign=top><b>$_:</b><td>",
            $q->textarea(-name=>$_,
                         -cols=>$textwidth,
                         -rows=>4,
                         -default=>$fields{$_});
    }
    else
    {
      print "<tr><td><b>$_:</b><td>",
            $q->textfield(-name=>$_,
                          -size=>$textwidth,
                          -default=>$fields{$_});
    }
    if ($fieldnames{$_} & $REASONCHANGE)
    {
      print "<tr><td valign=top><b>Reason Changed:</b><td>",
            $q->textarea(-name=>"$_-Why",
			 -default=>'',
			 -override=>1,
			 -cols=>$textwidth,
			 -rows=>2);
    }
    print "\n";
  }
  print	"</table>",
	$q->submit('cmd', 'submit edit'),
	" or ",
	$q->reset(-name=>'reset'),
	$q->end_form(),
	$q->hr(),
	"<h3>Audit-Trail:</h3>\n",
	$q->pre(CGI::escapeHTML($fields{'Audit-Trail'})),
	$q->end_html();
}

sub submitedit
{
  page_start_html('Edit PR Results');

  my $debug = 0;

  my($pr) = $q->param('pr');
  if(!$pr)
  {
    page_heading('Error');
    print "<h3>ERROR: You must specify a problem report number</h3>";
    return;
  }

  my(%fields, %mailto, $adr);
  my $audittrail = '';
  my $err = '';
  my $ok = 1;

  my(%oldfields) = lockpr($pr, $user);
  LOCKED:
  {
    # Merge %oldfields and CGI params to get %fields.  Not all gnats
    # fields are present in the CGI params, so the ones which are not
    # specified default to their old values.
    %fields = %oldfields;
    foreach my $key ($q->param)
    {
      my $val = $q->param($key);
      if($key =~ /-Why/
         || ($fieldnames{$key} && ($fieldnames{$key} & $MULTILINE)))
      {
	$val = fix_multiline_val($val);
      }
      $fields{$key} = $val;
    }

#    if ($debug)
#    {
#      print "<h3>debugging</h3><font size=1><pre>";
#      foreach my $f (sort keys %fields)
#      {
#	printf "%-16s %s\n", $f, CGI::escapeHTML($fields{$f});
#      }
#      print "</pre></font><hr>\n";
#    }

    # TODO: fix this default; it doesn't seem right
    if($user eq "")
    {
      $user = $oldfields{'From'};
    }

    if($fields{'Last-Modified'} ne $oldfields{'Last-Modified'})
    {
      page_heading('Error');
      print "<h3>Sorry, PR $pr has been modified since you started editing it.</h3>\n",
            "Please return to the edit form, press the Reload button, ",
            "then make your edits again.\n";
      print "<pre>Last-Modified was    '$fields{'Last-Modified'}'\n";
      print "Last-Modified is now '$oldfields{'Last-Modified'}'</pre>\n";
      last LOCKED;
    }

    if($user eq "" || $fields{'Responsible'} eq "")
    {
      page_heading('Error');
      print "<h3>Responsible party is '$fields{'Responsible'}', user is '$user'!</h3>\n";
      last LOCKED;
    }
    
    foreach (@fieldnames)
    {
      if($_ ne "Audit-Trail")
      {
        # 3/30/99 kenstir: These two commands screw up the Audit-Trail by
        # removing some newlines.  This causes the tests to fail.
        #$fields{$_} =~ s/^\s*$//g;
        #$oldfields{$_} =~ s/^\s*$//g;
	if($fields{$_} ne $oldfields{$_})
	{
          next unless ($fieldnames{$_} & $REASONCHANGE);
	  if($fieldnames{$_} & $MULTILINE)
	  {
	    $audittrail .= "$_-Changed-From:\n$oldfields{$_}";
	    $audittrail .= "$_-Changed-To:\n$fields{$_}";
	  }
          else
          {
            $audittrail .= "$_-Changed-From-To: $oldfields{$_}->$fields{$_}\n";
	  }
	  $audittrail .= "$_-Changed-By: $user\n";
	  $audittrail .= "$_-Changed-When: " . scalar(localtime()) . "\n";
	  if($fieldnames{$_} & $REASONCHANGE)
	  {
	    if($fields{"$_-Why"} =~ /^\s*$/)
	    {
              page_heading('Error') if $ok;
	      print "<h3>Field $_ must have a reason for change</h3>";
	      $ok = 0;
	    }
            else
            {
              $audittrail .= "$_-Changed-Why:\n" . $fields{"$_-Why"};
            }
	  }
	  #$audittrail .= "\n";
	}
      }
    }
    # every good let's continue
    if($ok)
    {
      my $mail_sent = 0;
      # 4/1/99 kenstir: don't send mail to the editor; they already know
      #if ($adr = praddr($user))
      #{
      #  $mailto{$adr} = 1;
      #}
      $mailto{$notify{$fields{'Category'}}} = 1 if($notify{$fields{'Category'}});
      $adr = $oldfields{'Reply-To'} || $oldfields{'From'};
      $mailto{$adr} = 1;
      if($fields{'Responsible'} ne $oldfields{'Responsible'})
      {
	if(!defined($adr = praddr($fields{'Responsible'})))
	{
          page_heading('Error');
	  print "<h3>Cannot find address for $fields{'Responsible'}.</h3>";
	  last LOCKED;
	}
	$mailto{lc($adr)} = 1;
      }
      if(!defined($adr = praddr($oldfields{'Responsible'})))
      {
        page_heading('Error');
	print "<h3>Cannot find address for $oldfields{'Responsible'}.</h3>";
	last LOCKED;
      }
      $mailto{lc($adr)} = 1;
      $fields{'Audit-Trail'} = $oldfields{'Audit-Trail'} . $audittrail;
      my($newpr) = unparsepr("", %fields);
      $newpr =~ s/\r//g;
      #print $q->pre(CGI::escapeHTML($newpr));
      #last LOCKED; # debug

      # Submit the edits.
      client_cmd("edit $fields{'Number'}");
      client_cmd("$newpr\n.");

      # Now send mail to all concerned parties,
      # but only if there's something interesting to say.
      my($mailto);
      delete $mailto{''};
      $mailto = join(", ", sort(keys(%mailto)));
      #print pre(CGI::escapeHTML("mailto->$mailto<-\n"));
      #last LOCKED; # debug
      if($mailto ne "" && $audittrail ne "")
      {
        if(open(MAILER, "|$site_mailer"))
	{
	  print MAILER "To: $mailto\n";
	  print MAILER "From: $user\n";
	  print MAILER "Subject: [gnatsweb] Re: $fields{'Category'}/$fields{'Number'}\n\n";
          if ($oldfields{'Synopsis'} eq $fields{'Synopsis'})
          {
            print MAILER "Synopsis: $fields{'Synopsis'}\n\n";
          }
          else
          {
            print MAILER "Old Synopsis: $oldfields{'Synopsis'}\n";
            print MAILER "New Synopsis: $fields{'Synopsis'}\n\n";
          }
          print MAILER "$audittrail\n";
          # Print URL so that HTML-enabled mail readers can jump to the PR.
          print MAILER $q->url() . "?cmd=view&pr=$fields{'Number'}\n";
          if(!close(MAILER))
	  {
            page_heading('Error');
	    print "<h3>Edit successful, but email notification failed</h3>",
                  "Bad pipe to $site_mailer";
	    last LOCKED;
	  }
          $mail_sent = 1;
	}
	else
	{
          page_heading('Error');
          print "<h3>Edit successful, but email notification failed</h3>",
                "Can't run $site_mailer";
          last LOCKED;
	}
      }
      page_heading('Edit Successful');
      print "<h3>Your changes to PR $fields{'Number'} were filed to the database.</h3>\n";
      print "The parties concerned were notified via e-mail:<br>",
            "<pre>$mailto</pre>"
            if $mail_sent;
    }
  }
  unlockpr($fields{'Number'});
}

sub query_page
{
  page_start_html('Query PR');
  page_heading('Query Problem Reports', 1);
  print_stored_queries();
  print $q->start_form(),
	"<table>",
	"<tr><td>Category:<td>",
	$q->popup_menu(-name=>'category',
		       -values=>\@category,
		       -default=>$category[0]),
	"<tr><td>Severity:<td>",
	$q->popup_menu(-name=>'severity',
	               -values=>\@severity,
		       -default=>$severity[0]),
	"<tr><td>Priority:<td>",
	$q->popup_menu(-name=>'priority',
	               -values=>\@priority,
		       -default=>$priority[0]),
	"<tr><td>Responsible:<td>",
	$q->popup_menu(-name=>'responsible',
		       -values=>\@responsible,
		       -default=>$responsible[0]),
	"<tr><td>State:<td>",
	$q->popup_menu(-name=>'state',
		       -values=>\@state,
		       -default=>$state[0]),
	"<tr><td><td>",
	$q->checkbox_group(-name=>'ignoreclosed',
	               -values=>['Ignore Closed'],
		       -defaults=>['Ignore Closed']),
	"<tr><td>Class:<td>",
	$q->popup_menu(-name=>'class',
		       -values=>\@class,
		       -default=>$class[0]),
	"<tr><td>Synopsis Search:<td>",
	$q->textfield(-name=>'synopsis',-size=>25),
	"<tr><td>Multi-line Text Search:<td>",
	$q->textfield(-name=>'multitext',-size=>25),
	"<tr><td><td>",
	$q->checkbox_group(-name=>'originatedbyme',
	               -values=>['Originated by You'],
		       -defaults=>[]),
	"<tr><td>Column Display:<td>",
	"</table>",
	"<table>";
  my $defaultsref = @columns ? \@columns : \@deffields;
  print $q->checkbox_group(-name=>'columns',
                           -values=>\@fields,
                           -defaults=>$defaultsref),
	"</table>",
        "<br><br>",
	$q->submit('cmd', 'submit query'),
        $q->end_form(),
        $q->end_html();
}

sub advanced_query_page
{
  page_start_html('Advanced Query');
  page_heading('Query Problem Reports', 1);
  print_stored_queries();
  print $q->start_form();

  my $width = 30;
  my $heading_bg = '#9fbdf9';
  my $cell_bg = '#d0d0d0';

  print $q->submit('cmd', 'submit query');
  print "<hr>";
  print "<center>";

  ### Text and multitext queries

  print "<table border=1 bgcolor=$cell_bg>",
        "<caption>Search All Text</caption>",
        "<tr bgcolor=$heading_bg>",
        "<th nowrap>Search these text fields",
        "<th nowrap>using regular expression",
        "</tr>\n";
  print "<tr><td>Single-line text fields:<td>",
        $q->textfield(-name=>'text', -size=>$width),
        "</tr>\n",
        "<tr><td>Multi-line text fields:<td>",
        $q->textfield(-name=>'multitext', -size=>$width),
        "</tr>\n",
        "</table>\n";

  ### Date queries

  print "<table border=1 bgcolor=$cell_bg>",
        "<caption>Search By Date</caption>",
        "<tr bgcolor=$heading_bg>",
        "<th nowrap>Date Search",
        "<th nowrap>Example: <tt>1999-04-01 05:00 GMT</tt>",
        "</tr>\n";
  foreach ('Arrived Before', 'Arrived After',
           'Modified Before', 'Modified After',
           'Closed Before', 'Closed After')
  {
    my $param_name = lc($_);
    $param_name =~ s/ //;
    print "<tr><td>$_:<td>",
          $q->textfield(-name=>$param_name, -size=>$width),
          "</tr>\n";
  }
  print "</table>\n";

  ### Field queries

  print "<table border=1 bgcolor=$cell_bg>",
        "<caption>Search Individual Fields</caption>",
        "<tr bgcolor=$heading_bg>",
        "<th nowrap>Search this field",
        "<th nowrap>using regular expression, or",
        "<th nowrap>using multi-selection",
        "</tr>\n";
  foreach (@fieldnames)
  {
    my $lc_fieldname = lc $_;
    next unless ($gnatsd_query{$lc_fieldname});

    print "<tr valign=top>";

    # 1st column is field name
    print "<td>$_:";

    # 2nd column is regexp search field
    print "<td>",
          $q->textfield(-name=>$lc_fieldname,
                        -size=>$width);
    if ($_ eq 'State')
    {
      print "<br>",
            $q->checkbox_group(-name=>'ignoreclosed',
                               -values=>['Ignore Closed'],
                               -defaults=>['Ignore Closed']),
    }

    # 3rd column is blank or scrolling multi-select list
    print "<td>";
    if ($fieldnames{$_} & $ENUM)
    {
      my $ary_ref = \@$lc_fieldname;
      my $size = scalar(@$ary_ref);
      $size = 4 if $size > 4;
      print $q->scrolling_list(-name=>$lc_fieldname,
                               -values=>$ary_ref,
                               -multiple=>1,
                               -size=>$size);
    }
    else
    {
      print "&nbsp;";
    }
    print "\n";
  }
  print	"</table>\n";

  ### Column selection

  my $defaultsref = @columns ? \@columns : \@deffields;
  print "<table border=1 bgcolor=$cell_bg>",
        "<caption>Select Columns to Display</caption>",
        "<tr valign=top><td>Display these columns:<td>",
        $q->scrolling_list(-name=>'columns',
                           -values=>\@fields,
                           -defaults=>$defaultsref,
                           -multiple=>1),
	"</table>\n";

  ### Wrapup

  print "</center>\n";
  print "<hr>",
	$q->submit('cmd', 'submit query'),
	$q->end_form(),
	$q->end_html();
}

sub submitquery
{
  page_start_html('Query Results');
  page_heading('Query Results', 1);
  my $debug = 0;

  my $originatedbyme = $q->param('originatedbyme');
  my $ignoreclosed   = $q->param('ignoreclosed');

  local($client_cmd_debug) = 1 if $debug;
  client_cmd("rset");
  client_cmd("orig $user") if($originatedbyme);
  client_cmd("nocl")       if($ignoreclosed);

  # Submit client_cmd for each param which specifies a query.
  my($param, $regexp, @val);
  foreach $param ($q->param())
  {
    next unless $gnatsd_query{$param};
    # Turn multiple values into regular expression.
    @val = $q->param($param);
    $regexp = join('|', @val);
    # Discard trailing '|all'.
    $regexp =~ s/\|all$//;
    # If there's still a query here, make it.
    client_cmd("$gnatsd_query{$param} $regexp")
          if($regexp && $regexp ne 'all');
  }

  my(@query_results) = client_cmd("sql2");

  display_query_results(@query_results);
}

# by_field -
#     Sort routine called by display_query_results.
#
#     Assumes $sortby is set by caller.
#
sub by_field
{
  my($val);
  if (!$sortby || $sortby eq 'PR')
  {
    $val = $a->[0] <=> $b->[0];
  }
  elsif ($sortby eq 'Category')
  {
    $val = $a->[1] cmp $b->[1];
  }
  elsif ($sortby eq 'Severity')
  {
    # sort by Severity then Priority then Class
    $val = $a->[4] <=> $b->[4]
                   ||
           $a->[5] <=> $b->[5]
                   ||
           $a->[8] <=> $b->[8]
                   ;
  }
  elsif ($sortby eq 'Priority')
  {
    # sort by Priority then Severity then Class
    $val = $a->[5] <=> $b->[5]
                   ||
           $a->[4] <=> $b->[4]
                   ||
           $a->[8] <=> $b->[8]
                   ;
  }
  elsif ($sortby eq 'Responsible')
  {
    $val = $a->[6] cmp $b->[6];
  }
  elsif ($sortby eq 'State')
  {
    $val = $a->[7] <=> $b->[7];
  }
  elsif ($sortby eq 'Class')
  {
    $val = $a->[8] <=> $b->[8];
  }
  elsif ($sortby eq 'Release')
  {
    $val = $a->[9] cmp $b->[9];
  }
  else
  {
    $val = $a->[0] <=> $b->[0];
  }
  $val;
}

# display_query_results -
#     Display the query results, and the "store query" form.
sub display_query_results
{
  my(@query_results) = @_;
  my(@fields) = $q->param('columns');
  my($field, %fields);

  #print $q->h1("Query Results:", scalar(@query_results), "matches");
  my $num_matches = scalar(@query_results);
  print $q->h2($num_matches ? $num_matches : "No", "matches found");

  # Sort @query_results according to the rules in by_field().
  # Using the "map, sort" idiom allows us to perform the expensive
  # split() only once per item, as opposed to during every comparison.
  # Note that $sortby must be 'local'...it's used in by_field().
  local($sortby) = $q->param('sortby');
  my(@sortable) = ('PR','Category','Severity','Priority','Responsible',
                   'State','Class','Release');
  my(@presplit_prs) = map { [ (split /\|/) ] } @query_results;
  my(@sorted_prs) = sort by_field @presplit_prs;

#  print '<hr><h2>query_results</h2><pre>';
#  foreach (@query_results) {
#    print "$_\n";
#  }
#  print '</pre><hr><h2>presplit_prs</h2><pre>';
#  foreach (@presplit_prs) {
#    print "$_->[0]\t", join('/', @{$_}), "\n";
#  }
#  print '</pre><hr><h2>sorted_prs</h2><pre>';
#  foreach (@sorted_prs) {
#    print "$_->[0]\t", join('/', @{$_}), "\n";
#    my($id, $cat) = @{$_};
#    print "$_->[0]\t$id\t$cat\n";
#  }
#  print '</pre><hr>';
#  exit;

  print $q->start_form(),
	$q->hidden(name=>'cmd', -value=>'view', -override=>1),
	"<table border=1>";

  # Print table header which allows sorting by some columns.
  # While printing the headers, temporarily override the 'sortby' param
  # so that self_url() works right.
  print "<tr>";
  for $field ('PR', @fields)
  {
    # @fields is in lower case, @sortable in initial cap
    $ufield = ucfirst $field;
    if (grep(/$ufield/, @sortable))
    {
      $q->param(-name=>'sortby', -value=>$ufield);
      my $href = $q->self_url();
      print "<th><a href=\"$href\">$ufield</a>";
    }
    else
    {
      print "<th>$ufield";
    }
    $fields{$field}++;
  }
  # Reset param 'sortby' to its original value, so that 'store query' works.
  $q->param(-name=>'sortby', -value=>$sortby);
  print "</tr>";

  foreach $_ (@sorted_prs)
  {
    print "<tr valign=top>";
    my($id, $cat, $syn, $conf, $sev,
       $pri, $resp, $state, $class, $sub,
       $arrival, $orig, $release, $lastmoddate, $closeddate)
          = @{$_};
    print "<td nowrap><a href=\"$sn?cmd=view&pr=$id\">$id</a>"; 
    print "<td nowrap>$cat"               if $fields{'category'};
    print "<td nowrap>" . $state[$state]  if $fields{'state'};
    print "<td nowrap>" . $class[$class]  if $fields{'class'};
    print "<td nowrap>" . $severity[$sev] if $fields{'severity'};
    print "<td nowrap>" . $priority[$pri] if $fields{'priority'};
    print "<td nowrap>$resp"              if $fields{'responsible'};
    print "<td nowrap>$sub"               if $fields{'submitter'};
    print "<td nowrap>$orig"              if $fields{'originator'};
    print "<td>$syn"                      if $fields{'synopsis'};
    print "</tr>\n";
  }
  print "</table>",
        $q->end_form();

  # Allow the user to store this query.  Need to repeat params as hidden
  # fields so they are available to the 'store query' handler.
  print $q->start_form();
  foreach ($q->param())
  {
    # Ignore certain params.
    next if /^(cmd|queryname)$/;
    print $q->hidden($_);
  }
  print "<table>",
        "<tr>",
        "<td>Remember this query as:",
        "<td>",
        $q->textfield(-name=>'queryname', -size=>25),
        "<td>";
  # Note: include hidden 'cmd' so user can simply press Enter w/o clicking.
  print $q->hidden(-name=>'cmd', -value=>'store query', -override=>1),
        $q->submit('cmd', 'store query'),
        "</table>",
        $q->end_form();
  print $q->end_html();
}

# store_query -
#     Save the current query in a cookie.
#
#     Queries are stored as individual cookies named
#     'gnatsweb-query-$queryname'.
#
sub store_query
{
  my $debug = 0;
  my $queryname = $q->param('queryname');

  # Don't save certain params.
  $q->delete('cmd');
  my $query_string = $q->query_string();

  my $new_cookie = $q->cookie(-name => "gnatsweb-query-$queryname",
                              -value => $query_string,
                              -expires => '+10y');
  print $q->header(-cookie => $new_cookie);
  page_start_html('Query Saved');
  page_heading('Query Saved');
  print "<h2>debugging</h2><pre>",
        "query_string: $query_string",
        "cookie: $new_cookie\n",
        "</pre><hr>\n"
        if $debug;
  print "<p>Your query has been saved.  It will be available ",
        "the next time you reload the Query page.",
        $q->end_html();
}

# print_stored_queries -
#     Retrieve any stored queries and print out a short form allowing
#     the submission of these queries.
#
#     Queries are stored as individual cookies named
#     'gnatsweb-query-$queryname'.
#
# side effects:
#     Sets global %stored_queries.
#
sub print_stored_queries
{
  %stored_queries = ();
  foreach my $cookie ($q->cookie())
  {
    if ($cookie =~ /gnatsweb-query-(.*)/)
    {
      $stored_queries{$1} = $q->cookie($1);
    }
  }
  if (%stored_queries)
  {
    print $q->start_form(),
          "<table cellspacing=0 cellpadding=0 border=0>",
          "<tr valign=top><td>",
          $q->submit('cmd', 'submit stored query'),
          "<td>&nbsp;<td>",
          $q->popup_menu(-name=>'queryname',
                         -values=>[ sort(keys %stored_queries) ]),
          "</tr></table>",
          $q->end_form();
  }
}

# submit_stored_query -
#     Submit the query named in the param 'queryname'.
#
#     Queries are stored as individual cookies named
#     'gnatsweb-query-$queryname'.
#
sub submit_stored_query
{
  my $debug = 0;
  my $queryname = $q->param('queryname');
  my $query_string;
  my $err = '';
  if (!$queryname)
  {
    $err = "Internal error: no 'queryname' parameter";
  }
  elsif (!($query_string = $q->cookie("gnatsweb-query-$queryname")))
  {
    $err = "No such named query: $queryname";
  }
  if ($err)
  {
    print $q->header(),
          $q->start_html('Error'),
          $q->h3($err);
  }
  else
  {
    my $query_url = $q->script_name() . '?cmd=' . $q->escape('submit query')
          . '&' . $query_string;
    if ($debug)
    {
      print $q->header(),
            $q->start_html(),
            $q->pre("debug: query_url: $query_url\n");
    }
    else
    {
      print $q->redirect($query_url);
    }
  }
}

sub help_page
{
  page_start_html('Help');
  page_heading('Help', 1);
  print p('Welcome to our problem report database. ',
          'You\'ll notice that here we call them "problem reports" ',
          'or "PR\'s", not "bugs".');
  print p('This web interface is called "gnatsweb". ',
          'The database system itself is called "gnats".',
          'You may want to peruse ',
          a({-href=>"$gnats_info_top?(gnats)"}, 'the gnats manual'),
          'to read about bug lifecycles and the like, ',
          'but then again, you may not.');
  print $q->end_html();
}

sub one_line_form
{
  my($label, @form_body) = @_;
  my $valign = 'baseline';
  print Tr({-valign=>$valign},
           td(b($label)),
           td(start_form(), @form_body, end_form()));
}

# can_edit -
#     Return true if the user has edit priviledges or better.
#
sub can_edit
{
  return ($access_level =~ /edit|admin/);
}

sub main_page
{
  page_start_html('Main');
  page_heading('Main Page', 1);
  print '<p><table>';

  one_line_form('Create Problem Report:',
                submit('cmd', 'create'));
  # Only include Edit action if user is allowed to edit PRs.
  # Note: include hidden 'cmd' so user can simply press Enter w/o clicking.
  if (can_edit())
  {
    one_line_form('Edit Problem Report:',
		  hidden(-name=>'cmd', -value=>'edit', -override=>1),
		  submit('cmd', 'edit'),
		  '#',
		  textfield(-size=>6, -name=>'pr'));
  }
  one_line_form('View Problem Report:',
                hidden(-name=>'cmd', -value=>'view', -override=>1),
                submit('cmd', 'view'),
                '#',
                textfield(-size=>6, -name=>'pr'));
  one_line_form('Query Problem Reports:',
                submit('cmd', 'query'));
  one_line_form('Advanced Query:',
                submit('cmd', 'advanced query'));
  one_line_form('Login again:',
                submit('cmd', 'login again'));
  one_line_form('Get Help:',
                submit('cmd', 'help'));
  print '</table>';
  print '<hr><small>',
        $q->escapeHTML('Gnatsweb 2.0 brought to you by ' .
                       'Matt Gerassimoff <mg@digalogsys.com> ' .
                       'and Kenneth H. Cox <kenstir@senteinc.com>.'),
        '</small>';
  print $q->end_html();
}

# cb -
#
#     Calls site_callback subroutine if defined.
#
# usage:
#     $something = cb($reason, @args) || 'default_value';
#
# arguments:
#     $reason - reason for the call.  Each reason is unique.
#     @args   - additional parameters may be provided in @args.
#
# returns:
#     undef if &site_callback is not defined,
#     else value returned by &site_callback.
#
sub cb
{
  my($reason, @args) = @_;
  my $val = undef;
  if (defined &site_callback)
  {
    $val = site_callback($reason, @args);
  }
  $val;
}

# page_start_html -
#
#     Print the HTML which starts off each page (<html><head>...</head>).  
#
#     By default, print a banner containing $site_banner_text, followed
#     by the given page $title.
#
#     The starting HTML can be overridden by &site_callback.
#
#     Supports debugging.
#
# arguments:
#     $title - title of page
#
sub page_start_html
{
  my $title = shift;
  my $debug = 0;

  # Allow site callback to override html.
  my $html = cb('page_start_html', $title);
  if ($html)
  {
    print $html;
    return;
  }

  print start_html(-title=>"$title - $site_banner_text",
                   -bgcolor=>'#ffffff');

  # Add the page banner.  This banner is a string slammed to the right
  # of a 100% width table.  The data is a link back to the main page.
  #
  # Note that the banner uses inline style, rather than a GIF; this
  # makes installation easier by eliminating the need to install GIFs
  # into a separate directory.  At least for Apache, you can't serve
  # GIFs out of your CGI directory.
  #
  # Danger!  Don't use double quotes inside $style; that will confuse
  # Netscape 4.5.  Use single quotes if needed.  Don't use multi-line
  # comments; they confuse Netscape 4.5.
  my $browser = $ENV{'HTTP_USER_AGENT'};
  my $style;
  if ($browser =~ /Mozilla.*X11/)
  {
    # Netscape Unix
    # monospace/36pt works well.
    $style = <<END_OF_STYLE;
      color:       white;
      font-family: monospace;
      /*font-family: lucidatypewriter, monospace;*/
      font-size:   36pt;
      text-decoration: none;
END_OF_STYLE
  }
  else
  {
    # monospace/28pt/bold works well in NS/Win95 (uses 'Courier New').
    $style = <<END_OF_STYLE;
      color:       white;
      font-family: 'Courier New', monospace;
      font-size:   28pt;
      font-weight: 600;
      text-decoration: none;
END_OF_STYLE
  }
  my($row, $banner);
  $row = Tr(td({-align=>'right'},
               a({-style=>$style, -href=>$sn},
                 ' ', $site_banner_text, ' ')));
  $banner = table({-bgcolor=>'#000000', -width=>'100%',
                   -border=>0, -cellpadding=>0, -cellspacing=>0},
                  $row);
  print $banner;

  # debugging
  if ($debug)
  {
    print "<h3>debugging params</h3><font size=1><pre>";
    my($param,@val);
    foreach $param (sort $q->param())
    {
      @val = $q->param($param);
      printf "%-12s %s\n", $param, $q->escapeHTML(join(' ', @val));
    }
    print "</pre></font><hr>\n";
  }
}

# page_heading -
#
#     Print the HTML which starts off a page.  Basically a fancy <h1>
#     plus user + database names.
#
sub page_heading
{
  my($heading, $display_user_info) = @_;

  # Allow site callback to override html.
  my $html = cb('page_heading', $heading);
  if ($html)
  {
    print $html;
    return;
  }

  my $leftcol = $heading ? $heading : '&nbsp;';
  my $rightcol;

  if ($user && defined($display_user_info))
  {
    $rightcol= tt("User: $user<br>Database: $database");
  }
  else
  {
    $rightcol = '&nbsp;';
  }

  print table(Tr(td({-nowrap=>1}, font({-size=>'+3'}, $leftcol)),
                 td({-width=>'100%'}, '&nbsp;'), # empty expandable filler
                 td({-nowrap=>1}, $rightcol)));
}

# fix_multiline_val -
#     Modify text of multitext field so that it contains \n separators
#     (not \r\n or \n as some platforms use), and so that it has a \n
#     at the end.
#
sub fix_multiline_val
{
  my $val = shift;
  $val =~ s/\r\n?/\n/g;
  $val .= "\n" unless $val =~ /\n$/;
  $val;
}

sub initialize
{
  @severity = ("all", "critical", "serious", "non-critical");
  @priority = ("all", "high", "medium", "low");
  @category = ("all");
  @confidential = ("all", "no", "yes");
  @fields = ("category", "state", "class", "severity", "priority",
             "responsible", "submitter", "originator", "synopsis");
  @deffields = ("category", "state", "responsible", "synopsis");

  # @fieldnames - fields appear in the standard order, defined by pr.h
  @fieldnames = (
    "Number",
    "Category",
    "Synopsis",
    "Confidential",
    "Severity",
    "Priority",
    "Responsible",
    "State",
    # "Quarter",
    # "Keywords",
    # "Date-Required",
    "Class",
    "Submitter-Id",
    "Arrival-Date",
    "Closed-Date",
    "Last-Modified",
    "Originator",
    "Release",
    "Organization",
    "Environment",
    "Description",
    "How-To-Repeat",
    "Fix",
    "Release-Note",
    "Audit-Trail",
    "Unformatted",
  );
  # %fieldnames maps the field name to a flag value composed of bits.
  # See $MULTILINE above for bit definitions.
  %fieldnames = (
    "Number"        => $SENDEXCLUDE | $EDITEXCLUDE,
    "Category"      => $ENUM,
    "Synopsis"      => 0,
    "Confidential"  => $ENUM,
    "Severity"      => $ENUM,
    "Priority"      => $ENUM,
    "Responsible"   => $ENUM | $REASONCHANGE | $SENDEXCLUDE,
    "State"         => $ENUM | $REASONCHANGE | $SENDEXCLUDE,
    #"Quarter"       => 0,
    #"Keywords"      => 0,
    #"Date-Required" => 0,
    "Class"         => $ENUM,
    "Submitter-Id"  => $SENDEXCLUDE | $EDITEXCLUDE,
    "Arrival-Date"  => $SENDEXCLUDE | $EDITEXCLUDE,
    "Closed-Date"   => $SENDEXCLUDE | $EDITEXCLUDE,
    "Last-Modified" => $SENDEXCLUDE | $EDITEXCLUDE,
    "Originator"    => $SENDEXCLUDE | $EDITEXCLUDE,
    "Release"       => 0,
    "Organization"  => $MULTILINE | $SENDEXCLUDE | $EDITEXCLUDE,
    "Environment"   => $MULTILINE,
    "Description"   => $MULTILINE,
    "How-To-Repeat" => $MULTILINE,
    "Fix"           => $MULTILINE,
    "Release-Note"  => $MULTILINE | $SENDEXCLUDE,
    "Audit-Trail"   => $MULTILINE | $SENDEXCLUDE | $EDITEXCLUDE,
    "Unformatted"   => $MULTILINE | $SENDEXCLUDE | $EDITEXCLUDE,
  );
  # gnatsd query commands: maps lc(field_name) to gnatsd command
  # (some keys are not actually field names, but form element names)
  %gnatsd_query = (
    "category"        => 'catg',
    "synopsis"        => 'synp',
    "confidential"    => 'conf',
    "severity"        => 'svty',
    "priority"        => 'prio',
    "responsible"     => 'resp',
    "state"           => 'stat',
    "class"           => 'clss',
    "submitter-id"    => 'subm',
    "originator"      => 'orig',
    "release"         => 'rlse',
    "text"            => 'text',
    "multitext"       => 'mtxt',
    "arrivedbefore"   => 'abfr',
    "arrivedafter"    => 'araf',
    "modifiedbefore"  => 'mbfr',
    "modifiedafter"   => 'maft',
    "closedbefore"    => 'cbfr',
    "closedafter"     => 'caft',
  );

  my $response;

  # Get gnatsd version from initial server connection text.
  ($response) = client_init();
  $GNATS_VERS = 999.0;
  if ($response =~ /GNATS server (.*) ready/)
  {
    $GNATS_VERS = $1;
  }

  client_cmd("chdb $database");

  # Get user permission level from user command.
  ($response) = client_cmd("user $user $password");
  $access_level = 'edit';
  if ($response =~ /User access level set to (\w*)/)
  {
    $access_level = $1;
  }

  # Get GNATS_ADDR by reading config file.  Note that its value may be
  # quoted, as the config file uses Bourne-shell syntax.  The default
  # value is 'bugs'.
  $GNATS_ADDR = 'bugs';
  foreach $_ (client_cmd("lcfg"))
  {
    if (/GNATS_ADDR\s*=\s*['"]?([^'"]*)['"]?/)
    {
      $GNATS_ADDR = $1;
    }
  }

  foreach $_ (client_cmd("lcat"))
  {
    my($cat, $desc, $resp, $notify) = split(/:/);
    push(@category, $cat);
    $notify{$cat} = $notify;
  }
  @state = ("all");
  foreach $_ (client_cmd("lsta"))
  {
    ($x, $dummy) = split(/:/);
    push(@state, $x);
  }
  @responsible = ("all");
  foreach $_ (client_cmd("lres"))
  {
    ($x, $dummy) = split(/:/);
    push(@responsible, $x);
  }
  @class = ("all");
  foreach $_ (client_cmd("lcla"))
  {
    ($x, $dummy) = split(/:/);
    push(@class, $x);
  }
}

sub parsepr
{
  my($hdrmulti) = "envelope";
  my(%fields);
  foreach (@_)
  {
    chomp($_);
    $_ .= "\n";
    if(!/^([>\w\-]+):\s*(.*)\s*$/)
    {
      if($hdrmulti ne "")
      {
        $fields{$hdrmulti} .= $_;
      }
      next;
    }
    local($hdr, $arg, $ghdr) = ($1, $2, "*not valid*");
    if($hdr =~ /^>(.*)$/)
    {
      $ghdr = $1;
    }
    if(exists($fieldnames{$ghdr}))
    {
      if($fieldnames{$ghdr} & $MULTILINE)
      {
        $hdrmulti = $ghdr;
	$fields{$ghdr} = "";
      }
      else
      {
        $hdrmulti = "";
        $fields{$ghdr} = $arg;
      }
    }
    elsif($hdrmulti ne "")
    {
      $fields{$hdrmulti} .= $_;
    }

    if($hdr eq "Reply-To" || $hdr eq "From")
    {
      # Grab a few fields out of the envelope as it flies by
      $arg = lc($arg);
      #  Delete everything inside parenthesis and outside <>'s, inclusive.
      $arg =~ s/\(.*\)//;
      $arg =~ s/.*<(.*)>.*/$1/;
      $arg =~ s/^\s+//;
      $arg =~ s/\s+$//;
      print "<h3>error: internal whitespace in Reply-to: or From: header!</h3>" if ($arg =~ /\s/);
      $fields{$hdr} = $arg;
      #print "storing, hdr = $hdr, arg = $arg\n";
    }
  }
  # 3/30/99 kenstir: For some reason Unformatted always ends up with an
  # extra newline here.
  $fields{'Unformatted'} =~ s/\n$//m;
  return %fields;
}

sub unparsepr
{
  my($send, %fields) = @_;
  my($tmp, $text);
  $text = $fields{'envelope'};
  foreach (@fieldnames)
  {
    next if($send eq "send" && $fieldnames{$_} & $SENDEXCLUDE);
    if($fieldnames{$_} & $MULTILINE)
    {
      # Lines which begin with a '.' need to be escaped by another '.'
      $tmp = $fields{$_};
      $tmp =~ s/^[.]/../gm;
      $text .= sprintf(">$_:\n%s", $tmp);
    }
    else
    {
      # Format string derived from gnats/pr.c.
      $text .= sprintf("%-16s %s\n", ">$_:", $fields{$_});
    }
  }
  return $text;
}

sub lockpr
{
  my($pr, $user) = @_;
  #print "<pre>locking $pr $user\n</pre>";
  return parsepr(client_cmd("lock $pr $user"));
}

sub unlockpr
{
  my($pr) = @_;
  #print "<pre>unlocking $pr\n</pre>";
  client_cmd("unlk $pr");
}

sub readpr
{
  my($pr) = @_;

  return parsepr(client_cmd("full $pr"));
}

sub praddr
{
  my($snick) = shift;
  my($nick, $long, $adr,  );
  foreach $_ (client_cmd("lres"))
  {
    ($nick, $long, $adr) = split(/:/);
    if($nick eq $snick)
    {
      return $adr;
    }
  }
  return undef;
}

sub login
{
  page_start_html('Login');
  page_heading('Login');

  client_init();
  my(@dbs) = client_cmd("dbla");
  print $q->start_form(),
        "<table>",
        "<tr><td>User Name:<td>",
        $q->textfield(-name=>'user',
                      -size=>15,
		      -default=>$user),
        "<tr><td>Password:<td>",
        $q->password_field(-name=>'password',
                           -value=>$password,
                           -size=>15,
                           -maxlength=>20),
	"<tr><td>Database:<td>",
	$q->popup_menu(-name=>'database',
	               -values=>\@dbs,
                       -default=>$database),
        "</table>",
        $q->submit('cmd','login'),
        $q->end_form(),
	$q->end_html();
}

#
# MAIN starts here:
#
# 3/18/99 kenstir: moved code inside gnats_main so that this code is
# callable from gnatsweb.
sub main
{
  # Load gnatsweb-site.pl if present.
  do 'gnatsweb-site.pl' if (-e 'gnatsweb-site.pl');

  $q = new CGI;
  $sn = $q->script_name;
  $cmd = $q->param('cmd') || ''; # avoid perl -w warning

  ### Cookie-related code must happen before we print the HTML header.

  # Upon a 'store query', create + save a new cookie containing the
  # query values.
  if($cmd eq 'store query')
  {
    store_query();
    exit();
  }

  # If running a stored query, redirect the user immediately to the URL.
  if($cmd eq 'submit stored query')
  {
    submit_stored_query();
    exit();
  }

  # Retrieve the gnatsweb cookie from the browser.
  %cookie = $q->cookie('gnatsweb');
  $user     = $cookie{'user'};
  $password = $cookie{'password'};
  $database = $cookie{'database'};
  $email    = $cookie{'email'};
  $cc       = $cookie{'cc'};
  @columns  = split(' ', $cookie{'columns'});

  # Upon login, store user/password/database in the gnatsweb cookie.
  if($cmd eq 'login')
  {
    $cookie{'user'}     = $user     = $q->param('user');
    $cookie{'password'} = $password = $q->param('password');
    $cookie{'database'} = $database = $q->param('database');
  }

  # Upon a new PR submission, store email addresses and select PR
  # fields in the gnatsweb cookie.  This facilitates entering bugs the
  # next time.
  if($cmd eq 'submit')
  {
    $cookie{'email'} = $email = $q->param('email');
    $cookie{'cc'}    = $cc    = $q->param('cc');
    #$cookie{'Category'}    = $Category    = $q->param('Category');
    #$cookie{'Release'}     = $Release     = $q->param('Release');
    #$cookie{'Environment'} = $Environment = $q->param('Environment');
  }

  # Upon a 'submit query', store column display list.
  if($cmd eq 'submit query')
  {
    @columns = $q->param('columns');
    $cookie{'columns'} = join(' ', @columns);
  }

  # Refresh the gnatsweb cookie, even if it hasn't been modified, so
  # that it doesn't expire.
  $new_cookie = $q->cookie(-name => 'gnatsweb', 
                           -value => \%cookie,
                           -expires => '+10y');

  # Serve the cookie.
  print $q->header(-cookie=>$new_cookie);

  ### Now determine what page the user wants to see.

  # Return to the login page only if we haven't been there
  # already, or if the user specifically requested to login again.
  if($cmd eq 'login again' || !$user || !$password || !$database)
  {
    login();
    exit();
  }

  initialize();

  if($cmd eq 'create')
  {
    sendpr();
  }
  elsif($cmd eq 'submit')
  {
    submitnewpr();
  }
  elsif($cmd eq 'view')
  {
    view(1);
  }
  elsif($cmd eq 'edit')
  {
    edit();
  }
  elsif($cmd eq 'submit edit')
  {
    submitedit();
  }
  elsif($cmd eq 'query')
  {
    query_page();
  }
  elsif($cmd eq 'advanced query')
  {
    advanced_query_page();
  }
  elsif($cmd eq 'submit query')
  {
    submitquery();
  }
  elsif($cmd eq 'store query')
  {
    store_query();
  }
  elsif($cmd eq 'help')
  {
    help_page();
  }
  else
  {
    main_page();
  }

  client_exit();
}

# To make this code callable from another source file, set $suppress_main.
$suppress_main ||= 0;
main() unless $suppress_main;

# Emacs stuff -
#
# Local Variables:
# perl-indent-level:2
# perl-continued-brace-offset:-6
# perl-continued-statement-offset:6
# End:
