archive
/
milkbone
1
0
Fork 0
Code Pull Requests Projects Releases Activity
Browse Source

""

master
milkbone57 22 years ago
parent
0f4720f08f
commit
7999d8b12d
4 changed files with 253 additions and 249 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 2
      Milkbone.pm
  2. 57
      plugins/Tk-GUI/Tk-GUI.pl
  3. 425
      plugins/Tk-GUI/Tk/Browser.pm
  4. 18
      plugins/Tk-GUI/test.pl

2
Milkbone.pm
Unescape View File

@ -20,6 +20,8 @@ use Benchmark; @@ -20,6 +20,8 @@ use Benchmark;
our $VERSION = "0.355";
require Exporter;
our @ISA = qw( Exporter );

57
plugins/Tk-GUI/Tk-GUI.pl
Unescape View File

@ -28,6 +28,9 @@ else @@ -28,6 +28,9 @@ else
$defaultFont = 'arial';
}
my %fonts;
map { $fonts{$_} = 1 } $mw->fontFamilies;
$mw->optionAdd("*font", "-*-$defaultFont-norma-r-*-*-*-120-*-*-*-*-*-*");
$mw->optionAdd("*borderWidth", 1);
$mw->optionAdd("*highlightThickness", 0);
@ -41,59 +44,65 @@ register_hook("tk_get_default_font", sub { $defaultFont }); @@ -41,59 +44,65 @@ register_hook("tk_get_default_font", sub { $defaultFont });
register_hook("tick", \&tick);
register_hook("tk_getmain", sub {
return $mw;
return $mw;
});
register_hook("tk_getfont". sub {
print "getfont called with" . $ARGS{-font};
return $ARGS{-font} if exists($fonts{$ARGS{-font}});
print "font doesn't exist - here's the default";
return $defaultFont;
});
register_hook("tk_bindwheel", sub {
if($^O =~ /win32/i)
{
$ARGS{-window}->bind('<MouseWheel>',
[ sub { $_[0]->yview('scroll', -($_[1] / 120), 'units') }, Tk::Ev('D')]);
[ sub { $_[0]->yview('scroll', -($_[1] / 120), 'units') }, Tk::Ev('D')]);
}
else
{
$ARGS{-window}->bind('<4>' => sub { $_[0]->yview('scroll', -1, 'units') unless $Tk::strictMotif;
});
});
$ARGS{-window}->bind('<5>' => sub { $_[0]->yview('scroll', 1, 'units') unless $Tk::strictMotif;
});
});
}
});
register_hook("after", sub {
$mw->after($ARGS{-time}, $ARGS{-code});
$mw->after($ARGS{-time}, $ARGS{-code});
});
sub tick
{
return unless $mw;
return unless $mw;
$mw->DoOneEvent(Tk::ALL_EVENTS);
$mw->DoOneEvent(Tk::ALL_EVENTS);
}
sub on_destroy
{
abort();
abort();
}
register_hook("error", sub {
my $text = $ARGS{-short};
($text) = $text =~ m/^(.*?)\n/;
my $error_box = $mw->Toplevel(-title => "Milkbone Error");
$error_box->Label(-text => $ARGS{-short}, -wraplength => 200)->pack;
$error_box->Button(-text => "OK", -command => [sub {
my ($self, $fatal) = @_;
$self->destroy;
hook("protocol_signoff") if $fatal;
$mw->destroy if $fatal && hook("protocol_signed_in");
}, $error_box, $ARGS{-fatal}])->pack->focus;
hook("tk_seticon", -wnd => $error_box);
$error_box->withdraw;
$error_box->geometry("+" . int(($mw->screenwidth() / 2) - int($error_box->width() / 2)) . "+" . int(($mw->screenheight() / 2) - int($error_box->height() / 2)) );
$error_box->deiconify;
$error_box->update;
$error_box->focus;
my $text = $ARGS{-short};
($text) = $text =~ m/^(.*?)\n/;
my $error_box = $mw->Toplevel(-title => "Milkbone Error");
$error_box->Label(-text => $ARGS{-short}, -wraplength => 200)->pack;
$error_box->Button(-text => "OK", -command => [sub {
my ($self, $fatal) = @_;
$self->destroy;
hook("protocol_signoff") if $fatal;
$mw->destroy if $fatal && hook("protocol_signed_in");
}, $error_box, $ARGS{-fatal}])->pack->focus;
hook("tk_seticon", -wnd => $error_box);
$error_box->withdraw;
$error_box->geometry("+" . int(($mw->screenwidth() / 2) - int($error_box->width() / 2)) . "+" . int(($mw->screenheight() / 2) - int($error_box->height() / 2)) );
$error_box->deiconify;
$error_box->update;
$error_box->focus;
});

425
plugins/Tk-GUI/Tk/Browser.pm
Unescape View File

@ -1,211 +1,214 @@ @@ -1,211 +1,214 @@
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', -background => 'white');
$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/&amp;/&/gi;
s/&gt;/>/gi;
s/&lt;/</gi;
s/&quot;/\"/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 = 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->{-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;
package Tk::Browser;
use Tk;
use Tk::Font;
use base 'Tk::ROText';
use Cwd qw(abs_path);
use Milkbone;
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/&amp;/&/gi;
s/&gt;/>/gi;
s/&lt;/</gi;
s/&quot;/\"/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 = 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->{-family} = "{" . hook("tk_getfont", -font => $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;

18
plugins/Tk-GUI/test.pl
Unescape View File

@ -1,20 +1,10 @@ @@ -1,20 +1,10 @@
use Tk;
use Tk::Text;
use Tk::Browser;
$mw = MainWindow->new;
$edit = $mw->TextUndo->pack;
$edit = $mw->Browser->pack;
$edit->insert('end', 't');
$edit->insertHTML('end', "<font face='garamond'>erererr");
$edit->tagConfigure('<b>', -font => $mw->Font(-family => 'times', -weight => 'bold'));
$edit->tagConfigure('elide', -elide => 1);
$tag = "<b>";
$mw->Button(-text => 'bold', -command => sub {
$edit->insert('insert', 'de', [$tag, 'elide']);
$edit->tagAdd($tag, 'insert');
})->pack;
MainLoop;
MainLoop;

Write Preview
Loading…
Cancel
Save