1package Prima::Drawable::Markup; 2 3use strict; 4use warnings; 5use Prima qw(Drawable::TextBlock); 6use base qw(Prima::Drawable::TextBlock Exporter); 7our @EXPORT_OK = 'M'; 8 9=head1 NAME 10 11Prima::Drawable::Markup - allow markup in widgets 12 13=head1 SYNOPSIS 14 15 use Prima qw(Application Buttons); 16 use Prima::Drawable::Markup q(M); 17 my $m = Prima::MainWindow->new; 18 $m-> insert( Button => 19 text => Prima::Drawable::Markup->new(markup => "B<Bold> bU<u>tton"), 20 hotKey => 'u', 21 pack => {}, 22 ); 23 $m->insert( Button => pack => {}, text => M "I<Italic> button" ); 24 $m->insert( Button => pack => {}, text => \ "Not an Q<I<italic>> button" ); 25 26 run Prima; 27 28=for podview <img src="Prima/markup.gif"> 29 30=for html <p><img src="https://raw.githubusercontent.com/dk/Prima/master/pod/Prima/markup.gif"> 31 32=head1 DESCRIPTION 33 34C<Prima::Drawable::Markup> adds the ability to recognize POD-like markup to Prima 35widgets. Supported markup sequences are C<B> (bold text), C<I> (italic text), 36C<U> (underlined text), C<F> (change font), C<S> (change font size), C<C> 37(change foreground color), C<G> (change background color), C<M> (move pointer), 38C<W> (disable wrapping), and C<P> (picture). 39 40The C<F> sequence is used as follows: C<FE<lt>n|textE<gt>>, where C<n> is a 410-based index into the C<fontPalette>. 42 43The C<S> sequence is used as follows: C<SE<lt>n|textE<gt>>, where C<n> is the 44number of points relative to the current font size. The font size may 45optionally be preceded by C<+> or C<->. 46 47The C<C> and C<G> sequences are used as follows: C<CE<lt>c|textE<gt>>, where 48C<c> is either: a color in any form accepted by Prima, including the C<cl> 49constants (C<Black> C<Blue> C<Green> C<Cyan> C<Red> C<Magenta> C<Brown> 50C<LightGray> C<DarkGray> C<LightBlue> C<LightGreen> C<LightCyan> C<LightRed> 51C<LightMagenta> C<Yellow> C<White> C<Gray>). Or, a 0-based index into the 52C<colorPalette>. Also, C<default> can be used to set the color that the canvas 53originaly had. For C<G> a special value C<off> can be used to turn off background 54color and set it as transparent. 55 56The C<M> command has three parameters, comma-separated: X, Y, and flags. X and 57Y are coordinates how much to move the current pointer. By default X and are in 58pixels, and do not extend block width. C<flags> is a set of characters, where 59each is: 60 61 m - set units to font height 62 p - set units to points 63 x - also extend the block width 64 65The text inside C<W> sequence will not be wrapped during C<text_wrap> calls. 66 67The text inside C<Q> sequence will not be treated as markup. 68 69The C<P> sequence is used as follows:C<< PE<lt>nE<gt> >>, where C<n> is a 700-based index into the C<picturePalette>. 71 72The methods C<text_out> and C<get_text_width> are affected by C<Prima::Drawable::Markup>. 73C<text_out> will write formatted text to the canvas, and C<get_text_width> will 74return the width of the formatted text. B<NOTE>: These methods do not save state 75between calls, so your markup cannot span lines (since each line is drawn or 76measured with a separate call). 77 78The module can export a single method C<M> that is a shortcut over creation of a new markup 79object with default color, font, and image palettes. These can be accessed directly as 80C<@COLORS, @FONTS, @IMAGES> correspondingly. 81 82=cut 83 84our (@FONTS, @COLORS, @IMAGES); 85sub M($) { 86 return Prima::Drawable::Markup->new( 87 markup => $_[0], 88 fontPalette => \@FONTS, 89 picturePalette => \@IMAGES, 90 colorPalette => \@COLORS, 91 ) 92} 93 94sub new 95{ 96 my ($class, %opt) = @_; 97 %opt = ( %opt, 98 fontmap => [{}], 99 colormap => [0,0], 100 ); 101 my $self = $class->SUPER::new(%opt); 102 $self-> $_( $opt{$_} || [] ) for qw(fontPalette colorPalette picturePalette); 103 $self-> markup( $opt{markup} || ''); 104 return $self; 105} 106 107sub parse_color 108{ 109 my ( $self, $mode, $command, $stacks, $state, $block, $c ) = @_; 110 111 my $key = ($command eq 'C') ? 'color' : 'backColor'; 112 113 if ( $mode ) { 114 if ( $c =~ /^[0-9a-f]{6}$/ ) { 115 $c = hex $c; 116 } elsif ( $c =~ /^(\D.+)$/ && exists($cl::{$1})) { 117 $c = &{$cl::{$1}}(); 118 } elsif ( $c =~ /^\d+$/) { 119 if ( $c >= @{ $self->{colorPalette} } ) { 120 warn "Color index outside palette: $c"; 121 return; 122 } 123 $c += 2; 124 $c |= tb::COLOR_INDEX; 125 } elsif ( lc($c) eq 'default' ) { 126 $c = $block->[($command eq 'G') ? tb::BLK_BACKCOLOR : tb::BLK_COLOR]; 127 } elsif ( $command eq 'G' && lc($c) eq 'off' ) { 128 $c = tb::BACKCOLOR_OFF; 129 } else { 130 warn "Bad color: $c"; 131 return; 132 } 133 push @{$stacks->{$key}}, $state->{$key}; 134 $state->{$key} = $c | (( $command eq 'G') ? tb::BACKCOLOR_FLAG : 0); 135 } else { 136 $state->{$key} = pop @{$stacks->{$key}}; 137 } 138 push @$block, tb::color($state->{$key}); 139 140 return 1; 141} 142 143sub parse_font_id 144{ 145 my ( $self, $mode, $command, $stacks, $state, $block, $f ) = @_; 146 147 if ( $mode ) { 148 if ( $f !~ /^\d+$/) { 149 warn "Bad fond id: $f"; 150 return; 151 } 152 if ( $f >= @{ $self->{fontPalette} } ) { 153 warn "Font index outside palette: $f"; 154 return; 155 } 156 push @{$stacks->{fontId}}, $state->{fontId}; 157 $state->{fontId} = $f + 1; 158 } else { 159 $state->{fontId} = pop @{$stacks->{fontId}}; 160 } 161 push @$block, tb::fontId($state->{fontId}); 162} 163 164sub parse_font_size 165{ 166 my ( $self, $mode, $command, $stacks, $state, $block, $s ) = @_; 167 168 if ( $mode ) { 169 unless ($s =~ /^[+-]?\d+$/) { 170 warn "Bad font size: $s"; 171 return; 172 } 173 push @{$stacks->{fontSize}}, $state->{fontSize}; 174 $state->{fontSize} += $s; 175 push @$block, tb::fontSize($s); 176 } else { 177 $state->{fontSize} = pop @{$stacks->{fontSize}}; 178 push @$block, tb::fontSize($state->{fontSize}); 179 } 180 return 1; 181} 182 183sub parse_font_style 184{ 185 my ( $self, $mode, $command, $stacks, $state, $block ) = @_; 186 187 if ( $mode ) { 188 my %cmd = ( 189 I => fs::Italic, 190 B => fs::Bold, 191 U => fs::Underlined, 192 ); 193 push @{$stacks->{fontStyle}}, $state->{fontStyle}; 194 $state->{fontStyle} |= $cmd{$command}; 195 push @$block, tb::fontStyle($state->{fontStyle}); 196 } else { 197 $state->{fontStyle} = pop @{$stacks->{fontStyle}}; 198 push @$block, tb::fontStyle($state->{fontStyle}); 199 } 200 return 1; 201} 202 203sub parse_transpose 204{ 205 my ( $self, $mode, $command, $stacks, $state, $block, $dx, $dy, $subcmd ) = @_; 206 my $fl = 0; 207 for my $s ( split //, $subcmd // '') { 208 if ( $s eq 'm') { 209 $fl |= tb::X_DIMENSION_FONT_HEIGHT; 210 } elsif ( $s eq 'p') { 211 $fl |= tb::X_DIMENSION_POINT; 212 } elsif ( $s eq 'x') { 213 $fl |= tb::X_EXTEND; 214 } else { 215 warn "Bad extension flag: $s"; 216 return; 217 } 218 } 219 push @$block, tb::moveto($dx || 0, $dy || 0, $fl); 220} 221 222sub parse_wrap 223{ 224 my ( $self, $mode, $command, $stacks, $state, $block ) = @_; 225 226 if ( $mode ) { 227 push @{$stacks->{wrap}}, $state->{wrap}; 228 $state->{wrap} = tb::WRAP_MODE_OFF; 229 } else { 230 $state->{wrap} = pop @{$stacks->{wrap}}; 231 } 232 push @$block, tb::wrap($state->{wrap}); 233 return 1; 234} 235 236sub paint_picture 237{ 238 my ( $self, $canvas, $block, $state, $x, $y, $r) = @_; 239 my ( $img, $zoom ) = @$r; 240 $y += ($block->[tb::BLK_HEIGHT] - $img->height * $zoom ) / 2 - $block->[tb::BLK_APERTURE_Y]; 241 $canvas-> stretch_image( $x, $y, $img-> width * $zoom, $img-> height * $zoom, $img); 242} 243 244sub parse_picture 245{ 246 my ( $self, $mode, $command, $stacks, $state, $block, $pic, $zoom ) = @_; 247 unless ($pic =~ /^\d+$/ && $pic < @{ $self->{picturePalette} } ) { 248 warn "Bad picture id: $pic"; 249 return; 250 } 251 if ( defined $zoom && $zoom !~ /^\d+(\.\d+)?$/) { 252 warn "Bad picture zoom: $zoom"; 253 return; 254 } 255 $pic = $self->{picturePalette}->[$pic]; 256 $zoom //= 1; 257 258 push @$block, 259 tb::wrap(tb::WRAP_MODE_OFF), 260 tb::extend( $pic->width * $zoom, $pic->height * $zoom, 0), 261 tb::code( \&paint_picture, [$pic, $zoom]), 262 tb::moveto( $pic->width * $zoom, 0, 0), 263 tb::wrap(tb::WRAP_MODE_ON) 264 ; 265} 266 267sub parse_quote 268{ 269 my ( $self, $mode, $command, $stacks, $state, $block ) = @_; 270 $state->{quote} = $mode; 271 return 1; 272} 273 274sub commands 275{ 276 return ( 277 # has params, has text, callback 278 C => [ 1, 1, \&parse_color ], 279 G => [ 1, 1, \&parse_color ], 280 F => [ 1, 1, \&parse_font_id ], 281 S => [ 1, 1, \&parse_font_size ], 282 I => [ 0, 1, \&parse_font_style ], 283 B => [ 0, 1, \&parse_font_style ], 284 U => [ 0, 1, \&parse_font_style ], 285 M => [ 1, 0, \&parse_transpose ], 286 W => [ 0, 1, \&parse_wrap ], 287 P => [ 1, 0, \&parse_picture ], 288 Q => [ 0, 1, \&parse_quote ], 289 ); 290} 291 292sub init_state 293{ 294 return { 295 color => 0 | tb::COLOR_INDEX, 296 backColor => tb::BACKCOLOR_DEFAULT, 297 fontId => 0, 298 fontSize => 0, 299 fontStyle => 0, 300 wrap => tb::WRAP_MODE_ON, 301 quote => 0, 302 }; 303} 304 305sub parse 306{ 307 my ( $self, $text ) = @_; 308 my (%stacks, @cmd_stack, @delim_stack ); 309 310 my %commands = $self->commands; 311 312 my @tokens = split /([A-Z]<(?:<+\s+)?|\n\r*)/, $text; 313 my $block = tb::block_create(); 314 my $plaintext = ''; 315 316 my $state = $self->init_state; 317 318 while ( @tokens ) { 319 my $token = shift @tokens; 320 # Look for the beginning of a sequence 321 if ( $token =~ /^[\n\r]+$/) { 322 push @$block, tb::wrap( tb::WRAP_IMMEDIATE ); 323 } elsif ( $token =~ /^([A-Z])(<(?:<+\s+)?)$/s && ! $state->{quote} ) { 324 # Push a new sequence onto the stack of those "in-progress" 325 my ($cmd, $ldelim) = ($1, $2); 326 $ldelim =~ s/\s+$//, (my $rdelim = $ldelim) =~ tr/</>/; 327 push @cmd_stack, '<>'; # temporary noop 328 push @delim_stack, $rdelim; 329 330 unless ( exists $commands{$cmd}) { 331 warn "Unknown command: $cmd\n"; 332 next; 333 } 334 335 my ( $has_params, $has_text, $callback ) = @{ $commands{$cmd} }; 336 my @params; 337 if ( $has_params ) { 338 my $t = shift @tokens; 339 unless ( defined $t ) { 340 warn "Unexpected end of input\n"; 341 last; 342 } 343 my ($ok, $param, $text); 344 if ( $has_text ) { 345 $ok = $t =~ /^([^|]+)\|(.*)$/s; 346 ($param, $text) = ($1, $2); 347 } else { 348 $ok = $t =~ /^([^>]*)>(.*)$/s; 349 ($param, $text) = ($1, $2); 350 } 351 352 if ( !$ok) { 353 warn "Expected parameters to $cmd.\n"; 354 last; 355 } 356 unshift @tokens, $text; 357 @params = split(',', $param); 358 } 359 next unless $callback->($self, 1, $cmd, \%stacks, $state, $block, @params); 360 $cmd_stack[-1] = $cmd; 361 } # end of if block for open sequence 362 # Look for sequence ending 363 else { 364 my $dlm; 365 # Make sure we match the right kind of closing delimiter 366 if ( $dlm = $delim_stack[$#delim_stack] and ( 367 ($dlm eq '>' and $token =~ /\A(.*?)(\>)/s) or 368 ($dlm ne '>' and $token =~ /\A(.*?)(\s{1,}$dlm)/s) 369 ) 370 ) { 371 my $t = $1; 372 pop @delim_stack; 373 push @$block, tb::text( length($plaintext), length($t) ); 374 $plaintext .= $t; 375 376 my $rest = substr($token, length($1) + length($2)); 377 length($rest) and unshift @tokens, $rest; 378 379 my $cmd = pop(@cmd_stack) // ''; 380 if( $self->{quote} && $cmd ne 'Q') { 381 push @cmd_stack, $cmd; 382 next; 383 } else { 384 next unless exists $commands{$cmd}; 385 } 386 387 my ( $has_params, $has_text, $callback ) = @{ $commands{$cmd} }; 388 $callback->($self, 0, $cmd, \%stacks, $state, $block) if $has_text; 389 } # end of if block for close sequence 390 else { # if we get here, we're non-escaped text 391 push @$block, tb::text( length($plaintext), length($token) ); 392 $plaintext .= $token; 393 } 394 } # end of else block after if block for open sequence 395 } # end of while loop 396 397 push @$block, tb::wrap(tb::WRAP_MODE_ON) if $state->{wrap} == tb::WRAP_MODE_OFF; 398 399 return $plaintext, $block; 400} 401 402sub markup 403{ 404 return $_[0]->{markup} unless $#_; 405 406 my ( $self, $markup ) = @_; 407 my ( $text, $block ) = $self-> parse( $markup ); 408 409 $self-> {markup} = $markup; 410 $self-> text( $text ); 411 $self-> {block} = $block; 412} 413 414sub acquire 415{ 416 my ($self, $canvas, %opt) = @_; 417 my $font; 418 if ( $opt{font} || $opt{dimensions} ) { 419 $font = $canvas->get_font; 420 $self->{fontmap}->[0] = $font; 421 $self->{block}->[tb::BLK_FONT_ID] = 0; 422 $self->{block}->[tb::BLK_FONT_SIZE] = $self->{baseFontSize} = $font->{size}; 423 $self->{block}->[tb::BLK_FONT_STYLE] = $self->{baseFontStyle} = $font->{style}; 424 $self->{direction} = $font->{direction}; 425 } 426 if ( $opt{colors}) { 427 $self->{block}->[tb::BLK_COLOR] = $self->{colormap}->[0] = $canvas->color; 428 $self->{colormap}->[1] = $canvas-> backColor; 429 $self->{block}->[tb::BLK_BACKCOLOR] = 430 ($canvas-> textOpaque ? $canvas-> backColor : tb::BACKCOLOR_DEFAULT); 431 } 432 if ( $opt{dimensions} ) { 433 my $signature = join('.', @{$font}{qw(name size height width style encoding direction)}); 434 if ( $signature ne $self->{fontSignature} ) { 435 $self->{fontSignature} = $signature; 436 $self->calculate_dimensions($canvas); 437 } 438 } 439} 440 441sub fontPalette 442{ 443 return $_[0]->{fontPalette} unless $#_; 444 my ( $self, $fp ) = @_; 445 $self->{fontPalette} = $fp; 446 splice( @{$self->{fontmap}}, 1 ); 447 push @{ $self->{fontmap}}, @$fp; 448} 449 450sub colorPalette 451{ 452 return $_[0]->{colorPalette} unless $#_; 453 my ( $self, $cp ) = @_; 454 $self->{colorPalette} = $cp; 455 splice( @{$self->{colormap}}, 2 ); 456 push @{ $self->{colormap}}, @$cp; 457} 458 459sub picturePalette 460{ 461 return $_[0]->{picturePalette} unless $#_; 462 my ( $self, $pp ) = @_; 463 $self->{picturePalette} = $pp; 464} 465 466sub text_wrap 467{ 468 my ( $self, $canvas, $width, $opt, $indent) = @_; 469 470 my @ret = @{ $self-> SUPER::text_wrap( $canvas, $width, $opt, $indent ) }; 471 472 my ( @blocks, @other); 473 for my $block ( @ret ) { 474 if ( ref($block) eq 'Prima::Drawable::TextBlock') { 475 $block = bless $block, __PACKAGE__; 476 $block->{$_} = [@{$self->{$_}}] for qw(fontmap colormap fontPalette colorPalette); 477 $block->{$_} = $self->{$_} for qw(restoreCanvas); 478 push @blocks, $block; 479 } else { 480 push @other, $block; 481 } 482 } 483 return @other unless @blocks; 484 485 # initials will be overwritten by acquire(), force copy them 486 for my $block ( @blocks ) { 487 my $b = $block->{block}; 488 splice( @$b, tb::BLK_START, 0, 489 tb::color( $$b[tb::BLK_COLOR]), 490 tb::color( $$b[tb::BLK_BACKCOLOR]), 491 tb::fontId( $$b[tb::BLK_FONT_ID]), 492 tb::fontSize( $$b[tb::BLK_FONT_SIZE] - $self->{baseFontSize}), 493 tb::fontStyle( $$b[tb::BLK_FONT_STYLE]) 494 ); 495 } 496 497 return [ @blocks, @other ]; 498} 499 500=head1 PROPERTIES 501 502The following properties are used: 503 504=over 505 506=item colorPalette([@colorPalette]) 507 508Gets or sets the color palette to be used for C<C> sequences within this widget. 509Each element of the array should be a C<cl::> constant. 510 511=item fontPalette([@fontPalette]) 512 513Gets or sets the font palette to be used for C<F> sequences within this widget. 514Each element of the array should be a hashref suitable for setting a font. 515 516=item picturePalette([@picturePalette]) 517 518Gets or sets the picture palette to be used for C<P> sequences within this widget. 519Each element of the array should be a C<Prima::Image> descendant. 520 521=back 522 523=head1 SEE ALSO 524 525L<Prima::Drawable::TextBlock>, F<examples/markup.pl> 526 527=head1 COPYRIGHT 528 529Copyright 2003 Teo Sankaro 530 531You may redistribute and/or modify this module under the same terms as Perl itself. 532(Although a credit would be nice.) 533 534=head1 AUTHOR 535 536This module based on work by Teo Sankaro, E<lt>teo_sankaro@hotmail.comE<gt>. 537 538=cut 539 5401; 541