package Text::Colorizer ;

use strict;
use warnings ;
use Carp ;

BEGIN 
{

use Sub::Exporter -setup => 
	{
	exports => [ qw() ],
	groups  => 
		{
		all  => [ qw() ],
		}
	};
	
use vars qw ($VERSION);
$VERSION     = '0.03';
}

#-------------------------------------------------------------------------------

use English qw( -no_match_vars ) ;

use Readonly ;
Readonly my $EMPTY_STRING => q{} ;

use Carp qw(carp croak confess) ;
use Term::ANSIColor qw(colored) ;

#-------------------------------------------------------------------------------

=head1 NAME

Text::Colorizer - Create colored text from text and color descrition. An ANSI to HTML tranformation is provided

=head1 SYNOPSIS

  my $c= Text::Colorizer->new
		(
		NAME => '' ,
		INTERACTION =>
			{
			INFO => sub {print @_},
			WARN => \&Carp::carp,
			DIE => \&Carp::confess,
			}
			
		FORMAT => 'HTML' | 'ANSI' |'ASCII',

		DEFAULT_COLOR => 'bright_white on_black',
		COLORS => 
			{
			HTML =>
				{
				white => "color:#888;",
				black => "color:#000;",
				...
				}
			ANSI => ...
			ASCII => ...
			}
		) ;

  # or 
  
  my $c= Text::Colorizer->new() ;
  
  my $colored_text = $c->color
			   (
			   'red on_black' => 'string',
			   $color => [... many strings..],
			   'user_defined_color_name' => 'string'
			   ) ;

=head1 DESCRIPTION

This module defined methods to produce colored html from ANSI color description. The generated code use I<pre> tags. 
The generated HTML can be embeded in your pod documentation.

=head1 DOCUMENTATION

Valid colors:
  
  black red  green  yellow  blue  magenta  cyan  white
  
  bright_black  bright_red      bright_green  bright_yellow
  bright_blue   bright_magenta  bright_cyan   bright_white

  on_black  on_red      on_green  on yellow
  on_blue   on_magenta  on_cyan   on_white
  
  on_bright_black  on_bright_red      on_bright_green  on_bright_yellow
  on_bright_blue   on_bright_magenta  on_bright_cyan   on_bright_white

  #256 colors terminals
  rgbRGB on_rgbRGB
  greyX  on_greyX

=head1 SUBROUTINES/METHODS

=cut


#-------------------------------------------------------------------------------

Readonly my $NEW_ARGUMENTS => [qw(NAME INTERACTION VERBOSE JOIN JOIN_FLAT FORMAT DEFAULT_COLOR COLORS)] ;

sub new
{

=head2 new(NAMED_ARGUMENTS)

Create a Text::Colorizer object.  

  my $c= Text::Colorizer->new() ;

I<Arguments> - a list of pairs - Option => Value

=over 2 

=item * NAME - String - Name of the Data::HexDump::Range object, set to 'Anonymous' by default

=item * INTERACTION - Hash reference - Set of subs that are used to display information to the user

Useful if you use Data::HexDump::Range in an application without terminal.

=item * VERBOSE - Boolean - Display information about the creation of the object. Default is I<false>

=item * JOIN - String - string used to join colored elements. Default is an empty string.

=item * JOIN_FLAT - String - string used to join colored elements passed in array references. Default is an empty string.

=item * FORMAT - String - format of the dump string generated by Data::HexDump::Range.

Default is B<ANSI> which allows for colors. Other formats are 'ASCII' and 'HTML'.

=item * DEFAULT_COLOR -  the color used if no color is defined

	DEFAULT_COLOR => {ANSI => 'bright_white', HTML => 'color:#aaa; '} ;

=item * COLORS - A hash reference or a file name

	{
	HTML =>
		{
		white => "color:#888;",
		black => "color:#000;",
		...
		}
	ANSI => ...
	ASCII => ...
	}

=back

I<Returns> - Text::Colorizer

I<Exceptions> - Dies if the color description are not valid

=cut

my ($invocant, @setup_data) = @_ ;

my $class = ref($invocant) || $invocant ;
confess 'Invalid constructor call!' unless defined $class ;

my $object = {} ;

my ($package, $file_name, $line) = caller() ;
bless $object, $class ;

$object->Setup($package, $file_name, $line, @setup_data) ;

return($object) ;
}

