Tags in Tk::Text 
Author Message
 Tags in Tk::Text

Hi all,

After much struggling I finally created a script to display POD
documents nicely in a Text (actually, a 'More') widget. It is not meant
to be the same as Tk::Pod - it is meant to be used to create
documentation for a program in its own document tree, not display the
documentation for perl as a whole.

Yes, this is mostly a rip-off of Tk::Parse & Tk::Pod, and a lot of the
code is similar (although there are big changes - I made my own pod
parser from Pod::Parse rather than use Tk::Parse which complained _way_
too much).

Anyway, my big, messy, all-in-one-file script works perfectly -
formating is done correctly, indents are right, internal and external
links work (no formatting for links other than the default yet, but its
getting there :) ). So I was happy, and moved to the next step of making
it into a nicely formatted widget so I could use it properly.

Unfortunately, once it was made into proper packages, the
bold/italic/etc formating tags suddenly stopped working. Indenting is
working OK (so $text->tagAdd is working at least), and links still
format as expected, but other tags just fail to show. I can't figure out
why.

Attached are 5 files:

Messy.pl - the all-in-one script. This one works, but if you look at the
code its not the most reusable thing in the world

Example.pod - and example pod file. Includes headings, italics, bolds,
links etc. Messy.pl will display this correctly, Clean.pl will not.

(Example::)Text.pm - should be put in a subdir 'Example'. This is the
'clean' version of the widget. Doesn't work for bold/italics etc

(Example::)Parser.pm - the parser module. This is the nice version of
the 'Example::Parser' package inside Messy.pl

Clean.pl - wrapper for Example::Text and Example::Text::Parser. Like
Messy.pl, it tries to render Example.pod. Unlike Messy.pl, it won't
display Bold/Italic etc and I don't know why.

To work, Example.pod, Messy.pl and Clean.pl should be placed in their
own directory, and Text.pm and Parser.pm should be placed in a
subdirectory named 'Example'. Oh, and you'll need Tk::More and Pod::Parse.

So can anyone see what is in
Clean.pl/Example::Text.pm/Example::Text::Parser.pm that is causing the
formatting tags to be ignored? Help!!

MB (net not not)

[ Clean.pl < 1K ]
use lib ".";

use Tk;
use Example::Text;

my $mw = MainWindow->new;
my $pt = $mw->ExampleText(-path => '.',
                          -file => 'Example.pod')->pack(-fill => 'both',
                                                        -expand => 1);
$pt->load;
MainLoop;

__END__

[ Example.pod < 1K ]
=head1 Example Pod File

This is an example POD file.

=over 4

=item 1

This is a numbered list. There are 10 elements

=item 2

Second

=item 3

Third

=item 4

Fourth

=item 5

Fifth

=item 6

Sixth

=item 7

Seventh

=item 8

Eighth

=item 9

Ninth

=item 10

Tenth

=back

And some text.

=over 4

=item

This is a bulleted list

=item

Here's another bullet!

=back

And here's some more text.

=head1 Next Heading

There should be a link to the top next to that heading. It should work

=over

This bit of text is blockquoted, and should be indented over a bit

=back

=over 4

=item B<This is a bold dictionary heading>

And this is the data for that item

=item I<This is an italic dictionary heading>

And this is the data for it as well

=over 4

=item 1

And this is a nested numbered list

=item 2

See?

=back

=back

=head1 THE END!

The end.

[ Messy.pl 28K ]
# Quite a bit of this code is taken from Tk::Parse and Tk::Pod

use strict;
use Tk;
require Tk::Font;
require Tk::More;
my $p = Example::Parser->new;
my $mw = MainWindow->new;
my $txt = $mw->Scrolled('More',
                        -wrap => 'word',
                        -scrollbars => 'soe')->pack(-expand => 1,
                                                    -fill => 'both');
$txt->tagConfigure('TEXT',
                   -font => Create_Font(family => 'times'));
$txt->tagConfigure('H1',
                   -font => Create_Font(size => 280,
                                        weight => 'bold',
                                        family => 'times'));
$txt->tagConfigure('H2',
                   -font => Create_Font(size => 252,
                                        weight => 'bold',
                                        family => 'times'));
$txt->tagConfigure('H3',
                   -font => Create_Font(size => 224,
                                        weight => 'bold',
                                        family => 'times'));
$txt->tagConfigure('H4',
                   -font => Create_Font(size => 196,
                                        weight => 'bold',
                                        family => 'times'));
$txt->tagConfigure('H5',
                   -font => Create_Font(size => 168,
                                        weight => 'bold',
                                        family => 'times'));
$txt->tagConfigure('H6',
                   -font => Create_Font(size => 140,
                                        weight => 'bold',
                                        family => 'times'));
$txt->tagConfigure('VTEXT',
                   -wrap => 'none');
$txt->tagConfigure('FILE',
                   -font => Create_Font(family => 'helvetica',
                                        weight => 'medium'));
$txt->tagConfigure('NB',
                   -font => Create_Font(wrap => 'none'));
$txt->tagConfigure('BOLD',
                   -font => Create_Font(family => 'times',
                                        weight => 'bold'));
$txt->tagConfigure('ITALIC',
                   -font => Create_Font(family => 'times',
                                        weight => 'medium',
                                        slant => 'i'));
$txt->tagConfigure('CODE',
                   -font => Create_Font(family => 'courier',
                                        weight => 'medium'));
my %seq_to_tag = (B => 'BOLD',
                  I => 'ITALIC',
                  C => 'CODE',
                  F => 'FILE',
                  S => 'NB');

sub Create_Font {
  # From Tk::Pod (or Parse - can't remember)

  $args{family} = 'times' unless (exists $args{family});
  $args{weight} = 'medium' unless (exists $args{weight});
  $args{slant} = 'r' unless (exists $args{slant});
  $args{size} = 140 unless (exists $args{size});
  $args{spacing} = '*' unless (exists $args{spacing});
  $args{slant} = substr($args{slant}, 0, 1);
  my $name = "-*-$args{family}-$args{weight}-$args{slant}-*-*-*-$args{size}-*-*-$args{spacing}-*-iso8859-1";
  return $name;

Quote:
}

$p->File('Example.pod');
$p->parse;
$p->simplify;

my $indent = 0;
my $liststart = '';
my $listtype = '';

my %index = ();
my %indent_tags = ();
pod($p->Last_Results);

sub pod {

  $index{__top__} = '1.0';


    (paragraph($layer), next)        if $cmd eq 'paragraph';
    (head($arg, $layer), next)       if $cmd eq 'head';
    (list($arg, $layer), next)       if $cmd eq 'list';
    (item($layer), next)             if $cmd eq 'item';
    (verbatim($arg), next)           if $cmd eq 'verbatim';
    (blockquote($arg, $layer), next) if $cmd eq 'blockquote';
    die "Bad pod item: $cmd, $arg";
  }

Quote:
}

sub paragraph {

  while (1) {


    last if $n->[0] eq 'end' and $n->[1] eq 'paragraph';
    (text($n->[1]), next)              if $n->[0] eq 'text';
    (tag($n->[1], $layer), next)       if $n->[0] eq 'tag';

    (escape($layer), next)             if $n->[0] eq 'escape';
    (anchor($layer), next)             if $n->[0] eq 'anchor';
    die "Bad paragraph item: $n->[0], $n->[1]";
  }
  # End the paragraph
  direct_insert("\n\n");

Quote:
}

sub escape {

  my $rchar = '';
  while (1) {


    last if $n->[0] eq 'end' and $n->[1] eq 'escape';
    ($rchar .= $n->[1], next) if $n->[0] eq 'text';
    die "Bad escape item: $n->[0], $n->[1]";
  }
  $rchar =~ s/[\s\n]+//;
  my $esc = $p->escape($rchar);
  die "Bad escape sequence: $rchar" if not defined $esc;
  insert_text($esc);

Quote:
}

sub head {

  $lev = 6 if $lev > 6;

  my $headname = sub {

    my $txt = '';

      if ($n->[0] eq 'end' and $n->[1] eq 'head') {
        $txt =~ s/[\s\n]+//g;
        return $txt;
      } elsif ($n->[0] eq 'text') {
        $txt .= $n->[1];
      }
    }
    die "No end of head";
  };
  my $start = $txt->index('end - 1 char');
  my $text = lc($headname->($layer));
  $index{$text} = $start;
  setindent(-4) if $indent;
  while (1) { # Expecting text and tag


    last if $n->[0] eq 'end' and $n->[1] eq 'head';
    (text($n->[1]), next)        if $n->[0] eq 'text';
    (tag($n->[1], $layer), next) if $n->[0] eq 'tag';
    (escape($layer), next)       if $n->[0] eq 'escape';
    die "Bad head item: $n->[0]";
  }

  if ($txt->index('end - 1 char') !~ /^1\./) {
    create_link("(top)", undef, "__top__");
  }
  direct_insert("\n\n");
  setindent(4);

