#!/usr/bin/perl -w
#
#  Perl/Tk optional vertical scrollbar bug
#
#  102410 -- liverpole
##

###############
## Libraries ##
###############
use strict;
use warnings;
use Tk;
use Tk::ROText;


##################
## Main program ##
##################
my $b_fix  = 0;
my $title  = "Fix for Perl/Tk Optional Scrollbar Bug";
my $mw     = new MainWindow(-title => $title);
my $top    = $mw->Frame->pack;
my $f1     = $top->Frame->pack;
my $f2     = $top->Frame->pack;
my $bot    = $f2->Frame->pack;
my @args   = qw( -bg white -wrap none -width 64 -scrollbars osoe );
my $rot    = $bot->Scrolled('ROText', @args)->pack;
my $c_out  = sub { $rot->insert("end", $_[0] . "\n"); $rot->see("end") };
my $c_quit = sub { exit };
my $c_fix  = sub { nudge_widget($rot) };

if ($b_fix) {
    my @b1args = (-text => 'Fix (^F)',  -bg => 'cyan', -comm => $c_fix);
    my $b1 = $f1->Button(@b1args);
    $b1->pack(-side => 'left');
    $mw->bind("<Control-f>" => sub { $b1->invoke });
}

my $b2  = $f1->Button(-text => 'Quit (^Q)', -bg => 'cyan', -comm => $c_quit);
$b2->pack(-side => 'left');
$mw->bind("<Control-q>" => sub { $b2->invoke });

$mw->after(100 => sub { show_bug($rot, $c_out) });

MainLoop;


#################
## Subroutines ##
#################
sub show_bug {
    my ($rot, $c_out) = @_;
    for (my $i = 0; $i < 64; $i++) {
        my $text = sprintf "%3d.  Text Text Text Text", $i + 1;
        $c_out->($text);
    }
}

##</code><code>##

sub simple_nudge {
    my ($w)    = @_;
    my $mw  = $w->toplevel;
    my $geo = $mw->geometry;
    ($geo =~ /^(\d+)x(\d+)[+](\d+)[+](\d+)$/) or return;
    my ($w0, $h0, $x, $y) = ($1, $2, $3, $4);

    # Grow the main window by 1 pixel, then restore its original size
    my ($w1, $h1) = ($w0 + 1, $h0 + 1);
    $mw->geometry("${w1}x${h1}+${x}+${y}"); $mw->update;
    $mw->geometry("${w0}x${h0}+${x}+${y}"); $mw->update;
}

##</code><code>##


sub nudge_widget {
    my ($w) = @_;

    my $mw  = $w->toplevel;
    my $geo = $mw->geometry;
    ($geo =~ /^(\d+)x(\d+)[+](\d+)[+](\d+)$/) or return;
    my ($w0, $h0, $x, $y) = ($1, $2, $3, $4);

    my $a_save = [ ];

    # Get current -expand and -fill values for a given widget
    my $c_info = sub {
        my $a_pack = shift;
        my ($exp, $fill);
        for (my $i = 0; $i < @$a_pack; $i += 2) {
            my ($key, $val) = ($a_pack->[$i], $a_pack->[$i+1]);
            ($key eq '-expand') and $exp  = $val;
            ($key eq '-fill')   and $fill = $val;
        }
        return [ $exp, $fill ];
    };

    # Save each widget's -expand and fill values
    for (my $this = $w; $this ne $mw; $this = $this->parent) {
        my $a_pack = $this->packInfo;
        push @$a_save, $c_info->($a_pack);
        $this->pack(-expand => 1, -fill => 'both');
    }

    # Grow the main window by 1 pixel, then restore the original size
    simple_nudge($w);

    # Restore the original -expand and fill values for each widget
    for (my $this = $w; $this ne $mw; $this = $this->parent) {
        my $a_pack = shift @$a_save;
        my ($exp, $fill) = @$a_pack;
        $this->pack(-expand => $exp, -fill => $fill);
    }
}