#-------------------------------------------------------------------------------

sub Setup
{

=head2 Setup

Helper sub called by new. This is a private sub.

=cut

my ($self, $package, $file_name, $line, @setup_data) = @_ ;

if (@setup_data % 2)
	{
	croak "Invalid number of argument '$file_name, $line'!" ;
	}

my %valid_argument = map {$_ => 1} @{$NEW_ARGUMENTS} ;

$self->CheckOptionNames(\%valid_argument, @setup_data) ;

%{$self} = 
	(
	NAME  => 'Anonymous',
	FILE  => $file_name,
	LINE  => $line,
	
	JOIN => $EMPTY_STRING,
	JOIN_FLAT => $EMPTY_STRING,
	
	FORMAT => 'ANSI',
	DEFAULT_COLOR => {ANSI => 'bright_white', HTML => 'color:#fff; '},
	
	COLORS => {ANSI => {}, HTML => {}}, 

	@setup_data,
	) ;

$self->{INTERACTION}{INFO} ||= sub {print @_} ;
$self->{INTERACTION}{WARN} ||= \&Carp::carp ;
$self->{INTERACTION}{DIE}  ||= \&Carp::croak ;

#default colors
my $default_colors = GetDefaultColors() ;

#lookup colors for user
while (my ($k, $v) = each %{$self->{COLORS}{ANSI}})
	{
	if($v =~ /^lookup:(.*)/)
		{
		if(exists $default_colors->{ANSI}{$1})
			{
			$self->{COLORS}{ANSI}{$k} = $default_colors->{ANSI}{$1} ;
			}
		else
			{
			$self->{INTERACTION}{DIE}("Can't lookup color '$1'.\n") ;
			}
		}
	}

while (my ($k, $v) = each %{$self->{COLORS}{HTML}})
	{
	if($v =~ /^lookup:(.*)/)
		{
		if(exists $default_colors->{HTML}{$1})
			{
			$self->{COLORS}{HTML}{$k} = $default_colors->{HTML}{$1} ;
			}
		else
			{
			$self->{INTERACTION}{DIE}("Can't lookup color '$1'.\n") ;
			}
		}
	}

#add default colors not set by user

$self->{COLORS}{ANSI} = { %{$default_colors->{ANSI}}, %{$self->{COLORS}{ANSI}} } ;
$self->{COLORS}{HTML} = { %{$default_colors->{HTML}}, %{$self->{COLORS}{HTML}} } ;

my $location = "$self->{FILE}:$self->{LINE}" ;

if($self->{VERBOSE})
	{
	$self->{INTERACTION}{INFO}('Creating ' . ref($self) . " '$self->{NAME}' at $location.\n") ;
	}

if(defined $self->{COLORS} && 'HASH' ne ref $self->{COLORS})
	{
	my $colors = do $self->{COLORS} 
		or $self->{INTERACTION}{DIE}("Can't load color file '$self->{COLORS}'.\n") ;
		
	'HASH' eq ref $colors
		or $self->{INTERACTION}{DIE}("Invalid color file '$self->{COLORS}'.\n") ;
	
	$self->{COLORS} = $colors ;
	}

return ;
}

#-------------------------------------------------------------------------------

