view release on metacpan or  search on metacpan

lib/Apache/Syntax/Highlight/Perl.pm  view on Meta::CPAN

		Apache::Constants->import(qw(DECLINED OK));
	}

	# Test caching necessaries modules
	eval { require Digest::MD5; Digest::MD5->can('md5_hex') };
	$can_cache = $@ ? 0 : 1;
}

my %default_styles = (
	'Comment_Normal'    => 'color:#006699;font-style:italic;',
	'Comment_POD'       => 'color:#001144;font-style:italic;',
	'Directive'         => 'color:#339999;font-style:italic;',
	'Label'             => 'color:#993399;font-style:italic;',
	'Quote'             => 'color:#0000aa;',
	'String'            => 'color:#0000aa;',
	'Subroutine'        => 'color:#998800;',
	'Variable_Scalar'   => 'color:#008800;',
	'Variable_Array'    => 'color:#ff7700;',
	'Variable_Hash'     => 'color:#8800ff;',
	'Variable_Typeglob' => 'color:#ff0033;',
	'Whitespace'        => '',
	'Character'         => 'color:#880000;',
	'Keyword'           => 'color:#000000;',
	'Builtin_Operator'  => 'color:#330000;',
	'Builtin_Function'  => 'color:#000011;',
	'Operator'          => 'color:#000000;',
	'Bareword'          => 'color:#33AA33;',
	'Package'           => 'color:#990000;',
	'Number'            => 'color:#ff00ff;',
	'Symbol'            => 'color:#000000;',
	'CodeTerm'          => 'color:#000000;',
	'DATA'              => 'color:#000000;',
	'LineNumber'        => 'color:#CCCCCC;'
);

sub handler {
	my $r = shift;
	my $str;  # buffered output
	my $mtime;
	my $have_to_cache = 0;
	
	return (MP2 ? Apache::DECLINED : Apache::Constants::DECLINED) if $r->args =~ /download/i;

	my $sln = ($r->dir_config('HighlightShowLineNumbers') =~ /^on$/i || $r->args =~ /ShowLineNumbers/i) ? 1 : 0;
	my $key = $r->filename . $sln;
	my $debug = $r->dir_config('HighlightDebug') eq 'On' ? 1 : 0;
		
	# Cache feature
	if ( $can_cache && $r->dir_config('HighlightCache') =~ /^on$/i ) {
		$mtime = (stat $r->filename)[9];
		# File needs to be processed
		if ( ! defined $stat{$key} || $mtime > $stat{$key} ) {
			$stat{$key} = $mtime;
			$have_to_cache = 1;
			print STDERR "[$$] We have to cache!\n" if $debug;
		}
		# We have already in cache
		else {
			$str = get_cache( file => $key, dir => $r->dir_config('HighlightCacheDir') || '/tmp', debug => $debug );
		}
		use Data::Dumper;
		print STDERR ("[$$] " . $r->filename . "\n" . Dumper(\%stat)) if $debug;
	}

	# When we must highlight?
	if ( $have_to_cache || ! $str ) {
	
		print STDERR "[$$] Generating highlight...\n" if $debug;

		my $formatter = new Syntax::Highlight::Perl;
	
		# Open file to highlight
		my $fh = new IO::File($r->filename);
	
		# Escapes HTML
		$formatter->define_substitution('<' => '&lt;', '>' => '&gt;', '&' => '&amp;'); 

		# Install the formats 
		if ( $r->dir_config('HighlightCSS') ) {
			foreach (keys %default_styles) {
				$formatter->set_format($_, [ "<span class=\"$_\">",'</span>' ] );
			}
			$str = '<LINK HREF="' . $r->dir_config('HighlightCSS') . '" REL="stylesheet" TYPE="text/css"><PRE>';
		}
		else {
			while ( my($type,$style) = each %default_styles ) {
				$formatter->set_format($type, [ "<span style=\"$style\">",'</span>' ] );
				$str = '<PRE style="font-size:10pt;color:#333366;">';
			}
		}
		my @lines = $formatter->format_string(<$fh>);
		undef $fh;

		# Adds line numbers
		if ( $sln ) {
			my $line_number = 1;
			my $max_space = length($formatter->line_count) + 1;
			@lines = map { '&nbsp;' x ($max_space - length($line_number)) . '<span class="LineNumber">' . $line_number++ . '</span>&nbsp;' . $_ } @lines;
		}
		$str .= join('',@lines) . '</PRE>';
	}

	if ( $have_to_cache ) {
		put_cache( file => $key, content => $str, dir => $r->dir_config('HighlightCacheDir') || '/tmp', debug => $debug );
	}

	# Output code to client
	$r->content_type('text/html');
	MP2 ? 1 : $r->send_http_header;
	$r->print($str);
	return MP2 ? Apache::OK : Apache::Constants::OK;
}

sub get_cache {
	my %args = @_;
	$args{'key'} ||= Digest::MD5->md5_hex($args{'file'});
	return undef if ! $args{'file'};
	print STDERR "[$$] Opening file: $args{'dir'}/$args{'key'}\n" if $args{'debug'};	
	my $fh = new IO::File("$args{'dir'}/$args{'key'}");
	my $slurp = do { local $/; <$fh> };
	return $slurp;