home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / SimpleBridge.pm < prev    next >
Encoding:
Text File  |  2003-02-11  |  12.4 KB  |  421 lines
  1.  
  2. require 5;
  3. use strict;
  4. package Tk::Pod::SimpleBridge;
  5. # Interface between Tk::Pod and Pod::Simple
  6.  
  7. BEGIN {  # Make a DEBUG constant very first thing...
  8.   if(defined &DEBUG) {
  9.   } elsif(($ENV{'TKPODDEBUG'} || '') =~ m/^(\d+)/) { # untaint
  10.     my $debug = $1;
  11.     *DEBUG = sub () { $debug };
  12.   } else {
  13.     *DEBUG = sub () {0};
  14.   }
  15. }
  16.  
  17. #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  18.  
  19. use Pod::Simple::PullParser;
  20. use Tk::Pod::Styles;
  21. use vars qw(@ISA);
  22. @ISA = qw(Tk::Pod::Styles);
  23.  
  24. #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  25. sub no_op {return}
  26.  
  27. sub process { # main routine: non-handler
  28.   my ($w,$file) = @_;  # window, filename
  29.   die "WHAT? Null filename?" unless defined $file and length $file;
  30.   die "WHAT? Non-existent $file" unless -e $file and -f $file;
  31.  
  32.   my $p = $w->{'pod_parser'} = Pod::Simple::PullParser->new;
  33.   $p->set_source($file);
  34.  
  35.   $w->toplevel->Busy;
  36.   $w->init_styles;
  37.  
  38.   my $process_no;
  39.   $w->{ProcessNo}++;
  40.   $process_no = $w->{ProcessNo};
  41.  
  42.   $w->{'sections'} = [];
  43.   $w->{'pod_tag'} = '10000'; # counter
  44.   my $style_stack = $w->{'style_stack'} ||= [];
  45.   my @pod_marks;
  46.  
  47.   DEBUG and warn "Pull-parsing $file (process number $process_no)\n";
  48.   $w->{'pod_title'} = $p->get_short_title || $file;
  49.  
  50.   my($token, $tagname, $style);
  51.   my $last_update = Tk::timeofday();
  52.   while($token = $p->get_token) {
  53.  
  54.     DEBUG > 7 and warn " t:", $token->dump, "\n";
  55.  
  56.     if($token->is_text) {
  57.       DEBUG > 10 and warn " ->pod_text( ", $token->text, ")\n";
  58.       $w->pod_text( $token );
  59.  
  60.     } elsif($token->is_start) {
  61.       ($tagname = $token->tagname ) =~ tr/-:./__/;
  62.       $style    = "style_"     . $tagname;
  63.       $tagname  = "pod_start_" . $tagname;
  64.       DEBUG > 7 and warn " ->$tagname & ->$style\n";
  65.       push @pod_marks, $w->index('end -1c');
  66.        # Yes, save the start-point for every element,
  67.        #  for feeding to its end-tag event.
  68.  
  69.       if( $w->can($style) ) {
  70.         push @$style_stack,  $w->$style($token);
  71.         DEBUG > 5 and warn "Style stack after adding ->$style: ",
  72.          join("|", map join('.',@$_), @{ $w->{'style_stack'} } ), "\n";
  73.       }
  74.  
  75.       &{ $w->can($tagname) || next }( $w, $token );
  76.       DEBUG > 10 and warn "   back from ->$tagname\n";
  77.  
  78.     } elsif($token->is_end) {
  79.       ($tagname = $token->tagname ) =~ tr/-:./__/;
  80.       $style    = "style_"   . $tagname;
  81.       $tagname  = "pod_end_" . $tagname;
  82.  
  83.       DEBUG > 7 and warn " ->$tagname & $style\n";
  84.  
  85.       &{ $w->can($tagname) || \&no_op }( $w, $token, pop(@pod_marks) );
  86.        # the output of that pop() is the start-point of this element
  87.       DEBUG > 10 and warn "   back from ->$tagname\n";
  88.  
  89.       if( $w->can($style) ) {
  90.         pop @$style_stack;
  91.         DEBUG > 5 and warn "Style stack after popping results of ->$style: ",
  92.          join("|", map join('.',@$_), @{ $w->{'style_stack'} } ), "\n";
  93.       }
  94.     }
  95.  
  96.     if (Tk::timeofday() > $last_update+0.5) { # XXX make configurable
  97.       $w->update;
  98.       $last_update = Tk::timeofday();
  99.       do { warn "ABORT!"; return } if $w->{ProcessNo} != $process_no;
  100.     }
  101.  
  102.   }
  103.  
  104.   undef $p;
  105.   delete $w->{'pod_parser'};
  106.   DEBUG and warn "Done rendering $file\n";
  107.  
  108.   $w->parent->add_section_menu if $w->parent->can('add_section_menu');
  109.   $w->Callback('-poddone', $file);
  110.   # set (invisible) insertion cursor to top of file
  111.   $w->markSet(insert => '@0,0');
  112.   $w->toplevel->Unbusy;
  113. }
  114.  
  115. ###########################################################################
  116.  
  117. sub pod_text {
  118.   my($w, $t) = @_;
  119.   if( $w->{'pod_in_X'} ) {
  120.     # no-op
  121.   } else {
  122.     # Emit it with whatever styles are in effect.
  123.  
  124.     my %attributes = (map @$_, @{ $w->{'style_stack'} } );
  125.     DEBUG > 4 and warn "Inserting <", $t->text, "> with attributes: ",
  126.       join('/', %attributes), "\n";
  127.  
  128.     my $startpoint = $w->index('end -1c');
  129.     $w->insert( 'end -1c', $t->text );
  130.     
  131.     $w->tag(
  132.       'add',
  133.       $w->tag_for(\%attributes),
  134.       $startpoint => 'end -1c'
  135.     );
  136.   }
  137.   return;
  138. }
  139.  
  140. #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  141.  
  142. sub pod_start_Document {
  143.   $_[0]->toplevel->title( "Tkpod: " . $_[0]->{'pod_title'} . " (loading)");
  144.   $_[0]->toplevel->update;
  145.   # XXX  Is it bad form to manipulate the top level?
  146.   return;
  147. }
  148.  
  149. sub pod_end_Document {
  150.   $_[0]->toplevel->title( "Tkpod: " . $_[0]->{'pod_title'});
  151.   $_[0]->toplevel->update;
  152.   # XXX  Is it bad form to manipulate the top level?
  153.   return;
  154. }
  155.  
  156. #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  157.  
  158. sub nlnl { $_[0]->insert( 'end -1c', "\n\n" ); $_[0]; }
  159.  
  160. sub fake_unget_bold_text {
  161.   require Pod::Simple::PullParserStartToken;
  162.   require Pod::Simple::PullParserTextToken;
  163.   require Pod::Simple::PullParserEndToken;
  164.  
  165.   $_[0]{'pod_parser'}->unget_token(
  166.     Pod::Simple::PullParserStartToken->new('B'),
  167.     Pod::Simple::PullParserTextToken->new($_[1]),
  168.     Pod::Simple::PullParserEndToken->new('B'),
  169.   );
  170. }
  171.  
  172. sub pod_start_item_bullet {
  173.   $_[0]->fake_unget_bold_text('* ');
  174. }
  175. sub pod_start_item_number {
  176.   $_[0]->fake_unget_bold_text($_[1]->attr('number') . '. ');
  177. }
  178.  
  179. sub pod_end_Para        { $_[0]->_indent($_[2]); $_[0]->nlnl }
  180. sub pod_end_Verbatim    { $_[0]->_indent($_[2]); $_[0]->nlnl }
  181. sub pod_end_item_bullet { $_[0]->_indent($_[2]); $_[0]->nlnl }
  182. sub pod_end_item_number { $_[0]->_indent($_[2]); $_[0]->nlnl }
  183. sub pod_end_item_text   { $_[0]->_indent($_[2]); $_[0]->nlnl }
  184.  
  185. sub _indent {
  186.   my ($w, $start) = @_;
  187.   
  188.   my $indent = 0;
  189.   foreach my $s (@{ $w->{'style_stack'} }) {
  190.     $indent += $s->[1] if @$s and $s->[0] eq 'indent';
  191.      # yes, indent is special -- it always has to be first
  192.   }
  193.   $indent = 0 if $indent < 0;
  194.   
  195.   DEBUG > 5 and warn "Style stack giving indent of $indent for $start: ",
  196.          join("|", map join('.',@$_), @{ $w->{'style_stack'} } ), "\n";
  197.   
  198.   my $tag = "Indent" . ($indent+0);
  199.   unless (exists $w->{'pod_indent_tag_known'}{$tag}) {
  200.     $w->{'pod_indent_tag_known'}{$tag} = 1;
  201.     
  202.     $indent *= 8;  # XXX  Why 8?
  203.     
  204.     $w->tag('configure' => $tag,
  205.             '-lmargin2' => $indent . 'p',
  206.             '-rmargin'  => $indent . 'p',
  207.             '-lmargin1' => $indent . 'p'
  208.            );
  209.   }
  210.   $w->tag('add', $tag, $start, 'end -1c');
  211.   DEBUG > 3 and warn "Applying $tag to $start\n";
  212.   return;
  213. }
  214.  
  215.  
  216. #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  217. # All we need for X<...>, I think:
  218. sub pod_start_X { $_[0]{'pod_in_X'}++; return; }
  219. sub pod_end_X   { $_[0]{'pod_in_X'}--; return; }
  220. #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  221.  
  222. sub tag_for {
  223.   my($w, $attr) = @_;
  224.   my $canonical_form =
  225.     join( '~', map {; $_, $attr->{$_}}
  226.       sort
  227.         grep $_ ne 'indent',
  228.           keys %$attr
  229.   ) || 'nihil';
  230.   
  231.   return
  232.     $w->{'known_tags'}{$canonical_form} ||=
  233.     do {
  234.       # initialize and return a new tagname
  235.       DEBUG and warn "Making a tag for $canonical_form\n";
  236.       $attr->{'family'}  = 'times'  unless exists $attr->{'family'};
  237.       $attr->{'weight'}  = 'medium' unless exists $attr->{'weight'};
  238.       $attr->{'slant'}   = 'r'      unless exists $attr->{'slant'};
  239.       $attr->{'size'}    = 10       unless exists $attr->{'size'};
  240.       $attr->{'spacing'} = '*'      unless exists $attr->{'spacing'};
  241.       $attr->{'slant'}   = substr( $attr->{'slant'},0,1 );
  242.       
  243.       my $font_name = join ' ',
  244.         $attr->{'family'},
  245.         $attr->{'size'},
  246.         ($attr->{'weight'} ne 'medium') ? 'bold'   : (),
  247.         ($attr->{'slant'}  ne 'r'     ) ? 'italic' : (),
  248.       ;
  249.       
  250.       DEBUG and warn "Defining new tag $canonical_form with font $font_name\n";
  251.       
  252.       $w->tagConfigure(
  253.         $canonical_form,
  254.         '-font' => $font_name,
  255.         ('none' eq ($attr->{'wrap'} || '')) ? ('-wrap' => 'none') : (),
  256.         $attr->{'underline'} ? ('-underline' => 'true') : (),
  257.       );
  258.       DEBUG > 10 and sleep 1;
  259.       $canonical_form;
  260.     }
  261.   ;
  262. }
  263.  
  264. #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  265.  
  266. sub pod_start_L {
  267.   push @{ $_[0]->{'pod_L_attr_stack'} }, $_[1]->attr_hash;
  268. }
  269.  
  270. sub pod_end_L   {
  271.   my $w = $_[0];
  272.   my $attr = pop @{ $w->{'pod_L_attr_stack'} };
  273.  
  274.   #$w->tag('add', 'L' , $_[2], 'end -1c');
  275.   
  276.   my $tag = # make a unique identifier for this guy:
  277.     join "__", '!',
  278.       map defined($_) ? $_ : '',
  279.         @$attr{'type', 'to', 'section'};
  280.     #"!" . $attr->{'to'}
  281.   ;
  282.   $tag =~ tr/ /_/;
  283.   DEBUG > 2 and warn "Link-tag <$tag>\n";
  284.   
  285.   my $to      = $attr->{'to'}     ; # might be undef!
  286.   my $section = $attr->{'section'}; # might be undef!
  287.   
  288.   my $methodname;
  289.   if($attr->{'type'} eq 'pod')      {
  290.     #$methodname = defined($to) ? 'Link' : 'Link_my_section';
  291.     $methodname = 'Link';
  292.   } elsif($attr->{'type'} eq 'url') {
  293.     $methodname = 'Link_url'
  294.   } elsif($attr->{'type'} eq 'man') {
  295.     $methodname = 'Link_man'
  296.   } else {
  297.     DEBUG and warn "Unknown link-type $$attr{'type'}!\n";
  298.   }
  299.  
  300.   $section = '' . $section if defined $section and ref $section;
  301.  
  302.   if(!defined $methodname) {
  303.     DEBUG > 2 and warn "No method for $$attr{'type'} links.\n";
  304.   } elsif($w->can($methodname)) {
  305.     DEBUG > 2 and warn "Binding $tag to $methodname\n";
  306.     $w->tag('bind', $tag, '<ButtonRelease-1>',
  307.             [$w, $methodname, 'reuse', Tk::Ev('@%x,%y'), $to, $section]);
  308.     $w->tag('bind', $tag, '<Shift-ButtonRelease-1>',
  309.             [$w, $methodname, 'new',   Tk::Ev('@%x,%y'), $to, $section]);
  310.     $w->tag('bind', $tag, '<ButtonRelease-2>',
  311.             [$w, $methodname, 'new',   Tk::Ev('@%x,%y'), $to, $section]);
  312.     $w->tag('bind', $tag, '<Enter>' => [$w, 'EnterLink']);
  313.     $w->tag('bind', $tag, '<Leave>' => [$w, 'LeaveLink']);
  314.     $w->tag('configure', $tag, '-underline' => 1, '-foreground' => 'blue' );
  315.   } else {
  316.     DEBUG > 2 and warn "Can't bind $tag to $methodname\n";
  317.     # green for no-good
  318.     $w->tag('configure', $tag, '-underline' => 1, '-foreground' => 'darkgreen' );
  319.   }
  320.   $w->tag('add', $tag, $_[2] ,'end -1c');
  321.  
  322.   return;
  323. }
  324.  
  325. #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  326.  
  327. sub pod_start_head1 { $_[0]->_common_heading('head1'); }
  328. sub pod_start_head2 { $_[0]->_common_heading('head2'); }
  329. sub pod_start_head3 { $_[0]->_common_heading('head3'); }
  330. sub pod_start_head4 { $_[0]->_common_heading('head4'); }
  331.  
  332. sub pod_end_head1 {  $_[0]->nlnl }
  333. sub pod_end_head2 {  $_[0]->nlnl }
  334. sub pod_end_head3 {  $_[0]->nlnl }
  335. sub pod_end_head4 {  $_[0]->nlnl }
  336.  
  337. sub _common_heading {
  338.   my $w = $_[0];
  339.   my $p = $w->{'pod_parser'};
  340.   my $end_tag = $_[1];
  341.   
  342.   my @to_put_back;
  343.   my $text = '';
  344.   my $token;
  345.   my $in_X = 0;
  346.   while($token = $p->get_token) {
  347.     push @to_put_back, $token;
  348.     if( $token->is_end ) {
  349.       last if $token->is_tag($end_tag);
  350.       --$in_X if $token->is_tag('X');
  351.     } elsif($token->is_start) {
  352.       ++$in_X if $token->is_tag('X');
  353.     } elsif($token->is_text) {
  354.       $text .= $token->text unless $in_X;
  355.     }
  356.     last if @to_put_back > 40; # too complex a heading!
  357.   }
  358.  
  359.   if(length $text) {
  360.     my $level;
  361.     $end_tag =~ m/(\d+)$/ or die "WHAAAT?  $end_tag!?";
  362.     $level = $1;
  363.     push @{$w->{'sections'}}, [$level, $text, $w->index('end')];
  364.     DEBUG and warn "Noting section heading head$level \"$text\".\n";
  365.   }
  366.  
  367.   $p->unget_token(@to_put_back);
  368.   return;
  369. }
  370.  
  371. # ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
  372.  
  373. #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  374. #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  375. #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  376. 1;
  377. __END__
  378.  
  379. =head1 NAME
  380.  
  381. Tk::Pod::SimpleBridge -- render Pod::Simple events to a Tk::Pod window
  382.  
  383. =head1 SYNOPSIS
  384.  
  385.   [
  386.     This is a class internal to Tk::Pod.
  387.     No user-serviceable parts inside.
  388.   ]
  389.  
  390. =head1 DESCRIPTION
  391.  
  392. This class contains methods that Tk::Pod (specifically Tk::Pod::Text)
  393. uses to render a pod page's text into its window.  It uses L<Pod::Simple>
  394. (specifically L<Pod::Simple::PullParser>) to do the parsing.
  395.  
  396. Tk::Pod used to use Tk::Parse (a snapshot of an old old Pod-parser)
  397. to do the Pod-parsing.  But it doesn't anymore -- it now uses Pod::Simple
  398. via this module.
  399.  
  400. =head1 COPYRIGHT AND DISCLAIMERS
  401.  
  402. Copyright (c) 2002 Sean M. Burke.  All rights reserved.
  403.  
  404. This library is free software; you can redistribute it and/or modify it
  405. under the same terms as Perl itself.
  406.  
  407. This program is distributed in the hope that it will be useful, but
  408. without any warranty; without even the implied warranty of
  409. merchantability or fitness for a particular purpose.
  410.  
  411. =head1 AUTHOR
  412.  
  413. Sean M. Burke <F<sburke@cpan.org>>, with bits of Tk code cribbed from
  414. the old Tk::Pod::Text code that Nick Ing-Simmons
  415. <F<nick@ni-s.u-net.com>> originally wrote.
  416.  
  417. Current maintainer is Slaven Rezic <F<slaven@rezic.de>>.
  418.  
  419. =cut
  420.  
  421.