1use strict; 2use warnings; 3use Prima; 4use Config; 5use Prima::Utils; 6use Prima::TextView; 7use Encode; 8 9package Prima::PodView::Link; 10use vars qw(@ISA); 11@ISA = qw( Prima::TextView::EventRectangles Prima::TextView::EventContent ); 12 13sub on_mousedown 14{ 15 my ( $self, $owner, $btn, $mod, $x, $y) = @_; 16 my $r = $self-> contains( $x, $y); 17 return 1 if $r < 0; 18 $r = $self-> {rectangles}-> [$r]; 19 $r = $self-> {references}-> [$$r[4]]; 20 $owner-> link_click( $r, $btn, $mod, $x, $y); 21 return 0; 22} 23 24sub on_mousemove 25{ 26 my ( $self, $owner, $mod, $x, $y) = @_; 27 my $r = $self-> contains( $x, $y); 28 if ( $r != $owner-> {lastLinkPointer}) { 29 my $was_hand = ($owner->{lastLinkPointer} >= 0) ? 1 : 0; 30 my $is_hand = ($r >= 0) ? 1 : 0; 31 if ( $is_hand != $was_hand) { 32 $owner-> pointer( $is_hand ? cr::Hand : cr::Text ); 33 } 34 my $rr = $self->rectangles; 35 my ($dx, $dy) = $owner->point2screen(0,0); 36 my $or = $owner->{lastLinkPointer}; 37 $owner-> {lastLinkPointer} = $r; 38 if ( $was_hand ) { 39 $or = $rr->[$or]; 40 $owner-> invalidate_rect($or->[0] + $dx, $dy - $or->[1], $or->[2] + $dx, $dy - $or->[3]); 41 } 42 if ( $is_hand ) { 43 $or = $rr->[$r]; 44 $owner-> invalidate_rect($or->[0] + $dx, $dy - $or->[1], $or->[2] + $dx, $dy - $or->[3]); 45 } 46 } 47} 48 49sub on_paint 50{ 51 my ( $self, $owner, $canvas, $ci ) = @_; 52 my ($dx, $dy) = $owner->point2screen(0,0); 53 my $r = $self->rectangles->[ $owner->{lastLinkPointer} ]; 54 my $c = $canvas-> color; 55 $canvas-> color( $owner-> {colorMap}->[ $ci ]); 56 $canvas-> translate(0,0); 57 $canvas-> line( $r->[0] + $dx, $dy - $r->[3], $r->[2] + $dx, $dy - $r->[3]); 58 $canvas-> color( $c); 59} 60 61package Prima::PodView; 62 63use vars qw(@ISA %HTML_Escapes $OP_LINK); 64@ISA = qw(Prima::TextView); 65 66use constant DEF_INDENT => 4; 67use constant DEF_FIRST_INDENT => 1; 68 69use constant COLOR_LINK_FOREGROUND => 2 | tb::COLOR_INDEX; 70use constant COLOR_LINK_BACKGROUND => 3 | tb::COLOR_INDEX; 71use constant COLOR_CODE_FOREGROUND => 4 | tb::COLOR_INDEX; 72use constant COLOR_CODE_BACKGROUND => 5 | tb::COLOR_INDEX; 73 74use constant STYLE_CODE => 0; 75use constant STYLE_TEXT => 1; 76use constant STYLE_HEAD_1 => 2; 77use constant STYLE_HEAD_2 => 3; 78use constant STYLE_HEAD_3 => 4; 79use constant STYLE_HEAD_4 => 5; 80use constant STYLE_ITEM => 6; 81use constant STYLE_LINK => 7; 82use constant STYLE_VERBATIM => 8; 83use constant STYLE_MAX_ID => 8; 84 85# model layout indices 86use constant M_TYPE => 0; # T_XXXX 87 # T_NORMAL 88use constant M_TEXT_OFFSET => 1; # contains same info as BLK_TEXT_OFFSET 89use constant M_INDENT => 2; # pod-content driven indent 90use constant M_FONT_ID => 3; # 0 or 1 ( i.e., variable or fixed ) 91use constant M_START => 4; # start of data, same purpose as BLK_START 92 # T_DIV 93use constant MDIV_TAG => 2; 94use constant MDIV_STYLE => 3; 95 96# model entries 97use constant T_NORMAL => 0; 98use constant T_DIV => 1; 99use constant TDIVTAG_OPEN => 0; 100use constant TDIVTAG_CLOSE => 1; 101use constant TDIVSTYLE_SOLID => 0; 102use constant TDIVSTYLE_OUTLINE => 1; 103 104# topic layout indices 105use constant T_MODEL_START => 0; # beginning of topic 106use constant T_MODEL_END => 1; # end of a topic 107use constant T_DESCRIPTION => 2; # topic name 108use constant T_STYLE => 3; # style of STYLE_XXX 109use constant T_ITEM_DEPTH => 4; # depth of =item recursion 110use constant T_LINK_OFFSET => 5; # 111 112# formatting constants 113use constant FORMAT_LINES => 100; 114use constant FORMAT_TIMEOUT => 300; 115 116$OP_LINK = tb::opcode(1, 'link'); 117 118sub model_create 119{ 120 my %opt = @_; 121 return ( 122 $opt{type} // T_NORMAL, 123 $opt{offset} // 0, 124 $opt{indent} // 0, 125 $opt{font} // 0 126 ); 127} 128 129sub div_create 130{ 131 my %opt = @_; 132 return ( 133 T_DIV, 134 $opt{offset} // 0, 135 $opt{open} ? TDIVTAG_OPEN : TDIVTAG_CLOSE, 136 $opt{style} // TDIVSTYLE_SOLID, 137 ); 138} 139 140{ 141my %RNT = ( 142 %{Prima::TextView-> notification_types()}, 143 Link => nt::Default, 144 Bookmark => nt::Default, 145 NewPage => nt::Default, 146); 147 148sub notification_types { return \%RNT; } 149} 150 151sub profile_default 152{ 153 my $def = $_[ 0]-> SUPER::profile_default; 154 my %prf = ( 155 colorMap => [ 156 $def-> {color}, 157 $def-> {backColor}, 158 0x337ab7, # link foreground 159 $def-> {backColor}, # link background 160 cl::Blue, # code foreground 161 0xf5f5f5, # code background 162 ], 163 images => [], 164 styles => [ 165 { fontId => 1, # STYLE_CODE 166 color => COLOR_CODE_FOREGROUND, 167 backColor => COLOR_CODE_BACKGROUND 168 }, 169 { }, # STYLE_TEXT 170 { fontSize => 4, fontStyle => fs::Bold }, # STYLE_HEAD_1 171 { fontSize => 2, fontStyle => fs::Bold }, # STYLE_HEAD_2 172 { fontSize => 1, fontStyle => fs::Bold }, # STYLE_HEAD_3 173 { fontSize => 1, fontStyle => fs::Bold }, # STYLE_HEAD_4 174 { fontStyle => fs::Bold }, # STYLE_ITEM 175 { color => COLOR_LINK_FOREGROUND}, # STYLE_LINK 176 { fontId => 1, # STYLE_VERBATIM 177 color => COLOR_CODE_FOREGROUND, 178 }, 179 ], 180 pageName => '', 181 topicView => 0, 182 textDirection => $::application->textDirection, 183 ); 184 @$def{keys %prf} = values %prf; 185 return $def; 186} 187 188 189sub init 190{ 191 my $self = shift; 192 $self-> {model} = []; 193 $self-> {links} = []; 194 $self-> {styles} = []; 195 $self-> {pageName} = ''; 196 $self-> {manpath} = ''; 197 $self-> {modelRange} = [0,0,0]; 198 $self-> {postBlocks} = {}; 199 $self-> {topics} = []; 200 $self-> {hasIndex} = 0; 201 $self-> {topicView} = 0; 202 $self-> {lastLinkPointer} = -1; 203 my %profile = $self-> SUPER::init(@_); 204 205 $self-> {contents} = [ Prima::PodView::Link-> new ]; 206 207 my %font = %{$self-> fontPalette-> [0]}; 208 $font{pitch} = fp::Fixed; 209 $self-> {fontPalette}-> [1] = \%font; 210 $self-> {fontPaletteSize} = 2; 211 212 $self-> $_($profile{$_}) for qw( styles images pageName topicView); 213 214 return %profile; 215} 216 217sub on_paint 218{ 219 my ( $self, $canvas ) = @_; 220 $self-> SUPER::on_paint($canvas); 221 $self-> {contents}-> [0]-> on_paint( $self, $canvas, COLOR_LINK_FOREGROUND & ~tb::COLOR_INDEX ) 222 if $self->{lastLinkPointer} >= 0 223} 224 225sub on_size 226{ 227 my ( $self, $oldx, $oldy, $x, $y) = @_; 228 $self-> SUPER::on_size( $oldx, $oldy, $x, $y); 229 $self-> format(1) if $oldx != $x; 230} 231 232sub on_fontchanged 233{ 234 my $self = $_[0]; 235 $self-> SUPER::on_fontchanged; 236 $self-> format(1); 237} 238 239# sub on_link { 240# my ( $self, $linkPointer, $mouseButtonOrKeyEventIfZero, $mod, $x, $y) = @_; 241# } 242 243# returns a storable string, that identifies position. 244# can report current positions and links to the upper topic 245sub make_bookmark 246{ 247 my ( $self, $where) = @_; 248 249 return undef unless length $self-> {pageName}; 250 if ( !defined $where) { # current position 251 my ( $ofs, $bid) = $self-> xy2info( $self-> {offset}, $self-> {topLine}); 252 my $topic = $self-> {modelRange}-> [0]; 253 $ofs = $self-> {blocks}-> [$bid]-> [tb::BLK_TEXT_OFFSET] + $ofs; 254 return "$self->{pageName}|$topic|$ofs\n"; 255 } elsif ( $where =~ /up|next|prev/ ) { # up 256 if ( $self-> {topicView} ) { 257 my $topic = $self-> {modelRange}-> [0]; 258 return undef if $where =~ /up|prev/ && $topic == 0; # contents 259 my $tid = -1; 260 my $t; 261 for ( @{$self-> {topics}}) { 262 $tid++; 263 next unless $$_[T_MODEL_START] == $topic; 264 $t = $_; 265 last; 266 } 267 268 if ( $where =~ /next|prev/) { 269 return undef unless defined $t; 270 my $index = scalar @{$self-> {topics}} - 1; 271 $tid += ( $where =~ /next/) ? 1 : -1; 272 return undef if $tid < 0 || $tid > $index; 273 $t = $self-> {topics}-> [$tid]-> [T_MODEL_START]; 274 return "$self->{pageName}|$t|0"; 275 } 276 277 return "$self->{pageName}|0|0" unless defined $t; 278 if ( $$t[ T_STYLE] >= STYLE_HEAD_1 && $$t[ T_STYLE] <= STYLE_HEAD_4) { 279 $t = $self-> {topics}-> [0]; 280 return "$self->{pageName}|$$t[T_MODEL_START]|0" 281 } 282 my $state = $$t[ T_STYLE] - STYLE_HEAD_1 + $$t[ T_ITEM_DEPTH]; 283 $state-- if $state > 0; 284 while ( $tid--) { 285 $t = $self-> {topics}-> [$tid]; 286 $t = $$t[ T_STYLE] - STYLE_HEAD_1 + $$t[ T_ITEM_DEPTH]; 287 $t-- if $t > 0; 288 next if $t >= $state; 289 $t = $self-> {topics}-> [$tid]-> [T_MODEL_START]; 290 return "$self->{pageName}|$t|0"; 291 } 292 # return index 293 $t = $self-> {topics}-> [-1]-> [T_MODEL_START]; 294 return "$self->{pageName}|$t|0"; 295 } 296 } 297 return undef; 298} 299 300sub load_bookmark 301{ 302 my ( $self, $mark) = @_; 303 304 return 0 unless defined $mark; 305 306 my ( $page, $topic, $ofs) = split( '\|', $mark, 3); 307 return 0 unless $ofs =~ /^\d+$/ && $topic =~ /^\d+$/; 308 309 310 if ( $page ne $self-> {pageName}) { 311 my $ret = $self-> load_file( $page); 312 return 2 if $ret != 1; 313 } 314 315 if ( $self-> {topicView}) { 316 for my $k ( @{$self-> {topics}}) { 317 next if $$k[T_MODEL_START] != $topic; 318 $self-> select_topic($k); 319 last; 320 } 321 } 322 $self-> select_text_offset( $ofs); 323 324 return 1; 325} 326 327sub load_link 328{ 329 my ( $self, $s) = @_; 330 331 my $mark = $self-> make_bookmark; 332 my $t; 333 if ( $s =~ /^topic:\/\/(.*)$/) { # local topic 334 $t = $1; 335 return 0 unless $t =~ /^\d+$/; 336 return 0 if $t < 0 || $t >= scalar @{$self-> {topics}}; 337 } 338 339 my $doBookmark; 340 341 unless ( defined $t) { # page / section / item 342 my ( $page, $section, $item, $lead_slash) = ( '', '', 1, ''); 343 my $default_topic = 0; 344 345 if ( $s =~ /^file:\/\/(.*)$/) { 346 $page = $1; 347 } elsif ( $s =~ m{^([:\w]+)/?$} ) { 348 $page = $1; 349 } elsif ( $s =~ /^([^\/]*)(\/)(.*)$/) { 350 ( $page, $lead_slash, $section) = ( $1, $2, $3); 351 } else { 352 $section = $s; 353 } 354 $item = 0 if $section =~ s/^\"(.*?)\"$/$1/; 355 356 if ( !length $page) { 357 my $tid = -1; 358 for ( @{$self-> {topics}}) { 359 $tid++; 360 next unless $section eq $$_[T_DESCRIPTION]; 361 next if !$item && $$_[T_STYLE] == STYLE_ITEM; 362 $t = $tid; 363 last; 364 } 365 if ( !defined $t || $t < 0) { 366 $tid = -1; 367 my $s = quotemeta $section; 368 for ( @{$self-> {topics}}) { 369 $tid++; 370 next unless $$_[T_DESCRIPTION] =~ m/^$s/; 371 next if !$item && $$_[T_STYLE] == STYLE_ITEM; 372 $t = $tid; 373 last; 374 } 375 } 376 unless ( defined $t) { # no such topic, must be a page? 377 $page = $lead_slash . $section; 378 $section = ''; 379 } 380 } 381 if ( length $page and $page ne $self-> {pageName}) { # new page? 382 if ( $self-> load_file( $page) != 1) { 383 $self-> notify(q(Bookmark), $mark) if $mark; 384 return 0; 385 } 386 $doBookmark = 1; 387 } 388 389 if ( ! defined $t) { 390 $t = $default_topic if length $page && $self-> {topicView}; 391 my $tid = -1; 392 for ( @{$self-> {topics}}) { 393 $tid++; 394 next unless $section eq $$_[T_DESCRIPTION]; 395 $t = $tid; 396 last; 397 } 398 if ( length( $section) and ( !defined $t || $t < 0)) { 399 $tid = -1; 400 my $s = quotemeta $section; 401 for ( @{$self-> {topics}}) { 402 $tid++; 403 next unless $$_[T_DESCRIPTION] =~ m/^$s/; 404 $t = $tid; 405 last; 406 } 407 } 408 } 409 } 410 411 if ( defined $t) { 412 if ( $t = $self-> {topics}-> [$t]) { 413 if ( $self-> {topicView}) { 414 $self-> select_topic($t); 415 } else { 416 $self-> select_text_offset( 417 $self-> {model}-> [ $$t[ T_MODEL_START]]-> [ M_TEXT_OFFSET] 418 ); 419 } 420 $self-> notify(q(Bookmark), $mark) if $mark; 421 return 1; 422 } 423 } elsif ( $doBookmark) { 424 $self-> notify(q(Bookmark), $mark) if $mark; 425 return 1; 426 } 427 428 return 0; 429} 430 431sub link_click 432{ 433 my ( $self, $s, $btn, $mod, $x, $y) = @_; 434 435 return unless $self-> notify(q(Link), \$s, $btn, $mod, $x, $y); 436 return if $btn != mb::Left; 437 $self-> load_link( $s); 438} 439 440# selects a sub-page; does not check if topicView, 441# so must be called with care 442sub select_topic 443{ 444 my ( $self, $t) = @_; 445 my @mr1 = @{$self-> {modelRange}}; 446 if ( defined $t) { 447 $self-> {modelRange} = [ 448 $$t[ T_MODEL_START], 449 $$t[ T_MODEL_END], 450 $$t[ T_LINK_OFFSET] 451 ] 452 } else { 453 $self-> {modelRange} = [ 0, scalar @{$self-> {model}} - 1, 0 ] 454 } 455 my @mr2 = @{$self-> {modelRange}}; 456 457 if ( grep { $mr1[$_] != $mr2[$_] } 0 .. 2) { 458 $self-> lock; 459 $self-> topLine(0); 460 $self-> offset(0); 461 $self-> selection(-1,-1,-1,-1); 462 $self-> format; 463 $self-> unlock; 464 $self-> notify(q(NewPage)); 465 } 466} 467 468 469sub topicView 470{ 471 return $_[0]-> {topicView} unless $#_; 472 my ( $self, $tv) = @_; 473 $tv = ( $tv ? 1 : 0); 474 return if $self-> {topicView} == $tv; 475 $self-> {topicView} = $tv; 476 return unless length $self-> {pageName}; 477 $self-> load_file( $self-> {pageName}); 478} 479 480 481sub pageName 482{ 483 return $_[0]-> {pageName} unless $#_; 484 $_[0]-> {pageName} = $_[1]; 485} 486 487sub textDirection 488{ 489 return $_[0]-> {textDirection} unless $#_; 490 my ( $self, $td ) = @_; 491 $self-> {textDirection} = $td; 492} 493 494sub styles 495{ 496 return $_[0]-> {styles} unless $#_; 497 my ( $self, @styles) = @_; 498 @styles = @{$styles[0]} if ( scalar(@styles) == 1) && ( ref($styles[0]) eq 'ARRAY'); 499 if ( $#styles < STYLE_MAX_ID) { 500 my @as = @{$_[0]-> {styles}}; 501 my @pd = @{$_[0]-> profile_default-> {styles}}; 502 while ( $#styles < STYLE_MAX_ID) { 503 if ( $as[ $#styles]) { 504 $styles[ $#styles + 1] = $as[ $#styles + 1]; 505 } else { 506 $styles[ $#styles + 1] = $pd[ $#styles + 1]; 507 } 508 } 509 } 510 $self-> {styles} = \@styles; 511 $self-> update_styles; 512 513} 514 515sub images 516{ 517 return $_[0]-> {images} unless $#_; 518 my ( $self, $images) = @_; 519 $self-> {images} = $images; 520 $self-> repaint; 521} 522 523sub update_styles # used for the direct {styles} hacking 524{ 525 my $self = $_[0]; 526 my @styleInfo; 527 for ( @{$self-> {styles}}) { 528 my $x = $_; 529 my ( @forw, @rev); 530 for ( qw( fontId fontSize fontStyle color backColor)) { 531 next unless exists $x-> {$_}; 532 push @forw, $tb::{$_}-> ( $x-> {$_}); 533 push @rev, $tb::{$_}-> ( 0); 534 } 535 push @styleInfo, \@forw, \@rev; 536 } 537 $self-> {styleInfo} = \@styleInfo; 538} 539 540sub message 541{ 542 my ( $self, $message, $error) = @_; 543 my $x; 544 $self-> open_read( createIndex => 0 ); 545 if ( $error) { 546 $x = $self-> {styles}-> [STYLE_HEAD_1]-> {color}; 547 $self-> {styles}-> [STYLE_HEAD_1]-> {color} = cl::Red; 548 $self-> update_styles; 549 } 550 $self-> read($message); 551 $self-> close_read( 0); 552 if ( $error) { 553 my $z = $self-> {styles}-> [STYLE_HEAD_1]; 554 defined $x ? $z-> {color} = $x : delete $z-> {color}; 555 $self-> update_styles; 556 } 557 $self-> pageName(''); 558 $self-> {manpath} = ''; 559} 560 561sub load_file 562{ 563 my ( $self, $manpage) = @_; 564 my $pageName = $manpage; 565 my $path = ''; 566 567 unless ( -f $manpage) { 568 my ( $fn, $mpath); 569 my @ext = ( '.pod', '.pm', '.pl' ); 570 push @ext, ( '.bat' ) if $^O =~ /win32/i; 571 push @ext, ( '.com' ) if $^O =~ /VMS/; 572 for ( map { $_, "$_/pod", "$_/pods" } 573 grep { defined && length && -d } 574 @INC, 575 split( $Config::Config{path_sep}, $ENV{PATH})) { 576 if ( -f "$_/$manpage") { 577 $manpage = "$_/$manpage"; 578 $path = $_; 579 last; 580 } 581 $fn = "$_/$manpage"; 582 $fn =~ s/::/\//g; 583 $mpath = $fn; 584 $mpath =~ s/\/[^\/]*$//; 585 for ( @ext ) { 586 if ( -f "$fn$_") { 587 $manpage = "$fn$_"; 588 $path = $mpath; 589 goto FOUND; 590 } 591 } 592 } 593 } 594FOUND: 595 596 unless ( open F, "< $manpage") { 597 my $m = <<ERROR; 598\=head1 Error 599 600Error loading '$manpage' : $! 601 602ERROR 603 $m =~ s/^\\=/=/gm; 604 undef $self-> {source_file}; 605 $self-> message( $m, 1); 606 return 0; 607 } 608 609 $self-> pointer( cr::Wait); 610 $self-> {manpath} = $path; 611 $self-> {source_file} = $manpage; 612 $self-> open_read; 613 $self-> read($_) while <F>; 614 close F; 615 616 $self-> pageName( $pageName); 617 my $ret = $self-> close_read( $self-> {topicView}); 618 619 $self-> pointer( cr::Default); 620 621 unless ( $ret) { 622 $_ = <<ERROR; 623\=head1 Warning 624 625The file '$manpage' does not contain any POD context 626 627ERROR 628 s/^\\=/=/gm; 629 $self-> message($_); 630 return 2; 631 } 632 return 1; 633} 634 635sub load_content 636{ 637 my ( $self, $content) = @_; 638 my $path = ''; 639 $self-> {manpath} = ''; 640 undef $self-> {source_file}; 641 $self-> open_read; 642 $self-> read($content); 643 return $self-> close_read( $self-> {topicView}); 644} 645 646 647sub open_read 648{ 649 my ($self, @opt) = @_; 650 return if $self-> {readState}; 651 $self-> clear_all; 652 $self-> {readState} = { 653 cutting => 1, 654 pod_cutting => 1, 655 begun => '', 656 bulletMode => 0, 657 658 indent => DEF_INDENT, 659 indentStack => [], 660 661 bigofs => 0, 662 wrapstate => '', 663 wrapindent => 0, 664 665 topicStack => [[-1]], 666 ignoreFormat => 0, 667 668 createIndex => 1, 669 encoding => undef, 670 bom => undef, 671 utf8 => undef, 672 verbatim => undef, 673 674 @opt, 675 }; 676} 677 678sub load_image 679{ 680 my ( $self, $src, $frame ) = @_; 681 return Prima::Icon-> load( $src, index => $frame, iconUnmask => 1) 682 if -f $src; 683 684 $src =~ s!::!/!g; 685 for my $path ( 686 map {( "$_", "$_/pod")} 687 grep { defined && length && -d } 688 ( length($self-> {manpath}) ? $self-> {manpath} : (), @INC) 689 ) { 690 return Prima::Icon-> load( "$path/$src", index => $frame, iconUnmask => 1) 691 if -f "$path/$src" && -r _; 692 } 693 return; 694} 695 696sub add_image 697{ 698 my ( $self, $src, %opt ) = @_; 699 700 my $w = $opt{width} // $src-> width; 701 my $h = $opt{height} // $src-> height; 702 my @resolution = $self-> resolution; 703 $w *= 72 / $resolution[0]; 704 $h *= 72 / $resolution[1]; 705 $src-> {stretch} = [$w, $h]; 706 $self-> {readState}-> {pod_cutting} = $opt{cut} ? 0 : 1 707 if defined $opt{cut}; 708 709 my @imgop = ( 710 tb::moveto( 2, 0, tb::X_DIMENSION_FONT_HEIGHT), 711 tb::wrap(tb::WRAP_MODE_OFF), 712 tb::extend( $w, $h, tb::X_DIMENSION_POINT), 713 tb::code( \&_imgpaint, $src), 714 tb::moveto( $w, 0, tb::X_DIMENSION_POINT), 715 tb::wrap(tb::WRAP_MODE_ON) 716 ); 717 718 push @{$self-> {model}}, 719 $opt{title} ? [div_create(open => 1, style => TDIVSTYLE_OUTLINE)] : (), 720 [model_create( 721 indent => $self-> {readState}-> {indent}, 722 offset => $self-> {readState}-> {bigofs} 723 ), 724 @imgop], 725 ; 726 if ( $opt{title}) { 727 my $r = $self-> {readState}; 728 729 my @g = model_create( 730 indent => $self-> {readState}-> {indent}, 731 offset => $r-> {bigofs} 732 ); 733 push @g, 734 tb::moveto( 2, 0, tb::X_DIMENSION_FONT_HEIGHT), 735 tb::fontStyle(fs::Italic), 736 tb::text(0, length $opt{title}), 737 tb::fontStyle(fs::Normal), 738 ; 739 $opt{title} .= "\n"; 740 ${$self->{text}} .= $opt{title}; 741 $r->{bigofs} += length $opt{title}; 742 743 push @{$self-> {model}}, 744 [model_create, tb::moveto(0, 1, tb::X_DIMENSION_FONT_HEIGHT)], 745 \@g, 746 [model_create, tb::moveto(0, 1, tb::X_DIMENSION_FONT_HEIGHT)], 747 [div_create(open => 0, style => TDIVSTYLE_OUTLINE) ] 748 ; 749 } 750 push @{$self-> {model}}, [model_create, tb::moveto(0, 1, tb::X_DIMENSION_FONT_HEIGHT)]; 751} 752 753sub add_formatted 754{ 755 my ( $self, $format, $text) = @_; 756 757 return unless $self-> {readState}; 758 759 if ( $format eq 'text') { 760 $self-> add($text,STYLE_CODE,0); 761 $self-> add_new_line; 762 } elsif ( $format eq 'podview') { 763 while ( $text =~ m/<\s*([^<>]*)\s*>/gcs) { 764 my $cmd = $1; 765 if ( lc($cmd) eq 'cut') { 766 $self-> {readState}-> {pod_cutting} = 0; 767 } elsif ( lc($cmd) eq '/cut') { 768 $self-> {readState}-> {pod_cutting} = 1; 769 } elsif ( $cmd =~ /^img\s*(.*)$/i) { 770 $cmd = $1; 771 my %opt; 772 while ( $cmd =~ m/\s*([a-z]*)\s*\=\s*(?:(?:'([^']*)')|(?:"([^"]*)")|(\S*))\s*/igcs) { 773 my ( $option, $value) = ( lc $1, defined($2)?$2:(defined $3?$3:$4)); 774 if ( $option =~ /^(width|height|frame)$/ && $value =~ /^\d+$/) { $opt{$option} = $value } 775 elsif ( $option =~ /^(src|cut|title)$/) { $opt{$option} = $value } 776 } 777 if ( defined $opt{src}) { 778 my $img = $self->load_image($opt{src}, $opt{frame} // 0); 779 $self->add_image($img, %opt) if $img; 780 } elsif ( defined $opt{frame} && defined $self->{images}->[$opt{frame}]) { 781 $self->add_image($self->{images}->[$opt{frame}], %opt); 782 } 783 } 784 } 785 } 786} 787 788sub _imgpaint 789{ 790 my ( $self, $canvas, $block, $state, $x, $y, $img) = @_; 791 my ( $dx, $dy) = @{$img->{stretch}}; 792 my @res = $self-> resolution; 793 $dx *= $res[0] / 72; 794 $dy *= $res[1] / 72; 795 $canvas-> stretch_image( $x, $y, $dx, $dy, $img); 796 if ( $self-> {selectionPaintMode}) { 797 my @save = ( fillPattern => $canvas-> fillPattern, rop => $canvas-> rop, fillPatternOffset => [$canvas->fillPatternOffset]); 798 $canvas-> set( fillPattern => fp::Borland, rop => rop::AndPut, fillPatternOffset => [$x, $y]); 799 $canvas-> bar( $x, $y, $x + $dx - 1, $y + $dy - 1); 800 $canvas-> set( @save); 801 } 802} 803 804sub _bulletpaint 805{ 806 my ( $self, $canvas, $block, $state, $x, $y, $filled) = @_; 807 $y -= $$block[ tb::BLK_APERTURE_Y]; 808 my $fh = $canvas-> font-> height * 0.3; 809 $filled ? 810 $canvas-> fill_ellipse( $x + $fh / 2, $y + $$block[ tb::BLK_HEIGHT] / 2, $fh, $fh) : 811 $canvas-> ellipse ( $x + $fh / 2, $y + $$block[ tb::BLK_HEIGHT] / 2, $fh, $fh); 812} 813 814sub read_paragraph 815{ 816 my ( $self, $line ) = @_; 817 my $r = $self-> {readState}; 818 819 for ( $line ) { 820 if ($r-> {cutting}) { 821 next unless /^=/; 822 $r-> {cutting} = 0; 823 } 824 825 unless ($r-> {pod_cutting}) { 826 next unless /^=/; 827 } 828 829 if ($r-> {begun}) { 830 my $begun = $r-> {begun}; 831 if (/^=end\s+$begun/ || /^=cut/) { 832 $r-> {begun} = ''; 833 $self-> add_new_line; # end paragraph 834 $r-> {cutting} = 1 if /^=cut/; 835 } else { 836 $self-> add_formatted( $r-> {begun}, $_); 837 } 838 next; 839 } 840 841 1 while s{^(.*?)(\t+)(.*)$}{ 842 $1 843 . (' ' x (length($2) * 8 - length($1) % 8)) 844 . $3 845 }me; 846 847 # Translate verbatim paragraph 848 if (/^\s/) { 849 $self-> add_verbatim_mark(1) unless defined $r->{verbatim}; 850 $self-> add($_,STYLE_VERBATIM,$r-> {indent}) for split "\n", $_; 851 $self-> add_new_line; 852 next; 853 } 854 $self-> add_verbatim_mark(0); 855 856 if (/^=for\s+(\S+)\s*(.*)/s) { 857 $self-> add_formatted( $1, $2) if defined $2; 858 next; 859 } elsif (/^=begin\s+(\S+)\s*(.*)/s) { 860 $r-> {begun} = $1; 861 $self-> add_formatted( $1, $2) if defined $2; 862 next; 863 } 864 865 if (s/^=//) { 866 my ($Cmd, $args) = split(' ', $_, 2); 867 $args = '' unless defined $args; 868 if ($Cmd eq 'cut') { 869 $r-> {cutting} = 1; 870 } 871 elsif ($Cmd eq 'pod') { 872 $r-> {cutting} = 0; 873 } 874 elsif ($Cmd eq 'head1') { 875 $self-> add( $args, STYLE_HEAD_1, DEF_FIRST_INDENT); 876 } 877 elsif ($Cmd eq 'head2') { 878 $self-> add( $args, STYLE_HEAD_2, DEF_FIRST_INDENT); 879 } 880 elsif ($Cmd eq 'head3') { 881 $self-> add( $args, STYLE_HEAD_3, DEF_FIRST_INDENT); 882 } 883 elsif ($Cmd eq 'head4') { 884 $self-> add( $args, STYLE_HEAD_4, DEF_FIRST_INDENT); 885 } 886 elsif ($Cmd eq 'over') { 887 push(@{$r-> {indentStack}}, $r-> {indent}); 888 $r-> {indent} += ( $args =~ m/^(\d+)$/ ) ? $1 : DEF_INDENT; 889 } 890 elsif ($Cmd eq 'back') { 891 $self-> _close_topic( STYLE_ITEM); 892 $r-> {indent} = pop(@{$r-> {indentStack}}) || 0; 893 } 894 elsif ($Cmd eq 'item') { 895 $self-> add( $args, STYLE_ITEM, $r-> {indentStack}-> [-1] || DEF_INDENT); 896 } 897 elsif ($Cmd eq 'encoding') { 898 $r->{encoding} = Encode::find_encoding($args); # or undef 899 } 900 } 901 else { 902 s/\n/ /g; 903 $self-> add($_, STYLE_TEXT, $r-> {indent}); 904 } 905 906 $self-> add_new_line unless $r->{bulletMode}; 907 } 908} 909 910sub read 911{ 912 my ( $self, $pod) = @_; 913 my $r = $self-> {readState}; 914 return unless $r; 915 916 unless ( defined $r->{bom} ) { 917 if ( $pod =~ s/^(\x{ef}\x{bb}\x{bf})// ) { # don't care about other BOMs so far 918 $r-> {bom} = $1; 919 $r-> {encoding} = Encode::find_encoding('utf-8'); 920 } 921 } 922 923 my $odd = 0; 924 for ( split ( "(\n)", $pod)) { 925 next unless $odd = !$odd; 926 $_ = $r->{encoding}->decode($_, Encode::FB_HTMLCREF) if $r->{encoding}; 927 928 if (defined $r-> {paragraph_buffer}) { 929 if ( /^\s*$/) { 930 my $pb = $r-> {paragraph_buffer}; 931 undef $r-> {paragraph_buffer}; 932 $self-> read_paragraph($pb); 933 } else { 934 $r-> {paragraph_buffer} .= "\n$_"; 935 next; 936 } 937 } elsif ( !/^$/) { 938 $r->{paragraph_buffer} = $_; 939 next; 940 } 941 } 942} 943 944sub close_read 945{ 946 my ( $self, $topicView) = @_; 947 return unless $self-> {readState}; 948 949 my $r = $self-> {readState}; 950 if ( defined $r->{paragraph_buffer}) { 951 my $pb = $r-> {paragraph_buffer}; 952 undef $r-> {paragraph_buffer}; 953 $self-> read_paragraph("$pb\n"); 954 } 955 956 $topicView = $self-> {topicView} unless defined $topicView; 957 $self-> add_new_line; # end 958 $self-> add_verbatim_mark(0); 959 $self-> {contents}-> [0]-> references( $self-> {links}); 960 961 goto NO_INDEX unless $self-> {readState}-> {createIndex}; 962 963 my $secid = 0; 964 my $msecid = scalar(@{$self-> {topics}}); 965 966 unless ( $msecid) { 967 push @{$self-> {topics}}, [ 968 0, scalar @{$self-> {model}} - 1, 969 "Document", STYLE_HEAD_1, 0, 0 970 ] if scalar @{$self-> {model}} > 2; # no =head's, but some info 971 goto NO_INDEX; 972 } 973 974 ## this code creates the Index section, adds it to the end of text, 975 ## and then uses black magic to put it in the front. 976 977 # remember the current end state 978 $self-> _close_topic( STYLE_HEAD_1); 979 my @text_ends_at = ( 980 $r-> {bigofs}, 981 scalar @{$self->{model}}, 982 scalar @{$self->{topics}}, 983 scalar @{$self->{links}}, 984 ); 985 986 # generate index list 987 my $ofs = $self-> {model}-> [$self-> {topics}-> [0]-> [T_MODEL_START]]-> [M_TEXT_OFFSET]; 988 my $firstText = substr( ${$self-> {text}}, 0, ( $ofs > 0) ? $ofs : 0); 989 if ( $firstText =~ /[^\n\s\t]/) { # the 1st lines of text are not =head 990 unshift @{$self-> {topics}}, [ 991 0, $self-> {topics}-> [0]-> [T_MODEL_START] - 1, 992 "Preface", STYLE_HEAD_1, 0, 0 993 ]; 994 $text_ends_at[2]++; 995 $msecid++; 996 } 997 my $start = scalar @{ $self->{model} }; 998 $self-> add_new_line; 999 $self-> add_verbatim_mark(1); 1000 $self-> add( " Contents", STYLE_HEAD_1, DEF_FIRST_INDENT); 1001 $self-> {hasIndex} = 1; 1002 $self-> {topics}->[-1]->[T_MODEL_START] = $start; 1003 my $last_style = STYLE_HEAD_1; 1004 for my $k ( @{$self-> {topics}}) { 1005 last if $secid == $msecid; # do not add 'Index' entry 1006 my ( $ofs, $end, $text, $style, $depth, $linkStart) = @$k; 1007 if ( $style == STYLE_ITEM ) { 1008 $style = $last_style; 1009 } else { 1010 $last_style = $style; 1011 } 1012 my $indent = DEF_INDENT + ( $style - STYLE_HEAD_1 + $depth ) * 2; 1013 $self-> add("L<$text|topic://$secid>", STYLE_TEXT, $indent); 1014 $secid++; 1015 } 1016 $self-> add_new_line; 1017 $self-> add_verbatim_mark(0); 1018 1019 $self-> _close_topic( STYLE_HEAD_1); 1020 1021 # remember the state after index is added 1022 my @index_ends_at = ( 1023 $r-> {bigofs}, 1024 scalar @{$self->{model}}, 1025 scalar @{$self->{topics}}, 1026 scalar @{$self->{links}}, 1027 ); 1028 1029 # exchange places for index and body 1030 my @offsets = map { $index_ends_at[$_] - $text_ends_at[$_] } 0 .. 3; 1031 my $m = $self-> {model}; 1032 # first shift the offsets 1033 $$_[M_TEXT_OFFSET] += $offsets[0] for @$m[0..$text_ends_at[1]-1]; 1034 $$_[M_TEXT_OFFSET] -= $text_ends_at[0] for @$m[$text_ends_at[1]..$index_ends_at[1]-1]; 1035 # next reshuffle the model 1036 unshift @$m, splice( @$m, $text_ends_at[1]); 1037 # text 1038 my $t = $self-> {text}; 1039 my $ts = substr( $$t, $text_ends_at[0]); 1040 substr( $$t, $text_ends_at[0]) = ''; 1041 substr( $$t, 0, 0) = $ts; 1042 # topics 1043 $t = $self-> {topics}; 1044 for ( @$t[0..$text_ends_at[2]-1]) { 1045 $$_[T_MODEL_START] += $offsets[1]; 1046 $$_[T_MODEL_END] += $offsets[1]; 1047 $$_[T_LINK_OFFSET] += $offsets[3]; 1048 } 1049 for ( @$t[$text_ends_at[2]..$index_ends_at[2]-1]) { 1050 $$_[T_MODEL_START] -= $text_ends_at[1]; 1051 $$_[T_MODEL_END] -= $text_ends_at[1]; 1052 $$_[T_LINK_OFFSET] -= $text_ends_at[3]; 1053 } 1054 unshift @$t, splice( @$t, $text_ends_at[2]); 1055 # update the map of blocks that contain OP_LINKs 1056 $self-> {postBlocks} = { 1057 map { 1058 ( $_ >= $text_ends_at[1]) ? 1059 ( $_ - $text_ends_at[1] ) : 1060 ( $_ + $offsets[1] ), 1061 1 1062 } keys %{$self-> {postBlocks}} 1063 }; 1064 # links 1065 my $l = $self-> {links}; 1066 s/^(topic:\/\/)(\d+)$/$1 . ( $2 + $offsets[2])/e for @$l; 1067 unshift @{$self->{links}}, splice( @{$self->{links}}, $text_ends_at[3]); 1068 1069NO_INDEX: 1070 # finalize 1071 undef $self-> {readState}; 1072 $self-> {lastLinkPointer} = -1; 1073 1074 my $topic; 1075 $topic = $self-> {topics}-> [$msecid] if $topicView; 1076 $self-> select_topic( $topic); 1077 1078 $self-> notify(q(NewPage)); 1079 1080 return scalar @{$self-> {model}} > 1; # if non-empty 1081} 1082 1083# internal sub, called when a new topic is emerged. 1084# responsible to what topics can include others ( =headX to =item) 1085sub _close_topic 1086{ 1087 my ( $self, $style, $topicToPush) = @_; 1088 1089 my $r = $self-> {readState}; 1090 my $t = $r-> { topicStack}; 1091 my $state = ( $style >= STYLE_HEAD_1 && $style <= STYLE_HEAD_4) ? 1092 0 : scalar @{$r-> {indentStack}}; 1093 1094 if ( $state <= $$t[-1]-> [0]) { 1095 while ( scalar @$t && $state <= $$t[-1]-> [0]) { 1096 my $nt = pop @$t; 1097 $nt = $$nt[1]; 1098 $$nt[ T_MODEL_END] = scalar @{$self-> {model}} - 1; 1099 } 1100 push @$t, [ $state, $topicToPush ] if $topicToPush; 1101 } else { 1102 # assert defined $topicToPush 1103 push @$t, [ $state, $topicToPush ]; 1104 } 1105} 1106 1107sub noremap { 1108 my $a = $_[0]; 1109 $a =~ tr/\000-\177/\200-\377/; 1110 return $a; 1111} 1112 1113sub add 1114{ 1115 my ( $self, $p, $style, $indent) = @_; 1116 1117 my $cstyle; 1118 my $r = $self-> {readState}; 1119 return unless $r; 1120 1121 $p =~ s/\n//g; 1122 my $g = [ model_create( indent => $indent, offset => $r-> {bigofs}) ]; 1123 my $styles = $self-> {styles}; 1124 my $no_push_block; 1125 my $itemid = scalar @{$self-> {model}}; 1126 1127 if ( $r-> {bulletMode}) { 1128 if ( $style == STYLE_TEXT || $style == STYLE_CODE || $style == STYLE_VERBATIM) { 1129 return unless length $p; 1130 $g = $self-> {model}-> [-1]; 1131 $$g[M_TEXT_OFFSET] = $r-> {bigofs}; 1132 $no_push_block = 1; 1133 $itemid--; 1134 } 1135 $r-> {bulletMode} = 0; 1136 } 1137 1138 if ( $style == STYLE_CODE || $style == STYLE_VERBATIM) { 1139 $$g[ M_FONT_ID] = $styles-> [$style]-> {fontId} || 1; # fixed font 1140 push @$g, tb::wrap(tb::WRAP_MODE_OFF); 1141 } 1142 1143 push @$g, @{$self-> {styleInfo}-> [$style * 2]}; 1144 $cstyle = $styles-> [$style]-> {fontStyle} || 0; 1145 1146 if ( $style == STYLE_CODE || $style == STYLE_VERBATIM) { 1147 push @$g, tb::text( 0, length $p), 1148 } elsif (( $style == STYLE_ITEM) && ( $p =~ /^\*\s*$/ || $p =~ /^\d+\.?$/)) { 1149 push @$g, 1150 tb::wrap(tb::WRAP_MODE_OFF), 1151 tb::color(0), 1152 tb::code( \&_bulletpaint, ($p =~ /^\*\s*$/) ? 1 : 0), 1153 tb::moveto( 1, 0, tb::X_DIMENSION_FONT_HEIGHT), 1154 tb::wrap(tb::WRAP_MODE_ON); 1155 $r-> {bulletMode} = 1; 1156 $p = ''; 1157 } else { # wrapable text 1158 $p =~ s/[\s\t]+/ /g; 1159 $p =~ s/([\200-\377])/"E<".ord($1).">"/ge; 1160 $p =~ s/(E<[^<>]+>)/noremap($1)/ge; 1161 $p =~ s/([:A-Za-z_][:A-Za-z_0-9]*\([^\)]*\))/C<$1>/g; 1162 my $maxnest = 10; 1163 my $linkStart = scalar @{$self-> {links}}; 1164 my $m = $p; 1165 my @ids = ( [-2, 'Z', 2], [ length($m), 'z', 1]); 1166 while ( $maxnest--) { 1167 while ( $m =~ m/([A-Z])(<<+) /gcs) { 1168 my ( $pos, $cmd, $left, $right) = ( pos($m), $1, $2, ('>' x ( length($2)))); 1169 if ( $m =~ m/\G.*? $right(?!>)/gcs) { 1170 if ( $cmd eq 'X') { 1171 my $d = length($cmd) + length($left) + 1; 1172 substr( $m, $pos - $d, pos($m) - $pos + $d, ''); 1173 } else { 1174 push @ids, [ 1175 $pos - length($left) - 2, 1176 $cmd, 1177 length($cmd)+length($left) 1178 ], [ 1179 pos($m) - length($right), 1180 lc $cmd, 1181 length($right) 1182 ]; 1183 substr $m, $ids[$_][0], $ids[$_][2], '_' x $ids[$_][2] 1184 for -2,-1; 1185 } 1186 } 1187 } 1188 while ( $m =~ m/([A-Z])<([^<>]*)>/gcs) { 1189 if ( $1 eq 'X') { 1190 my $d = length($2) + length($1) + 2; 1191 substr( $m, pos($m) - $d, $d, ''); 1192 } else { 1193 push @ids, 1194 [ pos($m) - length($2) - 3, $1, 2], 1195 [ pos($m) - 1, lc $1, 1]; 1196 substr $m, $ids[$_][0], $ids[$_][2], '_' x $ids[$_][2] for -2,-1; 1197 } 1198 } 1199 last unless $m =~ m/[A-Z]</; 1200 } 1201 1202 my %stack = map {[]} qw( fontStyle fontId fontSize wrap color backColor); 1203 my %val = ( 1204 fontStyle => $cstyle, 1205 fontId => 0, 1206 fontSize => 0, 1207 wrap => 1, 1208 color => tb::COLOR_INDEX, 1209 backColor => tb::BACKCOLOR_DEFAULT, 1210 ); 1211 my ( $link, $linkHREF) = ( 0, ''); 1212 1213 my $pofs = 0; 1214 $p = ''; 1215 for ( sort { $$a[0] <=> $$b[0] } @ids) { 1216 my $ofs = $$_[0] + $$_[2]; 1217 if ( $pofs < $$_[0]) { 1218 my $s = substr( $m, $pofs, $$_[0] - $pofs); 1219 $s =~ tr/\200-\377/\000-\177/; 1220 $s =~ s{ 1221 E< 1222 ( 1223 ( \d+ ) 1224 | ( [A-Za-z]+ ) 1225 ) 1226 > 1227 } { 1228 do { 1229 defined $2 1230 ? chr($2) 1231 : 1232 defined $HTML_Escapes{$3} 1233 ? do { $HTML_Escapes{$3} } 1234 : do { "E<$1>"; } 1235 } 1236 }egx; 1237 1238 if ( $link) { 1239 my $l; 1240 if ( $s =~ m/^([^\|]*)\|(.*)$/) { 1241 $l = $2; 1242 $s = $1; 1243 $linkHREF = ''; 1244 } else { 1245 $l = $s; 1246 } 1247 unless ( $s =~ /^\w+\:\/\//) { 1248 my ( $page, $section) = ( '', ''); 1249 if ( $s =~ /^([^\/]*)\/(.*)$/) { 1250 ( $page, $section) = ( $1, $2); 1251 } else { 1252 $section = $s; 1253 } 1254 $section =~ s/^\"(.*?)\"$/$1/; 1255 $s = length( $page) ? "$page: $section" : $section; 1256 } 1257 $linkHREF .= $l; 1258 } 1259 1260 push @$g, tb::text( length $p, length $s); 1261 $p .= $s; 1262 } 1263 $pofs = $ofs; 1264 1265 if ( $$_[1] ne lc $$_[1]) { # open 1266 if ( $$_[1] eq 'I' || $$_[1] eq 'F') { 1267 push @{$stack{fontStyle}}, $val{fontStyle}; 1268 push @$g, tb::fontStyle( $val{fontStyle} |= fs::Italic); 1269 } elsif ( $$_[1] eq 'C') { 1270 push @{$stack{wrap}}, $val{wrap}; 1271 push @$g, tb::wrap( $val{wrap} = tb::WRAP_MODE_OFF); 1272 my $z = $styles-> [STYLE_CODE]; 1273 for ( qw( fontId fontStyle fontSize color backColor)) { 1274 next unless exists $z-> {$_}; 1275 push @{$stack{$_}}, $val{$_}; 1276 push @$g, $tb::{$_}-> ( $val{$_} = $z-> {$_}); 1277 } 1278 } elsif ( $$_[1] eq 'L') { 1279 my $z = $styles-> [STYLE_LINK]; 1280 for ( qw( fontId fontStyle fontSize color backColor)) { 1281 next unless exists $z-> {$_}; 1282 push @{$stack{$_}}, $val{$_}; 1283 push @$g, $tb::{$_}-> ( $val{$_} = $z-> {$_}); 1284 } 1285 unless ($link) { 1286 push @$g, $OP_LINK, $link = 1; 1287 $linkHREF = ''; 1288 } 1289 } elsif ( $$_[1] eq 'S') { 1290 push @{$stack{wrap}}, $val{wrap}; 1291 push @$g, tb::wrap( $val{wrap} = tb::WRAP_MODE_OFF); 1292 } elsif ( $$_[1] eq 'B') { 1293 push @{$stack{fontStyle}}, $val{fontStyle}; 1294 push @$g, tb::fontStyle( $val{fontStyle} |= fs::Bold); 1295 } 1296 } else { # close 1297 if ( $$_[1] eq 'i' || $$_[1] eq 'f' || $$_[1] eq 'b') { 1298 push @$g, tb::fontStyle( $val{fontStyle} = pop @{$stack{fontStyle}}); 1299 } elsif ( $$_[1] eq 'c') { 1300 my $z = $styles-> [STYLE_CODE]; 1301 push @$g, tb::wrap( $val{wrap} = pop @{$stack{wrap}}); 1302 for ( qw( fontId fontStyle fontSize color backColor)) { 1303 next unless exists $z-> {$_}; 1304 push @$g, $tb::{$_}-> ( $val{$_} = pop @{$stack{$_}}); 1305 } 1306 } elsif ( $$_[1] eq 'l') { 1307 my $z = $styles-> [STYLE_LINK]; 1308 for ( qw( fontId fontStyle fontSize color backColor)) { 1309 next unless exists $z-> {$_}; 1310 push @$g, $tb::{$_}-> ( $val{$_} = pop @{$stack{$_}}); 1311 } 1312 if ( $link) { 1313 push @$g, $OP_LINK, $link = 0; 1314 push @{$self-> {links}}, $linkHREF; 1315 $self-> {postBlocks}-> { $itemid} = 1; 1316 } 1317 } elsif ( $$_[1] eq 's') { 1318 push @$g, tb::wrap( $val{wrap} = pop @{$stack{wrap}}); 1319 } 1320 } 1321 } 1322 if ( $link) { 1323 push @$g, $OP_LINK, $link = 0; 1324 push @{$self-> {links}}, $linkHREF; 1325 $self-> {postBlocks}-> { $itemid} = 1; 1326 } 1327 1328 # add topic 1329 if ( 1330 ( $style >= STYLE_HEAD_1 && $style <= STYLE_HEAD_4 ) || 1331 (( $style == STYLE_ITEM) && $p !~ /^[0-9*]+\.?$/) 1332 ) { 1333 my $itemDepth = ( $style == STYLE_ITEM) ? 1334 scalar @{$r-> {indentStack}} : 0; 1335 my $pp = $p; 1336 $pp =~ s/\|//g; 1337 $pp =~ s/([<>])/'E<' . (($1 eq '<') ? 'lt' : 'gt') . '>'/ge; 1338 if ( $style == STYLE_ITEM && $pp =~ /^\s*[a-z]/) { 1339 $pp =~ s/([\s\)\(\[\]\{\}].*)$/C<$1>/; # seems like function entry? 1340 } 1341 my $newTopic = [ $itemid, 0, $pp, $style, $itemDepth, $linkStart]; 1342 $self-> _close_topic( $style, $newTopic); 1343 push @{$self-> {topics}}, $newTopic; 1344 } 1345 } 1346 1347 1348 # add text 1349 $p .= "\n"; 1350 ${$self-> {text}} .= $p; 1351 1352 # all-string format options - close brackets 1353 push @$g, @{$self-> {styleInfo}-> [$style * 2 + 1]}; 1354 1355 # finish block 1356 $r-> {bigofs} += length $p; 1357 push @{$self-> {model}}, $g unless $no_push_block; 1358} 1359 1360sub add_new_line 1361{ 1362 my $self = $_[0]; 1363 my $r = $self-> {readState}; 1364 return unless $r; 1365 my $p = " \n"; 1366 ${$self-> {text}} .= $p; 1367 push @{$self-> {model}}, [ model_create( offset => $r->{bigofs} ), tb::text(0, 1) ]; 1368 $r-> {bigofs} += length $p; 1369} 1370 1371sub add_verbatim_mark 1372{ 1373 my ($self, $on) = @_; 1374 my $r = $self-> {readState}; 1375 return unless $r; 1376 1377 my $open; 1378 if ( $on ) { 1379 return if defined $r->{verbatim}; 1380 $open = 1; 1381 $r->{verbatim} = 1; 1382 } else { 1383 return unless defined $r->{verbatim}; 1384 $open = 0; 1385 undef $r->{verbatim}; 1386 } 1387 1388 push @{$self-> {model}}, [ div_create(open => $open, style => TDIVSTYLE_SOLID) ]; 1389} 1390 1391sub stop_format 1392{ 1393 my $self = $_[0]; 1394 $self-> {formatTimer}-> destroy if $self-> {formatTimer}; 1395 undef $self-> {formatData}; 1396 undef $self-> {formatTimer}; 1397} 1398 1399sub format 1400{ 1401 my ( $self, $keepOffset) = @_; 1402 my ( $pw, $ph) = $self-> get_active_area(2); 1403 1404 my $autoOffset; 1405 if ( $keepOffset) { 1406 if ( $self-> {formatData} && $self-> {formatData}-> {position}) { 1407 $autoOffset = $self-> {formatData}-> {position}; 1408 } else { 1409 my ( $ofs, $bid) = $self-> xy2info( $self-> {offset}, $self-> {topLine}); 1410 if ( $self-> {blocks}-> [$bid]) { 1411 $autoOffset = $ofs + $self-> {blocks}-> [$bid]-> [tb::BLK_TEXT_OFFSET]; 1412 } 1413 } 1414 } 1415 1416 $self-> stop_format; 1417 $self-> selection(-1,-1,-1,-1); 1418 1419 my $paneWidth = $pw; 1420 my $paneHeight = 0; 1421 my ( $min, $max, $linkIdStart) = @{$self-> {modelRange}}; 1422 if ( $min >= $max) { 1423 $self-> {blocks} = []; 1424 $self-> {contents}-> [0]-> rectangles([]); 1425 $self-> paneSize(0,0); 1426 return; 1427 } 1428 1429 $self-> {blocks} = []; 1430 $self-> {contents}-> [0]-> rectangles( []); 1431 1432 $self-> begin_paint_info; 1433 1434 # cache indents 1435 my @indents; 1436 my $state = $self-> create_state; 1437 1438 for my $fid ( 0 .. ( scalar @{$self-> fontPalette} - 1)) { 1439 $$state[ tb::BLK_FONT_ID] = $fid; 1440 $self-> realize_state( $self, $state, tb::REALIZE_FONTS); 1441 $indents[$fid] = $self-> font-> width; 1442 } 1443 $$state[ tb::BLK_FONT_ID] = 0; 1444 1445 $self-> end_paint_info; 1446 1447 $self-> {formatData} = { 1448 indents => \@indents, 1449 state => $state, 1450 orgState => [ @$state ], 1451 linkId => $linkIdStart, 1452 min => $min, 1453 max => $max, 1454 current => $min, 1455 paneWidth => $paneWidth, 1456 formatWidth => $paneWidth, 1457 linkRects => $self-> {contents}-> [0]-> rectangles, 1458 step => FORMAT_LINES, 1459 position => undef, 1460 positionSet => 0, 1461 verbatim => undef, 1462 last_ymap => 0, 1463 }; 1464 1465 $self-> {formatTimer} = $self-> insert( Timer => 1466 name => 'FormatTimer', 1467 delegations => [ 'Tick' ], 1468 timeout => FORMAT_TIMEOUT, 1469 ) unless $self-> {formatTimer}; 1470 1471 $self-> paneSize(0,0); 1472 $self-> {formatTimer}-> start; 1473 $self-> select_text_offset( $autoOffset) if $autoOffset; 1474 1475 while ( 1) { 1476 $self-> format_chunks; 1477 last unless 1478 $self-> {formatData} && 1479 $self-> {blocks}-> [-1] && 1480 $self-> {blocks}-> [-1]-> [tb::BLK_Y] < $ph; 1481 } 1482} 1483 1484sub FormatTimer_Tick 1485{ 1486 $_[0]-> format_chunks 1487} 1488 1489sub paint_code_div 1490{ 1491 my ( $self, $canvas, $block, $state, $x, $y, $coord) = @_; 1492 my $f = $canvas->font; 1493 my ($style, $w, $h) = @$coord; 1494 my @x = ( $canvas-> backColor, $canvas-> color ); 1495 my $path = $canvas->new_path->round_rect($x, $y, $x + $w, $y + $h, 20); 1496 if ( $style == TDIVSTYLE_SOLID ) { 1497 $canvas->set(backColor => $self->{colorMap}->[5], color => 0xcccccc); 1498 $path->fill_stroke; 1499 $canvas-> set( backColor => $x[0], color => $x[1] ); 1500 } else { 1501 $canvas->set(color => 0x808080); 1502 $path-> stroke; 1503 $canvas-> set( color => $x[1] ); 1504 } 1505} 1506 1507sub add_code_div 1508{ 1509 my ($self, $style, $from, $to) = @_; 1510 1511 my ($w,$y1,$y2) = (0,($self->{blocks}->[$from]->[tb::BLK_Y]) x 2); 1512 for my $b ( @{ $self->{blocks} } [$from .. $to] ) { 1513 $w = $$b[tb::BLK_X] + $$b[tb::BLK_WIDTH] if $w < $$b[tb::BLK_X] + $$b[tb::BLK_WIDTH]; 1514 $y1 = $$b[tb::BLK_Y] if $y1 > $$b[tb::BLK_Y]; 1515 $y2 = $$b[tb::BLK_Y] + $$b[tb::BLK_HEIGHT] if $y2 < $$b[tb::BLK_Y] + $$b[tb::BLK_HEIGHT]; 1516 } 1517 my ($fh, $fw) = ( $self->font->height, $self->font->width ); 1518 my $h = $y2 - $y1; 1519 my $b = tb::block_create(); 1520 $$b[tb::BLK_X] = $self->{blocks}->[$from]->[tb::BLK_X]; 1521 $$b[tb::BLK_Y] = $y1 - $fh / 2; 1522 $w += 2 * $fw; 1523 $$b[tb::BLK_WIDTH] = $w; 1524 $$b[tb::BLK_HEIGHT] = $h; 1525 $$b[tb::BLK_TEXT_OFFSET] = -1; 1526 push @$b, 1527 tb::code( \&paint_code_div, [$style, $w, $h]), 1528 tb::extend($w, $h); 1529 return $b; 1530} 1531 1532sub format_chunks 1533{ 1534 my $self = $_[0]; 1535 1536 my $f = $self-> {formatData}; 1537 1538 my $time = time; 1539 $self-> begin_paint_info; 1540 1541 my $mid = $f-> {current}; 1542 my $postBlocks = $self-> {postBlocks}; 1543 my $max = $f-> {current} + $f-> {step}; 1544 $max = $f-> {max} if $max > $f-> {max}; 1545 my $indents = $f-> {indents}; 1546 my $state = $f-> {state}; 1547 my $linkRects = $f-> {linkRects}; 1548 my $formatWidth = $f-> {formatWidth}; 1549 my $fw = $self->font->width; 1550 1551 for ( ; $mid <= $max; $mid++) { 1552 my $g = tb::block_create(); 1553 my $m = $self-> {model}-> [$mid]; 1554 1555 if ( $m->[M_TYPE] == T_DIV ) { 1556 if ( $m->[MDIV_TAG] == TDIVTAG_OPEN) { 1557 $f->{verbatim} = scalar @{ $self->{blocks} }; 1558 } else { 1559 splice @{ $self->{blocks} }, 1560 $f->{verbatim}, 0, 1561 $self-> add_code_div( $m->[MDIV_STYLE], $f->{verbatim}, $#{$self->{blocks}} ); 1562 undef $f->{verbatim}; 1563 } 1564 next; 1565 } 1566 1567 my @blocks; 1568 $$g[ tb::BLK_TEXT_OFFSET] = $$m[M_TEXT_OFFSET]; 1569 $$g[ tb::BLK_Y] = undef; 1570 push @$g, @$m[ M_START .. $#$m ]; 1571 1572 # format the paragraph 1573 1574 my $next_text_offs = ( $mid == $#{$self->{model}} ) ? length( ${$self->{text}} ) : $self->{model}->[$mid + 1]->[M_TEXT_OFFSET]; 1575 my $indent = $$m[M_INDENT] * $$indents[ $$m[M_FONT_ID]]; 1576 @blocks = $self-> block_wrap( $self, $g, $state, $formatWidth - $indent); 1577 1578 # adjust size 1579 for ( @blocks) { 1580 if ( $self->{textDirection} ) { 1581 $$_[ tb::BLK_X] = $f->{paneWidth} - $$_[ tb::BLK_WIDTH] - $indent; 1582 } else { 1583 $$_[ tb::BLK_X] += $indent; 1584 } 1585 $f-> {paneWidth} = $$_[ tb::BLK_X] + $$_[ tb::BLK_WIDTH] 1586 if $$_[ tb::BLK_X] + $$_[ tb::BLK_WIDTH] > $f-> {paneWidth}; 1587 } 1588 1589 # check links 1590 if ( $postBlocks-> {$mid}) { 1591 my $linkState = 0; 1592 my $linkStart = 0; 1593 my @rect; 1594 for my $b ( @blocks) { 1595 my @pos = ( $$b[tb::BLK_X], 0 ); 1596 1597 if ( $linkState) { 1598 $rect[0] = $$b[ tb::BLK_X]; 1599 $rect[1] = $$b[ tb::BLK_Y]; 1600 } 1601 1602 $self-> block_walk( $b, 1603 position => \@pos, 1604 trace => tb::TRACE_POSITION, 1605 link => sub { 1606 if ( $linkState = shift ) { 1607 $rect[0] = $pos[0]; 1608 $rect[1] = $$b[ tb::BLK_Y]; 1609 } else { 1610 $rect[2] = $pos[0] + $fw; 1611 $rect[3] = $$b[ tb::BLK_Y] + $$b[ tb::BLK_HEIGHT]; 1612 push @$linkRects, [ @rect, $f-> {linkId} ++ ]; 1613 } 1614 }, 1615 ); 1616 1617 if ( $linkState) { 1618 $rect[2] = $pos[0]; 1619 $rect[3] = $$b[ tb::BLK_Y] + $$b[ tb::BLK_HEIGHT]; 1620 push @$linkRects, [ @rect, $f-> {linkId}]; 1621 } 1622 } 1623 } 1624 1625 # push back 1626 push @{$self-> {blocks}}, @blocks; 1627 } 1628 1629 my $paneHeight = 0; 1630 my @settopline; 1631 if ( scalar @{$self-> {blocks}}) { 1632 my $b = $self-> {blocks}-> [-1]; 1633 $paneHeight = $$b[ tb::BLK_Y] + $$b[ tb::BLK_HEIGHT]; 1634 if ( defined $f-> {position} && 1635 ! $f-> {positionSet} && 1636 $self-> {topLine} == 0 && 1637 $self-> {offset} == 0 && 1638 $$b[ tb::BLK_TEXT_OFFSET] >= $f-> {position}) { 1639 $b = $self-> text_offset2block( $f-> {position}); 1640 $f-> {positionSet} = 1; 1641 if ( defined $b) { 1642 $b = $self-> {blocks}-> [$b]; 1643 @settopline = @$b[ tb::BLK_X, tb::BLK_Y]; 1644 } 1645 } 1646 } 1647 1648 $f-> {current} = $mid; 1649 $self-> end_paint_info; 1650 1651 if ( ! defined $f->{verbatim} ){ 1652 $self-> recalc_ymap( $f->{last_ymap} ); 1653 $f->{last_ymap} = scalar @{ $self->{blocks} }; 1654 if ( $f->{suppressed_ymap} ) { 1655 $f->{suppressed_ymap} = 0; 1656 $self->repaint; 1657 } 1658 } else { 1659 $f->{suppressed_ymap} = 1; 1660 } 1661 1662 my $ps = $self-> {paneWidth}; 1663 if ( $ps != $f-> {paneWidth}) { 1664 $self-> paneSize( $f-> {paneWidth}, $paneHeight); 1665 } else { 1666 my $oph = $self-> {paneHeight}; 1667 $self-> {paneHeight} = $paneHeight; # direct nasty hack 1668 $self-> reset_scrolls; 1669 $self-> repaint if $oph >= $self-> {topLine} && 1670 $oph <= $self-> {topLine} + $self-> height; 1671 } 1672 1673 if ( @settopline) { 1674 $self-> topLine( $settopline[1]); 1675 $self-> offset( $settopline[0]); 1676 } 1677 1678 $self-> stop_format if $mid >= $f-> {max}; 1679 $f-> {step} *= 2 unless time - $time; 1680} 1681 1682sub print 1683{ 1684 my ( $self, $canvas, $callback) = @_; 1685 1686 my ( $min, $max, $linkIdStart) = @{$self-> {modelRange}}; 1687 return 1 if $min >= $max; 1688 my $ret = 0; 1689 1690 goto ABORT if $callback && ! $callback-> (); 1691 1692 # cache indents 1693 my @indents; 1694 my $state = $self-> create_state; 1695 for ( 0 .. ( scalar @{$self-> fontPalette} - 1)) { 1696 $$state[ tb::BLK_FONT_ID] = $_; 1697 $self-> realize_state( $canvas, $state, tb::REALIZE_FONTS); 1698 $indents[$_] = $canvas-> font-> width; 1699 } 1700 $$state[ tb::BLK_FONT_ID] = 0; 1701 1702 my ( $formatWidth, $formatHeight) = $canvas-> size; 1703 my $hmargin = $formatWidth / 24; 1704 my $vmargin = $formatHeight / 12; 1705 $formatWidth -= $hmargin * 2; 1706 $formatHeight -= $vmargin * 2; 1707 $canvas->translate( $hmargin, $vmargin ); 1708 1709 my $mid = $min; 1710 my $y = $formatHeight; 1711 1712 my $pageno = 1; 1713 my $pagenum = sub { 1714 $canvas->translate( 0, 0 ); 1715 my %save = %{$canvas->font}; 1716 $canvas->font->set( name => $self->fontPalette->[0]->{name} || 'Default', size => 6, style => 0, pitch => fp::Default ); 1717 $canvas->set( color => cl::Black ); 1718 $canvas->text_out( $pageno, ( $formatWidth - $canvas->get_text_width($pageno) ) / 2, ($vmargin - $canvas->font->height ) / 2 ); 1719 delete $save{height}; # XXX fix this 1720 $canvas->font(\%save); 1721 $pageno++; 1722 }; 1723 my $new_page = sub { 1724 goto ABORT if $callback && ! $callback-> (); 1725 $pagenum->(); 1726 goto ABORT unless $canvas-> new_page; 1727 $canvas->translate( $hmargin, $vmargin ); 1728 }; 1729 1730 for ( ; $mid <= $max; $mid++) { 1731 my $g = tb::block_create(); 1732 my $m = $self-> {model}-> [$mid]; 1733 next if $$m[M_TYPE] != T_NORMAL; # don't print div background 1734 1735 my @blocks; 1736 $$g[ tb::BLK_TEXT_OFFSET] = $$m[M_TEXT_OFFSET]; 1737 $$g[ tb::BLK_Y] = undef; 1738 push @$g, @$m[ M_START .. $#$m ]; 1739 1740 # format the paragraph 1741 my $indent = $$m[M_INDENT] * $indents[ $$m[M_FONT_ID]]; 1742 @blocks = $self-> block_wrap( $canvas, $g, $state, $formatWidth - $indent); 1743 1744 # paint 1745 $self-> reset_state; 1746 for ( @blocks) { 1747 my $b = $_; 1748 if ( $y < $$b[ tb::BLK_HEIGHT]) { 1749 if ( $$b[ tb::BLK_HEIGHT] < $formatHeight) { 1750 $new_page->(); 1751 $y = $formatHeight - $$b[ tb::BLK_HEIGHT]; 1752 $self-> block_draw( $canvas, $b, $indent, $y); 1753 } else { 1754 $y -= $$b[ tb::BLK_HEIGHT]; 1755 while ( $y < 0) { 1756 $new_page->(); 1757 $self-> block_draw( $canvas, $b, $indent, $y); 1758 $y += $formatHeight; 1759 } 1760 } 1761 } else { 1762 $y -= $$b[ tb::BLK_HEIGHT]; 1763 goto ABORT unless $self-> block_draw( $canvas, $b, $indent, $y); 1764 } 1765 } 1766 } 1767 $pagenum->(); 1768 1769 $ret = 1; 1770ABORT: 1771 return $ret; 1772} 1773 1774sub select_text_offset 1775{ 1776 my ( $self, $pos) = @_; 1777 if ( defined $self-> {formatData}) { 1778 my $last = $self-> {blocks}-> [-1]; 1779 $self-> {formatData}-> {position} = $pos; 1780 return if ! $last || $$last[tb::BLK_TEXT_OFFSET] < $pos; 1781 } 1782 my $b = $self-> text_offset2block( $pos); 1783 if ( defined $b) { 1784 $b = $self-> {blocks}-> [$b]; 1785 $self-> topLine( $$b[ tb::BLK_Y]); 1786 $self-> offset( $$b[ tb::BLK_X]); 1787 } 1788} 1789 1790sub clear_all 1791{ 1792 my $self = $_[0]; 1793 $self-> SUPER::clear_all; 1794 $self-> {modelRange} = [0,0,0]; 1795 $self-> {model} = []; 1796 $self-> {links} = []; 1797 $self-> {postBlocks} = {}; 1798 $self-> {topics} = []; 1799 $self-> {topicIndex} = {}; 1800 $self-> {hasIndex} = 0; 1801} 1802 1803sub text_range 1804{ 1805 my $self = $_[0]; 1806 my @range; 1807 $range[0] = $self-> {model}-> [ $self-> {modelRange}-> [0]]-> [M_TEXT_OFFSET]; 1808 $range[1] = ( $self-> {modelRange}-> [1] + 1 >= scalar @{$self-> {model}}) ? 1809 length ( ${$self-> {text}} ) : 1810 $self-> {model}-> [ $self-> {modelRange}-> [1] + 1]-> [M_TEXT_OFFSET]; 1811 $range[1]-- if $range[1] > $range[0]; 1812 return @range; 1813} 1814 1815%HTML_Escapes = ( 1816 'amp' => '&', # ampersand 1817 'lt' => '<', # left chevron, less-than 1818 'gt' => '>', # right chevron, greater-than 1819 'quot' => '"', # double quote 1820 1821 "Aacute"=> "\xC1", # capital A, acute accent 1822 "aacute"=> "\xE1", # small a, acute accent 1823 "Acirc" => "\xC2", # capital A, circumflex accent 1824 "acirc" => "\xE2", # small a, circumflex accent 1825 "AElig" => "\xC6", # capital AE diphthong (ligature) 1826 "aelig" => "\xE6", # small ae diphthong (ligature) 1827 "Agrave"=> "\xC0", # capital A, grave accent 1828 "agrave"=> "\xE0", # small a, grave accent 1829 "Aring" => "\xC5", # capital A, ring 1830 "aring" => "\xE5", # small a, ring 1831 "Atilde"=> "\xC3", # capital A, tilde 1832 "atilde"=> "\xE3", # small a, tilde 1833 "Auml" => "\xC4", # capital A, dieresis or umlaut mark 1834 "auml" => "\xE4", # small a, dieresis or umlaut mark 1835 "Ccedil"=> "\xC7", # capital C, cedilla 1836 "ccedil"=> "\xE7", # small c, cedilla 1837 "Eacute"=> "\xC9", # capital E, acute accent 1838 "eacute"=> "\xE9", # small e, acute accent 1839 "Ecirc" => "\xCA", # capital E, circumflex accent 1840 "ecirc" => "\xEA", # small e, circumflex accent 1841 "Egrave"=> "\xC8", # capital E, grave accent 1842 "egrave"=> "\xE8", # small e, grave accent 1843 "ETH" => "\xD0", # capital Eth, Icelandic 1844 "eth" => "\xF0", # small eth, Icelandic 1845 "Euml" => "\xCB", # capital E, dieresis or umlaut mark 1846 "euml" => "\xEB", # small e, dieresis or umlaut mark 1847 "Iacute"=> "\xCD", # capital I, acute accent 1848 "iacute"=> "\xED", # small i, acute accent 1849 "Icirc" => "\xCE", # capital I, circumflex accent 1850 "icirc" => "\xEE", # small i, circumflex accent 1851 "Igrave"=> "\xCD", # capital I, grave accent 1852 "igrave"=> "\xED", # small i, grave accent 1853 "Iuml" => "\xCF", # capital I, dieresis or umlaut mark 1854 "iuml" => "\xEF", # small i, dieresis or umlaut mark 1855 "Ntilde"=> "\xD1", # capital N, tilde 1856 "ntilde"=> "\xF1", # small n, tilde 1857 "Oacute"=> "\xD3", # capital O, acute accent 1858 "oacute"=> "\xF3", # small o, acute accent 1859 "Ocirc" => "\xD4", # capital O, circumflex accent 1860 "ocirc" => "\xF4", # small o, circumflex accent 1861 "Ograve"=> "\xD2", # capital O, grave accent 1862 "ograve"=> "\xF2", # small o, grave accent 1863 "Oslash"=> "\xD8", # capital O, slash 1864 "oslash"=> "\xF8", # small o, slash 1865 "Otilde"=> "\xD5", # capital O, tilde 1866 "otilde"=> "\xF5", # small o, tilde 1867 "Ouml" => "\xD6", # capital O, dieresis or umlaut mark 1868 "ouml" => "\xF6", # small o, dieresis or umlaut mark 1869 "szlig" => "\xDF", # small sharp s, German (sz ligature) 1870 "THORN" => "\xDE", # capital THORN, Icelandic 1871 "thorn" => "\xFE", # small thorn, Icelandic 1872 "Uacute"=> "\xDA", # capital U, acute accent 1873 "uacute"=> "\xFA", # small u, acute accent 1874 "Ucirc" => "\xDB", # capital U, circumflex accent 1875 "ucirc" => "\xFB", # small u, circumflex accent 1876 "Ugrave"=> "\xD9", # capital U, grave accent 1877 "ugrave"=> "\xF9", # small u, grave accent 1878 "Uuml" => "\xDC", # capital U, dieresis or umlaut mark 1879 "uuml" => "\xFC", # small u, dieresis or umlaut mark 1880 "Yacute"=> "\xDD", # capital Y, acute accent 1881 "yacute"=> "\xFD", # small y, acute accent 1882 "yuml" => "\xFF", # small y, dieresis or umlaut mark 1883 1884 "lchevron"=> "\xAB", # left chevron (double less than) 1885 "rchevron"=> "\xBB", # right chevron (double greater than) 1886); 1887 18881; 1889 1890__END__ 1891 1892=pod 1893 1894=head1 NAME 1895 1896Prima::PodView - POD browser widget 1897 1898=head1 SYNOPSIS 1899 1900 use Prima qw(Application PodView); 1901 1902 my $window = Prima::MainWindow-> create; 1903 my $podview = $window-> insert( 'Prima::PodView', 1904 pack => { fill => 'both', expand => 1 } 1905 ); 1906 $podview-> open_read; 1907 $podview-> read("=head1 NAME\n\nI'm also a pod!\n\n"); 1908 $podview-> close_read; 1909 1910 run Prima; 1911 1912=for podview <img src="podview.gif"> 1913 1914=for html <p><img src="https://raw.githubusercontent.com/dk/Prima/master/pod/Prima/podview.gif"> 1915 1916=head1 DESCRIPTION 1917 1918Prima::PodView contains a formatter ( in terms of L<perlpod> ) and viewer of 1919POD content. It heavily employs its ascendant class L<Prima::TextView>, 1920and is in turn base for the toolkit's default help viewer L<Prima::HelpViewer>. 1921 1922=head1 USAGE 1923 1924The package consists of the several logically separated parts. These include 1925file locating and loading, formatting and navigation. 1926 1927=head2 Content methods 1928 1929The basic access to the content is not bound to the file system. The POD 1930content can be supplied without any file to the viewer. Indeed, the file 1931loading routine C<load_file> is a mere wrapper to the content loading 1932functions: 1933 1934=over 1935 1936=item open_read %OPTIONS 1937 1938Clears the current content and enters the reading mode. In this mode 1939the content can be appended by calling L<read> that pushes the raw POD 1940content to the parser. 1941 1942=item read TEXT 1943 1944Supplies TEXT string to the parser. Manages basic indentation, 1945but the main formatting is performed inside L<add> and L<add_formatted> 1946 1947Must be called only within open_read/close_read brackets 1948 1949=item add TEXT, STYLE, INDENT 1950 1951Formats TEXT string of a given STYLE ( one of C<STYLE_XXX> constants) with 1952INDENT space. 1953 1954Must be called only within open_read/close_read brackets. 1955 1956=item add_formatted FORMAT, TEXT 1957 1958Adds a pre-formatted TEXT with a given FORMAT, supplied by C<=begin> or C<=for> 1959POD directives. Prima::PodView understands 'text' and 'podview' FORMATs; 1960the latter format is for Prima::PodView itself and contains small number 1961of commands, aimed at inclusion of images into the document. 1962 1963The 'podview' commands are: 1964 1965=over 1966 1967=item cut 1968 1969Example: 1970 1971 =for podview <cut> 1972 1973 =for text just text-formatter info 1974 1975 .... 1976 text-only info 1977 ... 1978 1979 =for podview </cut> 1980 1981The E<lt>cut<gt> clause skips all POD input until cancelled. 1982It is used in conjunction with the following command, L<img>, to allow 1983a POD manpage provide both graphic ('podview', 'html', etc ) and text ( 'text' ) 1984content. 1985 1986=item img [src="SRC"] [width="WIDTH"] [height="HEIGHT"] [cut="CUT"] [frame="FRAME"] 1987 1988An image inclusion command, where src is a relative or an absolute path to 1989an image file. In case if scaling is required, C<width> and C<height> options 1990can be set. When the image is a multiframe image, the frame index can be 1991set by C<frame> option. Special C<cut> option, if set to a true value, activates the 1992L<cut> behavior if ( and only if ) the image load operation was unsuccessful. 1993This makes possible simultaneous use of 'podview' and 'text' : 1994 1995 =for podview <img src="graphic.gif" cut=1 > 1996 1997 =begin text 1998 1999 y . 2000 | . 2001 |. 2002 +----- x 2003 2004 =end text 2005 2006 =for podview </cut> 2007 2008In the example above 'graphic.gif' will be shown if it can be found and loaded, 2009otherwise the poor-man-drawings would be selected. 2010 2011If "src" is omitted, image is retrieved from C<images> array, from the index C<frame>. 2012 2013=back 2014 2015 2016=item close_read 2017 2018Closes the reading mode and starts the text rendering by calling C<format>. 2019Returns C<undef> if there is no POD context, 1 otherwise. 2020 2021=back 2022 2023=head2 Rendering 2024 2025The rendering is started by C<format> call, which returns ( almost ) immediately, 2026initiating the mechanism of delayed rendering, which is often time-consuming. 2027C<format>'s only parameter KEEP_OFFSET is a boolean flag, which, if set to 1, 2028remembers the current location on a page, and when the rendered text approaches 2029the location, scrolls the document automatically. 2030 2031The rendering is based an a document model, generated by open_read/close_read session. 2032The model is a set of same text blocks defined by L<Prima::TextView>, except 2033that the header length is only three integers: 2034 2035 M_INDENT - the block X-axis indent 2036 M_TEXT_OFFSET - same as BLK_TEXT_OFFSET 2037 M_FONT_ID - 0 or 1, because PodView's fontPalette contains only two fonts - 2038 variable ( 0 ) and fixed ( 1 ). 2039 2040The actual rendering is performed in C<format_chunks>, where model blocks are 2041transformed to the full text blocks, wrapped and pushed into TextView-provided 2042storage. In parallel, links and the corresponding event rectangles are calculated 2043on this stage. 2044 2045=head2 Topics 2046 2047Prima::PodView provides the C<::topicView> property, which governs whether 2048the man page is viewed by topics or as a whole. When it is viewed as topics, 2049C<{modelRange}> array selects the model blocks that include the topic. 2050Thus, having a single model loaded, text blocks change dynamically. 2051 2052Topics contained in C<{topics}> array, each is an array with indices of C<T_XXX> 2053constants: 2054 2055 T_MODEL_START - beginning of topic 2056 T_MODEL_END - length of a topic 2057 T_DESCRIPTION - topic name 2058 T_STYLE - STYLE_XXX constant 2059 T_ITEM_DEPTH - depth of =item recursion 2060 T_LINK_OFFSET - offset in links array, started in the topic 2061 2062=head2 Styles 2063 2064C<::styles> property provides access to the styles, applied to different pod 2065text parts. These styles are: 2066 2067 STYLE_CODE - style for C<> 2068 STYLE_TEXT - normal text 2069 STYLE_HEAD_1 - =head1 2070 STYLE_HEAD_2 - =head2 2071 STYLE_HEAD_3 - =head3 2072 STYLE_HEAD_4 - =head4 2073 STYLE_ITEM - =item 2074 STYLE_LINK - style for L<> text 2075 STYLE_VERBATIM - style for pre-formatted text 2076 2077Each style is a hash with the following keys: C<fontId>, C<fontSize>, C<fontStyle>, 2078C<color>, C<backColor>, fully analogous to the tb::BLK_DATA_XXX options. 2079This functionality provides another layer of accessibility to the pod formatter. 2080 2081In addition to styles, Prima::PodView defined C<colormap> entries for 2082C<STYLE_LINK> , C<STYLE_CODE>, and C<STYLE_VERBATIM>: 2083 2084 COLOR_LINK_FOREGROUND 2085 COLOR_LINK_BACKGROUND 2086 COLOR_CODE_FOREGROUND 2087 COLOR_CODE_BACKGROUND 2088 2089The default colors in the styles are mapped into these entries. 2090 2091=head2 Link and navigation methods 2092 2093Prima::PodView provides a hand-icon mouse pointer highlight for the link 2094entries and as an interactive part, the link documents or topics are loaded 2095when the user presses the mouse button on the link. The mechanics below that 2096is as follows. C<{contents}> of event rectangles, ( see L<Prima::TextView> ) 2097is responsible for distinguishing whether a mouse is inside a link or not. 2098When the link is activated, C<link_click> is called, which, in turn, calls 2099C<load_link> method. If the page is loaded successfully, depending on C<::topicView> 2100property value, either C<select_topic> or C<select_text_offset> method is called. 2101 2102The family of file and link access functions consists of the following methods: 2103 2104=over 2105 2106=item load_file MANPAGE 2107 2108Loads a manpage, if it can be found in the PATH or perl installation directories. 2109If unsuccessful, displays an error. 2110 2111=item load_link LINK 2112 2113LINK is a text in format of L<perlpod> C<LE<lt>E<gt>> link: "manpage/section". 2114Loads the manpage, if necessary, and selects the section. 2115 2116=item load_bookmark BOOKMARK 2117 2118Loads a bookmark string, prepared by L<make_bookmark> function. 2119Used internally. 2120 2121=item load_content CONTENT 2122 2123Loads content into the viewer. Returns C<undef> is there is no POD 2124context, 1 otherwise. 2125 2126=item make_bookmark [ WHERE ] 2127 2128Combines the information about the currently viewing manpage, topic and text offset 2129into a storable string. WHERE, an optional string parameter, can be either omitted, 2130in such case the current settings are used, or be one of 'up', 'next' or 'prev' strings. 2131 2132The 'up' string returns a bookmark to the upper level of the manpage. 2133 2134The 'next' and 'prev' return a bookmark to the next or the previous topics in a manpage. 2135 2136If the location cannot be stored or defined, C<undef> is returned. 2137 2138=back 2139 2140=head2 Events 2141 2142=over 2143 2144=item Bookmark BOOKMARK 2145 2146When a new topic is navigated to by the user, this event is triggered with the 2147current topic to have it eventually stored in bookmarks or history. 2148 2149=item Link LINK_REF, BUTTON, MOD, X, Y 2150 2151When the user clicks on a link, this event is called with the link address, 2152mouse button, modificator keys, and coordinates. 2153 2154=item NewPage 2155 2156Called after new content is loaded 2157 2158=back 2159 2160=cut 2161