4
package Tk::Pod::SimpleBridge;
5
# Interface between Tk::Pod and Pod::Simple
8
$VERSION = sprintf("%d.%02d", q$Revision: 5.1 $ =~ /(\d+)\.(\d+)/);
10
BEGIN { # Make a DEBUG constant very first thing...
12
} elsif(($ENV{'TKPODDEBUG'} || '') =~ m/^(\d+)/) { # untaint
14
*DEBUG = sub () { $debug };
20
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
22
use Pod::Simple::PullParser;
25
@ISA = qw(Tk::Pod::Styles);
27
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
30
sub process { # main routine: non-handler
31
my ($w,$file_or_textref, $title) = @_; # window, filename or string ref, title (optional)
33
my $p = $w->{'pod_parser'} = Pod::Simple::PullParser->new;
34
$p->set_source($file_or_textref);
35
my $file = !ref $file_or_textref && $file_or_textref;
42
$process_no = $w->{ProcessNo};
44
$w->{'sections'} = [];
45
$w->{'pod_tag'} = '10000'; # counter
46
#XXX my $style_stack = $w->{'style_stack'} ||= []; # || is probably harmful
47
my $style_stack = $w->{'style_stack'} = [];
51
DEBUG and $file and warn "Pull-parsing $file (process number $process_no)\n";
52
$w->{'pod_title'} = $p->get_short_title || $title || $file;
54
my($token, $tagname, $style);
55
my $last_update = Tk::timeofday();
56
while($token = $p->get_token) {
58
DEBUG > 7 and warn " t:", $token->dump, "\n";
61
DEBUG > 10 and warn " ->pod_text( ", $token->text, ")\n";
62
$w->pod_text( $token );
64
} elsif($token->is_start) {
65
($tagname = $token->tagname ) =~ tr/-:./__/;
66
$style = "style_" . $tagname;
67
$tagname = "pod_start_" . $tagname;
68
DEBUG > 7 and warn " ->$tagname & ->$style\n";
69
push @pod_marks, $w->index('end -1c');
70
# Yes, save the start-point for every element,
71
# for feeding to its end-tag event.
73
if( $w->can($style) ) {
74
push @$style_stack, $w->$style($token);
75
DEBUG > 5 and warn "Style stack after adding ->$style: ",
76
join("|", map join('.',@$_), @{ $w->{'style_stack'} } ), "\n";
79
&{ $w->can($tagname) || next }( $w, $token );
80
DEBUG > 10 and warn " back from ->$tagname\n";
82
} elsif($token->is_end) {
83
($tagname = $token->tagname ) =~ tr/-:./__/;
84
$style = "style_" . $tagname;
85
$tagname = "pod_end_" . $tagname;
87
DEBUG > 7 and warn " ->$tagname & $style\n";
89
&{ $w->can($tagname) || \&no_op }( $w, $token, pop(@pod_marks) );
90
# the output of that pop() is the start-point of this element
91
DEBUG > 10 and warn " back from ->$tagname\n";
93
if( $w->can($style) ) {
95
DEBUG > 5 and warn "Style stack after popping results of ->$style: ",
96
join("|", map join('.',@$_), @{ $w->{'style_stack'} } ), "\n";
100
if (Tk::timeofday() > $last_update+0.5) { # XXX make configurable
102
$last_update = Tk::timeofday();
103
do { warn "ABORT!"; return } if $w->{ProcessNo} != $process_no;
109
delete $w->{'pod_parser'};
110
DEBUG and $file and warn "Done rendering $file\n";
112
$w->parent->add_section_menu if $w->parent->can('add_section_menu');
113
$w->Callback('-poddone', $file);
114
# set (invisible) insertion cursor to top of file
115
$w->markSet(insert => '@0,0');
116
$w->toplevel->Unbusy;
119
###########################################################################
123
if( $w->{'pod_in_X'} ) {
126
# Emit it with whatever styles are in effect.
128
my %attributes = (map @$_, @{ $w->{'style_stack'} } );
129
DEBUG > 4 and warn "Inserting <", $t->text, "> with attributes: ",
130
join('/', %attributes), "\n";
132
my $startpoint = $w->index('end -1c');
133
$w->insert( 'end -1c', $t->text );
137
$w->tag_for(\%attributes),
138
$startpoint => 'end -1c'
144
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
146
sub pod_start_Document {
147
$_[0]->toplevel->title( "Tkpod: " . $_[0]->{'pod_title'} . " (loading)");
148
$_[0]->toplevel->update;
149
# XXX Is it bad form to manipulate the top level?
153
sub pod_end_Document {
154
$_[0]->toplevel->title( "Tkpod: " . $_[0]->{'pod_title'});
155
$_[0]->toplevel->update;
156
# XXX Is it bad form to manipulate the top level?
160
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
162
sub nlnl { $_[0]->insert( 'end -1c', "\n\n" ); $_[0]; }
163
sub nl { $_[0]->insert( 'end -1c', "\n" ); $_[0]; }
165
sub fake_unget_bold_text {
166
require Pod::Simple::PullParserStartToken;
167
require Pod::Simple::PullParserTextToken;
168
require Pod::Simple::PullParserEndToken;
170
$_[0]{'pod_parser'}->unget_token(
171
Pod::Simple::PullParserStartToken->new('B'),
172
Pod::Simple::PullParserTextToken->new($_[1]),
173
Pod::Simple::PullParserEndToken->new('B'),
177
sub pod_start_item_bullet {
178
$_[0]->fake_unget_bold_text('* ');
180
sub pod_start_item_number {
181
$_[0]->fake_unget_bold_text($_[1]->attr('number') . '. ');
184
sub pod_end_Para { $_[0]->_indent($_[2]); $_[0]->nlnl }
185
sub pod_end_Verbatim { $_[0]->_indent($_[2]); $_[0]->nlnl }
186
sub pod_end_item_bullet { $_[0]->_indent($_[2]); $_[0]->nlnl }
187
sub pod_end_item_number { $_[0]->_indent($_[2]); $_[0]->nlnl }
188
sub pod_end_item_text { $_[0]->_indent($_[2]); $_[0]->nl }
190
sub pod_end_over_text { $_[0]->nl } # XXX ok?
193
my ($w, $start) = @_;
196
foreach my $s (@{ $w->{'style_stack'} }) {
197
$indent += $s->[1] if @$s and $s->[0] eq 'indent';
198
# yes, indent is special -- it always has to be first
200
$indent = 0 if $indent < 0;
202
DEBUG > 5 and warn "Style stack giving indent of $indent for $start: ",
203
join("|", map join('.',@$_), @{ $w->{'style_stack'} } ), "\n";
205
my $tag = "Indent" . ($indent+0);
206
unless (exists $w->{'pod_indent_tag_known'}{$tag}) {
207
$w->{'pod_indent_tag_known'}{$tag} = 1;
209
$indent *= 8; # XXX Why 8?
211
$w->tag('configure' => $tag,
212
'-lmargin2' => $indent . 'p',
213
'-rmargin' => $indent . 'p',
214
'-lmargin1' => $indent . 'p'
217
$w->tag('add', $tag, $start, 'end -1c');
218
DEBUG > 3 and warn "Applying $tag to $start\n";
223
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
224
# All we need for X<...>, I think:
225
sub pod_start_X { $_[0]{'pod_in_X'}++; return; }
226
sub pod_end_X { $_[0]{'pod_in_X'}--; return; }
227
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
232
join( '~', map {; $_, $attr->{$_}}
239
$w->{'known_tags'}{$canonical_form} ||=
241
# initialize and return a new tagname
242
DEBUG and warn "Making a tag for $canonical_form\n";
243
$attr->{'family'} = 'times' unless exists $attr->{'family'};
244
$attr->{'weight'} = 'medium' unless exists $attr->{'weight'};
245
$attr->{'slant'} = 'r' unless exists $attr->{'slant'};
246
$attr->{'size'} = 10 unless exists $attr->{'size'};
247
$attr->{'spacing'} = '*' unless exists $attr->{'spacing'};
248
$attr->{'slant'} = substr( $attr->{'slant'},0,1 );
250
my $font_name = join ' ',
253
($attr->{'weight'} ne 'medium') ? 'bold' : (),
254
($attr->{'slant'} ne 'r' ) ? 'italic' : (),
257
DEBUG and warn "Defining new tag $canonical_form with font $font_name\n";
261
'-font' => $font_name,
262
('none' eq ($attr->{'wrap'} || '')) ? ('-wrap' => 'none') : (),
263
$attr->{'underline'} ? ('-underline' => 'true') : (),
265
DEBUG > 10 and sleep 1;
271
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
274
push @{ $_[0]->{'pod_L_attr_stack'} }, $_[1]->attr_hash;
279
my $attr = pop @{ $w->{'pod_L_attr_stack'} };
281
#$w->tag('add', 'L' , $_[2], 'end -1c');
283
my $tag = # make a unique identifier for this guy:
285
map defined($_) ? $_ : '',
286
@$attr{'type', 'to', 'section'};
290
DEBUG > 2 and warn "Link-tag <$tag>\n";
292
my $to = $attr->{'to'} ; # might be undef!
293
my $section = $attr->{'section'}; # might be undef!
296
if($attr->{'type'} eq 'pod') {
297
#$methodname = defined($to) ? 'Link' : 'Link_my_section';
298
$methodname = 'Link';
299
} elsif($attr->{'type'} eq 'url') {
300
$methodname = 'Link_url'
301
} elsif($attr->{'type'} eq 'man') {
302
$methodname = 'Link_man'
304
DEBUG and warn "Unknown link-type $$attr{'type'}!\n";
307
$section = '' . $section if defined $section and ref $section;
309
if(!defined $methodname) {
310
DEBUG > 2 and warn "No method for $$attr{'type'} links.\n";
311
} elsif($w->can($methodname)) {
312
DEBUG > 2 and warn "Binding $tag to $methodname\n";
313
$w->tag('bind', $tag, '<ButtonRelease-1>',
314
[$w, $methodname, 'reuse', Tk::Ev('@%x,%y'), $to, $section]);
315
$w->tag('bind', $tag, '<Shift-ButtonRelease-1>',
316
[$w, $methodname, 'new', Tk::Ev('@%x,%y'), $to, $section]);
317
$w->tag('bind', $tag, '<ButtonRelease-2>',
318
[$w, $methodname, 'new', Tk::Ev('@%x,%y'), $to, $section]);
319
$w->tag('bind', $tag, '<Enter>' => [$w, 'EnterLink']);
320
$w->tag('bind', $tag, '<Leave>' => [$w, 'LeaveLink']);
321
$w->tag('configure', $tag, '-underline' => 1, '-foreground' => 'blue' );
323
DEBUG > 2 and warn "Can't bind $tag to $methodname\n";
325
$w->tag('configure', $tag, '-underline' => 1, '-foreground' => 'darkgreen' );
327
$w->tag('add', $tag, $_[2] ,'end -1c');
332
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
334
sub pod_start_head1 { $_[0]->_common_heading('head1'); }
335
sub pod_start_head2 { $_[0]->_common_heading('head2'); }
336
sub pod_start_head3 { $_[0]->_common_heading('head3'); }
337
sub pod_start_head4 { $_[0]->_common_heading('head4'); }
339
sub pod_end_head1 { $_[0]->nlnl }
340
sub pod_end_head2 { $_[0]->nlnl }
341
sub pod_end_head3 { $_[0]->nlnl }
342
sub pod_end_head4 { $_[0]->nlnl }
344
sub _common_heading {
346
my $p = $w->{'pod_parser'};
353
while($token = $p->get_token) {
354
push @to_put_back, $token;
355
if( $token->is_end ) {
356
last if $token->is_tag($end_tag);
357
--$in_X if $token->is_tag('X');
358
} elsif($token->is_start) {
359
++$in_X if $token->is_tag('X');
360
} elsif($token->is_text) {
361
$text .= $token->text unless $in_X;
363
last if @to_put_back > 40; # too complex a heading!
368
$end_tag =~ m/(\d+)$/ or die "WHAAAT? $end_tag!?";
370
push @{$w->{'sections'}}, [$level, $text, $w->index('end')];
371
DEBUG and warn "Noting section heading head$level \"$text\".\n";
374
$p->unget_token(@to_put_back);
378
# ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
380
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
381
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
382
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
388
Tk::Pod::SimpleBridge -- render Pod::Simple events to a Tk::Pod window
393
This is a class internal to Tk::Pod.
394
No user-serviceable parts inside.
399
This class contains methods that Tk::Pod (specifically Tk::Pod::Text)
400
uses to render a pod page's text into its window. It uses L<Pod::Simple>
401
(specifically L<Pod::Simple::PullParser>) to do the parsing.
403
Tk::Pod used to use Tk::Parse (a snapshot of an old old Pod-parser)
404
to do the Pod-parsing. But it doesn't anymore -- it now uses Pod::Simple
407
=head1 COPYRIGHT AND DISCLAIMERS
409
Copyright (c) 2002 Sean M. Burke. All rights reserved.
411
This library is free software; you can redistribute it and/or modify it
412
under the same terms as Perl itself.
414
This program is distributed in the hope that it will be useful, but
415
without any warranty; without even the implied warranty of
416
merchantability or fitness for a particular purpose.
420
Sean M. Burke <F<sburke@cpan.org>>, with bits of Tk code cribbed from
421
the old Tk::Pod::Text code that Nick Ing-Simmons
422
<F<nick@ni-s.u-net.com>> originally wrote.
424
Current maintainer is Slaven Rezic <F<slaven@rezic.de>>.
added
removed
0CPAN/Tk-Pod-0.9932/Pod/SimpleBridge.pm
