| 239 | | =item highlight_perl6_simple |
| 240 | | |
| 241 | | This is same as C<highlight_perl> when --simple is used. |
| 242 | | No more javascript tree viewer or anything fancy. |
| 243 | | Only nodes that have a color are printed. Not optimal but works ;-) |
| 244 | | =cut |
| 245 | | sub highlight_perl6_simple { |
| 246 | | my ($orig,$events,$opt) = @ARG; |
| 247 | | my $str = ""; |
| 248 | | my $at = 0; |
| 249 | | my %colors = (); |
| 250 | | |
| 251 | | my $CSS = "STD_syntax_highlight.css"; |
| 252 | | open CSS_FILE, $CSS |
| 253 | | or die "Could not open $CSS: $OS_ERROR\n"; |
| 254 | | my $line; |
| 255 | | while($line = <CSS_FILE>) { |
| 256 | | if($line =~ /^\s*\.(\w+)\s*{\s*color\s*:\s*(\w+)/) { |
| 257 | | $colors{$1} = $2; |
| 258 | | } |
| 259 | | } |
| 260 | | close CSS_FILE; |
| 261 | | |
| 262 | | # slurp libraries and javascript to inline them |
| 263 | | my $css = qq{<link href="../$CSS" rel="stylesheet" type="text/css">}; |
| 264 | | if(!$clean_html) { |
| 265 | | $css = read_file($CSS) |
| 266 | | or die "Error while slurping file: $OS_ERROR\n"; |
| 267 | | $css = qq{<style type="text/css">\n$css\n</style>}; |
| 268 | | } |
| 269 | | |
| 270 | | my $timestamp = localtime; |
| 271 | | $str .= <<"HTML"; |
| 272 | | <html> |
| 273 | | <head> |
| 274 | | <title>$file</title> |
| 275 | | <!-- |
| 276 | | Generated by $PROGRAM_NAME at $timestamp |
| 277 | | --> |
| 278 | | $css |
| 279 | | </head> |
| 280 | | <body> |
| 281 | | <pre> |
| 282 | | HTML |
| 283 | | my $curr_rule = q{}; |
| 284 | | my @rules = (); |
| 285 | | my $code = ""; |
| 286 | | for (sort {$a->[0] <=> $b->[0] or $a->[4] <=> $b->[4]} @{$events}) { |
| 287 | | my $text = substr($orig,$at,$_->[0]-$at); |
| 288 | | my $esc_text .= escape_html($text); |
| 289 | | $at = $_->[0]; |
| 290 | | |
| 291 | | # process types, routines and identifiers |
| 292 | | if($curr_rule eq 'identifier') { |
| 293 | | if($parser->is_type($text)) { |
| 294 | | $code .= qq{<span class="_type">$esc_text</span>}; |
| 295 | | } elsif($parser->is_routine($text)) { |
| 296 | | $code .= qq{<span class="_routine">$esc_text</span>}; |
| 297 | | } else { |
| 298 | | $code .= $esc_text; |
| 299 | | } |
| 300 | | } else { |
| 301 | | $code .= $esc_text; |
| 302 | | } |
| 303 | | |
| 304 | | if ($_->[1] eq 'from') { |
| 305 | | $curr_rule = $_->[2]; |
| 306 | | push @rules, $curr_rule; |
| 307 | | my $has_color = $colors{$curr_rule}; |
| 308 | | $code .= '<span class="'.$curr_rule.'">' if $has_color; |
| 309 | | } elsif ($_->[1] eq 'to') { |
| 310 | | my $rule = pop @rules; |
| 311 | | my $has_color = $colors{$rule}; |
| 312 | | $code .= '</span>' if $has_color; |
| 313 | | } |
| 314 | | } |
| 315 | | # process comments |
| 316 | | $code =~ s{(#[^\n]*)}{<span class="_comment">$1</span>}g; |
| 317 | | $str .= $code; |
| 318 | | $str .= <<"HTML"; |
| 319 | | </pre> |
| 320 | | </body> |
| 321 | | </html> |
| 322 | | HTML |
| 323 | | |
| 324 | | $str; |
| 325 | | } |
| 326 | | |
