#!/usr/bin/perl -w 
#
#!/pro/bin/perl -w
# perl/Tk interface to the perlbug database
use strict;
my $VERSION = "1.02";
# my $host    = "l1";                           # CHANGE !!!
# my $perlbug = "/$host/pro/3gl/CPAN/PerlBug";  # CHANGE !!!
my $host    = "localhost";                              # CHANGE !!!
my $perlbug = "~perlbug/PerlBug";       # CHANGE !!!
# use Getopt::Long qw(:config nopermute bundling bundling_override);
use Getopt::Long;
Getopt::Long::Configure qw(nopermute bundling bundling_override);
use lib qw(/home/perlbug/Perlbug);  
use Tk;
use Tk::Balloon;
use Tk::BrowseEntry;
use Tk::NoteBook;
use Tk::ROText;
use Perlbug::Tk;
$ENV{MYSQLDB} = "perlbug";
if ($Tk::VERSION >= 800.013) {
    Tk::CmdLine->LoadResources ();
    Tk::CmdLine->SetArguments ();
    }
my $opt_m = 0;  # Match direct (don't use regex matching)
my $opt_x = 0;
GetOptions (
    "x"    => \&$opt_x,
    "m"    => \&$opt_m,
    ) or usage ();
my @sel = qw(ticketid admin
             status category severity osname
             fixed version
             subject author body
             note
             );
my %sel;        # Legal options to choose from
my %pat;        # What we've selected to see
my %subs;
my %ticket =    # SQL stuff for ticket
    map { $_ => "" } qw(ticketid status subject sourceaddr destaddr
                        severity category fixed version os osname
                        messageid follows author msgheader msgbody msgcount
                        noteid noteauthor noteheader notebody);
my @ticket;     # Current selected set
my $top;
my %head;
$pat{ticketid} = shift (@ARGV) || undef;
InitTU ();
SetList ();
MainLoop;
### ###########################################################################
sub usage
{
    print STDERR "usage: perlbug-db ...\n";
    exit 0;
    } # usage
sub to_background
{
    my $pid = fork;
    if ($pid < 0) {
        print STDERR "Unable to run in the background, cannot fork: $!\n";
        exit $?;
        }
    $pid and exit 0;
    } # to_background
sub pat_reset ($)
{
    my $mask = $_[-1];
    if (length ($mask) > 2 and exists $pat{$mask}) {
        $pat{$mask} = "";
        $pat{prv}{$mask} = "?";
        }
    else {
        $mask = qr/^$mask/;
        "t" =~ $mask and $pat{ticketid} = "", $pat{prv}{ticketid} = "?";
        "a" =~ $mask and $pat{admin}    = "", $pat{prv}{admin}    = "?";
        "s" =~ $mask and $pat{status}   = "", $pat{prv}{status}   = "?";
        "c" =~ $mask and $pat{category} = "", $pat{prv}{category} = "?";
        "y" =~ $mask and $pat{severity} = "", $pat{prv}{severity} = "?";
        "o" =~ $mask and $pat{osname}   = "", $pat{prv}{osname}   = "?";
        "f" =~ $mask and $pat{fixed}    = "", $pat{prv}{fixed}    = "?";
        "v" =~ $mask and $pat{version}  = "", $pat{prv}{version}  = "?";
        "u" =~ $mask and $pat{author}   = "", $pat{prv}{author}   = "?";
        "j" =~ $mask and $pat{subject}  = "", $pat{prv}{subject}  = "?";
        "b" =~ $mask and $pat{body}     = "", $pat{prv}{body}     = "?";
        "n" =~ $mask and $pat{note}     = "", $pat{prv}{note}     = "?";
        }
    $pat{prv}{admin} = "refresh";
    DoOneEvent ();
    } # pat_reset
sub GetData ($)
{
    my $init = shift;
    if ($init) {
        pat_reset (".");
        }
    $init and print STDERR "Getting data .";
    {   my $sth = prepex ("select type, flag from tm_flags");
        my ($type, $flag);
        $sth->bind_columns (\$type, \$flag);
        while ($sth->fetch) {
            push @{$sel{$type}}, $flag;
            }
        $sth->finish;
        }
    {   my $sth = prepex ("select userid, name from tm_users");
        my ($userid, $name);
        $sth->bind_columns (\$userid, \$name);
        while ($sth->fetch) {
            $sel{admin}{$userid} = $name;
            }
        $sth->finish;
        }
    foreach my $sel (qw(ticketid fixed version osname)) {
        my $sth = prepex ("select $sel from tm_tickets");
        my $f;
        my %f = ();
        $sth->bind_columns (\$f);
        while ($sth->fetch) {
            defined $f or next;
            $f{$f} = 1;
            }
        $sth->finish;
        @{$sel{$sel}} = sort keys %f;
        }
    $init and print STDERR "\n";
    } # GetData