Quote:
}

sub tag {

  my $rt = $seq_to_tag{$tn};
  return if not defined $rt;

  while (1) { # inside tag is only tag and text


    last if $n->[0] eq 'end' and $n->[1] eq "tag$tn";
    (text($n->[1]), next)              if $n->[0] eq 'text';
    (tag($n->[1], $layer), next)       if $n->[0] eq 'tag';
    (escape($layer), next)             if $n->[0] eq 'escape';

    die "Bad tag item: $n->[0], $n->[1]";
  }

Quote:
}

sub verbatim {

  my $start = $txt->index('end - 1 char');
  direct_insert($text);
  $txt->tagAdd('VTEXT', $start, 'end - 1 char');

Quote:
}

sub blockquote {

  setindent($amt);
  while (1) {


    last if $cmd eq 'end' and $arg eq 'blockquote';
    (paragraph($layer), next)        if $cmd eq 'paragraph';
    (head($arg, $layer), next)       if $cmd eq 'head';
    (list($arg, $layer), next)       if $cmd eq 'list';
    (item($layer), next)             if $cmd eq 'item';
    (verbatim($arg), next)           if $cmd eq 'verbatim';
    (blockquote($arg, $layer), next) if $cmd eq 'blockquote';
    die "Bad blockquote item: $cmd, $arg";
  }
  setindent(-($amt));

Quote:
}

sub text {

  insert_text($text);

Quote:
}

sub anchor {

  my $text = '';
  while (1) {


    last if $cmd eq 'end' and $arg eq 'anchor';
    ($text .= $arg, next) if $cmd eq 'text';
    die "Only text allowed in anchor";
  }
  # Links stored lower case with all non-alphanums removed
  $text =~ s/[\n\s]+//g;
  $text = lc($text);
  $text =~ s/[^a-z0-9]//g;
  my $ind = $txt->index('end - 1 char');
  $index{$text} = $ind;

Quote:
}

sub linked {

  $name = $guessname if not defined $name;
  # For now, don't do internal link formating
  while (1) {


    last if $cmd eq 'end' and $arg eq 'link';
  }
  create_link($name, $pod, $section);

Quote:
}

sub list {

  (bulleted_list($layer), return)   if ($type eq 'bulleted');
  (numbered_list($layer), return)   if ($type eq 'numbered');
  (dictionary_list($layer), return) if ($type eq 'dictionary');
  die "Unknown list type: $type";

Quote:
}

sub item {

  (bulleted_item($layer), return)   if $listtype eq 'bulleted';
  (numbered_item($layer), return)   if $listtype eq 'numbered';
  (dictionary_item($layer), return) if $listtype eq 'dictionary';
  (floating_item($layer), return)   if $listtype eq '';
  die "Bad list type for item: $listtype";

Quote:
}

sub setindent {

  return if $amt == 0;
  return if $amt < 0 and $indent == 0;
  $indent += $amt;
  $indent = 0 if $indent < 0;
  my $iname = "indent$indent";
  return if defined $indent_tags{$iname};
  $indent_tags{$iname} = 1;
  $txt->tagConfigure($iname,
                     -lmargin1 => (($indent * 4) . 'p'),
                     -lmargin2 => (($indent * 4) . 'p'));

Quote:
}

sub direct_insert {

  my $start = $txt->index('end - 1 char');
  $txt->insert('end - 1 char', $text);

    $txt->tagAdd($_, $start, 'end - 1 char');
  }
  $txt->tagAdd("indent$indent", $start, 'end - 1 char') if $indent;

Quote:
}

sub insert_text {

  $text = format_text($text);
  my $start = $txt->index('end - 1 char');
  $txt->insert('end - 1 char', $text);

    $txt->tagAdd($_, $start, 'end - 1 char');
  }
  $txt->tagAdd("indent$indent", $start, 'end - 1 char') if $indent;

Quote:
}

sub format_text {

  my ($starts, $ends) = ('', '');
  # No newlines!
  $text =~ s/[\n]+/ /g;
  # Expand tabs
  $text =~ s/\t/    /g;
  return $text;

Quote:
}

sub create_link {

  my $tag = "!$pod-$section";
  $txt->tagBind($tag, '<ButtonRelease-1>',
                ['main::FollowLink', $pod, $section]);
  $txt->tagBind($tag, '<Enter>' => ['main::EnterLink']);
  $txt->tagBind($tag, '<Leave>' => ['main::LeaveLink']);
  $txt->tagConfigure($tag,
                     -underline => 1,
                     -foreground => 'blue');


  insert_text($name);

Quote:
}

sub numbered_list {

  my $olstart = $liststart;
  my $oltype = $listtype;
  # scan for the number of items
  my $icnt = 0;
  my $llev = 0;
  my $last = '';

    ($llev++, next) if $n->[0] eq 'list';
    ($icnt++, next) if $n->[0] eq 'item' and $llev == 0;
    ($llev--, next) if $n->[0] eq 'end' and $n->[1] eq 'list' and $llev;
    last if $n->[0] eq 'end' and $n->[1] eq 'list' and not $llev;
  }
  my $width = length("$icnt");
  $liststart = sprintf("%${width}d  ", 1);
  $listtype = 'numbered';
  setindent(length($liststart));
  while (1) {


    last if $cmd eq 'end' and $arg eq 'list';
    ($last = 'list', list($arg, $layer), next)     if $cmd eq 'list';
    ($last = 'blockquote',
     blockquote($arg, $layer), next)               if $cmd eq 'blockquote';
    ($last = 'paragraph', paragraph($layer), next) if $cmd eq 'paragraph';
    ($last = 'item', item($layer), next)           if $cmd eq 'item';
    die "Bad list item: $cmd, $arg";
  }
  setindent(-(length($liststart)));
  $listtype = $oltype;
  $liststart = $olstart;
  direct_insert("\n") if $last ne 'paragraph' and $last ne 'list';

Quote:
}

sub bulleted_list {

  my $olstart = $liststart;
  my $oltype = $listtype;
  $liststart = "*  ";
  $listtype = 'bulleted';
  setindent(length($liststart));
  my $last = '';
  while (1) {


    last if $cmd eq 'end' and $arg eq 'list';
    ($last = 'list', list($arg, $layer), next)     if $cmd eq 'list';
    ($last = 'blockquote',
     blockquote($arg, $layer), next)               if $cmd eq 'blockquote';
    ($last = 'paragraph', paragraph($layer), next) if $cmd eq 'paragraph';
    ($last = 'item', item($layer), next)           if $cmd eq 'item';
    die "Bad list item: $cmd, $arg";
  }
  setindent(-(length($liststart)));
  $listtype = $oltype;
  $liststart = $olstart;
  direct_insert("\n") if $last ne 'paragraph' and $last ne 'list';

Quote:
}

sub dictionary_list {

  my $olstart = $liststart;
  my $oltype = $listtype;
  $liststart = "";
  $listtype = 'dictionary';
  setindent(length($liststart));
  my $last = '';
  while (1) {


    last if $cmd eq 'end' and $arg eq 'list';
    ($last = 'list', setindent(4),
     list($arg, $layer), setindent(-4), next)       if $cmd eq 'list';
    ($last = 'blockquote', setindent(4),
     blockquote($arg, $layer), setindent(-4), next) if $cmd eq 'blockquote';
    ($last = 'paragraph', setindent(4),
     paragraph($layer), setindent(-4), next)        if $cmd eq 'paragraph';
    ($last = 'item', item($layer), next)            if $cmd eq 'item';
    die "Bad dictionary list item: $cmd, $arg";
  }
  setindent(-(length($liststart)));
  $listtype = $oltype;
  $liststart = $olstart;
  direct_insert("\n") if $last ne 'paragraph' and $last ne 'list';

Quote:
}

sub numbered_item {

  setindent(-(length($liststart)));
  direct_insert($liststart);
  setindent(length($liststart));
  # Ignore everything to the end item
  while (1) {


    last if $cmd eq 'end' and $arg eq 'item';
  }
  $liststart =~ s/^(\s*)(\d+)(\s+)$/$1$2/;
  my $i = $2;
  $i++;
  $liststart = (" " x (length($liststart) - length("$i"))) . $i . "  ";

Quote:
}

