view release on metacpan or  search on metacpan

lib/DB/Color/Highlight.pm  view on Meta::CPAN

package DB::Color::Highlight;

use strict;
use warnings;
use Term::ANSIColor ':constants';
use Digest::MD5 'md5_hex';
use File::Spec::Functions qw(catfile catdir);
use File::Path 'make_path';

BEGIN {
    if ( !( Term::ANSIColor->VERSION >= 3 ) ) {
        no warnings 'redefine';
        *BRIGHT_BLUE = sub { BLUE };
    }
}

use Syntax::Highlight::Engine::Kate::Perl;

=head1 NAME

DB::Color::Highlight - Provides highlighting for DB::Color

=head1 VERSION

Version 0.20

=cut

our $VERSION = '0.20';

# increase this number by one to force the cache to generate new md5 numbers
my $FORMAT_NUMBER = 1;

BEGIN {
    no warnings 'redefine';
    *Syntax::Highlight::Engine::Kate::Template::logwarning = sub { };
}

sub new {
    my ( $class, $args ) = @_;
    my $self = bless {} => $class;
    $self->_initialize($args);
    return $self;
}

sub _initialize {
    my ( $self, $args ) = @_;

    my $cache_dir = $args->{cache_dir};
    $self->{debug_fh}  = $args->{debug_fh};
    $self->{cache_dir} = $cache_dir;

    if ( defined $cache_dir and not -d $cache_dir ) {
        mkdir $cache_dir or die "Cannot mkdir ($cache_dir): $!";
    }

#      CLEAR           RESET             BOLD            DARK
#      FAINT           ITALIC            UNDERLINE       UNDERSCORE
#      BLINK           REVERSE           CONCEALED
#
#      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

    my $highlighter = Syntax::Highlight::Engine::Kate::Perl->new(
        format_table => {
            'Keyword'      => [ YELLOW,      RESET ],
            'Comment'      => [ BRIGHT_BLUE, RESET ],
            'Decimal'      => [ YELLOW,      RESET ],
            'Float'        => [ YELLOW,      RESET ],
            'Function'     => [ CYAN,        RESET ],
            'Identifier'   => [ RED,         RESET ],
            'Normal'       => [ WHITE,       RESET ],
            'Operator'     => [ CYAN,        RESET ],
            'Preprocessor' => [ RED,         RESET ],
            'String'       => [ MAGENTA,     RESET ],
            'String Char'  => [ RED,         RESET ],
            'Symbol'       => [ CYAN,        RESET ],
            'DataType'     => [ CYAN,        RESET ],    # variable names
        }
    );
    $self->{highlighter} = $highlighter;
}

sub _highlighter  { $_[0]->{highlighter} }
sub _cache_dir    { $_[0]->{cache_dir} }
sub _should_cache { defined $_[0]->_cache_dir }

sub _debug {
    my ( $self, $message ) = @_;
    return unless my $debug = $self->{debug_fh};
    print $debug "$message\n";
}

sub highlight_text {