# Promote for derived widget classes
sub Tk::bindDefKeys ($$)
{
    my $w = shift;
    $w->bind ("<Delete>"        => "Backspace");
    $w->bind ("<Enter>"         => [ \&SetRealList ]);
    $w->bind ("<Control-Key-w>" => [ \&pat_reset, shift ]);
    $w->bind ("<Alt-Key-r>"     => [ \&pat_reset, "."   ]);
    $w;
    } # bindDefKeys
sub InitTU
{
    select ((select (STDERR), $| = 1)[0]);
    select ((select (STDOUT), $| = 1)[0]);
    GetData (1);
    $ticket{sql_list} = prepex (
        "select ticketid, status, subject, sourceaddr, destaddr,",
        "       severity, category, fixed, version, os, osname",
        "from   tm_tickets");
    $ticket{sql_list}->bind_columns (
        \@ticket{qw(ticketid status subject sourceaddr destaddr
                    severity category fixed version os osname)});
    $ticket{sql_list}->finish;
    $ticket{sql_ticket} = prepex (
        "select ticketid, status, subject, sourceaddr, destaddr,",
        "       severity, category, fixed, version, os, osname",
        "from   tm_tickets",
        "where  ticketid = ?");
    $ticket{sql_ticket}->bind_columns (
        \@ticket{qw(ticketid status subject sourceaddr destaddr
                    severity category fixed version os osname)});
    $ticket{sql_ticket}->finish;
    $ticket{sql_msg} = prepex (
        "select messageid, follows, author, msgheader, msgbody",
        "from   tm_messages",
        "where  ticketid = ?");
    $ticket{sql_msg}->bind_columns (
        \@ticket{qw(messageid follows author msgheader msgbody)});
    $ticket{sql_msg}->finish;
    $ticket{sql_notes} = prepex (
        "select noteid, author, msgheader, msgbody",
        "from   tm_notes",
        "where  ticketid = ?");
    $ticket{sql_notes}->bind_columns (
        \@ticket{qw(noteid noteauthor noteheader notebody)});
    $ticket{sql_notes}->finish;
    to_background ();
    $top = MainWindow->new (
        -name   => "perlbug",
        -cursor => "top_left_arrow");
    $top->title ("Perl5 Bug database");
    my $ico = Tk::Toplevel->new ($top,
        -borderwidth => 0,
        -class       => 'Icon');
#   $ico->Label (    # Give it an image
#       -image  => $ico->Pixmap (-file => "/pro/local/lib/xtel.xpm"),
#       -relief => "flat",
#       -anchor => "c"
#       )->pack (-fill => "both");
    $top->iconwindow ($ico);
    $top->iconname ("perlbug");
    $subs{SelBugs} = sub { SetList (); };
    my $bln = $top->Balloon (
        -foreground => "Blue4",
        -background => "LightYellow2");
    ########################### Basic layout ##################################
    # Set up some menubar here ...
    my %f = (
        search  => $top->Frame (
                        -relief  => "flat"  )->pack (
                            -side     => "top",
                            -expand   => 0,
                            -fill     => "x"),
        list    => $top->Frame (
                        -relief  => "sunken")->pack (
                            -side     => "left",
                            -expand   => 0,
                            -fill     => "y"),
        message => $top->Frame (
                        -relief  => "sunken")->pack (
                            -side     => "left",
                            -expand   => 1,
                            -fill     => "both"),
        );
    my $NIndex = undef;
    my $NCurrent = sub {
        $NIndex || $ticket{list}->index ("current");
        };
    ########################### Main search criteria ##########################
    my $f = $f{search}->Frame (-relief => "flat")->pack (qw(-side top -expand 0 fill x));
    foreach my $sel (qw(status category severity osname version fixed)) {
        #print STDERR "Preparing browse button for $sel\n";
        my $b = $f->BrowseEntry (
            -relief             => "sunken",
            -width              => 15,
            -borderwidth        =>  1,
            -highlightthickness =>  1,
            -listwidth          => 50,
            -variable           => \$pat{$sel},
            -browsecmd          => $subs{SelBugs})->pack (
                -anchor => "w",
                -side   => "left")->bindDefKeys (substr ($sel, 0, 1));
        $bln->attach ($b, -msg => "Browse to select $sel");
        $b->insert ("end", undef);
        foreach my $s (sort @{$sel{$sel}}) {
            $b->insert ("end", $s);
            }
        }
    # -------------------------------------------------------------------------
    $f = $f{search}->Frame (-relief => "flat")->pack (qw(-side left  -expand 0 fill x));
    my $e = $f->Frame (-relief => "flat")->pack (qw(-side top expand 0 -fill x));
    foreach my $sel (qw(ticketid admin)) {
        my $b = $e->BrowseEntry (
            -relief             => "sunken",
            -width              => 15,
            -borderwidth        =>  1,
            -highlightthickness =>  1,
            -listwidth          => 50,
            -variable           => \$pat{$sel},
            -browsecmd          => $subs{SelBugs})->pack (
                -anchor => "w",
                -side   => "left")->bindDefKeys ($sel);
        $bln->attach ($b, -msg => "Browse to select $sel");
        $b->insert ("end", undef);
        my @v = $sel eq "admin" ? keys %{$sel{$sel}} : @{$sel{$sel}};
        foreach my $s (sort @v) {
            $b->insert ("end", $s);
            }
        }
    $f->Button (
        -text    => "reset",
        -command => sub { pat_reset ("."); SetRealList (); },
        )->pack (qw(-side left -expand 1 -fill both));
    $f->Button (
        -text    => "quit",
        -command => \&exit,
        )->pack (qw(-side left -expand 1 -fill both));
    # -------------------------------------------------------------------------
     
    $f = $f{search}->Frame (-relief => "flat")->pack (qw(-side right -expand 0 fill x));
    foreach my $sel (qw(subject note message)) {
        #print STDERR "Preparing selection button for $sel\n";
        my $e = $f->Frame (-relief => "flat")->pack (qw(-side top expand 0 -fill x));
        $e->Label (
            -text       => ucfirst $sel,
            -foreground => "Green4",
            -anchor     => "c",
            -width      => 8,
            -relief     => "flat")->pack (
                -side => "left");
        my $b = $e->Entry (
            -relief             => "sunken",
            -width              => 60,
            -borderwidth        =>  1,
            -highlightthickness =>  1,
            -textvariable       => \$pat{$sel})->pack (
                -anchor => "w",
                -side   => "left")->bindDefKeys ($sel);
        $bln->attach ($b, -msg => "Enter selection criterium for $sel");
        }
#   Optional stuff to remove the balloons etc. but the setup kinda needs them
#
#    $bln->attach (
#       $f->Checkbutton (
#           -borderwidth        => 1,
#           -highlightthickness => 0,
#           -variable           => \$opt_m,
#           -command            => [ \&pat_reset, "0" ])->pack (
#               -side => "left"),
#       -msg => "Klik hier om magic aan of uit te zetten in criteria");
#    my $rm_balloon;
#    $bln->attach (
#       $rm_balloon = $f->Checkbutton (
#           -borderwidth        => 1,
#           -highlightthickness => 0)->pack (
#               -side => "left"),
#       -msg => "Klik hier ballonnetjes te verwijderen");
#    $rm_balloon->configure (
#       -command => sub {
#           # Change focus to remove current balloon
#           $top->focusNext;
#           $top->update;
#           $top->after (10, sub {
#               $bln->destroy;
#               $rm_balloon->packForget;
#               });
#           });
#    $opt_b and $top->after (100, sub { $rm_balloon->invoke });
    ########################### Main message window ###########################
    $f = $f{message}->Frame (-relief => "sunken")->pack (qw(-side top -expand 0 -fill x));
    foreach my $s (qw(status category severity osname version fixed admin)) {
        my $l = $f->Label (
            -textvariable => \$ticket{$s},
            -foreground   => "Green4",
            -anchor       => "c",
            -width        => 12,
            -relief       => "ridge")->pack (
                -side => "left");
        $bln->attach ($l, -msg => "This is the $s of the ticket");
        $head{$s} = $l;
        }
    my $l = $f->Label (
        -textvariable => \$ticket{msgcount},
        -foreground   => "Red4",
        -anchor       => "e",
        -width        => 6,
        -relief       => "flat")->pack (
            -side => "left");
    $bln->attach ($l, -msg => "This is the message count of the ticket");
    $head{msgcount} = $l;
    # -------------------------------------------------------------------------
    $f = $f{message}->Frame (-relief => "sunken")->pack (qw(-side top -expand 0 -fill x));
    $l = $f->Label (
        -textvariable => \$ticket{ticketid},
        -foreground   => "Red4",
        -anchor       => "c",
        -width        => 12,
        -relief       => "flat")->pack (
            -side => "left");
    $bln->attach ($l, -msg => "This is the ID of the ticket");
    $head{ticketid} = $l;
    $l = $f->Label (
        -textvariable => \$ticket{subject},
        -foreground   => "Blue4",
        -anchor       => "w",
        -width        => 8,
        -relief       => "sunken")->pack (
            -expand => 1,
            -fill   => "x",
            -side   => "left");
    $bln->attach ($l, -msg => "This is the subject of the ticket");
    $head{subject} = $l;
    $l = $f->Label (
        -textvariable => \$ticket{author},
        -foreground   => "Blue4",
        -anchor       => "w",
        -width        => 15,
        -relief       => "sunken")->pack (
            -expand => 0,
            -fill   => "x",
            -side   => "left");
    $bln->attach ($l, -msg => "This is the author of the ticket");
    $head{author} = $l;
    # -------------------------------------------------------------------------
    my $nb = $f{message}->NoteBook ()->pack (qw(-side top -expand 1 -fill both));
    foreach my $page (0 .. 24) {
        $ticket{message}[$page] = [ $nb, $nb->add ($page,
            -label  => sprintf ("%2d", $page),
            -state  => "disabled",
            -anchor => "nw")->Scrolled ("ROText",
                -scrollbars         => "osoe",
                -wrap               => "none",
                -borderwidth        =>  1,
                -highlightthickness =>  0,
                -width              => 70,
                -height             => 25)->pack (
                    -expand => 1,
                    -fill   => "both",
                    -side   => "top") ];
        }
    $ticket{note} = $f{message}->Scrolled ("ROText",
        -scrollbars         => "osoe",
        -wrap               => "none",
        -borderwidth        =>  1,
        -highlightthickness =>  0,
        -width              => 70,
        -height             =>  5)->pack (
            -expand => 1,
            -fill   => "both",
            -side   => "top");
    ########################################## Search results #################
    $f = $f{list};
    my $lastActive = "";
    my $NMotion = sub {
        my $e = $ticket{list}->XEvent;
        my ($x, $y) = ($e->x, $e->y);
        my $newLine = $ticket{list}->index ("\@$x,$y linestart");
        if ($newLine ne $lastActive) {
            $ticket{list}->tagRemove ("active", "1.0", "end");
            $lastActive = $newLine;
            $ticket{list}->tagAdd ("active", $lastActive, "$lastActive lineend");
            my $ticketid = $ticket[int ($lastActive) - 1];
            $ticket{sql_ticket}->execute ($ticketid);
            $ticket{sql_ticket}->fetch;
            $ticket{sql_msg}->execute ($ticketid);
            foreach my $page (0 .. 24) {
                $ticket{message}[$page][0]->pageconfigure ($page, -state => "disabled");
                $ticket{message}[$page][1]->delete ("0.0", "end");
                }
            my $page = 0;
            while ($ticket{sql_msg}->fetch) {
                $ticket{message}[$page][0]->pageconfigure ($page, -state => "normal");
                $ticket{message}[$page++][1]->insert ("end", $ticket{msgbody});
                }
            $ticket{msgcount} = $page;
            while (my ($k, $w) = each %head) {
                $w->configure (-text => $ticket{$k});
                $w->update;
                }
            $ticket{note}->delete ("0.0", "end");
            $ticket{sql_notes}->execute ($ticketid);
            while ($ticket{sql_notes}->fetch) {
                $ticket{note}->insert ("end",
                    sprintf "%5d %-20.20s %s\n", @ticket{qw(noteid noteauthor notebody)});
                }
            }
        };
    my $NLock = sub {
#       #$LblLock->configure (-text => "<1> Move");
#       $LblLock->configure (-fg => "Orange4");
        $ticket{list}->tagBind ("all", "<Motion>" => sub {});
        $NIndex = $ticket{list}->index ("current");
        };
    $subs{NUnlock} = sub {
#       #$LblLock->configure (-text => "<1> Lock");
#       $LblLock->configure (-fg => "Blue4");
        $ticket{list}->tagBind ("all", "<Motion>" => $NMotion);
        $NIndex = undef;
        };
    $ticket{list} = $f->Scrolled ("ROText",
        -scrollbars         => "osoe",
        -wrap               => "none",
        -borderwidth        =>  1,
        -highlightthickness =>  0,
        -width              => 13,
        -height             => 25)->pack (
            -fill   => "both",
            -expand => 1,
            -side   => "top")->Subwidget ("scrolled");
    $ticket{list}->bindDefKeys ("-");
    $ticket{list}->tagConfigure ("active",
        -relief      => "raised",
        -borderwidth => 1);
    $ticket{list}->tagBind ("all",
        "<Motion>" => $NMotion,
#       "<Key-Up>" => $NMotion # Here I want to enable Up-Arrow and Down-Arrow
        );
#    ### Popup menu on <3> and other fun
#
#    my $Actions = $ticket{list}->Menu;
#
#    my $NToggle = sub {
#       if (defined $NIndex) { &{$subs{NUnlock}} } else { &$NLock }
#       #&$NNotes;
#       &$NMotion;
#       };
#
#    $Actions->command (-label        => "~Desk",
#                      -command      => $NDesk);
#    $Actions->separator;
#    $Actions->command (-label        => "~Notes",    -accelerator => "  <1>",
#                      -command      => $NNotes);
#    $Actions->command (-label        => "~Address",  -accelerator => "S-<1>",
#                      -command      => $NAddr);
#    $Actions->separator;
##   $Actions->command (-label        => "~Hide",
##                     -command      => sub {
##                          # Change focus to remove current balloon
##                          $top->focusNext;
##                          $top->update;
##                          $top->after (10, sub {
##                              $Actions->withdraw;
##                              })
##                          });
#
#    $ticket{list}->tagBind ("all", "<Button-1>"         => $NToggle);
#    $ticket{list}->tagBind ("all", "<Button-2>"         => $NMach);
#    # As of 800.015, <3> is bound to default popup window (thanks Nick :-((
#    $ticket{list}->bind ("Tk::ROText", "<Button-3>"     => sub {
#       $Actions->Popup (-popover   => "cursor",
#                        -popanchor => "w");
#       $Actions->break;
#       });
#    $ticket{list}->tagBind ("all", "<Shift-Button-1>"   => $NAddr);
#    $ticket{list}->tagBind ("all", "<Shift-Button-2>"   => $NModem);
#    $ticket{list}->tagBind ("all", "<Shift-Button-3>"   => $NCall);
#
#    $ticket{list}->tagBind ("all", "<Control-Button-1>" => $NMail);
#    $ticket{list}->tagBind ("all", "<Control-Button-3>" => $NAddr);
#    $ticket{list}->tagBind ("all", "<Control-Button-3>" => $NCallFTP);
#
#    $top->update;
#    my $g = $top->geometry;
#    # Fit 10 lines + scrollbar or 11 lines
#    $g =~ m/x(\d+)/ and
#       $1 < 370 and
#       $g =~ s/x$1/x370/ and
#       $top->geometry ($g);
#
#    $opt_i and $top->iconify;
    $ticket{list}->after (500, $subs{SelBugs});
    } # InitTU