sub GetDefaultColors
{

=head2 GetDefaultColor

=cut

my (@ansi_rgb, @ansi_on_rgb, @html_rgb, @html_on_rgb) ;
for my $blue (0 .. 5)
        {
        for my $green (0 .. 5)
                {
                for my $red (0 .. 5)
                        {
                        push @ansi_rgb, "rgb$red$green$blue" =>  "rgb$red$green$blue" ;
                        push @ansi_on_rgb, "on_rgb$red$green$blue" =>  "on_rgb$red$green$blue" ;

			push @html_rgb, "rgb$red$green$blue" => "color:#$red$green$blue;  " ;
			push @html_on_rgb, "on_rgb$red$green$blue" => "background-color:#$red$green$blue; " ;
                        }
                }
        }
	

my (@ansi_greys, @ansi_on_greys, @html_greys, @html_on_greys) ;
for my $grey (0 .. 15)
	{
	push @ansi_greys, "grey$grey" =>  "grey$grey" ;
	push @ansi_on_greys, "on_grey$grey" => "on_grey$grey" ;

	my $hex = sprintf("%x",$grey) ;
	push @html_greys, "grey$grey" => "color:#$hex$hex$hex; " ;
	push @html_on_greys, "on_grey$grey" => "background-color:#$hex$hex$hex; " ;
	}

return
	{
	ANSI =>
		{
		# you can defined aliases too
		# alarm => 'bright_red on_bright_yellwo',
		reset => 'reset',
		
		white => 'white',
		black => 'black',
		green => 'green',
		yellow => 'yellow',
		cyan => 'cyan',
		red => 'red',
		blue => 'blue',
		magenta => 'magenta',
		
		bright_white => 'bright_white',
		bright_black => 'bright_black',
		bright_green => 'bright_green',
		bright_yellow => 'bright_yellow',
		bright_cyan => 'bright_cyan',
		bright_red => 'bright_red',
		bright_blue => 'bright_blue',
		bright_magenta => 'bright_magenta',
		
		on_white => 'on_white',
		on_black => 'on_black',
		on_green => 'on_green',
		on_yellow => 'on_yellow',
		on_cyan => 'on_cyan',
		on_red => 'on_red',
		on_blue => 'on_blue',
		on_magenta => 'on_magenta',
		
		on_bright_white => 'on_bright_white',
		on_bright_black => 'on_bright_black',
		on_bright_green => 'on_bright_green',
		on_bright_yellow => 'on_bright_yellow',
		on_bright_cyan => 'on_bright_cyan',
		on_bright_red => 'on_bright_red',
		on_bright_blue => 'on_bright_blue',
		on_bright_magenta => 'on_bright_magenta',
		@ansi_rgb,
		@ansi_on_rgb,
		@ansi_greys,
		@ansi_on_greys,
		},
		
	HTML =>
		{
		# any attribute you can put in a span
		reset => '',
		
		white => 'color:#aaa; ',
		black => 'color:#000; ',
		green => 'color:#0a0; ',
		yellow => 'color:#aa0; ',
		cyan => 'color:#0aa; ',
		red => 'color:#a00; ',
		blue => 'color:#00a; ',
		magenta => 'color:#a0a; ',
		
		bright_white => 'color:#fff; ',
		bright_black => 'color:#000; ',
		bright_green => 'color:#0f0; ',
		bright_yellow => 'color:#ff0; ',
		bright_cyan => 'color:#0ff; ',
		bright_red => 'color:#f00; ',
		bright_blue => 'color:#00f; ',
		bright_magenta => 'color:#f0f; ',

		on_white => 'background-color:#aaa; ',
		on_black => 'background-color:#000; ',
		on_green => 'background-color:#0a0; ',
		on_yellow => 'background-color:#aa0; ',
		on_cyan => 'background-color:#0aa; ',
		on_red => 'background-color:#a00; ',
		on_blue => 'background-color:#00a; ',
		on_magenta => 'background-color:#a0a; ',
		
		on_bright_white => 'background-color:#fff; ',
		on_bright_black => 'background-color:#000; ',
		on_bright_green => 'background-color:#0f0; ',
		on_bright_yellow => 'background-color:#ff0; ',
		on_bright_cyan => 'background-color:#0ff; ',
		on_bright_red => 'background-color:#f00; ',
		on_bright_blue => 'background-color:#00f; ',
		on_bright_magenta => 'background-color:#f0f; ',

		@html_rgb,
		@html_on_rgb,
		@html_greys,
		@html_on_greys,
		},
	} ;
}


#-------------------------------------------------------------------------------

sub CheckOptionNames
{

=head2 CheckOptionNames

Verifies the named options passed to the members of this class. Calls B<{INTERACTION}{DIE}> in case
of error. This shall not be used directly.

=cut

my ($self, $valid_options, @options) = @_ ;

if (@options % 2)
	{
	$self->{INTERACTION}{DIE}->('Invalid number of argument!') ;
	}

if('HASH' eq ref $valid_options)
	{
	# OK
	}
elsif('ARRAY' eq ref $valid_options)
	{
	$valid_options = map{$_ => 1} @{$valid_options} ;
	}
else
	{
	$self->{INTERACTION}{DIE}->("Invalid argument '$valid_options'!") ;
	}

my %options = @options ;

for my $option_name (keys %options)
	{
	unless(exists $valid_options->{$option_name})
		{
		$self->{INTERACTION}{DIE}->("$self->{NAME}: Invalid Option '$option_name' at '$self->{FILE}:$self->{LINE}'!")  ;
		}
	}

if
	(
	   (defined $options{FILE} && ! defined $options{LINE})
	|| (!defined $options{FILE} && defined $options{LINE})
	)
	{
	$self->{INTERACTION}{DIE}->("$self->{NAME}: Incomplete option FILE::LINE!") ;
	}

return(1) ;
}

