You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
270 lines
5.6 KiB
270 lines
5.6 KiB
package Tk::Browser; |
|
|
|
use Tk; |
|
use Tk::Font; |
|
use Tk::Balloon; |
|
use base 'Tk::ROText'; |
|
use Cwd qw(abs_path); |
|
|
|
use Milkbone; |
|
|
|
use strict; |
|
use warnings; |
|
|
|
Construct Tk::Widget 'Browser'; |
|
|
|
my %fonts; |
|
$fonts{$_} = 1 for hook("tk_getmain")->fontFamilies; |
|
|
|
sub Populate |
|
{ |
|
my ($self, $args) = @_; |
|
$self->SUPER::Populate($args); |
|
} |
|
|
|
sub insertHTML |
|
{ |
|
my ($self, $pos, $html) = @_; |
|
my @insert; |
|
|
|
print $html; |
|
|
|
$self->tagConfigure('BSEL', -background => '#c0c0c0'); |
|
$self->tagRaise('sel', 'BSEL'); |
|
|
|
$html =~ s/<br>/\n/gi; |
|
$html =~ s/<body bgcolor=/<font back=/gi; |
|
|
|
my (@items) = grep { $_ ne "" } split /(<.*?>)/, $html; |
|
|
|
my $data = {}; |
|
my $font = {-family => '{adobe arial}', -size => 11}; |
|
|
|
$self->begin($font); |
|
|
|
for(@items) |
|
{ |
|
if(!/^</) |
|
{ |
|
s/&/&/gi; |
|
s/>/>/gi; |
|
s/</</gi; |
|
s/"/\"/gi; |
|
push @insert, $_, [keys %{$data->{tags}}]; |
|
} |
|
else |
|
{ |
|
my ($tagname) = /^<\/?(\w*)/; |
|
my $func = /^<\// ? lc $tagname . "_end" : |
|
lc $tagname . "_begin"; |
|
$_ =~ s/^<\///; |
|
$self->$func($_, $data, $font); |
|
} |
|
} |
|
|
|
$self->end; |
|
|
|
$self->insert($pos, @insert); |
|
} |
|
|
|
sub begin |
|
{ |
|
my ($self, $font) = @_; |
|
$self->configure(-font => $self->Font(%{$font})->Pattern); |
|
} |
|
|
|
sub end |
|
{ |
|
my ($self) = @_; |
|
} |
|
|
|
sub b_begin |
|
{ |
|
my ($self, $tag, $data, $font) = @_; |
|
$font->{-weight} = 'bold'; |
|
$data->{tags}->{'<b>'} = 1; |
|
$self->tagConfigure('<b>', -font => $self->Font(%{$font})->Pattern); |
|
$self->tagRaise(sel => '<b>'); |
|
} |
|
|
|
sub b_end |
|
{ |
|
my ($self, $tag, $data, $font) = @_; |
|
$font->{-weight} = 'normal'; |
|
|
|
delete $data->{tags}->{'<b>'}; |
|
} |
|
|
|
sub i_begin |
|
{ |
|
my ($self, $tag, $data, $font) = @_; |
|
$font->{-slant} = 'italic'; |
|
$data->{tags}->{'<i>'} = 1; |
|
$self->tagConfigure('<i>', -font => $self->Font(%{$font})->Pattern); |
|
$self->tagRaise(sel => '<i>'); |
|
} |
|
|
|
sub i_end |
|
{ |
|
my ($self, $tag, $data, $font) = @_; |
|
$font->{-slant} = 'roman'; |
|
|
|
delete $data->{tags}->{'<i>'}; |
|
} |
|
|
|
sub u_begin |
|
{ |
|
my ($self, $tag, $data, $font) = @_; |
|
|
|
$data->{tags}->{'<u>'} = 1; |
|
$self->tagConfigure('<u>', -underline => 1, -font => $self->Font(%{$font})->Pattern); |
|
$self->tagRaise(sel => '<u>'); |
|
} |
|
|
|
sub u_end |
|
{ |
|
my ($self, $tag, $data, $font) = @_; |
|
|
|
delete $data->{tags}->{'<u>'}; |
|
} |
|
|
|
sub balloon_handle { |
|
my ($self) = @_; |
|
my ($x, $y) = ( |
|
$self->pointerx - $self->rootx, |
|
$self->pointery - $self->rooty); |
|
my $index = $self->index("\@$x,$y"); |
|
my @tags = $self->tagNames($index); |
|
for(@tags) { |
|
print; |
|
next unless /^<a.*href="(.*?)"/i |
|
and defined($1); |
|
$self->{msg} = $1; |
|
return "$x, $y"; |
|
} |
|
return 0; |
|
} |
|
|
|
sub a_begin |
|
{ |
|
# this assumes that no one will nest anchor tags |
|
#( a silly thing to do anyway ) |
|
|
|
my ($self, $tag, $data, $font) = @_; |
|
unless(defined($self->{balloon})) |
|
{ |
|
$self->{msg} = "test"; |
|
$self->{balloon} = $self->parent->Balloon; |
|
$self->{balloon}->attach($self, |
|
-msg => \$self->{msg}, |
|
-balloonposition => 'mouse', |
|
-postcommand => [\&balloon_handle,$self], |
|
#-motioncommand => sub { print "erer"; 1; } |
|
); |
|
} |
|
|
|
my ($href) = ($tag =~ m/href=\"(.*?)\"/i); |
|
|
|
$data->{tags}->{$tag} = 1; |
|
$self->tagConfigure($tag, -foreground => "blue", -underline => 1, -font => $self->Font(%{$font})->Pattern); |
|
$self->tagRaise(sel => $tag); |
|
|
|
$self->tagBind($tag, '<ButtonPress-1>', [sub { |
|
my $cmd; |
|
$cmd = defined(option("Browser")) ? option("Browser") : "\"c:\\program files\\internet explorer\\iexplore.exe\"" if $^O =~ m/Win32/; |
|
$cmd = defined(option("Browser")) ? option("Browser") : "opera" if $^O !~ m/Win32/; |
|
if($^O !~ m/Win32/) |
|
{ |
|
exec("$cmd $_[1]") unless fork; |
|
} |
|
else |
|
{ |
|
eval 'use Win32::Process; use Win32; ' . |
|
'my ($obj, $cmd);' . |
|
'$cmd = ' . "'" . 'C:\Progra~1\Intern~1\iexplore.exe' . "';" . |
|
'Win32::Process::Create($obj, "$cmd", "$cmd $_[1]", 0, 32, abs_path) or '. |
|
'die "eerr" . Win32::FormatMessage( Win32::GetLastError() );'; |
|
warn "$@ $!" if $@; |
|
} |
|
}, $href]); |
|
|
|
$self->tagBind($tag, '<Enter>', [sub { |
|
shift->configure(-cursor => 'hand2'); |
|
}, $self]); |
|
|
|
$self->tagBind($tag, '<Leave>', [sub { |
|
shift->configure(-cursor => 'xterm'); |
|
}, $self]); |
|
|
|
push @{$data->{atags}}, $tag; |
|
} |
|
|
|
sub a_end |
|
{ |
|
my ($self, $tag, $data, $font) = @_; |
|
|
|
$font->{-underline} = 0; |
|
|
|
delete $data->{tags}->{pop @{$data->{atags}}}; |
|
} |
|
|
|
sub font_begin |
|
{ |
|
my ($self, $tag, $data, $font) = @_; |
|
|
|
my ($family) = ($tag =~ m/face=\"(.*?)\"/i); |
|
my ($color) = ($tag =~ m/color=\"(.*?)\"/i); |
|
my ($size) = ($tag =~ m/size=\"?([^> ]*)\"?/i); |
|
my ($back) = ($tag =~ m/back=\"(.*?)\"/i); |
|
|
|
$size ||= 2; |
|
|
|
my $realsize; |
|
|
|
# Begin klugey OS hacks |
|
|
|
$realsize = int((8, 10, 12, 14, 18, 24, 38) [int($size) + 1]) + 2 if $size and $^O =~ /Win32/; |
|
|
|
$realsize = int((8, 10, 12, 14, 18, 24, 38) [int($size) + 1]) if $size and $^O !~ /Win32/; |
|
|
|
$font->{-size} = $realsize if $size; |
|
if($family) { |
|
if(exists $fonts{$family}) { |
|
$font->{-family} = $family; |
|
} |
|
else { |
|
$font->{-family} = "{adobe arial}"; |
|
} |
|
} |
|
|
|
$back = "" if defined($back) and $back eq "white" or |
|
$back =~ /ffffff/i; |
|
|
|
my %opts; |
|
$opts{-foreground} = $color if $color; |
|
$opts{-background} = $back if $back; |
|
|
|
$data->{tags}->{$tag} = 1; |
|
$self->tagConfigure($tag, %opts, -font => $self->Font(%{$font})->Pattern); |
|
$self->tagRaise(sel => $tag); |
|
|
|
push @{$data->{fonttags}}, $tag; |
|
} |
|
|
|
sub font_end |
|
{ |
|
my ($self, $tag, $data, $font) = @_; |
|
|
|
delete $data->{tags}->{pop @{$data->{fonttags}}}; |
|
} |
|
|
|
sub body_end |
|
{ |
|
my ($self, $tag, $data, $font) = @_; |
|
} |
|
|
|
sub AUTOLOAD |
|
{ |
|
} |
|
|
|
1;
|
|
|