sub bulleted_item {

  setindent(-(length($liststart)));
  direct_insert($liststart);
  setindent((length($liststart)));
  # Ignore everything to the end item
  while (1) {


    last if $cmd eq 'end' and $arg eq 'item';
  }

Quote:
}

sub dictionary_item {

  while (1) {


    last if $cmd eq 'end' and $arg eq 'item';
    (text($arg), next)              if $cmd eq 'text';
    (tag($arg, $layer), next)       if $cmd eq 'tag';

    (escape($layer), next)          if $cmd eq 'escape';
    (anchor($layer), next)          if $cmd eq 'anchor';
    die "Bad dictionary paragraph item: $cmd, $arg";
  }
  direct_insert("\n");

Quote:
}

sub floating_item {

  # Treat a floating item like a labeled paragraph
  while (1) {


    last if $cmd eq 'end' and $arg eq 'item';
    (text($arg), next)              if $cmd eq 'text';
    (tag($arg, $layer), next)       if $cmd eq 'tag';

    (escape($layer), next)          if $cmd eq 'escape';
    (anchor($layer), next)          if $cmd eq 'anchor';
    die "Bad floating paragraph item: $cmd, $arg";
  }
  direct_insert("\n");

Quote:
}

sub EnterLink {
  $txt->configure(-cursor => 'hand2');

Quote:
}

sub LeaveLink {
  $txt->configure(-cursor => undef);

Quote:
}

sub FollowLink {

  LeaveLink();
  if (not defined $pod) {
    # Internal link
    $section =~ s/[\s\n]//g;
    $section = lc($section);
    $txt->yview($index{$section}) if defined $index{$section};
  } else {
    # Most of this is defunct - the example has no external links
#    my $file = $root . "/" . join("/", (split /::/, $pod)) . ".pod";
#    if (not -e $file or not -f $file or not -r $file) {
#      $p->File($notfound); -- left out
#    } else {
#      $p->File($file);
#    }
#    foreach (keys %indent_tags) {
#      $txt->tagDelete($_);
#      delete $indent_tags{$_};
#    }
#    foreach (keys %index) {
#      delete $index{$_};
#    }
#    $p->parse;
#    $p->simplify;
#    $txt->delete('1.0', 'end - 1 char');
#    $indent = '';
#    $liststart = '';
#    $listtype = '';

#    %index = ();
#    pod($p->{Last_Results});
#    if (defined $section) {
#      # Internal link
#      $section =~ s/[\s\n]//g;
#      $section = lc($section);
#      $section =~ s/[^a-z0-9]//g;
#      $txt->yview($index{$section}) if defined $index{$section};
#    }
  }

Quote:
}

MainLoop;
exit;

