Syntax::Highlight::Perl6 - Perl 6 Syntax Highlighter

    ### NOTE: This is needed and will be removed in future releases
    use STD;
    use Syntax::Highlight::Perl6;

    # Creates the Perl6 syntax highlighter object
    my $p = Syntax::Highlight::Perl6->new(
        text => 'my $foo;'
    );

    # Prints html that can be embedded in your pages
    print $p->snippet_html;

    # Prints html with css (useful for full pages)
    print $p->simple_html;

    # Prints html that has a JavaScript node viewer
    print $p->full_html;

    # Prints ANSI escaped color sequences (useful for console and IRC output)
    print $p->ansi_text;

    # Prints an array of token records (useful for other libraries)
    print $p->tokens;

    +-----------+---------+-----------+------------+---------+
    | Matched   | Matched | Matched   | Parse tree | Matched |
    | Last      | string  | rule      | separated  | Line    |
    | Position  | buffer  | name      | by spaces  | Number  |
    |           |         |           |            |         |
    | $last_pos | $buffer | $rule     | $tree      | $lineno |
    +-----------+---------+-----------+------------+---------+

    use Data::Dumper;
    print Dumper($p->tokens);

    $VAR1 = {
      'tree' => '',
      'rule' => 0,
      'buffer' => '',
      'last_pos' => 0
    };
    $VAR2 = {
      'tree' => 'statementlist statement statement_modexpr statement_expr EXPR termish noun value number integer ',
      'rule' => 'number',
      'buffer' => '1',
      'last_pos' => 1
    };
    $VAR3 = {
      'tree' => 'statementlist eat_terminator ',
      'rule' => 0,
      'buffer' => ';',
      'last_pos' => 2
    };

package Syntax::Highlight::Perl6;
BEGIN {
  $Syntax::Highlight::Perl6::VERSION = '0.88';
}

# ABSTRACT: Perl 6 Syntax Highlighter

# core modules & directives
use 5.010;
use strict;
use warnings;
use Carp;

require Exporter;

# exports and version
our @EXPORT_OK = qw();

# filename constants
my $FILE_CSS    = 'p6_style.css';
my $FILE_ANSI   = 'p6_style.ansi';
my $FILE_JS     = 'p6_style.js';
my $FILE_JQUERY = 'jquery-1.4.3.min.js';


# my module variables
my @loc;

#find out the real path of the rsc directory
if ( !-f __FILE__ ) {
	croak 'Syntax::Highlight::Perl6 cannot see where it is installed';
}

require File::Basename;
require File::Spec;
require Cwd;

#----------------------------------------------------------------
# Returns the syntax highlighting object. It needs a hash
# of options.
#----------------------------------------------------------------
sub new {
	my ( $class, %options ) = @_;
	$options{rule}             = $options{rule}             // 'TOP';
	$options{inline_resources} = $options{inline_resources} // 0;
	$options{resource_url}     = $options{resource_url}     // q{};
	$options{page_title}       = $options{page_title}       // q{};
	$options{utf8_decode}      = $options{utf8_decode}      // 1;
	$options{tmp_prefix}       = $options{tmp_prefix}       // q{};

	#is 'text' undefined?
	if ( !defined $options{text} ) {
		croak "'text' option is not found in $class->new";
	}

	my $self = bless \%options, $class;
	$self->{parser}        = 0;
	$self->{src_text}      = 0;
	$self->{parsed_lazily} = 0;
	return $self;
}

#----------------------------------------------------------------
# Lazily parses the source string using STD.pm6 (only once)
# (private)
#----------------------------------------------------------------
sub _lazy_parse {
	my $self = shift;

	if ( !$self->{parsed_lazily} ) {

		# utf8-decode if required
		require Encode;
		my $src_text =
			$self->{utf8_decode}
			? Encode::decode( 'utf8', $self->{text} )
			: $self->{text};

		#grow the loc array while checking for empty strings
		my $len = length $src_text;
		if ( $len == 0 ) {
			$src_text = q{ };
			$len      = 1;
		}
		$loc[ $len - 1 ] = [];

		#STD parse the text for the rule provided
		require STD;
		$self->{parser} = STD->parse(
			$src_text,
			rule       => $self->{rule},
			actions    => __PACKAGE__ . '::Actions',
			tmp_prefix => $self->{tmp_prefix},
		);

		#we parsed it lazily...
		$self->{src_text} = $src_text;
		@{ $self->{loc} } = @loc;
		@loc = ();
		$self->{parsed_lazily} = 1;
	}
	return;
}


