File Coverage

blib/lib/Text/Colorizer.pm

Criterion	Covered	Total	%
statement	85	164	51.8
branch	8	46	17.3
condition	10	27	37.0
subroutine	14	25	56.0
pod	10	11	90.9
total	127	273	46.5

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 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 - 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

=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 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 - Text::Colorizer

I - 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 - None

I -  A hash reference

I - 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

=over 2

=item * \%colors - A hash reference

=back

I - Nothing

I - 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 -

=over 2

=item * $scalar -

=back

I - 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  - A list of colors and text pairs

=over 2

=item * $color -

=item * $text -

=back

I - A single string

I - Dies if the color is invalid

=cut

my ($self) = shift @_ ;

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

my %ascii_to_html =
	(
	'<' => '<',
	'>' => '>',
	'&' => '&',
	"'" => ''',
	'"' => '"',
	) ;

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~\n~ ;
		$colorizer =
			sub
			{
			my ($text, $color) = @_ ;

			$text =~ s/(<|>|&|\'|\")/$ascii_to_html{$1}/eg ;

			"" . $text . "" ;
			} ;

		$footer .= "\n\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

=over 2

=item * $xxx -

=back

I - Nothing

I

=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

=over 2

=item * $ -

=item * $color -

=item * $xxx -

=back

I - Nothing

I -  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

=over 2

=item * $xxx -

=back

I - A colorized string

I 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: [e-mail]

=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

=item * RT: CPAN's request tracker

Please report any bugs or feature requests to  L .

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

=item * Search CPAN

L

=back

=head1 SEE ALSO

L

=cut