# # Copyright (c) 1997-2002 The Protein Laboratory, University of Copenhagen # All rights reserved. # # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions # are met: # 1. Redistributions of source code must retain the above copyright # notice, this list of conditions and the following disclaimer. # 2. Redistributions in binary form must reproduce the above copyright # notice, this list of conditions and the following disclaimer in the # documentation and/or other materials provided with the distribution. # # THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE # ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE # FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS # OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) # HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT # LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY # OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF # SUCH DAMAGE. # # Created by: # Dmitry Karasik # # $Id$ use strict; use Prima; use Prima::IntUtils; use Prima::ScrollBar; package tb; use vars qw(@oplen); @oplen = ( 4, 2, 3, 4, 3, 2, 4); # lengths of tb::OP_XXX constants ( see below ) + 1 # basic opcodes use constant OP_TEXT => 0; # (3) text offset, text length, text width use constant OP_COLOR => 1; # (1) 0xRRGGBB or COLOR_INDEX | palette_index use constant OP_FONT => 2; # (2) op_font_mode, font info use constant OP_TRANSPOSE => 3; # (3) move current point to delta X, delta Y use constant OP_CODE => 4; # (2) code pointer and parameters # formatting opcodes use constant OP_WRAP => 5; # (1) on / off use constant OP_MARK => 6; # (3) id, x, y # OP_TEXT use constant T_OFS => 1; use constant T_LEN => 2; use constant T_WID => 3; # OP_FONT use constant F_MODE => 1; use constant F_DATA => 2; # OP_COLOR use constant COLOR_INDEX => 0x01000000; # index in colormap() array use constant BACKCOLOR_FLAG => 0x02000000; # OP_COLOR flag for backColor use constant BACKCOLOR_DEFAULT => BACKCOLOR_FLAG|COLOR_INDEX|1; use constant COLOR_MASK => 0xFCFFFFFF; # OP_TRANSPOSE - indices use constant X_X => 1; use constant X_Y => 2; use constant X_FLAGS => 3; # OP_TRANSPOSE - X_FLAGS constants use constant X_DIMENSION_PIXEL => 0; use constant X_TRANSPOSE => 0; use constant X_EXTEND => 1; # formatting flags use constant X_DIMENSION_FONT_HEIGHT => 2; # multiply by font height use constant X_DIMENSION_POINT => 4; # multiply by resolution / 72 # block header indices use constant BLK_FLAGS => 0; use constant BLK_WIDTH => 1; use constant BLK_HEIGHT => 2; use constant BLK_X => 3; use constant BLK_Y => 4; use constant BLK_APERTURE_X => 5; use constant BLK_APERTURE_Y => 6; use constant BLK_TEXT_OFFSET => 7; use constant BLK_DATA_START => 8; use constant BLK_FONT_ID => BLK_DATA_START; use constant BLK_FONT_SIZE => 9; use constant BLK_FONT_STYLE => 10; use constant BLK_COLOR => 11; use constant BLK_DATA_END => 12; use constant BLK_BACKCOLOR => BLK_DATA_END; use constant BLK_START => BLK_DATA_END + 1; # OP_FONT again use constant F_ID => BLK_FONT_ID; use constant F_SIZE => BLK_FONT_SIZE; use constant F_STYLE => BLK_FONT_STYLE; use constant F_HEIGHT=> 1000000; # BLK_FLAGS constants use constant T_SIZE => 0x1; use constant T_WRAPABLE => 0x2; # realize_state mode use constant REALIZE_FONTS => 0x1; use constant REALIZE_COLORS => 0x2; use constant REALIZE_ALL => 0x3; use constant YMAX => 1000; sub block_create { my $ret = [ ( 0 ) x BLK_START ]; $$ret[ BLK_FLAGS ] |= T_SIZE; push @$ret, @_; return $ret; } sub block_count { my $block = $_[0]; my $ret = 0; my ( $i, $lim) = ( BLK_START, scalar @$block); $i += $oplen[$$block[$i]], $ret++ while $i < $lim; return $ret; } # creates a new opcode for custom use sub opcode { my $len = $_[0] || 0; $len = 0 if $len < 0; push @oplen, $len + 1; return scalar(@oplen) - 1; } sub text { return OP_TEXT, $_[0], $_[1], $_[2] || 0 } sub color { return OP_COLOR, $_[0] } sub backColor { return OP_COLOR, $_[0] | BACKCOLOR_FLAG} sub colorIndex { return OP_COLOR, $_[0] | COLOR_INDEX } sub backColorIndex { return OP_COLOR, $_[0] | COLOR_INDEX | BACKCOLOR_FLAG} sub fontId { return OP_FONT, F_ID, $_[0] } sub fontSize { return OP_FONT, F_SIZE, $_[0] } sub fontHeight { return OP_FONT, F_SIZE, $_[0] + F_HEIGHT } sub fontStyle { return OP_FONT, F_STYLE, $_[0] } sub moveto { return OP_TRANSPOSE, $_[0], $_[1], $_[2] || 0 } sub extend { return OP_TRANSPOSE, $_[0], $_[1], ($_[2] || 0) | X_EXTEND } sub code { return OP_CODE, $_[0], $_[1] } sub wrap { return OP_WRAP, $_[0] } sub mark { return OP_MARK, $_[0], 0, 0 } package Prima::TextView::EventContent; sub on_mousedown {} sub on_mousemove {} sub on_mouseup {} package Prima::TextView; use vars qw(@ISA); @ISA = qw(Prima::Widget Prima::MouseScroller Prima::GroupScroller); sub profile_default { my $def = $_[ 0]-> SUPER::profile_default; my %prf = ( autoHScroll => 1, autoVScroll => 0, borderWidth => 2, colorMap => [ $def-> {color}, $def-> {backColor} ], fontPalette => [ { name => $def-> {font}-> {name}, encoding => '', pitch => fp::Default, }], hScroll => 1, offset => 0, paneWidth => 0, paneHeight => 0, paneSize => [0,0], resolution => [ $::application-> resolution ], topLine => 0, scaleChildren => 0, selectable => 1, textOutBaseline => 1, textRef => '', vScroll => 1, widgetClass => wc::Edit, pointer => cr::Text, ); @$def{keys %prf} = values %prf; return $def; } sub profile_check_in { my ( $self, $p, $default) = @_; $self-> SUPER::profile_check_in( $p, $default); if ( exists( $p-> { paneSize})) { $p-> { paneWidth} = $p-> { paneSize}-> [ 0]; $p-> { paneHeight} = $p-> { paneSize}-> [ 1]; } $p-> { text} = '' if exists( $p-> { textRef}); $p-> {autoHScroll} = 0 if exists $p-> {hScroll}; $p-> {autoVScroll} = 0 if exists $p-> {vScroll}; } sub init { my $self = shift; for ( qw( topLine scrollTransaction hScroll vScroll offset paneWidth paneHeight borderWidth autoVScroll autoHScroll)) { $self-> {$_} = 0; } my %profile = $self-> SUPER::init(@_); $self-> {paneSize} = [0,0]; $self-> {colorMap} = []; $self-> {fontPalette} = []; $self-> {blocks} = []; $self-> {resolution} = []; $self-> {defaultFontSize} = $self-> font-> size; $self-> {selection} = [ -1, -1, -1, -1]; $self-> {selectionPaintMode} = 0; $self-> {ymap} = []; $self-> setup_indents; $self-> resolution( @{$profile{resolution}}); for ( qw( autoHScroll autoVScroll colorMap fontPalette hScroll vScroll borderWidth paneWidth paneHeight offset topLine textRef)) { $self-> $_( $profile{ $_}); } return %profile; } sub reset_scrolls { my $self = shift; my @sz = $self-> get_active_area( 2, @_); if ( $self-> {scrollTransaction} != 1) { if ( $self-> {autoVScroll}) { my $vs = ($self-> {paneHeight} > $sz[1]) ? 1 : 0; if ( $vs != $self-> {vScroll}) { $self-> vScroll( $vs); @sz = $self-> get_active_area( 2, @_); } } $self-> {vScrollBar}-> set( max => $self-> {paneHeight} - $sz[1], pageStep => int($sz[1] * 0.9), step => $self-> font-> height, whole => $self-> {paneHeight}, partial => $sz[1], value => $self-> {topLine}, ) if $self-> {vScroll}; } if ( $self-> {scrollTransaction} != 2) { if ( $self-> {autoHScroll}) { my $hs = ($self-> {paneWidth} > $sz[0]) ? 1 : 0; if ( $hs != $self-> {hScroll}) { $self-> hScroll( $hs); @sz = $self-> get_active_area( 2, @_); } } $self-> {hScrollBar}-> set( max => $self-> {paneWidth} - $sz[0], whole => $self-> {paneWidth}, value => $self-> {offset}, partial => $sz[0], pageStep => int($sz[0] * 0.75), ) if $self-> {hScroll}; } } sub on_size { my ( $self, $oldx, $oldy, $x, $y) = @_; $self-> reset_scrolls( $x, $y); } sub on_fontchanged { my $f = $_[0]-> font; $_[0]-> {defaultFontSize} = $f-> size; $_[0]-> {fontPalette}-> [0]-> {name} = $f-> name; } sub set { my ( $self, %set) = @_; if ( exists $set{paneSize}) { $self-> paneSize( @{$set{paneSize}}); delete $set{paneSize}; } $self-> SUPER::set( %set); } sub text { unless ($#_) { my $hugeScalarRef = $_[0]-> textRef; return $$hugeScalarRef; } else { my $s = $_[1]; $_[0]-> textRef( \$s); } } sub textRef { return $_[0]-> {text} unless $#_; $_[0]-> {text} = $_[1] if $_[1]; } sub paneWidth { return $_[0]-> {paneWidth} unless $#_; my ( $self, $pw) = @_; $pw = 0 if $pw < 0; return if $pw == $self-> {paneWidth}; $self-> {paneWidth} = $pw; $self-> reset_scrolls; $self-> repaint; } sub paneHeight { return $_[0]-> {paneHeight} unless $#_; my ( $self, $ph) = @_; $ph = 0 if $ph < 0; return if $ph == $self-> {paneHeight}; $self-> {paneHeight} = $ph; $self-> reset_scrolls; $self-> repaint; } sub paneSize { return $_[0]-> {paneWidth}, $_[0]-> {paneHeight} if $#_ < 2; my ( $self, $pw, $ph) = @_; $ph = 0 if $ph < 0; $pw = 0 if $pw < 0; return if $ph == $self-> {paneHeight} && $pw == $self-> {paneWidth}; $self-> {paneWidth} = $pw; $self-> {paneHeight} = $ph; $self-> reset_scrolls; $self-> repaint; } sub offset { return $_[0]-> {offset} unless $#_; my ( $self, $offset) = @_; $offset = int($offset); my @sz = $self-> size; my @aa = $self-> get_active_area(2, @sz); my $pw = $self-> {paneWidth}; $offset = $pw - $aa[0] if $offset > $pw - $aa[0]; $offset = 0 if $offset < 0; return if $self-> {offset} == $offset; my $dt = $offset - $self-> {offset}; $self-> {offset} = $offset; if ( $self-> {hScroll} && $self-> {scrollTransaction} != 2) { $self-> {scrollTransaction} = 2; $self-> {hScrollBar}-> value( $offset); $self-> {scrollTransaction} = 0; } $self-> scroll( -$dt, 0, clipRect => [ $self-> get_active_area(0, @sz)]); } sub resolution { return @{$_[0]->{resolution}} unless $#_; my ( $self, $x, $y) = @_; die "Invalid resolution\n" if $x <= 0 or $y <= 0; @{$self-> {resolution}} = ( $x, $y); } sub topLine { return $_[0]-> {topLine} unless $#_; my ( $self, $top) = @_; $top = int($top); my @sz = $self-> size; my @aa = $self-> get_active_area(2, @sz); my $ph = $self-> {paneHeight}; $top = $ph - $aa[1] if $top > $ph - $aa[1]; $top = 0 if $top < 0; return if $self-> {topLine} == $top; my $dt = $top - $self-> {topLine}; $self-> {topLine} = $top; if ( $self-> {vScroll} && $self-> {scrollTransaction} != 1) { $self-> {scrollTransaction} = 1; $self-> {vScrollBar}-> value( $top); $self-> {scrollTransaction} = 0; } $self-> scroll( 0, $dt, clipRect => [ $self-> get_active_area(0, @sz)]); } sub VScroll_Change { my ( $self, $scr) = @_; return if $self-> {scrollTransaction}; $self-> {scrollTransaction} = 1; $self-> topLine( $scr-> value); $self-> {scrollTransaction} = 0; } sub HScroll_Change { my ( $self, $scr) = @_; return if $self-> {scrollTransaction}; $self-> {scrollTransaction} = 2; $self-> offset( $scr-> value); $self-> {scrollTransaction} = 0; } sub colorMap { return [ @{$_[0]-> {colorMap}}] unless $#_; my ( $self, $cm) = @_; $self-> {colorMap} = [@$cm]; $self-> {colorMap}-> [1] = $self-> backColor if scalar @$cm < 2; $self-> {colorMap}-> [0] = $self-> color if scalar @$cm < 1; $self-> repaint; } sub fontPalette { return [ @{$_[0]-> {fontPalette}}] unless $#_; my ( $self, $fm) = @_; $self-> {fontPalette} = [@$fm]; $self-> {fontPalette}-> [0] = { name => $self-> font-> name, encoding => '', pitch => fp::Default, } if scalar @$fm < 1; $self-> repaint; } sub create_state { my $self = $_[0]; my $g = tb::block_create(); $$g[ tb::BLK_FONT_SIZE] = $self-> {defaultFontSize}; $$g[ tb::BLK_COLOR] = tb::COLOR_INDEX; $$g[ tb::BLK_BACKCOLOR] = tb::BACKCOLOR_DEFAULT; return $g; } sub realize_state { my ( $self, $canvas, $state, $mode) = @_; if ( $mode & tb::REALIZE_FONTS) { my %f = %{$self-> {fontPalette}-> [ $$state[ tb::BLK_FONT_ID]]}; if ( $$state[ tb::BLK_FONT_SIZE] > tb::F_HEIGHT) { $f{height} = $$state[ tb::BLK_FONT_SIZE] - tb::F_HEIGHT; } else { $f{size} = $$state[ tb::BLK_FONT_SIZE]; } $f{style} = $$state[ tb::BLK_FONT_STYLE]; $canvas-> set_font( \%f); } return unless $mode & tb::REALIZE_COLORS; if ( $self-> {selectionPaintMode}) { $self-> selection_state( $canvas); } else { $canvas-> set( color => (( $$state[ tb::BLK_COLOR] & tb::COLOR_INDEX) ? ( $self-> {colorMap}-> [$$state[ tb::BLK_COLOR] & tb::COLOR_MASK]) : ( $$state[ tb::BLK_COLOR] & tb::COLOR_MASK)), backColor => (( $$state[ tb::BLK_BACKCOLOR] & tb::COLOR_INDEX) ? ( $self-> {colorMap}-> [$$state[ tb::BLK_BACKCOLOR] & tb::COLOR_MASK]) : ( $$state[ tb::BLK_BACKCOLOR] & tb::COLOR_MASK)), textOpaque => (( $$state[ tb::BLK_BACKCOLOR] == tb::BACKCOLOR_DEFAULT) ? 0 : 1), ); } } sub recalc_ymap { my ( $self, $from) = @_; $self-> {ymap} = [] unless $from; # ok if $from == 0 my $ymap = $self-> {ymap}; my ( $i, $lim) = ( defined($from) ? $from : 0, scalar(@{$self-> {blocks}})); my $b = $self-> {blocks}; for ( ; $i < $lim; $i++) { $_ = $$b[$i]; my $y1 = $$_[ tb::BLK_Y]; my $y2 = $$_[ tb::BLK_HEIGHT] + $y1; for ( int( $y1 / tb::YMAX) .. int ( $y2 / tb::YMAX)) { push @{$ymap-> [$_]}, $i; } } } sub block_wrap { my ( $self, $canvas, $b, $state, $width) = @_; $width = 0 if $width < 0; my ( $i, $lim) = ( tb::BLK_START, scalar @$b); my $cmd; my ( $o, $t) = ( $$b[ tb::BLK_TEXT_OFFSET], $self-> {text}); my ( $x, $y) = (0, 0); my $f_taint; my $wrapmode = 1; my $stsave = $state; $state = [ @$state ]; my ( $haswrapinfo, @wrapret); my ( @ret, $z); my $lastTextOffset = $$b[ tb::BLK_TEXT_OFFSET]; my $has_text; my $newblock = sub { push @ret, $z = tb::block_create(); @$z[ tb::BLK_DATA_START .. tb::BLK_DATA_END ] = @$state[ tb::BLK_DATA_START .. tb::BLK_DATA_END]; $$z[ tb::BLK_X] = $$b[ tb::BLK_X]; $$z[ tb::BLK_FLAGS] &= ~ tb::T_SIZE; $$z[ tb::BLK_TEXT_OFFSET] = $$b [ tb::BLK_TEXT_OFFSET]; $x = 0; undef $has_text; }; my $retrace = sub { $haswrapinfo = 0; splice( @{$ret[-1]}, $wrapret[0]); @$state = @{$wrapret[1]}; $newblock-> (); $i = $wrapret[2]; }; $newblock-> (); $$z[tb::BLK_TEXT_OFFSET] = $$b[tb::BLK_TEXT_OFFSET]; my %state_hash; # print "start - $$b[tb::BLK_TEXT_OFFSET] \n"; # first state - wrap the block # print "new wrap for $width\n"; for ( ; $i < $lim; $i += $tb::oplen[ $$b[ $i]]) { $cmd = $$b[$i]; if ( $cmd == tb::OP_TEXT) { # print "OP_TEXT @$b[$i+1..$i+3], x = $x\n"; unless ( $f_taint) { $self-> realize_state( $canvas, $state, tb::REALIZE_FONTS); $f_taint = $canvas-> get_font; my $state_key = join('.', @$state[tb::BLK_FONT_ID .. tb::BLK_FONT_STYLE] ); $state_hash{$state_key} = $f_taint unless $state_hash{$state_key}; } my $ofs = $$b[ $i + 1]; my $tlen = $$b[ $i + 2]; $lastTextOffset = $ofs + $tlen unless $wrapmode; REWRAP: my $tw = $canvas-> get_text_width( substr( $$t, $o + $ofs, $tlen), 1); my $apx = $f_taint-> {width}; # print "$x+$apx: new text $tw :|",substr( $$t, $o + $ofs, $tlen),"|\n"; if ( $x + $tw + $apx <= $width) { push @$z, tb::OP_TEXT, $ofs, $tlen, $tw; $x += $tw; $has_text = 1; # print "copied as is, advanced to $x, width $tw, $ofs\n"; } elsif ( $wrapmode) { next if $tlen <= 0; my $str = substr( $$t, $o + $ofs, $tlen); my $leadingSpaces = ''; if ( $str =~ /^(\s+)/) { $leadingSpaces = $1; $str =~ s/^\s+//; } my $l = $canvas-> text_wrap( $str, $width - $apx - $x, tw::ReturnFirstLineLength | tw::WordBreak | tw::BreakSingle); # print "repo $l bytes wrapped in $width - $apx - $x\n"; if ( $l > 0) { if ( $has_text) { push @$z, tb::OP_TEXT, $ofs, $l + length $leadingSpaces, $tw = $canvas-> get_text_width( $leadingSpaces . substr( $str, 0, $l), 1 ); } else { push @$z, tb::OP_TEXT, $ofs + length $leadingSpaces, $l, $tw = $canvas-> get_text_width( substr( $str, 0, $l), 1 ); $has_text = 1; } # print "$x + advance $$z[-1]/$tw|", $leadingSpaces , "+", substr( $str, 0, $l), "|\n"; $str = substr( $str, $l); $l += length $leadingSpaces; $newblock-> (); $ofs += $l; $tlen -= $l; # print "tx shift $l, str=|$str|, x=$x\n"; if ( $str =~ /^(\s+)/) { $ofs += length $1; $tlen -= length $1; $x += $canvas-> get_text_width( $1, 1); $str =~ s/^\s+//; } goto REWRAP if length $str; } else { # does not fit into $width # print "new block: x = $x |$str|\n"; my $ox = $x; $newblock-> (); $ofs += length $leadingSpaces; $tlen -= length $leadingSpaces; if ( length $str) { # well, it cannot be fit into width, # but may be some words can be stripped? goto REWRAP if $ox > 0; if ( $str =~ m/^(\S+)(\s*)/) { $tw = $canvas-> get_text_width( $1, 1); push @$z, tb::OP_TEXT, $ofs, length $1, $tw; $has_text = 1; $x += $tw; $ofs += length($1) + length($2); $tlen -= length($1) + length($2); goto REWRAP; } } push @$z, tb::OP_TEXT, $ofs, length($str), $x += $canvas-> get_text_width( $str, 1); $has_text = 1; } } elsif ( $haswrapinfo) { # unwrappable, and cannot be fit - retrace $retrace-> (); # print "retrace\n"; next; } else { # unwrappable, cannot be fit, no wrap info! - whole new block # print "new empty block - |", substr( $$t,$o + $ofs, $tlen), "|\n"; push @$z, tb::OP_TEXT, $ofs, $tlen, $tw; $newblock-> (); } } elsif ( $cmd == tb::OP_WRAP) { if ( $wrapmode == 1 && $$b[ $i + 1] == 0) { @wrapret = ( scalar @$z, [ @$state ], $i); $haswrapinfo = 1; # print "wrap start record x = $x\n"; } $wrapmode = $$b[ $i + 1]; # print "wrap: $wrapmode\n"; } elsif ( $cmd == tb::OP_FONT) { if ( $$b[$i + 1] == tb::F_SIZE && $$b[$i + 2] < tb::F_HEIGHT ) { $$state[ $$b[$i + 1]] = $self-> {defaultFontSize} + $$b[$i + 2]; } else { $$state[ $$b[$i + 1]] = $$b[$i + 2]; } $f_taint = undef; push @$z, @$b[ $i .. ( $i + $tb::oplen[ $cmd] - 1)]; } elsif ( $cmd == tb::OP_COLOR) { $$state[ tb::BLK_COLOR + (($$b[ $i + 1] & tb::BACKCOLOR_FLAG) ? 1 : 0)] = $$b[$i + 1]; push @$z, @$b[ $i .. ( $i + $tb::oplen[ $cmd] - 1)]; } elsif ( $cmd == tb::OP_TRANSPOSE) { my @r = @$b[ $i .. $i + 3]; if ( $$b[ $i + tb::X_FLAGS] & tb::X_DIMENSION_FONT_HEIGHT) { unless ( $f_taint) { $self-> realize_state( $canvas, $state, tb::REALIZE_FONTS); $f_taint = $canvas-> get_font; my $state_key = join('.', @$state[tb::BLK_FONT_ID .. tb::BLK_FONT_STYLE] ); $state_hash{$state_key} = $f_taint unless $state_hash{$state_key}; } $r[ tb::X_X] *= $f_taint-> {height}; $r[ tb::X_Y] *= $f_taint-> {height}; $r[ tb::X_FLAGS] &= ~ tb::X_DIMENSION_FONT_HEIGHT; } if ( $$b[ $i + tb::X_FLAGS] & tb::X_DIMENSION_POINT) { $r[ tb::X_X] *= $self-> {resolution}-> [0] / 72; $r[ tb::X_Y] *= $self-> {resolution}-> [1] / 72; $r[ tb::X_FLAGS] &= ~tb::X_DIMENSION_POINT; } # print "advance block $x $r[tb::X_X]\n"; if ( $x + $r[tb::X_X] >= $width) { if ( $wrapmode) { $newblock-> (); } elsif ( $haswrapinfo) { $retrace-> (); next; } } else { $x += $r[ tb::X_X]; } push @$z, @r; } else { push @$z, @$b[ $i .. ( $i + $tb::oplen[ $cmd] - 1)]; } } # remove eventual empty trailing blocks pop @ret while scalar ( @ret) && ( tb::BLK_START == scalar @{$ret[-1]}); # second stage - position the blocks $state = $stsave; $f_taint = undef; my $start; if ( !defined $$b[ tb::BLK_Y]) { # auto position the block if the creator didn't care $start = $$state[ tb::BLK_Y] + $$state[ tb::BLK_HEIGHT]; } else { $start = $$b[ tb::BLK_Y]; } $lastTextOffset = $$b[ tb::BLK_TEXT_OFFSET]; my $lastBlockOffset = $lastTextOffset; for ( @ret) { $b = $_; $$b[ tb::BLK_Y] = $start; ( $x, $y, $i, $lim) = ( 0, 0, tb::BLK_START, scalar @$b); for ( ; $i < $lim; $i += $tb::oplen[ $$b[ $i]]) { $cmd = $$b[$i]; if ( $cmd == tb::OP_TEXT) { $f_taint = $state_hash{ join('.', @$state[tb::BLK_FONT_ID .. tb::BLK_FONT_STYLE] ) }; $x += $$b[ $i + 3]; $$b[ tb::BLK_WIDTH] = $x if $$b[ tb::BLK_WIDTH ] < $x; $$b[ tb::BLK_APERTURE_Y] = $f_taint-> {descent} - $y if $$b[ tb::BLK_APERTURE_Y] < $f_taint-> {descent} - $y; $$b[ tb::BLK_APERTURE_X] = $f_taint-> {width} - $x if $$b[ tb::BLK_APERTURE_X] < $f_taint-> {width} - $x; my $newY = $y + $f_taint-> {ascent} + $f_taint-> {externalLeading}; $$b[ tb::BLK_HEIGHT] = $newY if $$b[ tb::BLK_HEIGHT] < $newY; # print "OP_TEXT patch $$b[$i+1] => "; $lastTextOffset = $$b[ tb::BLK_TEXT_OFFSET] + $$b[ $i + 1] + $$b[ $i + 2]; $$b[ $i + 1] -= $lastBlockOffset - $$b[ tb::BLK_TEXT_OFFSET]; # print "$$b[$i+1]\n"; } elsif ( $cmd == tb::OP_FONT) { if ( $$b[$i + 1] == tb::F_SIZE && $$b[$i + 2] < tb::F_HEIGHT ) { $$state[ $$b[$i + 1]] = $self-> {defaultFontSize} + $$b[$i + 2]; } else { $$state[ $$b[$i + 1]] = $$b[$i + 2]; } } elsif ( $cmd == tb::OP_TRANSPOSE) { my ( $newX, $newY) = ( $x + $$b[ $i + tb::X_X], $y + $$b[ $i + tb::X_Y]); $$b[ tb::BLK_WIDTH] = $newX if $$b[ tb::BLK_WIDTH ] < $newX; $$b[ tb::BLK_HEIGHT] = $newY if $$b[ tb::BLK_HEIGHT] < $newY; $$b[ tb::BLK_APERTURE_X] = -$newX if $newX < 0 && $$b[ tb::BLK_APERTURE_X] > -$newX; $$b[ tb::BLK_APERTURE_Y] = -$newY if $newY < 0 && $$b[ tb::BLK_APERTURE_Y] > -$newY; unless ( $$b[ $i + tb::X_FLAGS] & tb::X_EXTEND) { ( $x, $y) = ( $newX, $newY); } } elsif ( $cmd == tb::OP_MARK) { $$b[ $i + 2] = $x; $$b[ $i + 3] = $y; } } $$b[ tb::BLK_TEXT_OFFSET] = $lastBlockOffset; # print "block offset: $lastBlockOffset\n"; $$b[ tb::BLK_HEIGHT] += $$b[ tb::BLK_APERTURE_Y]; $$b[ tb::BLK_WIDTH] += $$b[ tb::BLK_APERTURE_X]; $start += $$b[ tb::BLK_HEIGHT]; $lastBlockOffset = $lastTextOffset; } if ( $ret[-1]) { $b = $ret[-1]; $$state[$_] = $$b[$_] for tb::BLK_X, tb::BLK_Y, tb::BLK_HEIGHT, tb::BLK_WIDTH; } return @ret; } sub selection_state { my ( $self, $canvas) = @_; $canvas-> color( $self-> hiliteColor); $canvas-> backColor( $self-> hiliteBackColor); $canvas-> textOpaque(0); } sub on_paint { my ( $self, $canvas) = @_; my @size = $canvas-> size; unless ( $self-> enabled) { $self-> color( $self-> disabledColor); $self-> backColor( $self-> disabledBackColor); } my ( $t, $offset, @aa) = ( $self-> { topLine}, $self-> { offset}, $self-> get_active_area(1,@size)); my @clipRect = $canvas-> clipRect; $self-> draw_border( $canvas, $self-> backColor, @size); my $bx = $self-> {blocks}; my $lim = scalar @$bx; return unless $lim; my @cy = ( $aa[3] - $clipRect[3], $aa[3] - $clipRect[1]); $cy[0] = 0 if $cy[0] < 0; $cy[1] = $aa[3] - $aa[1] if $cy[1] > $aa[3] - $aa[1]; $cy[$_] += $t for 0,1; $self-> clipRect( $self-> get_active_area( 1, @size)); @clipRect = $self-> clipRect; my $i = 0; my $b; my ( $sx1, $sy1, $sx2, $sy2) = @{$self-> {selection}}; for ( int( $cy[0] / tb::YMAX) .. int( $cy[1] / tb::YMAX)) { next unless $self-> {ymap}-> [$_]; for ( @{$self-> {ymap}-> [$_]}) { my $j = $_; $b = $$bx[$j]; my ( $x, $y) = ( $aa[0] - $offset + $$b[ tb::BLK_X], $aa[3] + $t - $$b[ tb::BLK_Y] - $$b[ tb::BLK_HEIGHT] ); next if $x + $$b[ tb::BLK_WIDTH] < $clipRect[0] || $x > $clipRect[2] || $y + $$b[ tb::BLK_HEIGHT] < $clipRect[1] || $y > $clipRect[3] || $$b[ tb::BLK_WIDTH] == 0 || $$b[ tb::BLK_HEIGHT] == 0; if ( $j == $sy1 || $j == $sy2) { # complex selection case my @cr = @clipRect; my $x1 = $x + $self-> text2xoffset(( $j == $sy1) ? $sx1 : $sx2, $j); my $eq = ( $j == $sy1 ) && ( $j == $sy2 ); $self-> {selectionPaintMode} = ( $eq || $j == $sy1 ) ? 0 : 1; if ( $cr[0] <= $x1 ) { # left upper part $cr[2] = $x1 - 1 if $cr[2] > $x1 - 1; $cr[2] = $aa[2] if $cr[2] > $aa[2]; $cr[2] = $aa[0] if $cr[2] < $aa[0]; if ( $cr[0] <= $cr[2]) { $self-> selection_state( $canvas) if $self-> {selectionPaintMode}; $self-> clipRect( @cr); $self-> block_draw( $canvas, $b, $x, $y); } @cr = @clipRect; } $self-> {selectionPaintMode} = (( $eq || $j == $sy1 ) ? 1 : 0); if ( $cr[2] >= $x1) { # right part $cr[0] = $x1 if $cr[0] < $x1; $cr[0] = $aa[0] if $cr[0] < $aa[0]; $cr[0] = $aa[2] if $cr[0] > $aa[2]; my $x2 = $x + $self-> text2xoffset( $sx2, $j); if ( $eq) { # selection is one block - center part if ( $cr[0] <= $x2) { my $cr2 = $cr[2]; $cr[2] = $x2 - 1 if $cr[2] > $x2 - 1; $cr[2] = $aa[0] if $cr[2] < $aa[0]; $cr[2] = $aa[2] if $cr[2] > $aa[2]; if ( $cr[0] <= $cr[2]) { $self-> selection_state( $canvas) if $self-> {selectionPaintMode}; $self-> clipRect( @cr); $self-> block_draw( $canvas, $b, $x, $y); } @cr = @clipRect; } $cr[0] = $x2 if $cr[0] < $x2; $cr[0] = $aa[0] if $cr[0] < $aa[0]; $cr[0] = $aa[2] if $cr[0] > $aa[2]; } $self-> {selectionPaintMode} = ( $eq || $j == $sy2 ) ? 0 : 1; if ( $cr[0] <= $cr[2]) { $self-> selection_state( $canvas) if $self-> {selectionPaintMode}; $self-> clipRect( @cr); $self-> block_draw( $canvas, $b, $x, $y); } } $self-> {selectionPaintMode} = 0; $self-> clipRect( @clipRect); } elsif ( $j > $sy1 && $j < $sy2) { # simple selection case $self-> {selectionPaintMode} = 1; $self-> selection_state( $canvas); $self-> block_draw( $canvas, $b, $x, $y); $self-> {selectionPaintMode} = 0; } else { $self-> block_draw( $canvas, $b, $x, $y); } } } $self-> {selectionPaintMode} = 0; } sub block_draw { my ( $self, $canvas, $b, $x, $y) = @_; my ( $i, $lim) = ( tb::BLK_START, scalar @$b); my $ret = 1; my $cmd; my ( $t, $o) = ( $self-> {text}, $$b[ tb::BLK_TEXT_OFFSET]); my @state = @$b[ 0 .. tb::BLK_DATA_END ]; my ( $f_taint, $c_taint); $canvas-> clear( $x, $y, $x + $$b[ tb::BLK_WIDTH] - 1, $y + $$b[ tb::BLK_HEIGHT] - 1) if $self-> {selectionPaintMode}; $x += $$b[ tb::BLK_APERTURE_X]; $y += $$b[ tb::BLK_APERTURE_Y]; for ( ; $i < $lim; $i += $tb::oplen[ $$b[ $i]] ) { $cmd = $$b[$i]; if ( $cmd == tb::OP_TEXT) { if ( $$b[$i + 2] > 0) { unless ( $f_taint) { $self-> realize_state( $canvas, \@state, tb::REALIZE_FONTS); $f_taint = $canvas-> get_font; } unless ( $c_taint) { $self-> realize_state( $canvas, \@state, tb::REALIZE_COLORS); $c_taint = 1; } $ret = $canvas-> text_out( substr( $$t, $o + $$b[$i + 1], $$b[$i + 2]), $x, $y); } $x += $$b[ $i + 3]; } elsif ( $cmd == tb::OP_FONT) { if ( $$b[$i + 1] == tb::F_SIZE && $$b[$i + 2] < tb::F_HEIGHT ) { $state[ $$b[$i + 1]] = $self-> {defaultFontSize} + $$b[$i + 2]; } else { $state[ $$b[$i + 1]] = $$b[$i + 2]; } $f_taint = undef; } elsif (( $cmd == tb::OP_TRANSPOSE) && !($$b[ $i + tb::X_FLAGS] & tb::X_EXTEND)) { $x += $$b[ $i + tb::X_X]; $y += $$b[ $i + tb::X_Y]; } elsif ( $cmd == tb::OP_CODE) { unless ( $f_taint) { $self-> realize_state( $canvas, \@state, tb::REALIZE_FONTS); $f_taint = $canvas-> get_font; } unless ( $c_taint) { $self-> realize_state( $canvas, \@state, tb::REALIZE_COLORS); $c_taint = 1; } $$b[ $i + 1]-> ( $self, $canvas, $b, \@state, $x, $y, $$b[ $i + 2]); } elsif ( $cmd == tb::OP_COLOR) { $state[ tb::BLK_COLOR + (($$b[ $i + 1] & tb::BACKCOLOR_FLAG) ? 1 : 0)] = $$b[$i + 1]; $c_taint = undef; } } return $ret; } sub xy2info { my ( $self, $x, $y) = @_; my $bx = $self-> {blocks}; my ( $pw, $ph) = $self-> paneSize; $x = 0 if $x < 0; $x = $pw if $x > $pw; return (0,0) if $y < 0 || !scalar(@$bx) ; $x = $pw, $y = $ph if $y > $ph; my ( $b, $bid); my $xhint = 0; # find if there's a block that has $y in its inferior my $ymapix = int( $y / tb::YMAX); if ( $self-> {ymap}-> [ $ymapix]) { my ( $minxdist, $bdist, $bdistid) = ( $self-> {paneWidth} * 2, undef, undef); for ( @{$self-> {ymap}-> [ $ymapix]}) { my $z = $$bx[$_]; if ( $y >= $$z[ tb::BLK_Y] && $y < $$z[ tb::BLK_Y] + $$z[ tb::BLK_HEIGHT]) { if ( $x >= $$z[ tb::BLK_X] && $x < $$z[ tb::BLK_X] + $$z[ tb::BLK_WIDTH] ) { $b = $z; $bid = $_; last; } elsif ( abs($$z[ tb::BLK_X] - $x) < $minxdist || abs($$z[ tb::BLK_X] + $$z[ tb::BLK_WIDTH] - $x) < $minxdist ) { $minxdist = ( abs( $$z[ tb::BLK_X] - $x) < $minxdist) ? abs( $$z[ tb::BLK_X] - $x) : abs( $$z[ tb::BLK_X] + $$z[ tb::BLK_WIDTH] - $x); $bdist = $z; $bdistid = $_; } } } if ( !$b && $bdist) { $b = $bdist; $bid = $bdistid; $xhint = (( $$b[ tb::BLK_X] > $x) ? -1 : 1); } } # if still no block found, find the closest block down unless ( $b) { my $minydist = $self-> {paneHeight} * 2; my $ymax = scalar @{$self-> {ymap}}; while ( $ymapix < $ymax) { if ( $self-> {ymap}-> [ $ymapix]) { for ( @{$self-> {ymap}-> [ $ymapix]}) { my $z = $$bx[$_]; if ( $minydist > $$z[ tb::BLK_Y] - $y && $$z[ tb::BLK_Y] >= $y ) { $minydist = $$z[ tb::BLK_Y] - $y; $b = $z; $bid = $_; } } } last if $b; $ymapix++; } $ymapix = int( $y / tb::YMAX); $xhint = -1; } # if still no block found, assume EOT unless ( $b) { $b = $$bx[-1]; $bid = scalar @{$bx} - 1; $xhint = 1; } if ( $xhint < 0) { # start of line return ( 0, $bid); } elsif ( $xhint > 0) { # end of line if ( $bid < ( scalar @{$bx} - 1)) { return ( $$bx[ $bid + 1]-> [ tb::BLK_TEXT_OFFSET] - $$b[ tb::BLK_TEXT_OFFSET], $bid ); } else { return ( length( ${$self-> {text}}) - $$b[ tb::BLK_TEXT_OFFSET], $bid); } } # find text offset my $bofs = $$b[ tb::BLK_TEXT_OFFSET]; my ( $ofs, $unofs) = (0,0); my $pm = $self-> get_paint_state; $self-> begin_paint_info unless $pm; my $savefont = $self-> get_font; my @state = @$b[ 0 .. tb::BLK_DATA_END ]; my $f_taint; my ( $i, $lim) = ( tb::BLK_START, scalar @$b); my $px = $$b[ tb::BLK_X]; for ( ; $i < $lim; $i += $tb::oplen[ $$b[ $i]] ) { my $cmd = $$b[$i]; if ( $cmd == tb::OP_TEXT) { my $npx = $px + $$b[$i+3]; if ( $px > $x) { $ofs = $$b[ $i + 1]; undef $unofs; last; } elsif ( $px <= $x && $npx > $x) { unless ( $f_taint) { $self-> realize_state( $self, \@state, tb::REALIZE_FONTS); $f_taint = $self-> get_font; } $ofs = $$b[ $i + 1] + $self-> text_wrap( substr( ${$self-> {text}}, $bofs + $$b[ $i + 1], $$b[ $i + 2] ), $x - $px, tw::ReturnFirstLineLength | tw::BreakSingle ); undef $unofs; last; } $unofs = $$b[ $i + 1] + $$b[ $i + 2]; $px = $npx; } elsif (( $cmd == tb::OP_TRANSPOSE) && !($$b[ $i + tb::X_FLAGS] & tb::X_EXTEND)) { $px += $$b[ $i + tb::X_X]; } elsif ( $cmd == tb::OP_FONT) { if ( $$b[$i + 1] == tb::F_SIZE && $$b[$i + 2] < tb::F_HEIGHT ) { $state[ $$b[$i + 1]] = $self-> {defaultFontSize} + $$b[$i + 2]; } else { $state[ $$b[$i + 1]] = $$b[$i + 2]; } $f_taint = undef; } } $pm ? $self-> set_font( $savefont) : $self-> end_paint_info; return defined( $unofs) ? $unofs : $ofs, $bid; } sub screen2point { my ( $self, $x, $y, @size) = @_; @size = $self-> size unless @size; my @aa = $self-> get_active_area( 0, @size); $x -= $aa[0]; $y = $aa[3] - $y; $y += $self-> {topLine}; $x += $self-> {offset}; return $x, $y; } sub text2xoffset { my ( $self, $x, $bid) = @_; my $b = $self-> {blocks}-> [$bid]; return 0 unless $b; return 0 if $x <= 0; # XXX my $pm = $self-> get_paint_state; $self-> begin_paint_info unless $pm; my $savefont = $self-> get_font; my @state = @$b[ 0 .. tb::BLK_DATA_END ]; my $f_taint; my ( $i, $lim) = ( tb::BLK_START, scalar @$b); my $px = $$b[tb::BLK_APERTURE_X]; my $bofs = $$b[tb::BLK_TEXT_OFFSET]; for ( ; $i < $lim; $i += $tb::oplen[ $$b[ $i]] ) { my $cmd = $$b[$i]; if ( $cmd == tb::OP_TEXT) { if ( $x >= $$b[$i+1]) { if ( $x < $$b[$i+1] + $$b[$i+2]) { unless ( $f_taint) { $self-> realize_state( $self, \@state, tb::REALIZE_FONTS ); $f_taint = $self-> get_font; } $px += $self-> get_text_width( substr( ${$self-> {text}}, $bofs + $$b[$i+1], $x - $$b[$i+1] ) ); last; } elsif ( $x == $$b[$i+1] + $$b[$i+2]) { $px += $$b[$i+3]; last; } } $px += $$b[$i+3]; } elsif (( $cmd == tb::OP_TRANSPOSE) && !($$b[ $i + tb::X_FLAGS] & tb::X_EXTEND)) { $px += $$b[ $i + tb::X_X]; } elsif ( $cmd == tb::OP_FONT) { if ( $$b[$i + 1] == tb::F_SIZE && $$b[$i + 2] < tb::F_HEIGHT ) { $state[ $$b[$i + 1]] = $self-> {defaultFontSize} + $$b[$i + 2]; } else { $state[ $$b[$i + 1]] = $$b[$i + 2]; } $f_taint = undef; } } $pm ? $self-> set_font( $savefont) : $self-> end_paint_info; return $px; } sub info2text_offset { my ( $self, $ofs, $blk) = @_; if ( $blk >= 0 && $ofs >= 0) { return $self-> {blocks}-> [$blk]-> [tb::BLK_TEXT_OFFSET] + $ofs; } else { return length ${$self-> {text}}; } } sub text_offset2info { my ( $self, $ofs) = @_; my $blk = $self-> text_offset2block( $ofs); return undef unless defined $blk; return $ofs - $self-> {blocks}-> [$blk]-> [ tb::BLK_TEXT_OFFSET], $blk; } sub info2xy { my ( $self, $ofs, $blk) = @_; $blk = $self-> {blocks}-> [$blk]; return undef unless defined $blk; return @$blk[ tb::BLK_X, tb::BLK_Y]; } sub text_offset2block { my ( $self, $ofs) = @_; my $bx = $self-> {blocks}; my $end = length ${$self-> {text}}; my $ret = 0; return undef if $ofs < 0 || $ofs >= $end; my ( $l, $r) = ( 0, scalar @$bx); while ( 1) { my $i = int(( $l + $r) / 2); last if $i == $ret; $ret = $i; my ( $b1, $b2) = ( $$bx[$i], $$bx[$i+1]); last if $ofs == $$b1[ tb::BLK_TEXT_OFFSET]; if ( $ofs > $$b1[ tb::BLK_TEXT_OFFSET]) { if ( $b2) { last if $ofs < $$b2[ tb::BLK_TEXT_OFFSET]; $l = $i; } else { last; } } else { $r = $i; } } return $ret; } sub on_mousedown { my ( $self, $btn, $mod, $x, $y) = @_; return if $self-> {mouseTransaction}; my @size = $self-> size; my @aa = $self-> get_active_area( 0, @size); return if $x < $aa[0] || $x >= $aa[2] || $y < $aa[1] || $y >= $aa[3]; ( $x, $y) = $self-> screen2point( $x, $y, @size); for my $obj ( @{$self-> {contents}}) { unless ( $obj-> on_mousedown( $self, $btn, $mod, $x, $y)) { $self-> clear_event; return; } } return if $btn != mb::Left; my ( $text_offset, $bid) = $self-> xy2info( $x, $y); $self-> {mouseTransaction} = 1; $self-> {mouseAnchor} = [ $text_offset, $bid ]; $self-> selection( -1, -1, -1, -1); $self-> capture(1); $self-> clear_event; } sub on_mouseclick { my ( $self, $btn, $mod, $x, $y, $dbl) = @_; return unless $dbl; return if $self-> {mouseTransaction}; return if $btn != mb::Left; my @size = $self-> size; my @aa = $self-> get_active_area( 0, @size); if ( $x < $aa[0] || $x >= $aa[2] || $y < $aa[1] || $y >= $aa[3]) { if ( $self-> has_selection) { $self-> selection( -1, -1, -1, -1); my $cp = $::application-> bring('Primary'); $cp-> text( '') if $cp; } return; } ( $x, $y) = $self-> screen2point( $x, $y, @size); my ( $text_offset, $bid) = $self-> xy2info( $x, $y); my $ln = ( $bid + 1 == scalar @{$self-> {blocks}}) ? length ${$self-> {text}} : $self-> {blocks}-> [$bid+1]-> [tb::BLK_TEXT_OFFSET]; $self-> selection( 0, $bid, $ln - $self-> {blocks}-> [$bid]-> [tb::BLK_TEXT_OFFSET], $bid); $self-> clear_event; my $cp = $::application-> bring('Primary'); $cp-> text( $self-> get_selected_text) if $cp; } sub on_mouseup { my ( $self, $btn, $mod, $x, $y) = @_; unless ( $self-> {mouseTransaction}) { ( $x, $y) = $self-> screen2point( $x, $y); for my $obj ( @{$self-> {contents}}) { unless ( $obj-> on_mouseup( $self, $btn, $mod, $x, $y)) { $self-> clear_event; return; } } return; } return if $btn != mb::Left; $self-> capture(0); $self-> {mouseTransaction} = undef; $self-> clear_event; my $cp = $::application-> bring('Primary'); $cp-> text( $self-> get_selected_text) if $cp; } sub on_mousemove { my ( $self, $mod, $x, $y) = @_; unless ( $self-> {mouseTransaction}) { ( $x, $y) = $self-> screen2point( $x, $y); for my $obj ( @{$self-> {contents}}) { unless ( $obj-> on_mousemove( $self, $mod, $x, $y)) { $self-> clear_event; return; } } return; } my @size = $self-> size; my @aa = $self-> get_active_area( 0, @size); if ( $x < $aa[0] || $x >= $aa[2] || $y < $aa[1] || $y >= $aa[3]) { $self-> scroll_timer_start unless $self-> scroll_timer_active; return unless $self-> scroll_timer_semaphore; $self-> scroll_timer_semaphore(0); } else { $self-> scroll_timer_stop; } my ( $nx, $ny) = $self-> screen2point( $x, $y, @size); my ( $text_offset, $bid) = $self-> xy2info( $nx, $ny); $self-> selection( @{$self-> {mouseAnchor}}, $text_offset, $bid); if ( $x < $aa[0] || $x >= $aa[2]) { my $px = $self-> {paneWidth} / 8; $px = 5 if $px < 5; $px *= -1 if $x < $aa[0]; $self-> offset( $self-> {offset} + $px); } if ( $y < $aa[1] || $y >= $aa[3]) { my $py = $self-> font-> height; $py = 5 if $py < 5; $py *= -1 if $y >= $aa[3]; $self-> topLine( $self-> {topLine} + $py); } } sub on_mousewheel { my ( $self, $mod, $x, $y, $z) = @_; $z = int( $z/120) * 3; $z *= $self-> font-> height + $self-> font-> externalLeading unless $mod & km::Ctrl; my $newTop = $self-> {topLine} - $z; $self-> topLine( $newTop > $self-> {paneHeight} ? $self-> {paneHeight} : $newTop); $self-> clear_event; } sub on_keydown { my ( $self, $code, $key, $mod, $repeat) = @_; $mod &= km::Alt|km::Ctrl|km::Shift; return if $mod & km::Alt; if ( grep { $key == $_ } ( kb::Up, kb::Down, kb::Left, kb::Right, kb::Space, kb::PgDn, kb::PgUp, kb::Home, kb::End )) { my ( $dx, $dy) = (0,0); if ( $key == kb::Up || $key == kb::Down) { $dy = $self-> font-> height; $dy = 5 if $dy < 5; $dy *= $repeat; $dy = -$dy if $key == kb::Up; } elsif ( $key == kb::Left || $key == kb::Right) { $dx = $self-> {paneWidth} / 8; $dx = 5 if $dx < 5; $dx *= $repeat; $dx = -$dx if $key == kb::Left; } elsif ( $key == kb::PgUp || $key == kb::PgDn || $key == kb::Space) { my @aa = $self-> get_active_area(0); $dy = ( $aa[3] - $aa[1]) * 0.9; $dy = 5 if $dy < 5; $dy *= $repeat; $dy = -$dy if $key == kb::PgUp; } $dx += $self-> {offset}; $dy += $self-> {topLine}; if ( $key == kb::Home) { $dy = 0; } elsif ( $key == kb::End) { $dy = $self-> {paneHeight}; } $self-> offset( $dx); $self-> topLine( $dy); $self-> clear_event; } if (((( $key == kb::Insert) && ( $mod & km::Ctrl)) || chr($code & 0xff) eq "\cC") && $self-> has_selection) { $self-> copy; $self-> clear_event; } } sub has_selection { return ( grep { $_ != -1 } @{$_[0]-> {selection}} ) ? 1 : 0; } sub selection { return @{$_[0]-> {selection}} unless $#_; my ( $self, $sx1, $sy1, $sx2, $sy2) = @_; $sy1 = 0 if $sy1 < 0; $sy2 = 0 if $sy2 < 0; my $lim = scalar @{$self-> {blocks}} - 1; $sy1 = $lim if $sy1 > $lim; $sy2 = $lim if $sy2 > $lim; my $empty = ! $self-> has_selection; my ( $osx1, $osy1, $osx2, $osy2) = @{$self-> {selection}}; my ( $x1, $y1, $x2, $y2) = (0,0,0,0); unless ( grep { $_ != -1 } $sx1, $sy1, $sx2, $sy2 ) { # new empty selection EMPTY: return if $empty; $y1 = $osy1; $y2 = $osy2; if ( $y1 == $y2) { $x1 = $osx1; $x2 = $osx2; } } else { ( $sy1, $sy2, $sx1, $sx2) = ( $sy2, $sy1, $sx2, $sx1) if $sy2 < $sy1; ( $sx1, $sx2) = ( $sx2, $sx1) if $sy2 == $sy1 && $sx2 < $sx1; ( $sx1, $sx2, $sy1, $sy2) = ( -1, -1, -1, -1), goto EMPTY if $sy1 == $sy2 && $sx1 == $sx2; if ( $empty) { $y1 = $sy1; $y2 = $sy2; if ( $y1 == $y2) { $x1 = $sx1; $x2 = $sx2; } } else { if ( $sy1 == $osy1 && $sx1 == $osx1) { return if $sy2 == $osy2 && $sx2 == $osx2; $y1 = $sy2; $y2 = $osy2; if ( $sy2 == $osy2) { $x1 = $sx2; $x2 = $osx2; } } elsif ( $sy2 == $osy2 && $sx2 == $osx2) { $y1 = $sy1; $y2 = $osy1; if ( $sy1 == $osy1) { $x1 = $sx1; $x2 = $osx1; } } else { $y1 = ( $sy1 < $osy1) ? $sy1 : $osy1; $y2 = ( $sy2 > $osy2) ? $sy2 : $osy2; if ( $sy1 == $sy2 && $osy1 == $osy2 && $sy2 == $osy1) { $x1 = ( $sx1 < $osx1) ? $sx1 : $osx1; $x2 = ( $sx2 > $osx2) ? $sx2 : $osx2; } } ( $y1, $y2, $x1, $x2) = ( $y2, $y1, $x2, $x1) if $y2 < $y1; } } my $bx = $self-> {blocks}; my @clipRect; my @size = $self-> size; my @aa = $self-> get_active_area( 0, @size); if ( $y2 != $y1) { my $b = $$bx[ $y1]; my @a = ( $$b[ tb::BLK_X], $$b[tb::BLK_Y], $$b[ tb::BLK_X], $$b[ tb::BLK_Y]); for ( $y1 .. $y2) { my $z = $$bx[ $_]; my @b = ( $$z[ tb::BLK_X], $$z[tb::BLK_Y], $$z[ tb::BLK_X] + $$z[ tb::BLK_WIDTH], $$z[ tb::BLK_Y] + $$z[ tb::BLK_HEIGHT]); for ( 0, 1) { $a[$_] = $b[$_] if $a[$_] > $b[$_] } for ( 2, 3) { $a[$_] = $b[$_] if $a[$_] < $b[$_] } } $clipRect[0] = $aa[0] - $self-> {offset} + $a[0]; $clipRect[1] = $aa[3] + $self-> {topLine} - $a[1] - 1; $clipRect[2] = $aa[0] - $self-> {offset} + $a[2]; $clipRect[3] = $aa[3] + $self-> {topLine} - $a[3] - 1; } else { my $b = $$bx[ $y1]; ( $x2, $x1) = ( $x1, $x2) if $x1 > $x2; $clipRect[0] = $aa[0] - $self-> {offset} + $$b[ tb::BLK_X] + $self-> text2xoffset( $x1, $y1); $clipRect[1] = $aa[3] - $$b[ tb::BLK_Y] - $$b[ tb::BLK_HEIGHT] + $self-> {topLine} - 1; $clipRect[2] = $aa[0] - $self-> {offset} + $$b[ tb::BLK_X] + $self-> text2xoffset( $x2, $y1); $clipRect[3] = $aa[3] - $$b[ tb::BLK_Y] + $self-> {topLine} - 1; } for ( 0, 1) { @clipRect[$_,$_+2] = @clipRect[$_+2,$_] if $clipRect[$_] > $clipRect[$_+2]; $clipRect[$_] = $aa[$_] if $clipRect[$_] < $aa[$_]; $clipRect[$_+2] = $aa[$_+2] if $clipRect[$_+2] > $aa[$_+2]; } $self-> {selection} = [ $sx1, $sy1, $sx2, $sy2 ]; my @cpr = $self-> get_invalid_rect; if ( $cpr[0] != $cpr[2] || $cpr[1] != $cpr[3]) { for ( 0,1) { $clipRect[$_] = $cpr[$_] if $clipRect[$_] > $cpr[$_]; $clipRect[$_+2] = $cpr[$_+2] if $clipRect[$_+2] < $cpr[$_+2]; } } $self-> invalidate_rect( @clipRect); } sub get_selected_text { my $self = $_[0]; return unless $self-> has_selection; my ( $sx1, $sy1, $sx2, $sy2) = $self-> selection; my ( $a1, $a2) = ( $self-> {blocks}-> [$sy1]-> [tb::BLK_TEXT_OFFSET] + $sx1, $self-> {blocks}-> [$sy2]-> [tb::BLK_TEXT_OFFSET] + $sx2, ); return substr( ${$self-> {text}}, $a1, $a2 - $a1); } sub copy { my $self = $_[0]; my $text = $self-> get_selected_text; $::application-> Clipboard-> store( 'Text', $text) if defined $text; } sub clear_all { my $self = $_[0]; $self-> selection(-1,-1,-1,-1); $self-> {blocks} = []; $self-> paneSize( 0, 0); $self-> text(''); } package Prima::TextView::EventRectangles; sub new { my $class = shift; my %profile = @_; my $self = {}; bless( $self, $class); $self-> {$_} = $profile{$_} ? $profile{$_} : [] for qw( rectangles references); return $self; } sub contains { my ( $self, $x, $y) = @_; my $rec = 0; for ( @{$self-> {rectangles}}) { return $rec if $x >= $$_[0] && $y >= $$_[1] && $x < $$_[2] && $y < $$_[3]; $rec++; } return -1; } sub rectangles { return $_[0]-> {rectangles} unless $#_; $_[0]-> {rectangles} = $_[1]; } sub references { return $_[0]-> {references} unless $#_; $_[0]-> {references} = $_[1]; } 1; __END__ =pod =head1 NAME Prima::TextView - rich text browser widget =head1 DESCRIPTION Prima::TextView accepts blocks of formatted text, and provides basic functionality - scrolling and user selection. The text strings are stored as one large text chunk, available by the C<::text> and C<::textRef> properties. A block of a formatted text is an array with fixed-length header and the following instructions. A special package C provides the block constants and simple functions for text block access. =head2 Capabilities Prima::TextView is mainly the text block functions and helpers. It provides function for wrapping text block, calculating block dimensions, drawing and converting coordinates from (X,Y) to a block position. Prima::TextView is centered around the text functionality, and although any custom graphic of arbitrary complexity can be embedded in a text block, the internal coordinate system is used ( TEXT_OFFSET, BLOCK ), where TEXT_OFFSET is a text offset from the beginning of a block and BLOCK is an index of a block. The functionality does not imply any text layout - this is up to the class descendants, they must provide they own layout policy. The only policy Prima::TextView requires is that blocks' BLK_TEXT_OFFSET field must be strictly increasing, and the block text chunks must not overlap. The text gaps are allowed though. A text block basic drawing function includes change of color, backColor and font, and the painting of text strings. Other types of graphics can be achieved by supplying custom code. =head2 Block header A block's fixed header consists of C integer scalars, each of those is accessible via the corresponding C constant. The constants are separated into two logical groups: BLK_FLAGS BLK_WIDTH BLK_HEIGHT BLK_X BLK_Y BLK_APERTURE_X BLK_APERTURE_Y BLK_TEXT_OFFSET and BLK_FONT_ID BLK_FONT_SIZE BLK_FONT_STYLE BLK_COLOR BLK_BACKCOLOR The second group is enclosed in C - C range, like the whole header is contained in 0 - C range. This is done for the backward compatibility, if the future development changes the length of the header. The first group fields define the text block dimension, aperture position and text offset ( remember, the text is stored as one big chunk ). The second defines the initial color and font settings. Prima::TextView needs all fields of every block to be initialized before displaying. L method can be used for automated assigning of these fields. =head2 Block parameters The scalars, beginning from C, represent the commands to the renderer. These commands have their own parameters, that follow the command. The length of a command is located in C<@oplen> array, and must not be changed. The basic command set includes C, C, C, C, and C. The additional codes are C and C, not used in drawing but are special commands to L. =over =item OP_TEXT - TEXT_OFFSET, TEXT_LENGTH, TEXT_WIDTH C commands to draw a string, from offset C, with a length TEXT_LENGTH. The third parameter TEXT_WIDTH contains the width of the text in pixels. Such the two-part offset scheme is made for simplification or an imaginary code, that would alter ( insert to, or delete part of ) the big text chunk; the updating procedure would not need to traverse all commands, but just the block headers. Relative to: C. =item OP_COLOR - COLOR C sets foreground or background color. To set the background, COLOR must be or-ed with C value. In addition to the two toolkit supported color values ( RRGGBB and system color index ), COLOR can also be or-ed with C flags, in such case it is an index in C<::colormap> property array. Relative to: C, C. =item OP_FONT - KEY, VALUE As the font is a complex property, that itself includes font name, size, direction, etc keys, C KEY represents one of the three parameters - C, C, C. All three have different VALUE meaning. Relative to: C, C, C. =over =item F_STYLE Contains a combination of C constants, such as C, C etc. Default value: 0 =item F_SIZE Contains the relative font size. The size is relative to the current widget's font size. As such, 0 is a default value, and -2 is the widget's default font decreased by 2 points. Prima::TextView provides no range checking ( but the toolkit does ), so while it is o.k. to set the negative C values larger than the default font size, one must be vary when relying on the combined font size value . If C value is added to a C constant, then it is treated as a font height in pixels rather than font size in points. The macros for these opcodes are named respectively C and C, while the opcode is the same. =item F_ID All other font properties are collected under an 'ID'. ID is a index in the C<::fontPalette> property array, which contains font hashes with the other font keys initialized - name, encoding, and pitch. These three are minimal required set, and the other font keys can be also selected. =back =item OP_TRANSPOSE X, Y, FLAGS Contains a mark for an empty space. The space is extended to the relative coordinates (X,Y), so the block extension algorithms take this opcode in the account. If FLAGS does not contain C, then in addition to the block expansion, current coordinate is also moved to (X,Y). In this regard, C<(OP_TRANSPOSE,0,0,0)> and C<(OP_TRANSPOSE,0,0,X_EXTEND)> are identical and are empty operators. There are formatting-only flags,in effect with L function. C indicates that (X,Y) values must be multiplied to the current font height. Another flag C does the same but multiplies by current value of L property divided by 72 ( basically, treats X and Y not as pixel but point values). C can be used for customized graphics, in conjunction with C to assign a space, so the rendering algorithms do not need to be re-written every time the new graphic is invented. As an example, see how L deals with the images. =item OP_CODE - SUB, PARAMETER Contains a custom code pointer SUB with a parameter PARAMETER, passed when a block is about to be drawn. SUB is called with the following format: ( $widget, $canvas, $text_block, $font_and_color_state, $x, $y, $parameter); $font_and_color_state ( or $state, through the code ) contains the state of font and color commands in effect, and is changed as the rendering algorithm advances through a block. The format of the state is the same as of text block, so one may notice that for readability F_ID, F_SIZE, F_STYLE constants are paired to BLK_FONT_ID, BLK_FONT_SIZE and BLK_FONT_STYLE. The SUB code is executed only when the block is about to draw. =item OP_WRAP ON_OFF C is only in effect in L method. ON_OFF is a boolean flag, selecting if the wrapping is turned on or off. L does not support stacking for the wrap commands, so the C<(OP_WRAP,1,OP_WRAP,1,OP_WRAP,0)> has same effect as C<(OP_WRAP,0)>. If ON_OFF is 1, wrapping is disabled - all following commands treated an non-wrapable until C<(OP_WRAP,0)> is met. =item OP_MARK PARAMETER, X, Y C is only in effect in L method and is a user command. L only sets (!) X and Y to the current coordinates when the command is met. Thus, C can be used for arbitrary reasons, easy marking the geometrical positions that undergo the block wrapping. =back As can be noticed, these opcodes are far not enough for the full-weight rich text viewer. However, the new opcodes can be created using C, that accepts the opcode length and returns the new opcode value. =head2 Rendering methods =over =item block_wrap C is the function, that is used to wrap a block into a given width. It returns one or more text blocks with fully assigned headers. The returned blocks are located one below another, providing an illusion that the text itself is wrapped. It does not only traverses the opcodes and sees if the command fit or not in the given width; it also splits the text strings if these do not fit. By default the wrapping can occur either on a command boundary or by the spaces or tab characters in the text strings. The unsolicited wrapping can be prevented by using C command brackets. The commands inside these brackets are not wrapped; C commands are removed from the output blocks. In general, C copies all commands and their parameters as is, ( as it is supposed to do ), but some commands are treated especially: - C's third parameter, C, is disregarded, and is recalculated for every C met. - If C's third parameter, C contains C flag, the command coordinates X and Y are multiplied to the current font height and the flag is cleared in the output block. - C's second and third parameters assigned to the current (X,Y) coordinates. - C removed from the output. =item block_draw CANVAS, BLOCK, X, Y The C draws BLOCK onto CANVAS in screen coordinates (X,Y). It can not only be used for drawing inside begin_paint/end_paint brackets; CANVAS can be an arbitrary C descendant. =back =head2 Coordinate system methods Prima::TextView employs two its own coordinate systems: (X,Y)-document and (TEXT_OFFSET,BLOCK)-block. The document coordinate system is isometric and measured in pixels. Its origin is located into the imaginary point of the beginning of the document ( not of the first block! ), in the upper-left point. X increases to the right, Y increases downwards. The block header values BLK_X and BLK_Y are in document coordinates, and the widget's pane extents ( regulated by C<::paneSize>, C<::paneWidth> and C<::paneHeight> properties ) are also in document coordinates. The block coordinate system in an-isometric - its second axis, BLOCK, is an index of a text block in the widget's blocks storage, C<$self-E{blocks}>, and its first axis, TEXT_OFFSET is a text offset from the beginning of the block. Below described different coordinate system converters =over =item screen2point X, Y Accepts (X,Y) in the screen coordinates ( O is a lower left widget corner ), returns (X,Y) in document coordinates ( O is upper left corner of a document ). =item xy2info X, Y Accepts (X,Y) is document coordinates, returns (TEXT_OFFSET,BLOCK) coordinates, where TEXT_OFFSET is text offset from the beginning of a block ( not related to the big text chunk ) , and BLOCK is an index of a block. =item info2xy TEXT_OFFSET, BLOCK Accepts (TEXT_OFFSET,BLOCK) coordinates, and returns (X,Y) in document coordinates of a block. =item text2xoffset TEXT_OFFSET, BLOCK Returns X coordinate where TEXT_OFFSET begins in a BLOCK index. =item info2text_offset Accepts (TEXT_OFFSET,BLOCK) coordinates and returns the text offset with regard to the big text chunk. =item text_offset2info TEXT_OFFSET Accepts big text offset and returns (TEXT_OFFSET,BLOCK) coordinates =item text_offset2block TEXT_OFFSET Accepts big text offset and returns BLOCK coordinate. =back =head2 Text selection The text selection is performed automatically when the user selects the region with a mouse. The selection is stored in (TEXT_OFFSET,BLOCK) coordinate pair, and is accessible via the C<::selection> property. If its value is assigned to (-1,-1,-1,-1) this indicates that there is no selection. For convenience the C method is introduced. Also, C returns the text within the selection (or undef with no selection ), and C copies automatically the selected text into the clipboard. The latter action is bound to C key combination. =head2 Event rectangles Partly as an option for future development, partly as a hack a concept of 'event rectangles' was introduced. Currently, C<{contents}> private variable points to an array of objects, equipped with C, C, and C methods. These are called within the widget's mouse events, so the overloaded classes can define the interactive content without overloading the actual mouse events ( which is although easy but is dependent on Prima::TextView own mouse reactions ). As an example L uses the event rectangles to catch the mouse events over the document links. Theoretically, every 'content' is to be bound with a separate logical layer; when the concept was designed, a html-browser was in mind, so such layers can be thought as ( in the html world ) links, image maps, layers, external widgets. Currently, C class is provided for such usage. Its property C<::rectangles> contains an array of rectangles, and the C method returns an integer value, whether the passed coordinates are inside one of its rectangles or not; in the first case it is the rectangle index. =cut