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.
211 lines
4.4 KiB
211 lines
4.4 KiB
package Tk::Browser; |
|
|
|
use Tk; |
|
use Tk::Font; |
|
use base 'Tk::ROText'; |
|
use Cwd qw(abs_path); |
|
|
|
use strict; |
|
use warnings; |
|
|
|
Construct Tk::Widget 'Browser'; |
|
|
|
sub insertHTML |
|
{ |
|
my ($self, $pos, $html) = @_; |
|
my @insert; |
|
|
|
$self->configure(-selectforeground => 'white', -selectbackground => 'black'); |
|
|
|
$html =~ s/<br>/\n/gi; |
|
$html =~ s/<body bgcolor=/<font back=/gi; |
|
|
|
my (@items) = grep { $_ ne "" } split /(<.*?>)/, $html; |
|
|
|
my $data = {}; |
|
my $font = {-family => 'times'}; |
|
|
|
$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); |
|
} |
|
|
|
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); |
|
} |
|
|
|
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); |
|
} |
|
|
|
sub u_end |
|
{ |
|
my ($self, $tag, $data, $font) = @_; |
|
|
|
delete $data->{tags}->{'<u>'}; |
|
} |
|
|
|
sub a_begin |
|
{ |
|
# this assumes that no one will nest anchor tags ( a silly thing to do anyway ) |
|
|
|
my ($self, $tag, $data, $font) = @_; |
|
|
|
my ($href) = ($tag =~ m/href=\"(.*?)\"/i); |
|
|
|
$data->{tags}->{$tag} = 1; |
|
$self->tagConfigure($tag, -foreground => "blue", -underline => 1, -font => $self->Font(%{$font})->Pattern); |
|
|
|
$self->tagBind($tag, '<ButtonPress-1>', [sub { |
|
my $cmd; |
|
$cmd = option("Browser") or "\"c:\\program files\\internet explorer\\iexplore.exe\"" if $^O =~ m/Win32/; |
|
$cmd = option("Browser") or "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:\Program Files\Internet Explorer\iexplore.exe' . "';" . |
|
'Win32::Process::Create($obj, "$cmd", "$cmd $_[1]", 0, 32, abs_path) or '. |
|
'die Win32::FormatMessage( Win32::GetLastError() );' |
|
or die "$@ $!"; |
|
} |
|
}, $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->{-family} = $family if $family; |
|
$font->{-size} = $realsize if $size; |
|
|
|
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); |
|
|
|
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;
|
|
|