local-lib5/lib/perl5/Syntax/Highlight/Engine/Kate/Template.pm

   1 # Copyright (c) 2006 Hans Jeuken. All rights reserved.
   2 # This program is free software; you can redistribute it and/or
   3 # modify it under the same terms as Perl itself.
   4
   5 package Syntax::Highlight::Engine::Kate::Template;
   6
   7 our $VERSION = '0.06';
   8
   9 use strict;
  10 use Carp qw(cluck);
  11 use Data::Dumper;
  12
  13 #my $regchars = '\\^.$|()[]*+?';
  14
  15 sub new {
  16         my $proto = shift;
  17         my $class = ref($proto) || $proto;
  18         my %args = (@_);
  19
  20         my $debug = delete $args{'debug'};
  21         unless (defined($debug)) { $debug = 0 };
  22         my $substitutions = delete $args{'substitutions'};
  23         unless (defined($substitutions)) { $substitutions = {} };
  24         my $formattable = delete $args{'format_table'};
  25         unless (defined($formattable)) { $formattable = {} };
  26         my $engine = delete $args{'engine'};
  27
  28         my $self = {};
  29         $self->{'attributes'} = {},
  30         $self->{'captured'} = [];
  31         $self->{'contextdata'} = {};
  32         $self->{'basecontext'} = '';
  33         $self->{'debug'} = $debug;
  34         $self->{'deliminators'} = '';
  35         $self->{'engine'} = '';
  36         $self->{'format_table'} = $formattable;
  37         $self->{'keywordcase'} = 1;
  38         $self->{'lastchar'} = '';
  39         $self->{'linesegment'} = '';
  40         $self->{'lists'} = {};
  41         $self->{'linestart'} = 1;
  42         $self->{'out'} = [];
  43         $self->{'plugins'} = {};
  44         $self->{'snippet'} = '';
  45         $self->{'snippetattribute'} = '';
  46         $self->{'stack'} = [];
  47         $self->{'substitutions'} = $substitutions;
  48         bless ($self, $class);
  49         unless (defined $engine) { $engine = $self };
  50         $self->engine($engine);
  51         $self->initialize;
  52         return $self;
  53 }
  54
  55 sub attributes {
  56         my $self = shift;
  57         if (@_) { $self->{'attributes'} = shift; };
  58         return $self->{'attributes'};
  59 }
  60
  61 sub basecontext {
  62         my $self = shift;
  63         if (@_) { $self->{'basecontext'} = shift; };
  64         return $self->{'basecontext'};
  65 }
  66
  67 sub captured {
  68         my ($self, $c) = @_;
  69         if (defined($c)) {
  70                 my $t = $self->engine->stackTop;
  71                 my $n = 0;
  72                 my @o = ();
  73                 while (defined($c->[$n])) {
  74                         push @o, $c->[$n];
  75                         $n ++;
  76                 }
  77                 if (@o) {
  78                         $t->[2] = \@o;
  79                 }
  80         };
  81 }
  82
  83 sub capturedGet {
  84         my ($self, $num) = @_;
  85         my $s = $self->engine->stack;
  86         if (defined($s->[1])) {
  87                 my $c = $s->[1]->[2];
  88                 $num --;
  89                 if (defined($c)) {
  90                         if (defined($c->[$num])) {
  91                                 my $r = $c->[$num];
  92                                 return $r;
  93                         } else {
  94                                 warn "capture number $num not defined";
  95                         }
  96                 } else {
  97                         warn "dynamic substitution is called for but nothing to substitute\n";
  98                         return undef;
  99                 }
 100         } else {
 101                 warn "no parent context to take captures from";
 102         }
 103 }
 104
 105 #sub captured {
 106 #       my $self = shift;
 107 #       if (@_) {
 108 #               $self->{'captured'} = shift;
 109 ##              print Dumper($self->{'captured'});
 110 #       };
 111 #       return $self->{'captured'}
 112 ##      my ($self, $c) = @_;
 113 ##      if (defined($c)) {
 114 ##              my $t = $self->engine->stackTop;
 115 ##              my $n = 0;
 116 ##              my @o = ();
 117 ##              while (defined($c->[$n])) {
 118 ##                      push @o, $c->[$n];
 119 ##                      $n ++;
 120 ##              }
 121 ##              if (@o) {
 122 ##                      $t->[2] = \@o;
 123 ##              }
 124 ##      };
 125 #}
 126 #
 127 #sub capturedGet {
 128 #       my ($self, $num) = @_;
 129 #       my $s = $self->captured;
 130 #       if (defined $s) {
 131 #               $num --;
 132 #               if (defined($s->[$num])) {
 133 #                       return $s->[$num];
 134 #               } else {
 135 #                       $self->logwarning("capture number $num not defined");
 136 #               }
 137 #       } else {
 138 #               $self->logwarning("dynamic substitution is called for but nothing to substitute");
 139 #               return undef;
 140 #       }
 141 #}
 142
 143 sub capturedParse {
 144         my ($self, $string, $mode) = @_;
 145         my $s = '';
 146         if (defined($mode)) {
 147                 if ($string =~ s/^(\d)//) {
 148                         $s = $self->capturedGet($1);
 149                         if ($string ne '') {
 150                                 $self->logwarning("character class is longer then 1 character, ignoring the rest");
 151                         }
 152                 }
 153         } else {
 154                 while ($string ne '') {
 155                         if ($string =~ s/^([^\%]*)\%(\d)//) {
 156                                 my $r = $self->capturedGet($2);
 157                                 if ($r ne '') {
 158                                         $s = $s . $1 . $r
 159                                 } else {
 160                                         $s = $s . $1 . '%' . $2;
 161                                         $self->logwarning("target is an empty string");
 162                                 }
 163                         } else {
 164                                 $string =~ s/^(.)//;
 165                                 $s = "$s$1";
 166                         }
 167                 }
 168         }
 169         return $s;
 170 }
 171
 172 sub column {
 173         my $self = shift;
 174         return length($self->linesegment);
 175 }
 176
 177 sub contextdata {
 178         my $self = shift;
 179         if (@_) { $self->{'contextdata'} = shift; };
 180         return $self->{'contextdata'};
 181 }
 182
 183 sub contextInfo {
 184         my ($self, $context, $item) = @_;
 185         if  (exists $self->contextdata->{$context}) {
 186                 my $c = $self->contextdata->{$context};
 187                 if (exists $c->{$item}) {
 188                         return $c->{$item}
 189                 } else {
 190                         return undef;
 191                 }
 192         } else {
 193                 $self->logwarning("undefined context '$context'");
 194                 return undef;
 195         }
 196 }
 197
 198 sub contextParse {
 199         my ($self, $plug, $context) = @_;
 200         if ($context =~ /^#pop/i) {
 201                 while ($context =~ s/#pop//i) {
 202                         $self->stackPull;
 203                 }
 204         } elsif ($context =~ /^#stay/i) {
 205                 #don't do anything
 206         } elsif ($context =~ /^##(.+)/) {
 207                 my $new = $self->pluginGet($1);
 208                 $self->stackPush([$new, $new->basecontext]);
 209         } else {
 210                 $self->stackPush([$plug, $context]);
 211         }
 212 }
 213
 214 sub debug {
 215         my $self = shift;
 216         if (@_) { $self->{'debug'} = shift; };
 217         return $self->{'debug'};
 218 }
 219
 220 sub debugTest {
 221         my $self = shift;
 222         if (@_) { $self->{'debugtest'} = shift; };
 223         return $self->{'debugtest'};
 224 }
 225
 226 sub deliminators {
 227         my $self = shift;
 228         if (@_) { $self->{'deliminators'} = shift; };
 229         return $self->{'deliminators'};
 230 }
 231
 232 sub engine {
 233         my $self = shift;
 234         if (@_) { $self->{'engine'} = shift; };
 235         return $self->{'engine'};
 236 }
 237
 238
 239 sub firstnonspace {
 240         my ($self, $string) = @_;
 241         my $line = $self->linesegment;
 242         if (($line =~ /^\s*$/) and ($string =~ /^[^\s]/)) {
 243                 return 1
 244         }
 245         return ''
 246 }
 247
 248 sub formatTable {
 249         my $self = shift;
 250         if (@_) { $self->{'format_table'} = shift; };
 251         return $self->{'format_table'};
 252 }
 253
 254 sub highlight {
 255         my ($self, $text) = @_;
 256         $self->snippet('');
 257         my $out = $self->out;
 258         @$out = ();
 259         while ($text ne '') {
 260                 my $top = $self->stackTop;
 261                 if (defined($top)) {
 262                         my ($plug, $context) = @$top;
 263                         if ($text =~ s/^(\n)//) {
 264                                 $self->snippetForce;
 265                                 my $e = $plug->contextInfo($context, 'lineending');
 266                                 if (defined($e)) {
 267                                         $self->contextParse($plug, $e)
 268                                 }
 269                                 my $attr = $plug->attributes->{$plug->contextInfo($context, 'attribute')};
 270                                 $self->snippetParse($1, $attr);
 271                                 $self->snippetForce;
 272                                 $self->linesegment('');
 273                                 my $b = $plug->contextInfo($context, 'linebeginning');
 274                                 if (defined($b)) {
 275                                         $self->contextParse($plug, $b)
 276                                 }
 277                         } else {
 278                                 my $sub = $plug->contextInfo($context, 'callback');
 279                                 my $result = &$sub($plug, \$text);
 280                                 unless($result) {
 281                                         my $f = $plug->contextInfo($context, 'fallthrough');
 282                                         if (defined($f)) {
 283                                                 $self->contextParse($plug, $f);
 284                                         } else {
 285                                                 $text =~ s/^(.)//;
 286                                                 my $attr = $plug->attributes->{$plug->contextInfo($context, 'attribute')};
 287                                                 $self->snippetParse($1, $attr);
 288                                         }
 289                                 }
 290                         }
 291                 } else {
 292                         push @$out, length($text), 'Normal';
 293                         $text = '';
 294                 }
 295         }
 296         $self->snippetForce;
 297         return @$out;
 298 }
 299
 300 sub highlightText {
 301         my ($self, $text) = @_;
 302         my $res = '';
 303         my @hl = $self->highlight($text);
 304         while (@hl) {
 305                 my $f = shift @hl;
 306                 my $t = shift @hl;
 307                 unless (defined($t)) { $t = 'Normal' }
 308                 my $s = $self->substitutions;
 309                 my $rr = '';
 310                 while ($f ne '') {
 311                         my $k = substr($f , 0, 1);
 312                         $f = substr($f, 1, length($f) -1);
 313                         if (exists $s->{$k}) {
 314                                  $rr = $rr . $s->{$k}
 315                         } else {
 316                                 $rr = $rr . $k;
 317                         }
 318                 }
 319                 my $rt = $self->formatTable;
 320                 if (exists $rt->{$t}) {
 321                         my $o = $rt->{$t};
 322                         $res = $res . $o->[0] . $rr . $o->[1];
 323                 } else {
 324                         $res = $res . $rr;
 325                         $self->logwarning("undefined format tag '$t'");
 326                 }
 327         }
 328         return $res;
 329 }
 330
 331 sub includePlugin {
 332         my ($self, $language, $text) = @_;
 333         my $eng = $self->engine;
 334         my $plug = $eng->pluginGet($language);
 335         if (defined($plug)) {
 336                 my $context = $plug->basecontext;
 337                 my $call = $plug->contextInfo($context, 'callback');
 338                 if (defined($call)) {
 339                         return &$call($plug, $text);
 340                 } else {
 341                         $self->logwarning("cannot find callback for context '$context'");
 342                 }
 343         }
 344         return 0;
 345 }
 346
 347 sub includeRules {
 348         my ($self, $context, $text) = @_;
 349         my $call = $self->contextInfo($context, 'callback');
 350         if (defined($call)) {
 351                 return &$call($self, $text);
 352         } else {
 353                 $self->logwarning("cannot find callback for context '$context'");
 354         }
 355         return 0;
 356 }
 357
 358 sub initialize {
 359         my $self = shift;
 360         if ($self->engine eq $self) {
 361                 $self->stack([[$self, $self->basecontext]]);
 362         }
 363 }
 364
 365 sub keywordscase {
 366         my $self = shift;
 367         if (@_) { $self->{'keywordcase'} = shift; }
 368         return $self->{'keywordscase'}
 369 }
 370
 371 sub languagePlug {
 372         my ($cw, $name) = @_;
 373         my %numb = (
 374                 '1' => 'One',
 375                 '2' => 'Two',
 376                 '3' => 'Three',
 377                 '4' => 'Four',
 378                 '5' => 'Five',
 379                 '6' => 'Six',
 380                 '7' => 'Seven',
 381                 '8' => 'Eight',
 382                 '9' => 'Nine',
 383                 '0' => 'Zero',
 384         );
 385         if ($name =~ s/^(\d)//) {
 386                 $name = $numb{$1} . $name;
 387         }
 388         $name =~ s/\.//;
 389         $name =~ s/\+/plus/g;
 390         $name =~ s/\-/minus/g;
 391         $name =~ s/#/dash/g;
 392         $name =~ s/[^0-9a-zA-Z]/_/g;
 393         $name =~ s/__/_/g;
 394         $name =~ s/_$//;
 395         $name = ucfirst($name);
 396         return $name;
 397 }
 398
 399 sub lastchar {
 400         my $self = shift;
 401         my $l = $self->linesegment;
 402         if ($l eq '') { return "\n" } #last character was a newline
 403         return substr($l, length($l) - 1, 1);
 404 }
 405
 406 sub lastcharDeliminator {
 407         my $self = shift;
 408         my $deliminators = '\s|\~|\!|\%|\^|\&|\*|\+|\(|\)|-|=|\{|\}|\[|\]|:|;|<|>|,|\\|\||\.|\?|\/';
 409         if ($self->linestart or ($self->lastchar =~ /$deliminators/))  {
 410                 return 1;
 411         }
 412         return '';
 413 }
 414
 415 sub linesegment {
 416         my $self = shift;
 417         if (@_) { $self->{'linesegment'} = shift; };
 418         return $self->{'linesegment'};
 419 }
 420
 421 sub linestart {
 422         my $self = shift;
 423         if ($self->linesegment eq '') {
 424                 return 1
 425         }
 426         return '';
 427 }
 428
 429 sub lists {
 430         my $self = shift;
 431         if (@_) { $self->{'lists'} = shift; }
 432         return $self->{'lists'}
 433 }
 434
 435 sub out {
 436         my $self = shift;
 437         if (@_) { $self->{'out'} = shift; }
 438         return $self->{'out'};
 439 }
 440
 441 sub listAdd {
 442         my $self = shift;
 443         my $listname = shift;
 444         my $lst = $self->lists;
 445         if (@_) {
 446                 my @l = reverse sort @_;
 447                 $lst->{$listname} = \@l;
 448         } else {
 449                 $lst->{$listname} = [];
 450         }
 451 }
 452
 453 sub logwarning {
 454         my ($self, $warning) = @_;
 455         my $top = $self->engine->stackTop;
 456         if (defined $top) {
 457                 my $lang = $top->[0]->language;
 458                 my $context = $top->[1];
 459                 $warning = "$warning\n  Language => $lang, Context => $context\n";
 460         } else {
 461                 $warning = "$warning\n  STACK IS EMPTY: PANIC\n"
 462         }
 463         cluck($warning);
 464 }
 465
 466 sub parseResult {
 467         my ($self, $text, $string, $lahead, $column, $fnspace, $context, $attr) = @_;
 468         my $eng = $self->engine;
 469         if ($fnspace) {
 470                 unless ($eng->firstnonspace($$text)) {
 471                         return ''
 472                 }
 473         }
 474         if (defined($column)) {
 475                 if ($column ne $eng->column) {
 476                         return '';
 477                 }
 478         }
 479         unless ($lahead) {
 480                 $$text = substr($$text, length($string));
 481                 my $r;
 482                 unless (defined($attr)) {
 483                         my $t = $eng->stackTop;
 484                         my ($plug, $ctext) = @$t;
 485                         $r = $plug->attributes->{$plug->contextInfo($ctext, 'attribute')};
 486                 } else {
 487                         $r = $self->attributes->{$attr};
 488                 }
 489                 $eng->snippetParse($string, $r);
 490         }
 491         $eng->contextParse($self, $context);
 492         return 1
 493 }
 494
 495 sub pluginGet {
 496         my ($self, $language) = @_;
 497         my $plugs = $self->{'plugins'};
 498         unless (exists($plugs->{$language})) {
 499                 my $modname = 'Syntax::Highlight::Engine::Kate::' . $self->languagePlug($language);
 500                 unless (defined($modname)) {
 501                         $self->logwarning("no valid module found for language '$language'");
 502                         return undef;
 503                 }
 504                 my $plug;
 505                 eval "use $modname; \$plug = new $modname(engine => \$self);";
 506                 if (defined($plug)) {
 507                         $plugs->{$language} = $plug;
 508                 } else {
 509                         $self->logwarning("cannot create plugin for language '$language'\n$@");
 510                 }
 511         }
 512         if (exists($plugs->{$language})) {
 513                 return $plugs->{$language};
 514         }
 515         return undef;
 516 }
 517
 518 sub reset {
 519         my $self = shift;
 520         $self->stack([[$self, $self->basecontext]]);
 521         $self->out([]);
 522         $self->snippet('');
 523 }
 524
 525 sub snippet {
 526         my $self = shift;
 527         if (@_) { $self->{'snippet'} = shift; }
 528         return $self->{'snippet'};
 529 }
 530
 531 sub snippetAppend {
 532         my ($self, $ch) = @_;
 533
 534         return if not defined $ch;
 535         $self->{'snippet'} = $self->{'snippet'} . $ch;
 536         if ($ch ne '') {
 537                 $self->linesegment($self->linesegment . $ch);
 538         }
 539         return;
 540 }
 541
 542 sub snippetAttribute {
 543         my $self = shift;
 544         if (@_) { $self->{'snippetattribute'} = shift; }
 545         return $self->{'snippetattribute'};
 546 }
 547
 548 sub snippetForce {
 549         my $self = shift;
 550         my $parse = $self->snippet;
 551         if ($parse ne '') {
 552                 my $out = $self->{'out'};
 553                 push(@$out, $parse, $self->snippetAttribute);
 554                 $self->snippet('');
 555         }
 556 }
 557
 558 sub snippetParse {
 559         my $self = shift;
 560         my $snip = shift;
 561         my $attr = shift;
 562         if ((defined $attr) and ($attr ne $self->snippetAttribute)) {
 563                 $self->snippetForce;
 564                 $self->snippetAttribute($attr);
 565         }
 566         $self->snippetAppend($snip);
 567 }
 568
 569 sub stack {
 570         my $self = shift;
 571         if (@_) { $self->{'stack'} = shift; }
 572         return $self->{'stack'};
 573 }
 574
 575 sub stackPush {
 576         my ($self, $val) = @_;
 577         my $stack = $self->stack;
 578         unshift(@$stack, $val);
 579 }
 580
 581 sub stackPull {
 582         my ($self, $val) = @_;
 583         my $stack = $self->stack;
 584         return shift(@$stack);
 585 }
 586
 587 sub stackTop {
 588         my $self = shift;
 589         return $self->stack->[0];
 590 }
 591
 592 sub stateCompare {
 593         my ($self, $state) = @_;
 594         my $h = [ $self->stateGet ];
 595         my $equal = 0;
 596         if (Dumper($h) eq Dumper($state)) { $equal = 1 };
 597         return $equal;
 598 }
 599
 600 sub stateGet {
 601         my $self = shift;
 602         my $s = $self->stack;
 603         return @$s;
 604 }
 605
 606 sub stateSet {
 607         my $self = shift;
 608         my $s = $self->stack;
 609         @$s = (@_);
 610 }
 611
 612 sub substitutions {
 613         my $self = shift;
 614         if (@_) { $self->{'substitutions'} = shift; }
 615         return $self->{'substitutions'};
 616 }
 617
 618 sub testAnyChar {
 619         my $self = shift;
 620         my $text = shift;
 621         my $string = shift;
 622         my $insensitive = shift;
 623         my $test = substr($$text, 0, 1);
 624         my $bck = $test;
 625         if ($insensitive) {
 626                 $string = lc($string);
 627                 $test = lc($test);
 628         }
 629         if (index($string, $test) > -1) {
 630                 return $self->parseResult($text, $bck, @_);
 631         }
 632         return ''
 633 }
 634
 635 sub testDetectChar {
 636         my $self = shift;
 637         my $text = shift;
 638         my $char = shift;
 639         my $insensitive = shift;
 640         my $dyn = shift;
 641         if ($dyn) {
 642                 $char = $self->capturedParse($char, 1);
 643         }
 644         my $test = substr($$text, 0, 1);
 645         my $bck = $test;
 646         if ($insensitive) {
 647                 $char = lc($char);
 648                 $test = lc($test);
 649         }
 650         if ($char eq $test) {
 651                 return $self->parseResult($text, $bck, @_);
 652         }
 653         return ''
 654 }
 655
 656 sub testDetect2Chars {
 657         my $self = shift;
 658         my $text = shift;
 659         my $char = shift;
 660         my $char1 = shift;
 661         my $insensitive = shift;
 662         my $dyn = shift;
 663         if ($dyn) {
 664                 $char = $self->capturedParse($char, 1);
 665                 $char1 = $self->capturedParse($char1, 1);
 666         }
 667         my $string = $char . $char1;
 668         my $test = substr($$text, 0, 2);
 669         my $bck = $test;
 670         if ($insensitive) {
 671                 $string = lc($string);
 672                 $test = lc($test);
 673         }
 674         if ($string eq $test) {
 675                 return $self->parseResult($text, $bck, @_);
 676         }
 677         return ''
 678 }
 679
 680 sub testDetectIdentifier {
 681         my $self = shift;
 682         my $text = shift;
 683         if ($$text =~ /^([a-zA-Z_][a-zA-Z0-9_]+)/) {
 684                 return $self->parseResult($text, $1, @_);
 685         }
 686         return ''
 687 }
 688
 689 sub testDetectSpaces {
 690         my $self = shift;
 691         my $text = shift;
 692         if ($$text =~ /^([\\040|\\t]+)/) {
 693                 return $self->parseResult($text, $1, @_);
 694         }
 695         return ''
 696 }
 697
 698 sub testFloat {
 699         my $self = shift;
 700         my $text = shift;
 701         if ($self->engine->lastcharDeliminator) {
 702                 if ($$text =~ /^((?=\.?\d)\d*(?:\.\d*)?(?:[Ee][+-]?\d+)?)/) {
 703                         return $self->parseResult($text, $1, @_);
 704                 }
 705         }
 706         return ''
 707 }
 708
 709 sub testHlCChar {
 710         my $self = shift;
 711         my $text = shift;
 712         if ($$text =~ /^('.')/) {
 713                 return $self->parseResult($text, $1, @_);
 714         }
 715         return ''
 716 }
 717
 718 sub testHlCHex {
 719         my $self = shift;
 720         my $text = shift;
 721         if ($self->engine->lastcharDeliminator) {
 722                 if ($$text =~ /^(0x[0-9a-fA-F]+)/) {
 723                         return $self->parseResult($text, $1, @_);
 724                 }
 725         }
 726         return ''
 727 }
 728
 729 sub testHlCOct {
 730         my $self = shift;
 731         my $text = shift;
 732         if ($self->engine->lastcharDeliminator) {
 733                 if ($$text =~ /^(0[0-7]+)/) {
 734                         return $self->parseResult($text, $1, @_);
 735                 }
 736         }
 737         return ''
 738 }
 739
 740 sub testHlCStringChar {
 741         my $self = shift;
 742         my $text = shift;
 743         if ($$text =~ /^(\\[a|b|e|f|n|r|t|v|'|"|\?])/) {
 744                 return $self->parseResult($text, $1, @_);
 745         }
 746         if ($$text =~ /^(\\x[0-9a-fA-F][0-9a-fA-F]?)/) {
 747                 return $self->parseResult($text, $1, @_);
 748         }
 749         if ($$text =~ /^(\\[0-7][0-7]?[0-7]?)/) {
 750                 return $self->parseResult($text, $1, @_);
 751         }
 752         return ''
 753 }
 754
 755 sub testInt {
 756         my $self = shift;
 757         my $text = shift;
 758         if ($self->engine->lastcharDeliminator) {
 759                 if ($$text =~ /^([+-]?\d+)/) {
 760                         return $self->parseResult($text, $1, @_);
 761                 }
 762         }
 763         return ''
 764 }
 765
 766 sub testKeyword {
 767         my $self = shift;
 768         my $text = shift;
 769         my $list = shift;
 770         my $eng = $self->engine;
 771         my $deliminators = $self->deliminators;
 772         if (($eng->lastcharDeliminator)  and ($$text =~ /^([^$deliminators]+)/)) {
 773                 my $match = $1;
 774                 my $l = $self->lists->{$list};
 775                 if (defined($l)) {
 776                         my @list = @$l;
 777                         my @rl = ();
 778                         unless ($self->keywordscase) {
 779                                 @rl = grep { (lc($match) eq lc($_)) } @list;
 780                         } else {
 781                                 @rl = grep { ($match eq $_) } @list;
 782                         }
 783                         if (@rl) {
 784                                 return $self->parseResult($text, $match, @_);
 785                         }
 786                 } else {
 787                         $self->logwarning("list '$list' is not defined, failing test");
 788                 }
 789         }
 790         return ''
 791 }
 792
 793 sub testLineContinue {
 794         my $self = shift;
 795         my $text = shift;
 796         my $lahead = shift;
 797         if ($lahead) {
 798                 if ($$text =~ /^\\\n/) {
 799                         $self->parseResult($text, "\\", $lahead, @_);
 800                         return 1;
 801                 }
 802         } else {
 803                 if ($$text =~ s/^(\\)(\n)/$2/) {
 804                         return $self->parseResult($text, "\\", $lahead, @_);
 805                 }
 806         }
 807         return ''
 808 }
 809
 810 sub testRangeDetect {
 811         my $self = shift;
 812         my $text = shift;
 813         my $char = shift;
 814         my $char1 = shift;
 815         my $insensitive = shift;
 816         my $string = "$char\[^$char1\]+$char1";
 817         return $self->testRegExpr($text, $string, $insensitive, 0, @_);
 818 }
 819
 820 sub testRegExpr {
 821         my $self = shift;
 822         my $text = shift;
 823         my $reg = shift;
 824         my $insensitive = shift;
 825         my $dynamic = shift;
 826         if ($dynamic) {
 827                 $reg = $self->capturedParse($reg);
 828         }
 829         my $eng = $self->engine;
 830         if ($reg =~ s/^\^//) {
 831                 unless ($eng->linestart) {
 832                         return '';
 833                 }
 834         } elsif ($reg =~ s/^\\(b)//i) {
 835                 my $lastchar = $self->engine->lastchar;
 836                 if ($1 eq 'b') {
 837                         if ($lastchar =~ /\w/) { return '' }
 838                 } else {
 839                         if ($lastchar =~ /\W/) { return '' }
 840                 }
 841         }
 842 #       $reg = "^($reg)";
 843         $reg = "^$reg";
 844         my $pos;
 845 #       my @cap = ();
 846         my $sample = $$text;
 847         if ($insensitive) {
 848                 if ($sample =~ /$reg/ig) {
 849                         $pos = pos($sample);
 850 #                       @cap = ($1, $2, $3, $4, $5, $6, $7, $8, $9);
 851 #                       my @cap = ();
 852                         if ($#-) {
 853                                 no strict 'refs';
 854                                 my @cap = map {$$_} 1 .. $#-;
 855                                 $self->captured(\@cap)
 856                         }
 857 #                       my $r  = 1;
 858 #                       my $c  = 1;
 859 #                       my @cap = ();
 860 #                       while ($r) {
 861 #                               eval "if (defined\$$c) { push \@cap, \$$c } else { \$r = 0 }";
 862 #                               $c ++;
 863 #                       }
 864 #                       if (@cap) { $self->captured(\@cap) };
 865                 }
 866         } else {
 867                 if ($sample =~ /$reg/g) {
 868                         $pos = pos($sample);
 869 #                       @cap = ($1, $2, $3, $4, $5, $6, $7, $8, $9);
 870 #                       my @cap = ();
 871                         if ($#-) {
 872                                 no strict 'refs';
 873                                 my @cap = map {$$_} 1 .. $#-;
 874                                 $self->captured(\@cap);
 875                         }
 876 #                       my $r  = 1;
 877 #                       my $c  = 1;
 878 #                       my @cap = ();
 879 #                       while ($r) {
 880 #                               eval "if (defined\$$c) { push \@cap, \$$c } else { \$r = 0 }";
 881 #                               $c ++;
 882 #                       }
 883 #                       if (@cap) { $self->captured(\@cap) };
 884                 }
 885         }
 886         if (defined($pos) and ($pos > 0)) {
 887                 my $string = substr($$text, 0, $pos);
 888                 return $self->parseResult($text, $string, @_);
 889         }
 890         return ''
 891 }
 892
 893 sub testStringDetect {
 894         my $self = shift;
 895         my $text = shift;
 896         my $string = shift;
 897         my $insensitive = shift;
 898         my $dynamic = shift;
 899         if ($dynamic) {
 900                 $string = $self->capturedParse($string);
 901         }
 902         my $test = substr($$text, 0, length($string));
 903         my $bck = $test;
 904         if ($insensitive) {
 905                 $string = lc($string);
 906                 $test = lc($test);
 907         }
 908         if ($string eq $test) {
 909                 return $self->parseResult($text, $bck, @_);
 910         }
 911         return ''
 912 }
 913
 914
 915 1;
 916
 917 __END__
 918
 919 =cut
 920
 921 =head1 NAME
 922
 923 Syntax::Highlight::Engine::Kate::Template - a template for syntax highlighting plugins
 924
 925 =head1 DESCRIPTION
 926
 927 Syntax::Highlight::Engine::Kate::Template is a framework to assist authors of plugin modules.
 928 All methods to provide highlighting to the Syntax::Highlight::Engine::Kate module are there, Just
 929 no syntax definitions and callbacks. An instance of Syntax::Highlight::Engine::Kate::Template
 930 should never be created, it's meant to be sub classed only.
 931
 932 =head1 METHODS
 933
 934 =over 4
 935
 936 =item B<attributes>(I<?$attributesref?>);
 937
 938 Sets and returns a reference to the attributes hash.
 939
 940 =item B<basecontext>(I<?$context?>);
 941
 942 Sets and returns the basecontext instance variable. This is the context that is used when highlighting starts.
 943
 944 =item B<captured>(I<$cap>);
 945
 946 Puts $cap in the first element of the stack, the current context. Used when the context is dynamic.
 947
 948 =item B<capturedGet>(I<$num>);
 949
 950 Returns the $num'th element that was captured in the current context.
 951
 952 =item B<capturedParse>(I<$string>, I<$mode>);
 953
 954 If B<$mode> is specified, B<$string> should only be one character long and numeric.
 955 B<capturedParse> will return the Nth captured element of the current context.
 956
 957 If B<$mode> is not specified, all occurences of %[1-9] will be replaced by the captured
 958 element of the current context.
 959
 960 =item B<column>
 961
 962 returns the column position in the line that is currently highlighted.
 963
 964 =item B<contextdata>(I<\%data>);
 965
 966 Sets and returns a reference to the contextdata hash.
 967
 968 =item B<contextInfo>(I<$context>, I<$item>);
 969
 970 returns the value of several context options. B<$item> can be B<callback>, B<attribute>, B<lineending>,
 971 B<linebeginning>, B<fallthrough>.
 972
 973 =item B<contextParse>(I<$plugin>, I<$context>);
 974
 975 Called by the plugins after a test succeeds. if B<$context> has following values:
 976
 977  #pop       returns to the previous context, removes to top item in the stack. Can
 978             also be specified as #pop#pop etc.
 979  #stay      does nothing.
 980  ##....     Switches to the plugin specified in .... and assumes it's basecontext.
 981  ....       Swtiches to the context specified in ....
 982
 983 =item B<deliminators>(I<?$delim?>);
 984
 985 Sets and returns a string that is a regular expression for detecting deliminators.
 986
 987 =item B<engine>
 988
 989 Returns a reference to the Syntax::Highlight::Engine::Kate module that created this plugin.
 990
 991 =item B<firstnonspace>(I<$string>);
 992
 993 returns true if the current line did not contain a non-spatial character so far and the first
 994 character in B<$string> is also a spatial character.
 995
 996 =item B<formatTable>
 997
 998 sets and returns the instance variable B<format_table>. See also the option B<format_table>
 999
1000 =item B<highlight>(I<$text>);
1001
1002 highlights I<$text>. It does so by selecting the proper callback
1003 from the B<commands> hash and invoke it. It will do so untill
1004 $text has been reduced to an empty string. returns a paired list
1005 of snippets of text and the attribute with which they should be
1006 highlighted.
1007
1008 =item B<highlightText>(I<$text>);
1009
1010 highlights I<$text> and reformats it using the B<format_table> and B<substitutions>
1011
1012 =item B<includePlugin>(I<$language>, I<\$text>);
1013
1014 Includes the plugin for B<$language> in the highlighting.
1015
1016 =item B<includeRules>(I<$language>, I<\$text>);
1017
1018 Includes the plugin for B<$language> in the highlighting.
1019
1020 =item B<keywordscase>
1021
1022 Sets and returns the keywordscase instance variable.
1023
1024 =item B<lastchar>
1025
1026 return the last character that was processed.
1027
1028 =item B<lastcharDeliminator>
1029
1030 returns true if the last character processed was a deliminator.
1031
1032 =item B<linesegment>
1033
1034 returns the string of text in the current line that has been processed so far,
1035
1036 =item B<linestart>
1037
1038 returns true if processing is currently at the beginning of a line.
1039
1040 =item B<listAdd>(I<'listname'>, I<$item1>, I<$item2> ...);
1041
1042 Adds a list to the 'lists' hash.
1043
1044 =item B<lists>(I<?\%lists?>);
1045
1046 sets and returns the instance variable 'lists'.
1047
1048 =item B<out>(I<?\@highlightedlist?>);
1049
1050 sets and returns the instance variable 'out'.
1051
1052 =item B<parseResult>(I<\$text>, I<$match>, I<$lookahaed>, I<$column>, I<$firstnonspace>, I<$context>, I<$attribute>);
1053
1054 Called by every one of the test methods below. If the test matches, it will do a couple of subtests.
1055 If B<$column> is a defined numerical value it will test if the process is at the requested column.
1056 If B<$firnonspace> is true, it will test this also.
1057 Ig it is not a look ahead and all tests are passed, B<$match> is then parsed and removed from B<$$text>.
1058
1059 =item B<pluginGet>(I<$language>);
1060
1061 Returns a reference to a plugin object for the specified language. Creating an
1062 instance if needed.
1063
1064 =item B<reset>
1065
1066 Resets the highlight engine to a fresh state, does not change the syntx.
1067
1068 =item B<snippet>
1069
1070 Contains the current snippet of text that will have one attribute. The moment the attribute
1071 changes it will be parsed.
1072
1073 =item B<snippetAppend>(I<$string>)
1074
1075 appends I<$string> to the current snippet.
1076
1077 =item B<snippetAttribute>(I<$attribute>)
1078
1079 Sets and returns the used attribute.
1080
1081 =item B<snippetForce>
1082
1083 Forces the current snippet to be parsed.
1084
1085 =item B<snippetParse>(I<$text>, I<?$attribute?>)
1086
1087 If attribute is defined and differs from the current attribute it does a snippetForce and
1088 sets the current attribute to B<$attribute>. Then it does a snippetAppend of B<$text>
1089
1090 =item B<stack>
1091
1092 sets and returns the instance variable 'stack', a reference to an array
1093
1094 =item B<stackPull>
1095
1096 retrieves the element that is on top of the stack, decrements stacksize by 1.
1097
1098 =item B<stackPush>(I<$tagname>);
1099
1100 puts I<$tagname> on top of the stack, increments stacksize by 1
1101
1102 =item B<stackTop>
1103
1104 Retrieves the element that is on top of the stack.
1105
1106 =item B<stateCompare>(I<\@state>)
1107
1108 Compares two lists, \@state and the stack. returns true if they
1109 match.
1110
1111 =item B<stateGet>
1112
1113 Returns a list containing the entire stack.
1114
1115 =item B<stateSet>(I<@list>)
1116
1117 Accepts I<@list> as the current stack.
1118
1119 =item B<substitutions>
1120
1121 sets and returns a reference to the substitutions hash.
1122
1123 =back
1124
1125 The methods below all return a boolean value.
1126
1127 =over 4
1128
1129 =item B<testAnyChar>(I<\$text>, I<$string>, I<$insensitive>, I<$lookahaed>, I<$column>, I<$firstnonspace>, I<$context>, I<$attribute>);
1130
1131 =item B<testDetectChar>(I<\$text>, I<$char>, I<$insensitive>, I<$dynamic>, I<$lookahaed>, I<$column>, I<$firstnonspace>, I<$context>, I<$attribute>);
1132
1133 =item B<testDetect2Chars>(I<\$text>, I<$char1>, I<$char2>, I<$insensitive>, I<$dynamic>, I<$lookahaed>, I<$column>, I<$firstnonspace>, I<$context>, I<$attribute>);
1134
1135 =item B<testDetectIdentifier>(I<\$text>, I<$lookahaed>, I<$column>, I<$firstnonspace>, I<$context>, I<$attribute>);
1136
1137 =item B<testDetectSpaces>(I<\$text>, I<$lookahaed>, I<$column>, I<$firstnonspace>, I<$context>, I<$attribute>);
1138
1139 =item B<testFloat>(I<\$text>, I<$lookahaed>, I<$column>, I<$firstnonspace>, I<$context>, I<$attribute>);
1140
1141 =item B<testHlCChar>(I<\$text>, I<$lookahaed>, I<$column>, I<$firstnonspace>, I<$context>, I<$attribute>);
1142
1143 =item B<testHlCHex>(I<\$text>, I<$lookahaed>, I<$column>, I<$firstnonspace>, I<$context>, I<$attribute>);
1144
1145 =item B<testHlCOct>(I<\$text>, I<$lookahaed>, I<$column>, I<$firstnonspace>, I<$context>, I<$attribute>);
1146
1147 =item B<testHlCStringChar>(I<\$text>, I<$lookahaed>, I<$column>, I<$firstnonspace>, I<$context>, I<$attribute>);
1148
1149 =item B<testInt>(I<\$text>, I<$lookahaed>, I<$column>, I<$firstnonspace>, I<$context>, I<$attribute>);
1150
1151 =item B<testKeyword>(I<\$text>, I<$list>, I<$insensitive>, I<$lookahaed>, I<$column>, I<$firstnonspace>, I<$context>, I<$attribute>);
1152
1153 =item B<testLineContinue>(I<\$text>, I<$lookahaed>, I<$column>, I<$firstnonspace>, I<$context>, I<$attribute>);
1154
1155 =item B<testRangeDetect>(I<\$text>,  I<$char1>, I<$char2>, I<$insensitive>, I<$lookahaed>, I<$column>, I<$firstnonspace>, I<$context>, I<$attribute>);
1156
1157 =item B<testRegExpr>(I<\$text>, I<$reg>, I<$insensitive>, I<$dynamic>, I<$lookahaed>, I<$column>, I<$firstnonspace>, I<$context>, I<$attribute>);
1158
1159 =item B<testStringDetect>(I<\$text>, I<$string>, I<$insensitive>, I<$dynamic>, II<$lookahaed>, I<$column>, I<$firstnonspace>, I<$context>, I<$attribute>);
1160
1161 =back
1162
1163 =head1 ACKNOWLEDGEMENTS
1164
1165 All the people who wrote Kate and the syntax highlight xml files.
1166
1167 =head1 AUTHOR AND COPYRIGHT
1168
1169 This module is written and maintained by:
1170
1171 Hans Jeuken < haje at toneel dot demon dot nl >
1172
1173 Copyright (c) 2006 by Hans Jeuken, all rights reserved.
1174
1175 You may freely distribute and/or modify this module under same terms as
1176 Perl itself
1177
1178 =head1 SEE ALSO
1179
1180 Synax::Highlight::Engine::Kate http:://www.kate-editor.org
1181
1182 =cut
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195