#!/usr/bin/perl
#
#  Demonstrate *very* bizarre scrollbar behavior
#  in Win32 Perl/Tk, version 804.027-r6.
#
#  061029 -- liverpole
#

# Strict
use strict;
use warnings;

# User-defined
my $font = "arial 10";

# Libraries
use Data::Dumper;
use HTML::TreeBuilder;
use LWP::UserAgent;
use Tk;
use Tk::Canvas;
use Tk::ROText;

# Globals
my $http_url = "";


# =============================================================
#  Main Program -- create the GUI
# =============================================================
#
my $mw   = new MainWindow(-title => "Tk Version = '$Tk::VERSION'");
my $f1   = framex($mw, "^x");
my $f2   = framex($mw, "^*{443}");
my $b0   = button($f1, ">Exit (Esc)", sub { $mw->destroy });
my $pout = rotext($f2, "^*{434}");
my $e1   = labent($f1, "<HTTP Address[,64]", \$http_url);
my $b1   = button($f1, "<Load (Return)", sub { load_url($http_url, $po
+ut) });
$e1->focus();
MainLoop;


# ============================================================
# Subroutines
# ============================================================
sub load_url {
    my ($url, $pout) = @_;
    $pout->();
    ($url || 0) or return;
    if ($url =~ s/^http://i) {
        $url =~ s,^//,,;
    }
    $url = "http://$url";
    my $ua = new LWP::UserAgent(agent => 'Mozilla/5.0');
    my $resp = $ua->get($url);
    if (!$resp->is_success) {
        $pout->("Unable to load address '$url'", "$font bold", "red");
        return;
    }

    my $content = $resp->content;
    my $tree = HTML::TreeBuilder->new_from_content($content);
    my $text = $tree->as_HTML();
    $pout->($text, $font);
}


sub button {
    my ($w, $opts, $ps) = @_;
    $opts =~ s/^([<>])//;
    my $side = ($1 eq '>')? 'right': 'left';
    my @opts = (-bg => 'green');
    push @opts, -text, $opts;
    ($ps || 0) and push @opts, -command => $ps;
    my $b = $w->Button(@opts);
    ($opts =~ s/\((.+)\)$//) and bind_button($b, $1);
    $b->pack(-side => $side);
    return $b;
}


sub rotext {
    my ($w, $opts) = @_;
    my $pfopts = get_exp_fill(\$opts);
    my @opts = (-bg => get_colors($w, \$opts));
    push @opts, -wrap => 'word';
    my $t = $w->Scrolled('ROText', @opts);
    $t->configure(-scrollbars => "osoe");
    $t->pack(@$pfopts);
    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
+);
        # Workaround for "non-appearing slider" bug
        # See Perlmonks node 581114
        $t->see("1.0"); $t->toplevel->update();
        $t->see("end"); $t->toplevel->update();
    };
    return $psub;
}


sub framex {
    my ($w, $opts) = @_;
    $opts ||= "";
    my $pfopts = get_exp_fill(\$opts);
    my @opts = (-bg => get_colors($w, \$opts));
    if ($opts =~ s/\[(\d*),?(\d*)\]//) {
        my ($width, $height) = ($1, $2);
        ($width  || 0) and push @opts, -width  => $width;
        ($height || 0) and push @opts, -height => $height;
    }
    my $f = $w->Frame(@opts);
    $f->pack(@$pfopts);
    return $f;
}


sub labent {
    my ($w, $opts, $tv) = @_;
    $opts ||= "";
    $opts =~ s/^([<>])//i;
    my $fr = framex($w, "$1n{004}");
    my @lopts = (-bg => get_colors($w, \$opts));
    my @eopts = (-textvar => $tv);
    if ($opts =~ s/\[(\d*),?(\d*)\]//) {
        my ($lwidth, $ewidth) = ($1, $2);
        ($lwidth || 0) and push @lopts, -width => $lwidth;
        ($ewidth || 0) and push @eopts, -width => $ewidth;
    }
    push @lopts, -text => $opts;
    my $lab = $fr->Label(@lopts);
    my $ent = $fr->Entry(@eopts);
    $lab->pack(-side => 'left', -expand => 1, -fill => 'y');
    $ent->pack(-side => 'left', -expand => 1, -fill => 'y');
}


sub get_colors {
    my ($w, $pstr) = @_;
    my %col = qw( b blue r red g green y yellow c cyan m magenta );
    my %int = qw( 0 00 1 3f 2 7f 3 bf 4 ff );
    ($$pstr =~ s/\{([^}]+)}//) or return $w->cget(-bg);
    my $bg = $1;
    exists($col{$bg}) and $bg = $col{$bg};
    $bg =~ s/^([0-4])([0-4])([0-4])$/'#'.$int{$1}.$int{$2}.$int{$3}/e;
    return $bg;
}


sub bind_button {
    my ($b, $str) = @_;
    my $mw = $b->toplevel();
    my $key = "";
    ($str =~ s/^\^(.+)//)      and $key  = "Control-Key-" . lc($1);
    ($str =~ s/^(f\d+)//i)     and $key  = "Key-" . uc($1);
    ($str =~ s/^a-([bci])$//i) and $key  = "Alt-Key-" . lc($1);
    ($str =~ s/^esc//i)        and $key .= "Escape";
    ($str =~ s/^return//i)     and $key .= "Return";
    ($str =~ s/^ret//i)        and $key .= "Return";
    ($str =~ s/^<cr>//i)       and $key .= "Return";
    ($str =~ s/^\[cr\]//i)     and $key .= "Return";
    ($str =~ /([a-z])$/i)      and $key .= lc($1);
    $key or return 0;
    return $mw->bind("<$key>" => sub { $b->invoke() });
}


sub get_exp_fill {
    my ($popts) = @_;
    my %sides = qw( < left > right ^ top v bottom );
    my %fills = qw( x x y y n none b both * both );
    my ($side, $exp, $fill);
    if ($$popts =~ s/^([<>^v])([xynb*])//i) {
        $side = $sides{$1};
        my $exfi = $2;
        ($exp, $fill) = (($exfi =~ /[XYNB*]/)? 1: 0, $fills{lc $exfi})
+;
    }
    my @opts = ( );
    ($side || 0) and push @opts, -side   => $side;
    ($exp  || 0) and push @opts, -expand => $exp;
    ($fill || 0) and push @opts, -fill   => $fill;
    return [ @opts ];
}
[download]