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
Unified 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;
our $VERSION = "0.355"; our $VERSION = "0.355";
require Exporter; require Exporter;
our @ISA = qw( Exporter ); our @ISA = qw( Exporter );

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

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

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

@ -1,211 +1,214 @@
package Tk::Browser; package Tk::Browser;
use Tk; use Tk;
use Tk::Font; use Tk::Font;
use base 'Tk::ROText'; use base 'Tk::ROText';
use Cwd qw(abs_path); use Cwd qw(abs_path);
use strict; use Milkbone;
use warnings;
use strict;
Construct Tk::Widget 'Browser'; use warnings;
sub insertHTML Construct Tk::Widget 'Browser';
{
my ($self, $pos, $html) = @_; sub insertHTML
my @insert; {
my ($self, $pos, $html) = @_;
$self->configure(-selectforeground => 'white', -selectbackground => 'black', -background => 'white'); my @insert;
$html =~ s/<br>/\n/gi; $self->configure(-selectforeground => 'white', -selectbackground => 'black');
$html =~ s/<body bgcolor=/<font back=/gi;
$html =~ s/<br>/\n/gi;
my (@items) = grep { $_ ne "" } split /(<.*?>)/, $html; $html =~ s/<body bgcolor=/<font back=/gi;
my $data = {}; my (@items) = grep { $_ ne "" } split /(<.*?>)/, $html;
my $font = {-family => 'times'};
my $data = {};
$self->begin($font); my $font = {-family => 'times'};
for(@items) $self->begin($font);
{
if(!/^</) for(@items)
{ {
s/&amp;/&/gi; if(!/^</)
s/&gt;/>/gi; {
s/&lt;/</gi; s/&amp;/&/gi;
s/&quot;/\"/gi; s/&gt;/>/gi;
push @insert, $_, [keys %{$data->{tags}}]; s/&lt;/</gi;
} s/&quot;/\"/gi;
else push @insert, $_, [keys %{$data->{tags}}];
{ }
my ($tagname) = /^<\/?(\w*)/; else
my $func = /^<\// ? lc $tagname . "_end" : {
lc $tagname . "_begin"; my ($tagname) = /^<\/?(\w*)/;
$_ =~ s/^<\///; my $func = /^<\// ? lc $tagname . "_end" :
$self->$func($_, $data, $font); lc $tagname . "_begin";
} $_ =~ s/^<\///;
} $self->$func($_, $data, $font);
}
$self->end; }
$self->insert($pos, @insert); $self->end;
}
$self->insert($pos, @insert);
sub begin }
{
my ($self, $font) = @_; sub begin
$self->configure(-font => $self->Font(%{$font})->Pattern); {
} my ($self, $font) = @_;
$self->configure(-font => $self->Font(%{$font})->Pattern);
sub end }
{
my ($self) = @_; sub end
} {
my ($self) = @_;
sub b_begin }
{
my ($self, $tag, $data, $font) = @_; sub b_begin
$font->{-weight} = 'bold'; {
$data->{tags}->{'<b>'} = 1; my ($self, $tag, $data, $font) = @_;
$self->tagConfigure('<b>', -font => $self->Font(%{$font})->Pattern); $font->{-weight} = 'bold';
} $data->{tags}->{'<b>'} = 1;
$self->tagConfigure('<b>', -font => $self->Font(%{$font})->Pattern);
sub b_end }
{
my ($self, $tag, $data, $font) = @_; sub b_end
$font->{-weight} = 'normal'; {
my ($self, $tag, $data, $font) = @_;
delete $data->{tags}->{'<b>'}; $font->{-weight} = 'normal';
}
delete $data->{tags}->{'<b>'};
sub i_begin }
{
my ($self, $tag, $data, $font) = @_; sub i_begin
$font->{-slant} = 'italic'; {
$data->{tags}->{'<i>'} = 1; my ($self, $tag, $data, $font) = @_;
$self->tagConfigure('<i>', -font => $self->Font(%{$font})->Pattern); $font->{-slant} = 'italic';
} $data->{tags}->{'<i>'} = 1;
$self->tagConfigure('<i>', -font => $self->Font(%{$font})->Pattern);
sub i_end }
{
my ($self, $tag, $data, $font) = @_; sub i_end
$font->{-slant} = 'roman'; {
my ($self, $tag, $data, $font) = @_;
delete $data->{tags}->{'<i>'}; $font->{-slant} = 'roman';
}
delete $data->{tags}->{'<i>'};
sub u_begin }
{
my ($self, $tag, $data, $font) = @_; sub u_begin
{
$data->{tags}->{'<u>'} = 1; my ($self, $tag, $data, $font) = @_;
$self->tagConfigure('<u>', -underline => 1, -font => $self->Font(%{$font})->Pattern);
} $data->{tags}->{'<u>'} = 1;
$self->tagConfigure('<u>', -underline => 1, -font => $self->Font(%{$font})->Pattern);
sub u_end }
{
my ($self, $tag, $data, $font) = @_; sub u_end
{
delete $data->{tags}->{'<u>'}; 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 ) sub a_begin
{
my ($self, $tag, $data, $font) = @_; # this assumes that no one will nest anchor tags ( a silly thing to do anyway )
my ($href) = ($tag =~ m/href=\"(.*?)\"/i); my ($self, $tag, $data, $font) = @_;
$data->{tags}->{$tag} = 1; my ($href) = ($tag =~ m/href=\"(.*?)\"/i);
$self->tagConfigure($tag, -foreground => "blue", -underline => 1, -font => $self->Font(%{$font})->Pattern);
$data->{tags}->{$tag} = 1;
$self->tagBind($tag, '<ButtonPress-1>', [sub { $self->tagConfigure($tag, -foreground => "blue", -underline => 1, -font => $self->Font(%{$font})->Pattern);
my $cmd;
$cmd = defined(option("Browser")) ? option("Browser") : "\"c:\\program files\\internet explorer\\iexplore.exe\"" if $^O =~ m/Win32/; $self->tagBind($tag, '<ButtonPress-1>', [sub {
$cmd = defined(option("Browser")) ? option("Browser") : "opera" if $^O !~ m/Win32/; my $cmd;
if($^O !~ m/Win32/) $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/;
exec("$cmd $_[1]") unless fork; if($^O !~ m/Win32/)
} {
else exec("$cmd $_[1]") unless fork;
{ }
eval 'use Win32::Process; use Win32; ' . else
'my ($obj, $cmd);' . {
'$cmd = ' . "'" . 'C:\Progra~1\Intern~1\iexplore.exe' . "';" . eval 'use Win32::Process; use Win32; ' .
'Win32::Process::Create($obj, "$cmd", "$cmd $_[1]", 0, 32, abs_path) or '. 'my ($obj, $cmd);' .
'die "eerr" . Win32::FormatMessage( Win32::GetLastError() );'; '$cmd = ' . "'" . 'C:\Progra~1\Intern~1\iexplore.exe' . "';" .
warn "$@ $!" if $@; 'Win32::Process::Create($obj, "$cmd", "$cmd $_[1]", 0, 32, abs_path) or '.
} 'die "eerr" . Win32::FormatMessage( Win32::GetLastError() );';
}, $href]); warn "$@ $!" if $@;
}
$self->tagBind($tag, '<Enter>', [sub { }, $href]);
shift->configure(-cursor => 'hand2');
}, $self]); $self->tagBind($tag, '<Enter>', [sub {
shift->configure(-cursor => 'hand2');
$self->tagBind($tag, '<Leave>', [sub { }, $self]);
shift->configure(-cursor => 'xterm');
}, $self]); $self->tagBind($tag, '<Leave>', [sub {
shift->configure(-cursor => 'xterm');
push @{$data->{atags}}, $tag; }, $self]);
}
push @{$data->{atags}}, $tag;
sub a_end }
{
my ($self, $tag, $data, $font) = @_; sub a_end
{
$font->{-underline} = 0; my ($self, $tag, $data, $font) = @_;
delete $data->{tags}->{pop @{$data->{atags}}}; $font->{-underline} = 0;
}
delete $data->{tags}->{pop @{$data->{atags}}};
sub font_begin }
{
my ($self, $tag, $data, $font) = @_; sub font_begin
{
my ($family) = ($tag =~ m/face=\"(.*?)\"/i); my ($self, $tag, $data, $font) = @_;
my ($color) = ($tag =~ m/color=\"(.*?)\"/i);
my ($size) = ($tag =~ m/size=\"?([^> ]*)\"?/i); my ($family) = ($tag =~ m/face=\"(.*?)\"/i);
my ($back) = ($tag =~ m/back=\"(.*?)\"/i); my ($color) = ($tag =~ m/color=\"(.*?)\"/i);
my ($size) = ($tag =~ m/size=\"?([^> ]*)\"?/i);
$size ||= 2; my ($back) = ($tag =~ m/back=\"(.*?)\"/i);
my $realsize; $size ||= 2;
# Begin klugey OS hacks my $realsize;
$realsize = int((8, 10, 12, 14, 18, 24, 38) [int($size) + 1]) + 2 if $size and $^O =~ /Win32/; # Begin klugey OS hacks
$realsize = int((8, 10, 12, 14, 18, 24, 38) [int($size) + 1]) if $size and $^O !~ /Win32/; $realsize = int((8, 10, 12, 14, 18, 24, 38) [int($size) + 1]) + 2 if $size and $^O =~ /Win32/;
$font->{-family} = "{$family}" if $family; $realsize = int((8, 10, 12, 14, 18, 24, 38) [int($size) + 1]) if $size and $^O !~ /Win32/;
$font->{-size} = $realsize if $size;
$font->{-family} = "{" . hook("tk_getfont", -font => $family) . "}"
my %opts; if $family;
$opts{-foreground} = $color if $color; $font->{-size} = $realsize if $size;
$opts{-background} = $back if $back;
my %opts;
$data->{tags}->{$tag} = 1; $opts{-foreground} = $color if $color;
$self->tagConfigure($tag, %opts, -font => $self->Font(%{$font})->Pattern); $opts{-background} = $back if $back;
push @{$data->{fonttags}}, $tag; $data->{tags}->{$tag} = 1;
} $self->tagConfigure($tag, %opts, -font => $self->Font(%{$font})->Pattern);
sub font_end push @{$data->{fonttags}}, $tag;
{ }
my ($self, $tag, $data, $font) = @_;
sub font_end
delete $data->{tags}->{pop @{$data->{fonttags}}}; {
} my ($self, $tag, $data, $font) = @_;
sub body_end delete $data->{tags}->{pop @{$data->{fonttags}}};
{ }
my ($self, $tag, $data, $font) = @_;
} sub body_end
{
sub AUTOLOAD my ($self, $tag, $data, $font) = @_;
{ }
}
sub AUTOLOAD
1; {
}
1;

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

@ -1,20 +1,10 @@
use Tk; use Tk;
use Tk::Text; use Tk::Browser;
$mw = MainWindow->new; $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')); MainLoop;
$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;

Write Preview
Loading…
Cancel
Save