#---------------------------------------------------------------------
# Returns snippet htmls which can embedded without any side effects
# on your page
#---------------------------------------------------------------------
sub snippet_html {
	my $self = shift;
	my $str  = q{};

	$self->_lazy_parse();

	my %colors = _read_css_file();

	$str .= '<pre>';

	local *spit_snippet_html = sub {
		my ( $i, $buffer, $rule, $tree, $lineno ) = @_;
		$buffer = _escape_html($buffer);
		my $style = $colors{$rule};
		if ($rule) {
			$str .= qq{<span style="$style">$buffer</span>};
		} else {
			$str .= $buffer;
		}
	};
	$self->_redspans_traverse( \&spit_snippet_html, %colors );

	$str .= '</pre>';

	return $str;
}

#---------------------------------------------------------------
# Returns the Perl 6 highlighted HTML string
# (without the JavaScript stuff).
#---------------------------------------------------------------
sub simple_html {
	my $self = shift;
	my $str  = q{};

	$self->_lazy_parse();

	my %colors = _read_css_file();

	# slurp css inline it
	my $css;
	if ( $self->{inline_resources} ) {
		$css = _slurp( _shared($FILE_CSS) )
			or croak "Error while slurping file: $!\n";
		$css = qq{<style type="text/css">\n$css\n</style>};
	} else {
		my $prefix = $self->{resource_url};
		$css = qq{<link href="$prefix$FILE_CSS" rel="stylesheet" type="text/css">};
	}
	my $page_title = $self->{page_title};
	my $timestamp  = localtime;
	$str .= <<"HTML";
<html>
<head>
    <title>$page_title</title>
<!--
     Generated by $0 at $timestamp
-->
    $css
</head>
<body>
    <pre>
HTML

	local *spit_simple_html = sub {
		my ( $i, $buffer, $rule, $tree, $lineno ) = @_;
		$buffer = _escape_html($buffer);
		if ($rule) {
			$str .= qq{<span class="$rule">$buffer</span>};
		} else {
			$str .= $buffer;
		}
	};

	$self->_redspans_traverse( \&spit_simple_html, %colors );

	$str .= <<'HTML';
    </pre>
</body>
</html>
HTML

	return $str;
}

#-------------------------------------------------------------------
# Returns the Perl 6 highlighted HTML string. The HTML consists of a
# JavaScript Parse Tree Viewer along with CSS-styling.
#-------------------------------------------------------------------
sub full_html {
	my $self = shift;
	my $str  = q{};

	$self->_lazy_parse();

	# slurp libraries and JavaScript to inline them
	my %colors = _read_css_file();
	my ( $jquery_js, $js, $css );
	if ( $self->{inline_resources} ) {
		my $contents;
		$contents = _slurp( _shared($FILE_JQUERY) )
			or croak "Error while slurping file: $!\n";
		$jquery_js = qq{<script type="text/javascript">\n$contents\n</script>};
		$contents  = _slurp( _shared($FILE_JS) )
			or croak "Error while slurping file: $!\n";
		$js       = qq{<script type="text/javascript">\n$contents\n</script>};
		$contents = _slurp( _shared($FILE_CSS) )
			or croak "Error while slurping file: $!\n";
		$css = qq{<style type="text/css">\n$contents\n</style>};
	} else {
		my $prefix = $self->{resource_url};
		$jquery_js = qq{<script type="text/javascript" src="$prefix$FILE_JQUERY"></script>};
		$js        = qq{<script type="text/javascript" src="$prefix$FILE_JS"></script>};
		$css       = qq{<link href="$prefix$FILE_CSS" rel="stylesheet" type="text/css">};
	}

	my $page_title = $self->{page_title};
	my $timestamp  = localtime;
	$str .= <<"HTML";
<html>
<head>
    <title>$page_title</title>
<!--
    Generated by $0 at $timestamp
-->
    $css
    $jquery_js
    $js
</head>
<body>
    <div id="parse_tree">
        <button id="parse_tree_expand">Show Syntax Tree</button>
        <button id="parse_tree_collapse">Hide it</button>
        <button id="parse_tree_help">Help</button>
        <div id="parse_tree_output"></div>
    </div>
    <pre>
HTML

	local *spit_full_html = sub {
		my ( $i, $buffer, $rule, $tree, $lineno ) = @_;
		$buffer = _escape_html($buffer);
		$str .= qq{<span id="tree_$i" style="display:none;">$tree</span>};
		if ($rule) {
			$str .= qq{<span id="node_$i" class="$rule">$buffer</span>};
		} else {
			$str .= $buffer;
		}
	};

	$self->_redspans_traverse( \&spit_full_html, %colors );

	$str .= <<'HTML';
    </pre>
</body>
</html>
HTML

	return $str;
}