BEGIN {
  package Example::Parser;

  use Pod::Parser;
  use strict;


  # Outright stolen from Tk::Parse
  my %Escapes =
    ('amp'       =>    '&',      # ampersand
     'apos'      =>    "'",      # apostrophe
     'lt'        =>    '<',      # left chevron, less-than
     'gt'        =>    '>',      # right chevron, greater-than
     'quot'      =>    '"',      # double quote
     'sol'       =>    '/',      # solidus (forward slash)
     'verbar'    =>    '|',      # vertical bar

     "Aacute"    =>    "\xC1",   # capital A, acute accent
     "aacute"    =>    "\xE1",   # small a, acute accent
     "Acirc"     =>    "\xC2",   # capital A, circumflex accent
     "acirc"     =>    "\xE2",   # small a, circumflex accent
     "AElig"     =>    "\xC6",   # capital AE diphthong (ligature)
     "aelig"     =>    "\xE6",   # small ae diphthong (ligature)
     "Agrave"    =>    "\xC0",   # capital A, grave accent
     "agrave"    =>    "\xE0",   # small a, grave accent
     "Aring"     =>    "\xC5",   # capital A, ring
     "aring"     =>    "\xE5",   # small a, ring
     "Atilde"    =>    "\xC3",   # capital A, tilde
     "atilde"    =>    "\xE3",   # small a, tilde
     "Auml"      =>    "\xC4",   # capital A, dieresis or umlaut mark
     "auml"      =>    "\xE4",   # small a, dieresis or umlaut mark
     "Ccedil"    =>    "\xC7",   # capital C, cedilla
     "ccedil"    =>    "\xE7",   # small c, cedilla
     "Eacute"    =>    "\xC9",   # capital E, acute accent
     "eacute"    =>    "\xE9",   # small e, acute accent
     "Ecirc"     =>    "\xCA",   # capital E, circumflex accent
     "ecirc"     =>    "\xEA",   # small e, circumflex accent
     "Egrave"    =>    "\xC8",   # capital E, grave accent
     "egrave"    =>    "\xE8",   # small e, grave accent
     "ETH"       =>    "\xD0",   # capital Eth, Icelandic
     "eth"       =>    "\xF0",   # small eth, Icelandic
     "Euml"      =>    "\xCB",   # capital E, dieresis or umlaut mark
     "euml"      =>    "\xEB",   # small e, dieresis or umlaut mark
     "Iacute"    =>    "\xCD",   # capital I, acute accent
     "iacute"    =>    "\xED",   # small i, acute accent
     "Icirc"     =>    "\xCE",   # capital I, circumflex accent
     "icirc"     =>    "\xEE",   # small i, circumflex accent
     "Igrave"    =>    "\xCC",   # capital I, grave accent
     "igrave"    =>    "\xEC",   # small i, grave accent
     "Iuml"      =>    "\xCF",   # capital I, dieresis or umlaut mark
     "iuml"      =>    "\xEF",   # small i, dieresis or umlaut mark
     "Ntilde"    =>    "\xD1",   # capital N, tilde
     "ntilde"    =>    "\xF1",   # small n, tilde
     "Oacute"    =>    "\xD3",   # capital O, acute accent
     "oacute"    =>    "\xF3",   # small o, acute accent
     "Ocirc"     =>    "\xD4",   # capital O, circumflex accent
     "ocirc"     =>    "\xF4",   # small o, circumflex accent
     "Ograve"    =>    "\xD2",   # capital O, grave accent
     "ograve"    =>    "\xF2",   # small o, grave accent
     "Oslash"    =>    "\xD8",   # capital O, slash
     "oslash"    =>    "\xF8",   # small o, slash
     "Otilde"    =>    "\xD5",   # capital O, tilde
     "otilde"    =>    "\xF5",   # small o, tilde
     "Ouml"      =>    "\xD6",   # capital O, dieresis or umlaut mark
     "ouml"      =>    "\xF6",   # small o, dieresis or umlaut mark
     "szlig"     =>    "\xDF",   # small sharp s, German (sz ligature)
     "THORN"     =>    "\xDE",   # capital THORN, Icelandic
     "thorn"     =>    "\xFE",   # small thorn, Icelandic
     "Uacute"    =>    "\xDA",   # capital U, acute accent
     "uacute"    =>    "\xFA",   # small u, acute accent
     "Ucirc"     =>    "\xDB",   # capital U, circumflex accent
     "ucirc"     =>    "\xFB",   # small u, circumflex accent
     "Ugrave"    =>    "\xD9",   # capital U, grave accent
     "ugrave"    =>    "\xF9",   # small u, grave accent
     "Uuml"      =>    "\xDC",   # capital U, dieresis or umlaut mark
     "uuml"      =>    "\xFC",   # small u, dieresis or umlaut mark
     "Yacute"    =>    "\xDD",   # capital Y, acute accent
     "yacute"    =>    "\xFD",   # small y, acute accent
     "yuml"      =>    "\xFF",   # small y, dieresis or umlaut mark

     "laquo"     =>    "\xAB",   # left pointing double angle quotation mark
     "lchevron"  =>    "\xAB",   #  synonym (backwards compatibility)
     "raquo"     =>    "\xBB",   # right pointing double angle quotation mark
     "rchevron"  =>    "\xBB",   #  synonym (backwards compatibility)

     "iexcl"     =>    "\xA1",   # inverted exclamation mark
     "cent"      =>    "\xA2",   # cent sign
     "pound"     =>    "\xA3",   # (UK) pound sign
     "curren"    =>    "\xA4",   # currency sign
     "yen"       =>    "\xA5",   # yen sign
     "brvbar"    =>    "\xA6",   # broken vertical bar
     "sect"      =>    "\xA7",   # section sign
     "uml"       =>    "\xA8",   # diaresis
     "copy"      =>    "\xA9",   # Copyright symbol
     "ordf"      =>    "\xAA",   # feminine ordinal indicator
     "not"       =>    "\xAC",   # not sign
     "shy"       =>    '',       # soft (discretionary) hyphen
     "reg"       =>    "\xAE",   # registered trademark
     "macr"      =>    "\xAF",   # macron, overline
     "deg"       =>    "\xB0",   # degree sign
     "plusmn"    =>    "\xB1",   # plus-minus sign
     "sup2"      =>    "\xB2",   # superscript 2
     "sup3"      =>    "\xB3",   # superscript 3
     "acute"     =>    "\xB4",   # acute accent
     "micro"     =>    "\xB5",   # micro sign
     "para"      =>    "\xB6",   # pilcrow sign = paragraph sign
     "middot"    =>    "\xB7",   # middle dot = Georgian comma
     "cedil"     =>    "\xB8",   # cedilla
     "sup1"      =>    "\xB9",   # superscript 1
     "ordm"      =>    "\xBA",   # masculine ordinal indicator
     "frac14"    =>    "\xBC",   # vulgar fraction one quarter
     "frac12"    =>    "\xBD",   # vulgar fraction one half
     "frac34"    =>    "\xBE",   # vulgar fraction three quarters
     "iquest"    =>    "\xBF",   # inverted question mark
     "times"     =>    "\xD7",   # multiplication sign
     "divide"    =>    "\xF7",   # division sign

     "nbsp"      =>    "\xA0");  # non-breaking space # XXX differs!

  sub initialise {
    my $self = shift;

    $self->{Last_Results} = [];
    $self->{Current_File} = undef;
    $self->{New_File} = 1;
    return $ret;
  }

  sub File {
    my $self = shift;

      $self->{Current_File} = shift;
      $self->{New_File} = 1;
    }
    return $self->{Current_File};
  }

  sub Last_Results {
    my $self = shift;
    return $self->{Last_Results};
  }

  sub parse {
    my $self = shift;

    return if not $self->{New_File}; # Don't reparse something we've already parsed
    return if not defined $self->{Current_File};
    $self->{Last_Results} = [];
    $self->parse_from_file($self->{Current_File}, '/dev/null');
    $self->{New_File} = 0;
  }

  sub command {
    my $self = shift;

    # We're not handling for, pod, cut, begin and end in this parser
    return if scalar grep {$_ eq $command} qw(for pod cut begin end);
    my $pt = $self->parse_text($para);
    $ppara->parse_tree($pt);

  }

  sub verbatim {
    my $self = shift;


  }

  sub textblock {
    my $self = shift;

    my $pt = $self->parse_text($para);
    $ppara->parse_tree($pt);

  }

  sub escape {
    my $self = shift;

    my $res = $Escapes{$seq};
    return $res;
  }

  sub flatten {
    my $self = shift;

    my $txt = '';
    return $txt if not defined $pt;
    foreach my $c ($pt->children) {
      if (not ref $c) {
        $txt .= $c;
      } elsif ($c->cmd_name eq 'E') {
        # An escape
        my $esc = $self->flatten($c->parse_tree);
        $esc =~ s/(?:^\s*)|(?:\s*$ )//gx;
        $txt .= $self->escape($esc);
      } else {
        $txt .= $self->flatten($c->parse_tree);
      }
    }
    return $txt;
  }

  sub strip {
    my $self = shift;

    $txt =~ s/^[\s\n]+//;
    $txt =~ s/[\s\n]+$//;
    return $txt;
  }

  sub collapse {
    my $self = shift;

    $txt = $self->strip($txt);
    $txt =~ s/[\s\n]+/ /g;
    return $txt;
  }

  sub simplify {
    my $self = shift;

    $self->{New_File} = 1; # Reparse to get old results
    $self->{Last_Results} = [];


      $self->simplify_node($lr[$i], $lr[($i + 1)]);
    }
  }

  sub simplify_node {
    my $self = shift;


    if ($type eq 'PRE') {
      # Verbatim paragraph

    } elsif ($type eq 'CMD') {
      $self->simplify_command($para, $next);
    } elsif ($type eq 'TXT') {
      $self->simplify_text($para);
    } else {
      die "Bad type";
    }
  }

  sub simplify_command {
    my $self = shift;

    my $name = $para->cmd_name;
    if ($name =~ /^head(\d+)$/) {

      for my $c ($para->parse_tree->children) {
        $self->simplify_child($c);
      }

    } elsif ($name eq 'over') {
      my $amt = $self->collapse($para->text);
      $amt = 4 if $amt !~ /^\d+$/;
      my ($cmd, $arg) = (undef, undef);
      if ($next->[0] eq 'CMD' and $next->[1]->cmd_name eq 'item') {
        my $cmp = $self->collapse($self->flatten($next->[1]->parse_tree));
        if ($cmp =~ /^\d+\.?$/) {
          $arg = 'numbered';
        } elsif ($cmp =~ /^\*?$/) {
          $arg = 'bulleted';
        } else {
          $arg = 'dictionary';
        }
      }
      if (not defined $arg) {
        $cmd = 'blockquote';
        $arg = $amt;
      } else {
        $cmd = 'list';
      }


    } elsif ($name eq 'back') {


    } elsif ($name eq 'item') {

      my $cmp = $self->collapse($self->flatten($para->parse_tree));
      if ($cmp !~ /^\d+\.?/ and $cmp !~ /^\*?$/) {
        for my $c ($para->parse_tree->children) {
          $self->simplify_child($c);
        }
      }

    }
  }

  sub simplify_text {
    my $self = shift;

    my ($text, $tree) = ($para->text, $para->parse_tree);

    foreach my $c ($tree->children) {
      $self->simplify_child($c);
    }

  }

  sub simplify_child {
    my $self = shift;

    my $txt = '';
    if (ref($child)) {
      # An Internal Sequence
      if ($child->cmd_name eq 'E') {

        foreach my $c ($child->parse_tree->children) {
          $self->simplify_child($c);
        }

      } elsif ($child->cmd_name eq 'Z') {
        return;
      } elsif ($child->cmd_name eq 'X') {

        foreach my $c ($child->parse_tree->children) {
          $self->simplify_child($c);
        }

      } elsif ($child->cmd_name eq 'L') {
        my $rt = $self->flatten($child->parse_tree);
        my $guesstxt = '';
        my ($txt, $linkdata) = split /\|/, $rt, 2;
        if (not defined $linkdata) {
          $linkdata = $txt;
          $txt = undef;
          $guesstxt = $linkdata;
        } else {
          $guesstxt = $txt;
        }
        $linkdata =~ /^(?:([^\/]+))?(?:(\/)(.*))?$/;
        my ($pod, $section) = ($1, $3);

                                        [$txt, $guesstxt, $pod, $section]];
        foreach my $c ($child->parse_tree->children) {
          $self->simplify_child($c);
        }

      } else {

        foreach my $c ($child->parse_tree->children) {
          $self->simplify_child($c);
        }

      }
    } else {
      # Text

    }
  }

Quote:
}

1;
__END__

[ Parser.pm 12K ]
package Example::Parser;

use Pod::Parser;
use strict;