#-------------------------------------------------------------------------------

sub get_colors
{

=head2 get_colors( )

Returns the  colors defined in the object

 my $colors = $c->get_colors( ) ;

I<Arguments> - None

I<Returns> -  A hash reference

I<Exceptions> - None

=cut

my ($self) = @_ ;

return $self->{COLORS} ;
}

#-------------------------------------------------------------------------------

sub set_colors
{

=head2 set_colors(\%colors)

Copies 

  my %colors =
  	(
 	HTML =>
 		{
		white => "style='color:#888;'",
		black => "style='color:#000;'",
		...
		bright_white => "style='color:#fff;'",
		bright_black => "style='color:#000;'",
		bright_green => "style='color:#0f0;'",
		...
		}
	) ;
	
  $c->set_color(\%colors) ;

I<Arguments> 

=over 2 

=item * \%colors - A hash reference

=back

I<Returns> - Nothing

I<Exceptions> - dies if the color definitions are invalid

=cut

my ($self, $colors) = @_ ;

$self->{COLORS} = $colors ;

return ;
}

#-------------------------------------------------------------------------------

sub flatten 
{ 
	
=head2 [P] flatten($scalar || \@array)

Transforms array references to a flat list

I<Arguments> - 

=over 2 

=item * $scalar - 

=back

I<Returns> - a lsit of scalars

=cut

map 
	{
	my  $description = $_ ;
	
	if(ref($description) eq 'ARRAY')
		{
		flatten(@{$description}) ;
		}
	else
		{
		$description
		}
	} @_ 
}

#-------------------------------------------------------------------------------

