local-lib5/lib/perl5/Syntax/Highlight/Engine/Kate/XMLData.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::XMLData;
   6
   7 use strict;
   8 use warnings;
   9 use XML::TokeParser;
  10 use Data::Dumper;
  11
  12 our $VERSION = '0.06';
  13
  14 my $regchars = "\\^.\$|()[]{}*+?~!%^&/";
  15
  16 sub new {
  17         my $proto = shift;
  18         my $class = ref($proto) || $proto;
  19
  20         my $file = shift @_;
  21         unless (defined($file)) { $file = ''; }
  22         my $self = {
  23                 basecontext => '',
  24                 contexts => {},
  25                 adddeliminators => '',
  26                 weakdeliminators => '',
  27                 filename => '',
  28                 itemdata => {},
  29                 keywordscase => 1,
  30                 language => {},
  31                 lists => {},
  32                 metadata =>{},
  33         };
  34         bless ($self, $class);
  35         if (defined($file)) {
  36                 $self->loadXML($file)
  37         }
  38         return $self;
  39 }
  40
  41
  42 sub basecontext {
  43         my $self = shift;
  44         if (@_) { $self->{'basecontext'} = shift }
  45         return $self->{'basecontext'}
  46 }
  47
  48 sub contexts {
  49         my $self = shift;
  50         if (@_) { $self->{'contexts'} = shift }
  51         return $self->{'contexts'}
  52 }
  53
  54 sub additionalDeliminator {
  55         my $self = shift;
  56         if (@_) { $self->{'adddeliminators'} = shift }
  57         return $self->{'adddeliminators'}
  58 }
  59
  60 sub weakDeliminator {
  61         my $self = shift;
  62         if (@_) { $self->{'weakdeliminators'} = shift }
  63         return $self->{'weakdeliminators'}
  64 }
  65
  66 sub filename {
  67         my $self = shift;
  68         if (@_) { $self->{'filename'} = shift }
  69         return $self->{'filename'}
  70 }
  71
  72 sub getItems {
  73         my ($self, $parser) = @_;
  74         my @list = ();
  75         while (my $token = $parser->get_token) {
  76                 if ($token->[0] eq 'S') {
  77                         my $t = $token->[2];
  78                         $t->{'type'} = $token->[1];
  79                         my @items = $self->getItems($parser);
  80                         if (@items) {
  81                                 $t->{'items'} = \@items
  82                         }
  83                         push @list, $t;
  84                 } elsif ($token->[0] eq 'E') {
  85                         return @list;
  86                 }
  87         }
  88 }
  89
  90 sub itemdata {
  91         my $self = shift;
  92         if (@_) { $self->{'itemdata'} = shift }
  93         return $self->{'itemdata'}
  94 }
  95
  96 sub keywordscase {
  97         my $self = shift;
  98         if (@_) { $self->{'keywordscase'} = shift }
  99         return $self->{'keywordscase'}
 100 }
 101
 102 sub loadXML {
 103         my ($self, $file) = @_;
 104         unless (open KATE, "<$file") { die "cannot open $file"; };
 105         print "loading $file\n";
 106         my $parser = new XML::TokeParser(\*KATE, Noempty => 1);
 107         my %curargs = ();
 108         my @curlist = ();
 109         my $curitem = '';
 110         my $mode = 'base';
 111         while (my $token = $parser->get_token) {
 112                 if ($mode eq 'base') {
 113                         if ($token->[0] eq 'S') {
 114                                 if ($token->[1] eq 'language') {
 115                                         my $args = $token->[2];
 116                                         $self->language($args);
 117                                 } elsif ($token->[1] eq 'list') {
 118                                         $curitem = $token->[2]->{'name'};
 119         #                               print "current list '$curitem'\n";
 120                                         $mode = 'list';
 121                                 } elsif ($token->[1]  eq 'context') {
 122                                         my $ctx = delete $token->[2]->{'name'};
 123                                         unless (defined($ctx)) { $ctx ='noname' };
 124         #                               print "current context '$ctx'\n";
 125                                         my $ar = $token->[2];
 126                                         my %args = %$ar;
 127                                         if ($self->basecontext eq '') {
 128                                                 $self->basecontext($ctx);
 129                                         }
 130                                         my @items = $self->getItems($parser);
 131                                         if (@items) { $args{'items'} = \@items };
 132                                         $self->contexts->{$ctx} = \%args;
 133                                 } elsif ($token->[1] eq 'itemData') {
 134                                         my $style = $token->[2]->{'defStyleNum'};
 135                                         unless (defined($style)) { $style = '';};
 136                                         $style =~ s/^ds//;
 137                                         $self->itemdata->{$token->[2]->{'name'}} =  $style;
 138                                 } elsif ($token->[1] eq 'keywords') {
 139                                         my $case = delete $token->[2]->{'casesensitive'};
 140                                         if (defined($case)) {
 141                                                 if (lc($case) eq 'true') {
 142                                                         $self->keywordscase(1);
 143                                                 } else {
 144                                                         $self->keywordscase(0);
 145                                                 }
 146                                         }
 147                                         my $wdelim = delete $token->[2]->{'weakDeliminator'};
 148                                         if (defined($wdelim)) {
 149                                                 $self->weakDeliminator($wdelim)
 150                                         }
 151                                         my $adelim = delete $token->[2]->{'additionalDeliminator'};
 152                                         if (defined($wdelim)) {
 153                                                 $self->additionalDeliminator($wdelim)
 154                                         }
 155                                 }
 156                         }
 157                 } elsif ($mode eq 'list') {
 158                         if ($token->[0] eq 'T') {
 159                                 my $tx = $token->[1];
 160                                 $tx =~ s/^\s+//;
 161                                 $tx =~ s/\s+$//;
 162                                 push @curlist, $tx;
 163                         } elsif ($token->[0] eq 'E') {
 164                                 if ($token->[1] eq 'list') {
 165                                         $self->lists->{$curitem} = [ @curlist ];
 166                                         $mode = 'base';
 167                                         @curlist = ();
 168                                         $curitem = '';
 169                                 }
 170                         }
 171                 }
 172         }
 173         close KATE;
 174         $self->filename($file);
 175 }
 176
 177 sub language {
 178         my $self = shift;
 179         if (@_) { $self->{'language'} = shift }
 180         return $self->{'language'}
 181 }
 182
 183 sub lists {
 184         my $self = shift;
 185         if (@_) { $self->{'lists'} = shift }
 186         return $self->{'lists'}
 187 }
 188
 189 sub metadata {
 190         my $self = shift;
 191         my $key = shift;
 192         my $m = $self->{'metadata'};
 193         if (@_) {
 194                 $m->{$key} = shift;
 195         }
 196         my $res = '';
 197         if (exists $m->{$key}) {
 198                 $res = $m->{$key}
 199         }
 200         return $res;
 201 }
 202
 203 sub metadataBackup {
 204         my $self = shift;
 205         my $m = $self->{'metadata'};
 206         my $dstr = Dumper($m);
 207         my $VAR1;
 208         eval $dstr;
 209         return $VAR1;
 210 }
 211
 212 sub samplefile {
 213         my $self = shift;
 214         if (@_) { $self->{'samplefile'} = shift }
 215         return $self->{'samplefile'};
 216 }
 217
 218
 219 1;