package Tk::HyperText; use strict; use warnings; use base qw(Tk::Derived Tk::ROText); use Tk::PNG; use Tk::JPEG; use Data::Dumper; our $VERSION = "0.05"; Construct Tk::Widget 'HyperText'; # Base64 encodings of the default "missing/broken image" images. our $IMG_BROKEN = q~iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAABGdBTUEAAK/INwWK6QAAABl0RVh0 U29mdHdhcmUAQWRvYmUgSW1hZ2VSZWFkeXHJZTwAAAKTSURBVHjaYmxpafnPMEAgPT2dASCAWECM 6upqxoFwwJs3b/4DBBATwwADgAAacAcABNCAOwAggAbcAQABNOAOAAigAXcAQAANuAMAAmjAHQAQ QAPuAIAAItoBjIyM04D4PxKeBhVPBuIzyOJAzEesuQABxESk5S4uoqKZ/6urGf63tjL89/ZmUGJh yQSKBwGlM8/U1hr/Ly5m+C8oyJAK5DNAMFEAIIAYQJUREDAQwkAwrYON7f9/Tc3//5WV/+8WEAAJ 7i53c/v/v7T0/xsGhv8xQAwUOwPEfMSY+fr16/8AAUSKA+SB+O4hoCXAcP7/X1b2f7mu7v//RUX/ /7Ow/I8GigtCHJBMjHkwBwAEENFpAKjhIZCaXosQYOjg5GRgWLWKYfKfPwwngELvgfJAdXNJSYQA AURSLgAa3nOQgWH1ahkZBgY2NgaGW7cYnj95wvAaFDRg+xk6Sc0FAAFEkgOAiQ4UDcbGJiYMDOzs DD8+fGBgBgrYAbE4AwMwBhhcSHUAQACRWg6Ud7i4KClxcTE8uX6dYRdQ4C0Q6wPxVIh8JilZEAQA AoiUciBZSUgos9zIiIFh+XKGFqBYPhCD4p4ViJ2BOA0YOkCqgxQHAAQQseUAyFeZq8zNGRjmzmUo +vePYQ9Q4AEw0YF8fhaILwOxJxDzQkIhiFgHAAQQC5HqMssZGY0/b9/OEAvk3IEkunugRAe0nBno iDRQWvgAxI5AvAlSEK0jxmCAACKqHAAVLKCCiAGSz/9D7GcogcoZAPFMJLndQBxEbDkAEEAsRGa/ T0AqC4rR5S6AWthQTDIACKABrw0BAmjAHQAQQAPuAIAAGnAHAATQgDsAIIAG3AEAATTgDgAIIEZw q2QAAUCAAQBj+lYRrQ+vagAAAABJRU5ErkJggg==~; our $IMG_INVALID = q~iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAABGdBTUEAAK/INwWK6QAAABl0RVh0 U29mdHdhcmUAQWRvYmUgSW1hZ2VSZWFkeXHJZTwAAAGvSURBVHjaYmxpafnPMEAgPT2dASCAWECM 6upqxoFwwJs3b/4DBBATwwADgAAacAcABNCAOwAggAbcAQABNOAOAAigAXcAQAANuAMAAmjAHQAQ QAPuAIAAIssBjIyM8kA8DYj/Q/E0ch0AEEDkhkBmR4d75v//PQz//1sxBAQwZAIdEUqOQQABREEU PAfiYwzXrx9jePSIfFMAAogCB7wD4lMMu3czMHz4QL4pAAHEQqa+e/fufQdSzAxfvzIwPH0KFttD jkEAAUSuA96/f/8DSH1j+PKFgeHnTwZgWvj/nhyDAAKIiXwH/AbW5//BIQDikxsFAAFErgNO7dnz a/rcuSIMz56B+dPJdQBAAJEbBZnl5fqZLi7yDFZWmxju3GGoAmbD/cBoIDkdAAQQuSEgKCj4gcHY +Ao4Dfz7BxEjxyCAAGIhuxR4/pChuZmBYf9+Boa3b8nPhgABRK4Dpk+cyMAHigoYHxj8q8kxCCCA yHIA0LKHQCoLiikCAAE04LUhQAANuAMAAmjAHQAQQAPuAIAAGnAHAATQgDsAIIAG3AEAAcT4+vXr /wPpAIAAAwBlDWwDA3CdBwAAAABJRU5ErkJggg==~; sub Populate { my ($cw,$args) = @_; # Strip out the arguments we want before passing them to ROText. my $opts = { # -autorender => re-render the entire HTML document on update # (otherwise, only render incoming HTML) rerender => delete $args->{'-rerender'} || 1, # -linkcommand => a callback when a user clicks a link linkcommand => delete $args->{'-linkcommand'} || sub {}, # -titlecommand => a callback when a page sets its title titlecommand => delete $args->{'-titlecommand'} || sub {}, # -basehref => the "root" of the webpage basehref => delete $args->{'-basehref'} || '.', # -attributes => define default attributes for each tag attributes => { body => { bgcolor => '#FFFFFF', text => '#000000', link => '#0000FF', vlink => '#990099', alink => '#FF0000', }, font => { family => 'Times New Roman', size => 3, # HTML size; not point size. color => '', # inherit from body back => '', # inherit from body }, }, }; # Copy attributes over. if (exists $args->{'-attributes'}) { my $attr = delete $args->{'-attributes'}; foreach my $tag (keys %{$attr}) { foreach my $name (keys %{$attr->{$tag}}) { $opts->{attributes}->{$tag}->{$name} = $attr->{$tag}->{$name}; } } } # Pass the remaining arguments to our ROText parent. $args->{'-foreground'} = $opts->{attributes}->{body}->{text}; $args->{'-background'} = $opts->{attributes}->{body}->{bgcolor}; $cw->SUPER::Populate($args); # Reconfigure the ROText widget with our attributes. $cw->SUPER::configure ( -highlightthickness => 0, -font => [ -family => $opts->{attributes}->{font}->{family}, -size => $cw->_size ($opts->{attributes}->{font}->{size}), ], ); $cw->{hypertext} = { html => '', # holds HTML code rerender => $opts->{rerender}, attributes => $opts->{attributes}, linkcommand => $opts->{linkcommand}, titlecommand => $opts->{titlecommand}, basehref => $opts->{basehref}, history => {}, # a history of visited links permissions => 'allow_all', allow => {}, deny => {}, }; } sub insert { my $cw = shift; my $pos = shift; $pos = $cw->index ($pos); my $text = shift; # TODO: insert will only insert to the "end" $cw->{hypertext}->{html} .= $text; # If we're doing re-rendering, render the entire block of HTML at once. if ($cw->{hypertext}->{rerender}) { # Reset the title to blank. &{$cw->{hypertext}->{titlecommand}} ($cw,""); # Render the whole entire page. $cw->SUPER::delete ("0.0","end"); $cw->render ($cw->{hypertext}->{html}); } else { # Just render this text. $cw->render ($text); } } sub delete { my $cw = shift; # TODO: delete just deletes everything $cw->{hypertext}->{html} = ''; $cw->SUPER::delete ("0.0","end"); } sub get { my $cw = shift; # TODO: get just gets everything. return $cw->{hypertext}->{html}; } sub clear { my $cw = shift; # Delete everything. $cw->{hypertext}->{html} = ''; $cw->SUPER::delete ("0.0","end"); } sub clearHistory { my $cw = shift; # Clear the history. $cw->{hypertext}->{history} = {}; } sub namesMode { my $cw = shift; my $new = shift || ''; if (length $new) { $new = 'allow_all' unless $new =~ /^(allow_all|deny_all|allow_some|deny_some)$/i; $cw->{hypertext}->{permissions} = $new; } return $cw->{hypertext}->{permissions}; } sub namesAllow { my $cw = shift; my @new = @_; if (scalar(@new)) { foreach my $name (@new) { $name =~ s/[<>]//ig; $name = uc($name); my $name2 = "/" . $name; if (exists $cw->{hypertext}->{deny}->{$name}) { delete $cw->{hypertext}->{deny}->{$name}; } $cw->{hypertext}->{allow}->{$name} = 1; if (exists $cw->{hypertext}->{deny}->{$name2}) { delete $cw->{hypertext}->{deny}->{$name2}; } $cw->{hypertext}->{allow}->{$name2} = 1; } } my @return = sort keys %{$cw->{hypertext}->{allow}}; return (@return); } sub namesDeny { my $cw = shift; my @new = @_; if (scalar(@new)) { foreach my $name (@new) { $name =~ s/[<>]//ig; $name = uc($name); my $name2 = "/" . $name; if (exists $cw->{hypertext}->{allow}->{$name}) { delete $cw->{hypertext}->{allow}->{$name}; } $cw->{hypertext}->{deny}->{$name} = 1; if (exists $cw->{hypertext}->{allow}->{$name2}) { delete $cw->{hypertext}->{allow}->{$name2}; } $cw->{hypertext}->{deny}->{$name2} = 1; } } my @return = sort keys %{$cw->{hypertext}->{deny}}; return (@return); } sub render { my ($cw,$html) = @_; # Make the HTML tags easier to find. $html =~ s//%TK::HYPERTEXT::END::TAG%/g; # Split the tags apart. my @parts = split(/%TK::HYPERTEXT/, $html); # Make an array of default styles for this render. my %default = ( bgcolor => $cw->{hypertext}->{body}->{bgcolor} || '#FFFFFF', text => $cw->{hypertext}->{body}->{text} || '#000000', link => $cw->{hypertext}->{body}->{link} || '#0000FF', vlink => $cw->{hypertext}->{body}->{vlink} || '#990099', alink => $cw->{hypertext}->{body}->{alink} || '#FF0000', size => $cw->{hypertext}->{font}->{size} || 3, font => $cw->{hypertext}->{font}->{family} || 'Times New Roman', ); # Make an array of escape sequences. my @escape = ( '<' => '<', '>' => '>', '"' => '"', ''' => "'", ' ' => ' ', '®' => chr(0x00ae), # registered trademark '©' => chr(0x00a9), # copyright sign '&' => '&', ); # Reset the configuration of our ROText widget. $cw->SUPER::configure ( -background => $default{bgcolor}, -foreground => $default{text}, -font => [ -family => $default{font}, -size => $cw->_size ($default{size}), ], ); # Make an array of current styles for this render. my %style = ( weight => 'normal', # or 'bold' slant => 'roman', # or 'italic' underline => 0, # or 1 overstrike => 0, # or 1 family => '', size => '', foreground => '', background => '', justify => 'left', # or 'center' or 'right' offset => 0, # changes for and lmargin1 => 0, # for
s lmargin2 => 0, # and
    s rmargin => 0, # and