sub color
{

=head2 color($color_name, $text, $color_name, \@many_text_strings, ...) ;

Returns colored text. according to the object setting. Default is HTML color coded.

  my $colored_text = $c->color
			   (
			   'red on_black' => 'string',
			   $color => [... many strings..]
			   'user_defined_color_name' => 'string'
			   ) ;
				   
I<Arguments>  - A list of colors and text pairs

=over 2 

=item * $color - 

=item * $text - 

=back

I<Returns> - A single string

I<Exceptions> - Dies if the color is invalid

=cut

my ($self) = shift @_ ;

my ($header, $footer, $colorizer)  = ('', '') ;

my %ascii_to_html =
	(
	'<' => '&lt;',
	'>' => '&gt;',
	'&' => '&amp;',
	"'" => '&apos;',
	'"' => '&quot;',
	) ;

for ($self->{FORMAT})
	{
	/ASCII/ and do
		{
		$colorizer = 
			sub 
				{
				#~ my ($text, $color) = @_ ; 
				#~ return $text ;
				
				$_[0] ;
				} ;
			
		last ;
		} ;
		
	/ANSI/ and do
		{
		$colorizer = sub { my ($text, $color) = @_ ; (defined $color && $color ne '') ? colored($text, $color) : $text ; } ;
			
		last ;
		} ;
		
	/HTML/ and do
		{
		$header = qq~<pre style ="font-family: monospace; background-color: #000 ;">\n~ ;
		$colorizer = 
			sub 
			{ 
			my ($text, $color) = @_ ; 
			
			$text =~ s/(<|>|&|\'|\")/$ascii_to_html{$1}/eg ;
			
			"<span style = '$color'>" . $text . "</span>" ;
			} ;
			
		$footer .= "\n</pre>\n" ;
		
		last ;
		} ;
		
	$self->{INTERACTION}{DIE}("Error: Invalid format '$self->{FORMAT}'.\n");
	}

$self->{INTERACTION}{DIE}("Error: number of elements in argument list'.\n") if @_ % 2 ;

my @formated ;

while(@_)
	{
	my ($color_tag, $text) = (shift, shift) ;
	my $colors = $self->{DEFAULT_COLOR}{$self->{FORMAT}} ;
	
	if(defined $color_tag && $self->{FORMAT} ne 'ASCII')
		{
		for my $color_tag_component (split /\s+/, $color_tag)
			{
			$color_tag_component =~ s/\s+//g ;
			
			my $color = $self->{COLORS}{$self->{FORMAT}}{$color_tag_component} ;
			
			$self->{INTERACTION}{DIE}("Error: Invalid color component '$self->{FORMAT}::$color_tag_component'.\n") unless defined $color ;
			
			$colors .= ' ' . $color ;
			}
		}
		
	push @formated, join $self->{JOIN_FLAT}, map {$colorizer->($_, $colors)} flatten($text) ;
	}

return $header . join($self->{JOIN}, @formated) . $footer ;
}

#-------------------------------------------------------------------------------

sub color_all
{

=head2 color_all($color, $string, \@many_text_strings, ...)

Uses a single color to colorize all the strings

  my $colored_text = $c->color_all($color, $string, \@many_text_strings, ...) ;

I<Arguments>

=over 2 

=item * $xxx - 

=back

I<Returns> - Nothing

I<Exceptions>

=cut

my ($self, $color) = (shift @_, shift @_) ;

#todo: verify colors

return $self->color(map{$color, $_} @_) ;
}

#-------------------------------------------------------------------------------

sub color_with
{

=head2 color_with(\%color_definitions, 'color' => 'text', $color => \@many_text_strings, ...) ;

Colors a text, temporarely overridding the colors defined in the object.

  my %colors =
  	{
 	HTML =>
 		{
		white => "style='color:#888;'",
		black => "style='color:#000;'",
		...
		bright_white => "style='color:#fff;'",
		bright_black => "style='color:#000;'",
		bright_green => "style='color:#0f0;'",
		...
		}
	},
	
  my $colored_text = $c->color_with
			   (
			   \%colors, 
			   'red on_black' => 'string',
			   'blue on_yellow' => [... many strings..]
			   'user_defined_color_name' => 'string'
			   ) ;

I<Arguments>

=over 2 

=item * $ - 

=item * $color - 

=item * $xxx - 

=back

I<Returns> - Nothing

I<Exceptions> -  Dies if  any argument is invalid

=cut

my ($self, $colors) = (shift @_, shift @_) ;

local $self->{COLORS} = $colors ;
return $self->color(@_) ;
}

#-------------------------------------------------------------------------------

sub color_all_with
{

=head2 color_all_with($temporary_colors, $color, $text | \@many_text_string, ...) ;

Uses a single color to colorize all the strings, using a temporary color definition

  my $temporary_colors =
  	{
 	HTML =>
 		{
		white => "style='color:#888;'",
		black => "style='color:#000;'",
		...
		bright_white => "style='color:#fff;'",
		bright_black => "style='color:#000;'",
		bright_green => "style='color:#0f0;'",
		...
		}
	},
	
  my $colored_text = $c->color_all_with($temporary_colors, $color, 'string', [... many strings..], ...) ;

I<Arguments>

=over 2 

=item * $xxx - 

=back

I<Returns> - A colorized string

I<Exceptions> Dies if invalid input is received

=cut

my ($self, $colors) = (shift @_, shift @_) ;

local $self->{COLORS} = $colors ;
return $self->color_all(@_) ;
}

#-------------------------------------------------------------------------------

1 ;

=head1 BUGS AND LIMITATIONS

None so far.

=head1 AUTHOR

	Nadim ibn hamouda el Khemir
	CPAN ID: NKH
	mailto: nadim@cpan.org

=head1 COPYRIGHT & LICENSE

Copyright 2010 Nadim Khemir.

This program is free software; you can redistribute it and/or
modify it under the terms of either:

=over 4

=item * the GNU General Public License as published by the Free
Software Foundation; either version 1, or (at your option) any
later version, or

=item * the Artistic License version 2.0.

=back

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Text::Colorizer

You can also look for information at:

=over 4

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/Color::ANSI-ToHTML>

=item * RT: CPAN's request tracker

Please report any bugs or feature requests to  L <bug-Color::ANSI-tohtml@rt.cpan.org>.

We will be notified, and then you'll automatically be notified of progress on
your bug as we make changes.

=item * Search CPAN

L<http://search.cpan.org/dist/Color::ANSI-ToHTML>

=back

=head1 SEE ALSO

L<HTML::FromANSI first>

=cut