# Outright stolen from Tk::Parse
my %Escapes =
  ('amp'       =>    '&',      # ampersand
   'apos'      =>    "'",      # apostrophe
   'lt'        =>    '<',      # left chevron, less-than
   'gt'        =>    '>',      # right chevron, greater-than
   'quot'      =>    '"',      # double quote
   'sol'       =>    '/',      # solidus (forward slash)
   'verbar'    =>    '|',      # vertical bar

   "Aacute"    =>    "\xC1",   # capital A, acute accent
   "aacute"    =>    "\xE1",   # small a, acute accent
   "Acirc"     =>    "\xC2",   # capital A, circumflex accent
   "acirc"     =>    "\xE2",   # small a, circumflex accent
   "AElig"     =>    "\xC6",   # capital AE diphthong (ligature)
   "aelig"     =>    "\xE6",   # small ae diphthong (ligature)
   "Agrave"    =>    "\xC0",   # capital A, grave accent
   "agrave"    =>    "\xE0",   # small a, grave accent
   "Aring"     =>    "\xC5",   # capital A, ring
   "aring"     =>    "\xE5",   # small a, ring
   "Atilde"    =>    "\xC3",   # capital A, tilde
   "atilde"    =>    "\xE3",   # small a, tilde
   "Auml"      =>    "\xC4",   # capital A, dieresis or umlaut mark
   "auml"      =>    "\xE4",   # small a, dieresis or umlaut mark
   "Ccedil"    =>    "\xC7",   # capital C, cedilla
   "ccedil"    =>    "\xE7",   # small c, cedilla
   "Eacute"    =>    "\xC9",   # capital E, acute accent
   "eacute"    =>    "\xE9",   # small e, acute accent
   "Ecirc"     =>    "\xCA",   # capital E, circumflex accent
   "ecirc"     =>    "\xEA",   # small e, circumflex accent
   "Egrave"    =>    "\xC8",   # capital E, grave accent
   "egrave"    =>    "\xE8",   # small e, grave accent
   "ETH"       =>    "\xD0",   # capital Eth, Icelandic
   "eth"       =>    "\xF0",   # small eth, Icelandic
   "Euml"      =>    "\xCB",   # capital E, dieresis or umlaut mark
   "euml"      =>    "\xEB",   # small e, dieresis or umlaut mark
   "Iacute"    =>    "\xCD",   # capital I, acute accent
   "iacute"    =>    "\xED",   # small i, acute accent
   "Icirc"     =>    "\xCE",   # capital I, circumflex accent
   "icirc"     =>    "\xEE",   # small i, circumflex accent
   "Igrave"    =>    "\xCC",   # capital I, grave accent
   "igrave"    =>    "\xEC",   # small i, grave accent
   "Iuml"      =>    "\xCF",   # capital I, dieresis or umlaut mark
   "iuml"      =>    "\xEF",   # small i, dieresis or umlaut mark
   "Ntilde"    =>    "\xD1",   # capital N, tilde
   "ntilde"    =>    "\xF1",   # small n, tilde
   "Oacute"    =>    "\xD3",   # capital O, acute accent
   "oacute"    =>    "\xF3",   # small o, acute accent
   "Ocirc"     =>    "\xD4",   # capital O, circumflex accent
   "ocirc"     =>    "\xF4",   # small o, circumflex accent
   "Ograve"    =>    "\xD2",   # capital O, grave accent
   "ograve"    =>    "\xF2",   # small o, grave accent
   "Oslash"    =>    "\xD8",   # capital O, slash
   "oslash"    =>    "\xF8",   # small o, slash
   "Otilde"    =>    "\xD5",   # capital O, tilde
   "otilde"    =>    "\xF5",   # small o, tilde
   "Ouml"      =>    "\xD6",   # capital O, dieresis or umlaut mark
   "ouml"      =>    "\xF6",   # small o, dieresis or umlaut mark
   "szlig"     =>    "\xDF",   # small sharp s, German (sz ligature)
   "THORN"     =>    "\xDE",   # capital THORN, Icelandic
   "thorn"     =>    "\xFE",   # small thorn, Icelandic
   "Uacute"    =>    "\xDA",   # capital U, acute accent
   "uacute"    =>    "\xFA",   # small u, acute accent
   "Ucirc"     =>    "\xDB",   # capital U, circumflex accent
   "ucirc"     =>    "\xFB",   # small u, circumflex accent
   "Ugrave"    =>    "\xD9",   # capital U, grave accent
   "ugrave"    =>    "\xF9",   # small u, grave accent
   "Uuml"      =>    "\xDC",   # capital U, dieresis or umlaut mark
   "uuml"      =>    "\xFC",   # small u, dieresis or umlaut mark
   "Yacute"    =>    "\xDD",   # capital Y, acute accent
   "yacute"    =>    "\xFD",   # small y, acute accent
   "yuml"      =>    "\xFF",   # small y, dieresis or umlaut mark

   "laquo"     =>    "\xAB",   # left pointing double angle quotation mark
   "lchevron"  =>    "\xAB",   #  synonym (backwards compatibility)
   "raquo"     =>    "\xBB",   # right pointing double angle quotation mark
   "rchevron"  =>    "\xBB",   #  synonym (backwards compatibility)

   "iexcl"     =>    "\xA1",   # inverted exclamation mark
   "cent"      =>    "\xA2",   # cent sign
   "pound"     =>    "\xA3",   # (UK) pound sign
   "curren"    =>    "\xA4",   # currency sign
   "yen"       =>    "\xA5",   # yen sign
   "brvbar"    =>    "\xA6",   # broken vertical bar
   "sect"      =>    "\xA7",   # section sign
   "uml"       =>    "\xA8",   # diaresis
   "copy"      =>    "\xA9",   # Copyright symbol
   "ordf"      =>    "\xAA",   # feminine ordinal indicator
   "not"       =>    "\xAC",   # not sign
   "shy"       =>    '',       # soft (discretionary) hyphen
   "reg"       =>    "\xAE",   # registered trademark
   "macr"      =>    "\xAF",   # macron, overline
   "deg"       =>    "\xB0",   # degree sign
   "plusmn"    =>    "\xB1",   # plus-minus sign
   "sup2"      =>    "\xB2",   # superscript 2
   "sup3"      =>    "\xB3",   # superscript 3
   "acute"     =>    "\xB4",   # acute accent
   "micro"     =>    "\xB5",   # micro sign
   "para"      =>    "\xB6",   # pilcrow sign = paragraph sign
   "middot"    =>    "\xB7",   # middle dot = Georgian comma
   "cedil"     =>    "\xB8",   # cedilla
   "sup1"      =>    "\xB9",   # superscript 1
   "ordm"      =>    "\xBA",   # masculine ordinal indicator
   "frac14"    =>    "\xBC",   # vulgar fraction one quarter
   "frac12"    =>    "\xBD",   # vulgar fraction one half
   "frac34"    =>    "\xBE",   # vulgar fraction three quarters
   "iquest"    =>    "\xBF",   # inverted question mark
   "times"     =>    "\xD7",   # multiplication sign
   "divide"    =>    "\xF7",   # division sign

   "nbsp"      =>    "\xA0");  # non-breaking space

sub initialise {
  my $self = shift;

  $self->{Last_Results} = [];
  $self->{Current_File} = undef;
  $self->{New_File} = 1;
  return $ret;

Quote:
}

sub File {
  my $self = shift;

    $self->{Current_File} = shift;
    $self->{New_File} = 1;
  }
  return $self->{Current_File};

Quote:
}

sub Last_Results {
  my $self = shift;
  return $self->{Last_Results};

Quote:
}

sub parse {
  my $self = shift;

  return if not $self->{New_File};
  $self->{Last_Results} = [];
  return if not defined $self->{Current_File};
  $self->parse_from_file($self->{Current_File}, '/dev/null');
  $self->{New_File} = 0;
  return 1;

Quote:
}

sub command {
  my $self = shift;

  # We're not handling for, pod, cut, begin and end in this parser
  return if scalar grep {$_ eq $command} qw(for pod cut begin end);
  my $pt = $self->parse_text($para);
  $ppara->parse_tree($pt);

Quote:
}

sub verbatim {
  my $self = shift;


Quote:
}

sub textblock {
  my $self = shift;

  my $pt = $self->parse_text($para);
  $ppara->parse_tree($pt);

Quote:
}

sub escape {
  my $self = shift;

  my $res = $Escapes{$seq};
  return $res;

Quote:
}

sub flatten {
  my $self = shift;

  my $txt = '';
  return $txt if not defined $pt;
  foreach my $c ($pt->children) {
    if (not ref $c) {
      $txt .= $c;
    } elsif ($c->cmd_name eq 'E') {
      # An escape
      my $esc = $self->flatten($c->parse_tree);
      $esc =~ s/(?:^\s*)|(?:\s*$ )//gx;
      $txt .= $self->escape($esc);
    } else {
      $txt .= $self->flatten($c->parse_tree);
    }
  }
  return $txt;

Quote:
}

sub strip {
  my $self = shift;

  $txt =~ s/^[\s\n]+//;
  $txt =~ s/[\s\n]+$//;
  return $txt;

Quote:
}

sub collapse {
  my $self = shift;

  $txt = $self->strip($txt);
  $txt =~ s/[\s\n]+/ /g;
  return $txt;

Quote:
}

sub simplify {
  my $self = shift;

  $self->{Last_Results} = [];
  $self->{New_File} = 1; # Reparse again to get back to original results


    $self->simplify_node($lr[$i], $lr[($i + 1)]);
  }

Quote:
}

sub simplify_node {
  my $self = shift;


  if ($type eq 'PRE') {
    # Verbatim paragraph

  } elsif ($type eq 'CMD') {
    $self->simplify_command($para, $next);
  } elsif ($type eq 'TXT') {
    $self->simplify_text($para);
  } else {
    die "Bad type $type";
  }

Quote:
}