#---------------------------------------------------------------
# Returns a Perl highlighted ANSI escape color string.
#---------------------------------------------------------------
sub ansi_text {
	my $self = shift;
	my $str  = q{};

	$self->_lazy_parse();

	my %colors = _read_ansi_file();

	require Term::ANSIColor;
	local *spit_ansi_text = sub {
		my ( $i, $buffer, $rule, $tree, $lineno ) = @_;
		if ($rule) {
			my $color = $colors{$rule};
			$str .= Term::ANSIColor::color($color) . $buffer . Term::ANSIColor::color('reset');
		} else {
			$str .= $buffer;
		}
	};

	$self->_redspans_traverse( \&spit_ansi_text, %colors );

	return $str;
}

#---------------------------------------------------------------
# Returns a Perl 5 array containing parse tree records.
# The array consists of one or more of the following record:
#   ($last_pos, $buffer, $rule, $tree)
#---------------------------------------------------------------
sub tokens {
	my $self = shift;

	$self->_lazy_parse();

	my %colors = _read_ansi_file();
	my @tokens = ();
	local *spit_parse_tree = sub {
		push @tokens,
			{
			'last_pos' => $_[0],
			'buffer'   => $_[1],
			'rule'     => $_[2],
			'tree'     => $_[3],
			'lineno'   => $_[4],
			};
	};
	$self->_redspans_traverse( \&spit_parse_tree, %colors );

	return @tokens;
}


#--------------------------------------------------------------------
# Reads the css file and return a hash of colors
#--------------------------------------------------------------------
sub _read_css_file {

	my %colors   = ();
	my $filename = _shared($FILE_CSS);
	my $fh       = IO::File->new($filename)
		or croak "Could not open $filename: $!\n";
	my $line;
	while ( $line = <$fh> ) {
		if ($line =~ /^\s*           # <whitespace>
                                        \.(\w+)\s*      # .<css class>
                                        {\s*(.+?)\s*}   # { <css style>* }
                                        /x
			)
		{
			$colors{$1} = $2;
		}
	}
	close $fh
		or croak "Could not close $filename";

	return %colors;
}

#--------------------------------------------------------------
# Reads an ANSI rule-name=color property file and stores
# the color values in a hash of rule-name,color
#--------------------------------------------------------------
sub _read_ansi_file {
	my %colors   = ();
	my $filename = _shared($FILE_ANSI);
	my $fh       = IO::File->new($filename)
		or croak "Could not open $filename: $!\n";
	my $line;
	while ( $line = <$fh> ) {
		if ($line =~ m{^(\w+)     # <start> <rule-name>
                                        =(.+)$      # <=> <ansi-color> <end>
                                        }x
			)
		{
			$colors{$1} = $2;
		}
	}
	close $fh
		or croak "Could not close $filename";

	return %colors;
}