sub fail ($)
{
    my $id = shift;
    my ($s, $p) = ($ticket{$id}, $pat{regex}{$id});
    defined $s or $s = "";
    defined $p or return 0;
    $opt_m and return index (uc $s, $p) < 0;
    $s !~ $p;
    } # fail
sub SetList
{
    if ($top->state eq "iconic") {
        $ticket{list}->after (5000, $subs{SelBugs});
        return;
        }
    local $" = "÷";
    "@pat{@sel}" eq "@{$pat{prv}}{@sel}" and return;
#   &{$subs{NUnlock}};
    $ticket{list}->DoWhenIdle (\&SetRealList);
    } # SetList
sub SetRealList
{
    $top->Busy;
    @{$pat{prv}}{@sel} = @pat{@sel};
    my @tickets = ();
    foreach my $sel (@sel) {
        my $p = $pat{$sel};
        if ($opt_m) {
            $pat{regex}{$sel} = uc $p;
            next;
            }
        do { # Invalid pattern (might be still incomplete)
            eval {'' =~ m/$p/};
            } while ($@ and chop $p);
        $pat{regex}{$sel} = qr/$p/i;
        }
    $ticket{sql_list}->execute;
    while ($ticket{sql_list}->fetch) {
        fail ("ticketid") and next;
        fail ("admin")    and next;
        fail ("status")   and next;
        fail ("category") and next;
        fail ("severity") and next;
        fail ("osname")   and next;
        fail ("fixed")    and next;
        fail ("version")  and next;
        fail ("subject")  and next;
        push @tickets, $ticket{ticketid};
        }
    $ticket{list}->delete ("1.0", "end");
    @ticket = reverse sort @tickets;
    foreach my $tid (@ticket) {
        my @tags = ("all");
        $ticket{list}->insert ("end", "$tid\n", \@tags);
        }
    $top->Unbusy;
    $ticket{list}->after (500, $subs{SelBugs});
    } # SetRealList