sub simplify_command {
  my $self = shift;

  my $name = $para->cmd_name;
  if ($name =~ /^head(\d+)$/) {

    for my $c ($para->parse_tree->children) {
      $self->simplify_child($c);
    }

  } elsif ($name eq 'over') {
    my $amt = $self->collapse($para->text);
    $amt = 4 if $amt !~ /^\d+$/;
    my ($cmd, $arg) = (undef, undef);
    if ($next->[0] eq 'CMD' and $next->[1]->cmd_name eq 'item') {
      my $cmp = $self->collapse($self->flatten($next->[1]->parse_tree));
      if ($cmp =~ /^\d+\.?$/) {
        $arg = 'numbered';
      } elsif ($cmp =~ /^\*?$/) {
        $arg = 'bulleted';
      } else {
        $arg = 'dictionary';
      }
    }
    if (not defined $arg) {
      $cmd = 'blockquote';
      $arg = $amt;
    } else {
      $cmd = 'list';
    }


  } elsif ($name eq 'back') {


  } elsif ($name eq 'item') {

    my $cmp = $self->collapse($self->flatten($para->parse_tree));
    if ($cmp !~ /^\d+\.?/ and $cmp !~ /^\*?$/) {
      for my $c ($para->parse_tree->children) {
        $self->simplify_child($c);
      }
    }

  }

Quote:
}

sub simplify_text {
  my $self = shift;

  my ($text, $tree) = ($para->text, $para->parse_tree);

  foreach my $c ($tree->children) {
    $self->simplify_child($c);
  }

Quote:
}

sub simplify_child {
  my $self = shift;

  my $txt = '';
  if (ref($child)) {
    # An Internal Sequence
    # ISEQ
    if ($child->cmd_name eq 'E') {

      foreach my $c ($child->parse_tree->children) {
        $self->simplify_child($c);
      }

    } elsif ($child->cmd_name eq 'Z') {
      return;
    } elsif ($child->cmd_name eq 'X') {

      foreach my $c ($child->parse_tree->children) {
        $self->simplify_child($c);
      }

    } elsif ($child->cmd_name eq 'L') {
      my $rt = $self->flatten($child->parse_tree);
      my $guesstxt = '';
      my ($txt, $linkdata) = split /\|/, $rt, 2;
      if (not defined $linkdata) {
        $linkdata = $txt;
        $txt = undef;
        $guesstxt = $linkdata;
      } else {
        $guesstxt = $txt;
      }
      $linkdata =~ /^(?:([^\/]+))?(?:(\/)(.*))?$/;
      my ($pod, $section) = ($1, $3);

                                      [$txt, $guesstxt, $pod, $section]];
      foreach my $c ($child->parse_tree->children) {
        $self->simplify_child($c);
      }

    } else {

      foreach my $c ($child->parse_tree->children) {
        $self->simplify_child($c);
      }

    }
  } else {
    # Text

  }

Quote:
}

sub simplify_children {
  my $self = shift;

  my $txt = '';

    if (ref($c)) {
      $txt .= $c->raw_text;
    } else {
      $txt .= $c;
    }
  }

Quote:
}

1;
__END__

[ Text.pm 21K ]
package Example::Text;

use strict;
use Tk::Frame;
use Example::Parser;
use Tk::More;
use File::Spec::Functions;


Construct Tk::Widget 'ExampleText';

sub Populate {
  my $self = shift;

  $self->SUPER::Populate($args);

  $self->{Parser} = Example::Parser->new;

  my $txt = $self->Scrolled('More',
                            -wrap => 'word',
                            -scrollbars => 'soe');
  $self->Advertise(more => $txt);
  $txt->pack(-expand => 1,
             -fill => 'both');

  #  $txt->configure(-font => $self->Create_Font(family => 'courier'));
  $txt->tagConfigure('TEXT', -font => $self->Create_Font(family => 'times'));
  $txt->tagConfigure('H1', -font => $self->Create_Font(size => 280,
                                                       weight => 'bold',
                                                       family => 'times'));
  $txt->tagConfigure('H2', -font => $self->Create_Font(size => 252,
                                                       weight => 'bold',
                                                       family => 'times'));
  $txt->tagConfigure('H3', -font => $self->Create_Font(size => 224,
                                                       weight => 'bold',
                                                       family => 'times'));
  $txt->tagConfigure('H4', -font => $self->Create_Font(size => 196,
                                                       weight => 'bold',
                                                       family => 'times'));
  $txt->tagConfigure('H5', -font => $self->Create_Font(size => 168,
                                                       weight => 'bold',
                                                       family => 'times'));
  $txt->tagConfigure('H6', -font => $self->Create_Font(size => 140,
                                                       weight => 'bold',
                                                       family => 'times'));
  $txt->tagConfigure('VTEXT', -wrap => 'none');
  $txt->tagConfigure('FILE', -font => $self->Create_Font(family => 'helvetica',
                                                         weight => 'medium'));
  $txt->tagConfigure('NB', -font => $self->Create_Font(family => 'courier',
                                                       weight => 'bold',
                                                       wrap => 'none',
                                                       slant => 'o'));
  $txt->tagConfigure('BOLD', -font => $self->Create_Font(family => 'times',
                                                         weight => 'bold'));
  $txt->tagConfigure('ITALIC', -font => $self->Create_Font(family => 'times',
                                                           weight => 'medium',
                                                           slant => 'i'));
  $txt->tagConfigure('CODE', -font => $self->Create_Font(family => 'courier',
                                                         weight => 'medium'));

  $self->{Code_To_Tag} = {F => 'FILE',
                          S => 'NB',
                          B => 'BOLD',
                          I => 'ITALIC',
                          C => 'CODE'};

  $self->{404} = '';
  $self->{Root} = '';
  $self->{Indent} = 0;
  $self->{ListStart} = '';
  $self->{ListType} = '';
  $self->{LastLine} = '';
  $self->{Tags} = [];
  $self->{Index} = {};
  $self->{Indent_Tags} = {};
  $self->{Bullets} = ['o', '*', '+', '-', '>', "\#"];
  $self->{Bullet_Index} = 0;

  eval {$txt->EditMenuItems;
        $txt->SearchMenuItems;
        $txt->ViewMenuItems;};

  my $m = $txt->Menu(-tearoff => 0,
                   -menuitems =>
                     [[Button => 'Back',
                       -command => [$self, 'history_move', -1]],
                      [Button => 'Forward',
                       -command => [$self, 'history_move', +1]],
                      [Button => 'Reload',
                       -command => [$self, 'load']],
                      [Separator => ""],
                      ($txt->can('EditMenuItems') ?
                       [Cascade => 'Edit',
                        -tearoff => 0,
                        -menuitems => $txt->EditMenuItems] : ()),
                      ($txt->can('SearchMenuItems') ?
                       [Cascade => 'Search',
                        -tearoff => 0,
                        -menuitems => $txt->SearchMenuItems] : ()),
                      ($txt->can('ViewMenuItems') ?
                       [Cascade => 'View',
                        -tearoff => 0,
                        -menuitems => $txt->ViewMenuItems] : ())]);
  eval {$txt->menu($m)};

  $self->Delegates(DEFAULT => $txt);

  $self->ConfigSpecs(-file       => ['PASSIVE'],
                     -path       => ['PASSIVE'],
                     -wrap       => [$txt, qw(wrap Wrap word)],
                     -scrollbars => [$txt, qw(scrollbars Scrollbars soe)],
                     DEFAULT     => [$txt]);

Quote:
}

sub Create_Font {

  $args{family} = 'times' unless (exists $args{family});
  $args{weight} = 'medium' unless (exists $args{weight});
  $args{slant} = 'r' unless (exists $args{slant});
  $args{size} = 140 unless (exists $args{size});
  $args{spacing} = '*' unless (exists $args{spacing});
  $args{slant} = substr($args{slant}, 0, 1);
  my $name = "-*-$args{family}-$args{weight}-$args{slant}-*-*-*-$args{size}-*-*-$args{spacing}-*-iso8859-1";
  return $name;

Quote:
}

# Stolen again from Tk::Pod
sub Print {
  my $self = shift;
  my $pod = catfile($self->{Configure}->{-path}, $self->{Configure}->{-file});
  die "Cannot find POD '$pod'" if not -r $pod;
  die "No POSIX module found" if not eval { require POSIX; 1 };
  if ($self->find_exe("pod2man") and $self->find_exe("groff")) {
    my $gv = ($self->find_exe("gv") or
              $self->find_exe("ghostview") or
              $self->find_exe("XXXggv") or
              $self->find_exe("kghostview"));
    if ($gv) {
      my $temp = POSIX::tmpnam();
      system("pod2man $pod | groff -man -Tps > $temp");
      system("$gv $temp &");
      END {unlink $temp};
      return;
    }
  }
  $self->messageBox(-message => "Can't print: missing one or more of\npod2man, groff, gv or ghostview.");
  return;

Quote:
}

