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