# 
# This file is part of Curses-Toolkit
# 
# This software is copyright (c) 2008 by Damien "dams" Krotkine.
# 
# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
# 
use warnings;
use strict;

package Curses::Toolkit::Object::MarkupString;
our $VERSION = '0.100320';


# ABSTRACT: a string that contains markups

use parent qw(Curses::Toolkit::Object);

use Curses;


# Warning
# The code in this file is just hideous ! :) One day it'll have to be rewritten
# properly I guess...

sub new {
	my ($class, $markup_string) = @_;
	length $markup_string or $markup_string = '';
	my $self = bless { markup_string => undef,
					   stripped_string => undef,
					 }, $class;
	$self->set_markup_text($markup_string);
	return bless $self, $class;
}

sub new_from_computed_string {
	my ($class, $markup_string, $stripped_string, $attr_struct) = @_;
	return bless { markup_string => $markup_string,
				   stripped_string => $stripped_string,
				   attr_struct => $attr_struct,
				 }, $class;
}

sub stripped {
	my ($self) = @_;
	return $self->{stripped_string};
}

sub set_markup_text {
	my ($self, $text) = @_;
	$self->{markup_string} = $text;
	$self->_recompute();
	return;
}

sub get_attr_struct {
	my ($self) = @_;
	return $self->{attr_struct};
}

sub stripped_length {
	my ($self) = @_;
	$self->{stripped_string}
	  or return 0;
	return length $self->{stripped_string};
}