sub load {
  my $self = shift;

  $self->clean_up;
  if (not $let_parser_do_file) {
    $self->{Parser}->File(catfile($self->{Configure}->{-path},
                                  $self->{Configure}->{-file}));
  }
  if (not $self->{Parser}->parse) {
    $self->{Parser}->File($self->{Configure}->{-404});
    if (not $self->{Parser}->parse) {
      $self->Default_Not_Found;
      return;
    }
  }
  $self->{Parser}->simplify;
  $self->pod($self->{Parser}->Last_Results);

Quote:
}

sub Default_Not_Found {
  my $self = shift;
  print "NOT FOUND: $self->{Configure}->{-path}/$self->{Configure}->{-file}\n";

Quote:
}

sub clean_up {
  my $self = shift;
  $self->delete('1.0', 'end - 1 char');
  foreach (keys %{$self->{Indent_Tags}}) {
    $self->tagDelete($_);
    delete $self->{Indent_Tags}->{$_};
  }

    $self->tagDelete($_);
  }
  foreach (keys %{$self->{Index}}) {
    delete $self->{Index}->{$_};
  }

Quote:
}

sub pod {
  my $self = shift;

  $self->{Index}->{__top__} = '1.0';
  while (defined($layer->[0])) {


    ($self->paragraph($layer), next) if $cmd eq 'paragraph';
    ($self->head($arg, $layer), next) if $cmd eq 'head';
    ($self->list($arg, $layer), next) if $cmd eq 'list';
    ($self->item($layer), next) if $cmd eq 'item';
    ($self->verbatim($arg), next) if $cmd eq 'verbatim';
    ($self->blockquote($arg, $layer), next) if $cmd eq 'blockquote';
    die "Bad pod item: $cmd";
  }

Quote:
}

sub paragraph {
  my $self = shift;

  while (1) {


    last if $n->[0] eq 'end' and $n->[1] eq 'paragraph';
    ($self->text($n->[1]), next) if $n->[0] eq 'text';
    ($self->tag($n->[1], $layer), next) if $n->[0] eq 'tag';

    ($self->escape($layer), next) if $n->[0] eq 'escape';
    ($self->anchor($layer), next) if $n->[0] eq 'anchor';
    die "Bad paragraph item: $n->[0], $n->[1]";
  }
  $self->direct_insert("\n\n");

Quote:
}

sub escape {
  my $self = shift;

  my $rchar = '';
  while (1) {


    last if $n->[0] eq 'end' and $n->[1] eq 'escape';
    ($rchar .= $n->[1], next) if $n->[0] eq 'text';
    die "Bad escape item: $n->[0], $n->[1]";
  }
  $rchar =~ s/[\s\n]+//;
  my $esc = $self->{Parser}->escape($rchar);
  die "Bad escape sequence: $rchar" if not defined $esc;
  $self->insert_text($esc);

Quote:
}

sub head {
  my $self = shift;

  $lev = 6 if $lev > 6;

  my $headname = sub {

    my $txt = '';

      if ($n->[0] eq 'end' and $n->[1] eq 'head') {
        $txt =~ s/[\s\n]+//g;
        return $txt;
      } elsif ($n->[0] eq 'text') {
        $txt .= $n->[1];
      }
    }
    die "No end of head";
  };
  my $start = $self->index('end - 1 char');
  my $text = lc($headname->($layer));
  $text =~ s/[^a-z0-9]//g;
  $self->{Index}->{$text} = $start;
  $self->setindent(-4) if $self->{Indent};
  while (1) { # Expecting text and tag


    last if $n->[0] eq 'end' and $n->[1] eq 'head';
    ($self->text($n->[1]), next) if $n->[0] eq 'text';
    ($self->tag($n->[1], $layer), next) if $n->[0] eq 'tag';
    ($self->escape($layer), next) if $n->[0] eq 'escape';
    die "Bad head item: $n->[0]";
  }

  if ($self->index('end - 1 char') !~ /^1\./) {
    $self->create_link("(top)", undef, "__top__");
  }
  $self->direct_insert("\n\n");
  $self->setindent(4);

Quote:
}

sub tag {
  my $self = shift;

  my $rt = $self->{Code_To_Tag}->{$tn};
  return if not defined $rt;

  while (1) { # inside tag is only tag and text


    last if $n->[0] eq 'end' and $n->[1] eq "tag$tn";
    ($self->text($n->[1]), next) if $n->[0] eq 'text';
    ($self->tag($n->[1], $layer), next) if $n->[0] eq 'tag';
    ($self->escape($layer), next) if $n->[0] eq 'escape';

    die "Bad tag item: $n->[0]";
  }

Quote:
}

sub verbatim {
  my $self = shift;

  my $start = $self->index('end - 1 char');
  $self->direct_insert($text);
  $self->tagAdd('VTEXT', $start, 'end - 1 char');

Quote:
}

sub blockquote {
  my $self = shift;

  $self->setindent($amt);
  while (1) {


    last if $cmd eq 'end' and $arg eq 'blockquote';
    ($self->paragraph($layer), next) if $cmd eq 'paragraph';
    ($self->head($arg, $layer), next) if $cmd eq 'head';
    ($self->list($arg, $layer), next) if $cmd eq 'list';
    ($self->item($layer), next) if $cmd eq 'item';
    ($self->verbatim($arg), next) if $cmd eq 'verbatim';
    ($self->blockquote($arg, $layer), next) if $cmd eq 'blockquote';
    die "Bad blockquote item: $cmd";
  }
  $self->setindent(-($amt));

Quote:
}

sub text {
  my $self = shift;

  $self->insert_text($text);

Quote:
}

sub anchor {
  my $self = shift;

  my $text = '';
  while (1) {


    last if $cmd eq 'end' and $arg eq 'anchor';
    ($text .= $arg, next) if $cmd eq 'text';
    die "Only text allowed in anchor";
  }
  $text =~ s/[\n\s]+//g;
  $text = lc($text);
  $text =~ s/[^a-z0-9]//g;
  my $ind = $self->index('end - 1 char');
  $self->{Index}->{$text} = $ind;

Quote:
}

sub linked {
  my $self = shift;

  $name = $guessname if not defined $name;
  # For now, don't do internal link formating
  while (1) {


    last if $cmd eq 'end' and $arg eq 'link';
  }
  $self->create_link($name, $pod, $section);

Quote:
}

sub list {
  my $self = shift;

  ($self->bulleted_list($layer), return) if ($type eq 'bulleted');
  ($self->numbered_list($layer), return) if ($type eq 'numbered');
  ($self->dictionary_list($layer), return) if ($type eq 'dictionary');
  die "Unknown list type: $type";

Quote:
}

sub item {
  my $self = shift;

  ($self->bulleted_item($layer), return) if $self->{ListType} eq 'bulleted';
  ($self->numbered_item($layer), return) if $self->{ListType} eq 'numbered';
  ($self->dictionary_item($layer), return)
    if $self->{ListType} eq 'dictionary';
  ($self->floating_item($layer), return) if $self->{ListType} eq '';
  die "Bad list type for item: $self->{ListType}";

Quote:
}

sub setindent {
  my $self = shift;

  return if $amt == 0;
  return if $amt < 0 and $self->{Indent} == 0;
  $self->{Indent} += $amt;
  $self->{Indent} = 0 if $self->{Indent} < 0;
  my $iname = "indent$self->{Indent}";
  return if defined $self->{Indent_Tags}->{$iname};
  $self->{Indent_Tags}->{$iname} = 1;
  $self->tagConfigure($iname,
                      -lmargin1 => (($self->{Indent} * 4) . 'p'),
                      -lmargin2 => (($self->{Indent} * 4) . 'p'));

Quote:
}

sub direct_insert {
  my $self = shift;

  my $start = $self->index('end - 1 char');
  $self->insert('end - 1 char', $text);

    $self->tagAdd($_, $start, 'end - 1 char');
  }
  $self->tagAdd("indent$self->{Indent}", $start, 'end - 1 char')
    if $self->{Indent};

Quote:
}

sub insert_text {
  my $self = shift;

  $text = $self->format_text($text);
  my $start = $self->index('end - 1 char');
  $self->insert('end - 1 char', $text);

    $self->tagAdd($_, $start, 'end - 1 char');
  }
  $self->tagAdd("indent$self->{Indent}", $start, 'end - 1 char')
    if $self->{Indent};

Quote:
}