#---------------------------------------------------------------
#    Helper private method that traverses STD.pm6's parse
# tree array. It needs a callback process_buffer and a
# colors hash.
#---------------------------------------------------------------
sub _redspans_traverse {
	my ( $self, $process_buffer, %colors ) = @_;
	my @loc = @{ $self->{loc} };
	my ( $last_tree, $buffer, $last_type ) = ( q{}, q{}, q{} );
	my $parser = $self->{parser};
	my $len    = length $self->{src_text};
	for my $i ( 0 .. $len - 1 ) {
		if ( not defined $loc[$i] ) {
			next;
		}
		my $c = substr $self->{src_text}, $i, 1;
		my $tree = q{};
		for my $action_ref ( @{ $loc[$i] } ) {
			$tree .= ${$action_ref} . q{ };
		}
		if ( $tree ne $last_tree ) {
			my $rule_to_color = 0;
			my @rules         = ();
			if ( $last_tree ne q{} ) {
				@rules = reverse split / /, $last_tree;
			}
			for my $rule (@rules) {
				if ( $rule eq 'unv' ) {
					$rule_to_color = '_comment';
					last;
				} elsif ( $colors{$rule} && $buffer ne q{} ) {
					$rule_to_color = $rule;
					last;
				}
			}
			if ($rule_to_color) {
				if ( $last_tree =~ /\sidentifier/x ) {
					if ( $last_type ne q{} ) {
						$rule_to_color = $last_type;
						$last_type     = q{};
					}
				} elsif ( $last_tree =~ /\ssigil/x ) {
					given ($buffer) {
						when ('$') { $last_type = '_scalar'; }
						when ('@') { $last_type = '_array'; }
						when ('%') { $last_type = '_hash'; }
						default    { $last_type = q{}; }
					};
					if ( $last_type ne q{} ) {
						$rule_to_color = $last_type;
					}
				}
			}

			#now delegate printing to a callback
			#HACK to prevent parser->lineof(position) from breaking. lineof should be called in the same dynamic scope of parsing
			$::ORIG = $self->{src_text};
			$process_buffer->( $i, $buffer, $rule_to_color, $last_tree, $parser->lineof($i) );
			$buffer = $c;
		} else {
			$buffer .= $c;
		}
		$last_tree = $tree;
	}
	return;
}

#------------------------------------------------------------------
# R E D S P A N S
# STD.pm6 calls this method when you call STD->parse(...)
# and we populate @loc with action references and parse trees...
#------------------------------------------------------------------
{

	package Syntax::Highlight::Perl6::Actions;
BEGIN {
  $Syntax::Highlight::Perl6::Actions::VERSION = '0.88';
}

	our $AUTOLOAD;

	my %action_refs = ();

	sub AUTOLOAD {
		my $self = shift;
		my $C    = shift;
		my $F    = $C->{_from};
		my $P    = $C->{_pos};
		$AUTOLOAD =~ s/^Syntax::Highlight::Perl6::Actions:://x;
		if ( $loc[$P] ) {

			# in case we backtracked to here
			$loc[$P] = [];
		}
		my $action     = $AUTOLOAD;
		my $action_ref = $action_refs{$action};
		if ( !$action_ref ) {
			$action_refs{$action} = $action_ref = \$action;
		}
		for ( $F .. $P - 1 ) {
			unshift @{ $loc[$_] }, $action_ref;
		}
		return;
	}

	sub stdstopper  { }
	sub terminator  { }
	sub unitstopper { }
	sub comp_unit   { }
}

#---------------------------------------------------------------
# Private method to converts characters to their equivalent
# html entities.
#----------------------------------------------------------------
sub _escape_html {
	my $str = shift;
	my %esc = (
		'<' => '&lt;',
		'>' => '&gt;',
		'"' => '&quot;',
		'&' => '&amp;',
	);
	my $re = join '|', map {quotemeta} keys %esc;
	$str =~ s/($re)/$esc{$1}/g;
	return $str;
}

#-----------------------------------------------------
# convert to shared package real resource path
#-----------------------------------------------------
sub _shared {
	require File::ShareDir;
	return File::ShareDir::dist_file('Syntax-Highlight-Perl6', shift);
}

#-----------------------------------------------------
# Load file into a scalar without File::Slurp
# see perlfaq5
#-----------------------------------------------------
sub _slurp {
	my $filename = shift;
	my $fh       = IO::File->new($filename)
		or croak "Could not open $filename for reading";
	local $/ = undef; #enable localized slurp mode
	my $contents = <$fh>;
	close $fh
		or croak "Could not close $filename";
	return $contents;
}

1;

#------------------ T H E   E N D --------------------

__END__