#!/usr/bin/perl
#
#  Example of an apparent Windows Perl/Tk bug in ROText & Text.
#  061028 -- liverpole
#

# Strict
use strict;
use warnings;

# Libraries
use HTML::TreeBuilder;
use LWP::Simple;
use Tk;
use Tk::Canvas;
use Tk::ROText;

# Globals
my $workaround = 0;
my $http_url   = "";


# =============================================================
#  Main Program -- create the GUI
# =============================================================
#
my $mw   = new MainWindow(-title=>'Bug in Win32 Perl/Tk??');

my $f1   = $mw->Frame->pack(-expand => 0, -fill => 'x');
my $f2   = $mw->Frame->pack(-expand => 1, -fill => 'both');

my $b0   = $f1->Button(
              -bg      => "green", 
              -text    => "Exit  (Escape)",
              -command => sub { $mw->destroy }
           )->pack(-side => 'right');

my $pout = rotext($f2);

my $f3   = $f1->Frame->pack(-side => 'left', -fill => 'none');

my $c1   = $f3->Checkbutton(-text => "Workaround", -variable => \$workaround)
              ->pack(-side => 'left');

my $l1   = $f3->Label(-text  => "   HTTP Address")
              ->pack(-side => 'left', -expand => 0, -fill => 'y');

my $e1   = $f3->Entry(-width => 64, -textvar => \$http_url)
              ->pack(-side => 'left', -expand => 0, -fill => 'y');

my $b1   = $f1->Button(
               -bg      => "green",
               -text    => "Load  (Return)",
               -command => sub { load_url($http_url, $pout) }
           )->pack(-side => "left");

$mw->bind("<Escape>" => sub { $b0->invoke() });
$mw->bind("<Return>" => sub { $b1->invoke() });

$e1->focus();
MainLoop;


# ============================================================
#  Subroutines
# ============================================================
sub load_url {
    my ($url, $pout) = @_;
    $pout->();
    ($url || 0) or return;
    ($url =~ m|^http://i|) or $url = "http://$url";
    my $content = get($url);
    my $font = "arial 10";
    if (!defined($content)) {
        $pout->("Unable to load address '$url'", "$font bold", "red");
        return;
    }

    $pout->($content);
}


sub rotext {
    my ($w) = @_;
    my $t = $w->Scrolled('ROText', '-bg', '#ffdfff', '-scrollbars', 'osoe');
    $t->pack(qw(-side top -expand 1 -fill both));
    my $tag = 0;
    my $psub = sub {
        my ($text, $font, $color) = @_;
        ($text  || 0) or  $t->delete("1.0", "end");
        ($text  || 0) and $t->insert("end", "$text\n", ++$tag);
        ($font  || 0) and $t->tagConfigure($tag, -font       => $font);
        ($color || 0) and $t->tagConfigure($tag, -background => $color);
        if ($workaround) {
            $t->see("1.0"); $t->toplevel->update();
        }
        $t->see("end"); $t->toplevel->update();
    };
    return $psub;
}