sub format_text {
  my $self = shift;

  $text =~ s/[\n]+/ /g;
  $text =~ s/\t/    /g;
  return $text;

Quote:
}

sub create_link {
  my $self = shift;

  my $tag = "!$pod-$section";
  $self->tagBind($tag, '<ButtonRelease-1>',
                 [$self, 'FollowLink', $pod, $section]);
  $self->tagBind($tag, '<Enter>' => [$self, 'EnterLink']);
  $self->tagBind($tag, '<Leave>' => [$self, 'LeaveLink']);
  $self->tagConfigure($tag,
                      -underline => 1,
                      -foreground => 'blue');

  $self->{Tags} = [$tag];
  $self->insert_text($name);

Quote:
}

sub numbered_list {
  my $self = shift;

  my $olstart = $self->{ListStart};
  my $oltype = $self->{ListType};
  # scan for the number of items
  my $icnt = 0;
  my $llev = 0;
  my $last = '';

    ($llev++, next) if $n->[0] eq 'list';
    ($icnt++, next) if $n->[0] eq 'item' and $llev == 0;
    ($llev--, next) if $n->[0] eq 'end' and $n->[1] eq 'list' and $llev;
    last if $n->[0] eq 'end' and $n->[1] eq 'list' and not $llev;
  }
  my $width = length("$icnt");
  $self->{ListStart} = sprintf("%${width}d  ", 1);
  $self->{ListType} = 'numbered';
  $self->setindent(length($self->{ListStart}));
  while (1) {


    last if $cmd eq 'end' and $arg eq 'list';
    ($last = 'list', $self->list($arg, $layer), next) if $cmd eq 'list';
    ($last = 'blockquote',
     $self->blockquote($arg, $layer), next) if $cmd eq 'blockquote';
    ($last = 'paragraph',
     $self->paragraph($layer), next) if $cmd eq 'paragraph';
    ($last = 'item', $self->item($layer), next) if $cmd eq 'item';
    die "Bad list item: $cmd, $arg";
  }
  $self->setindent(-(length($self->{ListStart})));
  $self->{ListType} = $oltype;
  $self->{ListStart} = $olstart;
  $self->direct_insert("\n") if $last ne 'paragraph' and $last ne 'list';

Quote:
}

sub bulleted_list {
  my $self = shift;

  my $olstart = $self->{ListStart};
  my $oltype = $self->{ListType};
  my $bul = ($self->{Bulleted_Index} >= scalar {$self->{Bullets}}

             : $self->{Bullets}->[$self->{Bullet_Index}]);
  $self->{Bullet_Index}++;
  $self->{ListStart} = "$bul  ";
  $self->{ListType} = 'bulleted';
  $self->setindent(length($self->{ListStart}));
  my $last = '';
  while (1) {


    last if $cmd eq 'end' and $arg eq 'list';
    ($last = 'list', $self->list($arg, $layer), next) if $cmd eq 'list';
    ($last = 'blockquote',
     $self->blockquote($arg, $layer), next) if $cmd eq 'blockquote';
    ($last = 'paragraph',
     $self->paragraph($layer), next) if $cmd eq 'paragraph';
    ($last = 'item', $self->item($layer), next) if $cmd eq 'item';
    die "Bad list item: $cmd, $arg";
  }
  $self->setindent(-(length($self->{ListStart})));
  $self->{Bullet_Index}--;
  $self->{ListType} = $oltype;
  $self->{ListStart} = $olstart;
  $self->direct_insert("\n") if $last ne 'paragraph' and $last ne 'list';

Quote:
}

sub dictionary_list {
  my $self = shift;

  my $olstart = $self->{ListStart};
  my $oltype = $self->{ListType};
  $self->{ListStart} = "";
  $self->{ListType} = 'dictionary';
  $self->setindent(length($self->{ListStart}));
  my $last = '';
  while (1) {


    last if $cmd eq 'end' and $arg eq 'list';
    ($last = 'list', $self->setindent(4),
     $self->list($arg, $layer), $self->setindent(-4), next) if $cmd eq 'list';
    ($last = 'blockquote', $self->setindent(4),
     $self->blockquote($arg, $layer), $self->setindent(-4), next)
      if $cmd eq 'blockquote';
    ($last = 'paragraph', $self->setindent(4),
     $self->paragraph($layer), $self->setindent(-4), next)
      if $cmd eq 'paragraph';
    ($last = 'item', $self->item($layer), next) if $cmd eq 'item';
    die "Bad dictionary list item: $cmd, $arg";
  }
  $self->setindent(-(length($self->{ListStart})));
  $self->{ListType} = $oltype;
  $self->{ListStart} = $olstart;
  $self->direct_insert("\n") if $last ne 'paragraph' and $last ne 'list';

Quote:
}

sub numbered_item {
  my $self = shift;

  $self->setindent(-(length($self->{ListStart})));
  $self->direct_insert($self->{ListStart});
  $self->setindent(length($self->{ListStart}));
  # Ignore everything to the end item
  while (1) {


    last if $cmd eq 'end' and $arg eq 'item';
  }
  $self->{ListStart} =~ s/^(\s*)(\d+)(\s+)$/$1$2/;
  my $i = $2;
  $i++;
  $self->{ListStart} = ((" " x (length($self->{ListStart}) - length("$i"))) .
                        $i . "  ");

Quote:
}

sub bulleted_item {
  my $self = shift;

  $self->setindent(-(length($self->{ListStart})));
  $self->direct_insert($self->{ListStart});
  $self->setindent((length($self->{ListStart})));
  # Ignore everything to the end item
  while (1) {


    last if $cmd eq 'end' and $arg eq 'item';
  }

Quote:
}

sub dictionary_item {
  my $self = shift;

  while (1) {


    last if $cmd eq 'end' and $arg eq 'item';
    ($self->text($arg), next) if $cmd eq 'text';
    ($self->tag($arg, $layer), next) if $cmd eq 'tag';

    ($self->escape($layer), next) if $cmd eq 'escape';
    ($self->anchor($layer), next) if $cmd eq 'anchor';
    die "Bad dictionary paragraph item: $cmd, $arg";
  }
  $self->direct_insert("\n");

Quote:
}

sub floating_item {
  my $self = shift;

  # Treat a floating item like a labeled paragraph
  while (1) {


    last if $cmd eq 'end' and $arg eq 'item';
    ($self->text($arg), next) if $cmd eq 'text';
    ($self->tag($arg, $layer), next) if $cmd eq 'tag';

    ($self->escape($layer), next) if $cmd eq 'escape';
    ($self->anchor($layer), next) if $cmd eq 'anchor';
    die "Bad floating paragraph item: $cmd, $arg";
  }
  $self->direct_insert("\n");    

Quote:
}

sub EnterLink {
  my $self = shift;
  $self->configure(-cursor => 'hand2');

Quote:
}

sub LeaveLink {
  my $self = shift;
  $self->configure(-cursor => undef);

Quote:
}

sub FollowLink {
  my $self = shift;

  $self->LeaveLink;
  if (not defined $pod) {
    # Internal link
    $section =~ s/[\s\n]//g;
    $section = lc($section);
    $self->yview($self->{Index}->{$section})
      if defined $self->{Index}->{$section};
  } else {
    my $file = catfile($self->{Configure}->{-path},
                       catfile(split /::/, $pod)) . ".pod";
    if (not -e $file or not -f $file or not -r $file) {
      print "404 FOR $file\n";
      $self->{Parser}->File($self->{Configure}->{-404});
      $self->load(1);
    } else {
      $self->{Configure}->{-file} = (catfile(split /::/, $pod) . ".pod");
      $self->{Parser}->File($file);
      $self->load;
    }
    if (defined $section) {
      # Internal link
      $section =~ s/[\s\n]//g;
      $section = lc($section);
      $self->yview($self->{Index}->{$section})
        if defined $self->{Index}->{$section};
    }
  }

Quote:
}

1;
__END__


Fri, 25 Mar 2005 09:43:18 GMT  
 
 [ 1 post ] 

 Relevant Pages 

1. Tags On Tk::Text

2. Tag for all new text in Tk::Text

3. Tk::Text, tags and Tk::Balloon

4. strange Tk::Text with tag -elide=>1

5. Tagged text --> list of tags, revisited

6. Text Tags and Text Selection

7. Color Coding Text in a Tk::Text Widget

8. scrollbars, Tk::Text, large text

9. Help with pulling text out of a Tk::Text

10. TK::Text - Inserting text

11. Tk::Text text width with non-fixed fonts

12. Getting text between tags

 

 
Powered by phpBB® Forum Software