sub _recompute {
	my ($self) = @_;
	my $markup_string = $self->{markup_string};
	if (!defined $markup_string || ! length $markup_string) {
		$self->{stripped_string} = '';
		$self->{attr_struct} = [];
	}

	use HTML::Parser;

# 	my %text_to_const = ( normal => A_NORMAL,
# 						  standout => A_STANDOUT,
# 						  underline => A_UNDERLINE,
# 						  reverse => A_REVERSE,
# 						  blink => A_BLINK,
# 						  dim => A_DIM,
# 						  bold => A_BOLD );

# 	my %text_to_color = (black => COLOR_BLACK,
# 						 red => COLOR_RED,
# 						 green => COLOR_GREEN,
# 						 yellow => COLOR_YELLOW,
# 						 blue => COLOR_BLUE,
# 						 magenta => COLOR_MAGENTA,
# 						 cyan => COLOR_CYAN,
# 						 white => COLOR_WHITE,
# 						);
	my @struct;

	my @current_attrs;
	my @stack;
	my $parser = HTML::Parser->new(
		api_version => 3,
		start_h   => [ sub {
						   my ($tagname, $text, $attr) = @_;
						   my %struct = ();
						   if      ($tagname eq 'span') {
							   push @stack, $tagname;

							   my $weight = $attr->{weight}; #$text_to_const{$attr->{weight} || 'normal'};
							   if (defined $weight) {
								   $struct{weight} = $weight;
							   }

							   my $fgcolor = defined $attr->{fgcolor} ? $attr->{fgcolor} : undef; #$text_to_color{$attr->{fgcolor}}
							   my $bgcolor = defined $attr->{bgcolor} ? $attr->{bgcolor} : undef; #$text_to_color{$attr->{bgcolor}}

							   defined $fgcolor
								 and $struct{fgcolor} = $fgcolor;
							   defined $bgcolor
								 and $struct{bgcolor} = $bgcolor;
							   push @current_attrs, \%struct;
						   } elsif ($tagname eq 'b') {
							   push @stack, $tagname;
							   push @current_attrs, { weight => A_BOLD };
						   } elsif ($tagname eq 'u') {
							   push @stack, $tagname;
							   push @current_attrs, { weight => A_UNDERLINE };
						   } else {
							   push @struct, map { [ $_, _deep_copy(@current_attrs) ] } split(//, $text);
						   }
					   },
					   'tagname, text, attr' ],
		end_h     => [ sub {
						   my ($tagname, $text) = @_;
						   if (@stack && $tagname eq $stack[-1]) {
							   pop @stack;
							   pop @current_attrs;
						   } else {
							   push @struct, map { [ $_, _deep_copy(@current_attrs) ] } split(//, $text);
						   }
					   },   'tagname, text' ],
		default_h => [ sub {
						   my ($dtext) = @_;
						   defined $dtext or $dtext = '';
						   push @struct, map { [ $_, _deep_copy(@current_attrs) ] } split(//, $dtext);
					   },   'dtext' ],
	);
	$parser->parse($markup_string);
	$parser->eof;                 # signal end of document

	$self->{stripped_string} = join('', map { $_->[0] } @struct);
	$self->{attr_struct} = \@struct;
	return;
}

sub _deep_copy {
	return map {
		  ref $_ eq 'ARRAY'  ? [ _deep_copy(@$_) ]
		: ref $_ eq 'HASH'   ? { _deep_copy(%$_) }
		: ref $_ eq 'SCALAR' ? \_deep_copy($$_)
		: $_;
	} @_;
}

sub substring {
	my ($self, $start, $width) = @_;
	my $class = ref $self;
	my $new_stripped_string = '';
	$start < length($self->{stripped_string})
	  and $new_stripped_string = substr($self->{stripped_string}, $start, $width);
	my $r = $class->new_from_computed_string(
			undef,                                            # markup string
			$new_stripped_string, # stripped string
			[ @{$self->{attr_struct}}[$start..$start+$width-1] ], # attr_struct
		);
	return $r;
}

sub search_replace {
	my ($self, $pattern, $replace, $limit) = @_;
	defined $replace or $replace = '';
	my $string = $self->{stripped_string};
	my $count = 0;
	while ( $string =~ /$pattern/g ) {
		my $start = length($`);
		my $width = length($&);

		$self->{markup_string} = undef;
		substr($self->{stripped_string}, $start, $width, $replace);

		my @repl_attr = @{ ($start ? $self->{attr_struct}->[$start - 1] : [] ) };
		shift @repl_attr;
		splice(@{$self->{attr_struct}}, $start, $width, map { [ $_, @repl_attr ] } split(//, $replace) );

		defined $limit or next;
		++$count >= $limit and last;
	}
	return;
	
}

sub split_string {
	my ($self, $pattern, $limit) = @_;
	my $class = ref $self;
	my $string = $self->{stripped_string};
	my $start = 0;
	my $count = 0;
	my @results = ();
	while ( $string =~ /$pattern/g ) {
		my $end = $start + length($`) - 1;
		push @results, $class->new_from_computed_string(
			undef,                                 # markup string
			$`,                                    # stripped string
			[ @{$self->{attr_struct}}[$start..$end] ], # attr_struct
		);
		$start = $end + 1 + length($&);
		$string = $';
		defined $limit or next;
		++$count >= $limit and last;
	}
	length $string and
	  push @results, $class->new_from_computed_string(
		undef,
		$string,
		[ @{$self->{attr_struct}}[$start..length($string)-$start-1] ]
	  );
	return @results;
}

sub append {
	my ($self, $append) = @_;
	if (ref $append eq ref $self) {
		$self->{stripped_string} .= $append->{stripped_string};
		defined $self->{markup_string} && defined $append->{markup_string}
		  and $self->{markup_string} .= $append->{markup_string};
		$self->{attr_struct} = [ @{$self->{attr_struct}}, @{$append->{attr_struct}} ];
		return;
	}
	$self->{stripped_string} .= $append;
	$self->{markup_string} = undef;

	my $i = scalar @{$self->{attr_struct}};
	my @repl_attr = @{ $i ? $self->{attr_struct}->[-1] : []  };

	shift @repl_attr;
	push( @{$self->{attr_struct}}, map { [ $_, @repl_attr ] } split(//, $append) );
	return;
}

sub chomp_string {
	my ($self) = @_;
	my $original_len = $self->stripped_length();
	chomp $self->{stripped_string};
	my $new_len = $self->stripped_length();
	if ($original_len != $new_len) {
		$self->{markup_string} = undef;
		splice(@{$self->{attr_struct}}, $new_len, $original_len - $new_len );
	}
	return $original_len - $new_len;
}

1;


__END__

=pod

=head1 NAME

Curses::Toolkit::Object::MarkupString - a string that contains markups

=head1 VERSION

version 0.100320

=head1 DESCRIPTION

Class that manage tied strings to handle style markup transparently

  my $string = Curses::Toolkit::Object::MarkupString->new('hello <span weight="bold">world</span>');

This is an internal Class, you shouldn't use it. 

see L<Curses::Toolkit::Widget::Label> to get the list of supported markups
(like <u>, <b>, <span>).



=head1 AUTHOR

  Damien "dams" Krotkine

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2008 by Damien "dams" Krotkine.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut 