328 lines
7.6 KiB
Perl
328 lines
7.6 KiB
Perl
package Enum;
|
|
|
|
use strict;
|
|
use warnings;
|
|
use DocsParser;
|
|
|
|
BEGIN {
|
|
use Exporter ();
|
|
our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
|
|
|
|
# set the version for version checking
|
|
$VERSION = 1.00;
|
|
@ISA = qw(Exporter);
|
|
@EXPORT = ( );
|
|
%EXPORT_TAGS = ( );
|
|
# your exported package globals go here,
|
|
# as well as any optionally exported functions
|
|
@EXPORT_OK = ( );
|
|
}
|
|
our @EXPORT_OK;
|
|
|
|
# class Enum
|
|
# {
|
|
# bool flags;
|
|
# string type;
|
|
# string module;
|
|
# string c_type;
|
|
#
|
|
# string array elem_names;
|
|
# string array elem_values;
|
|
# string c_prefix;
|
|
#
|
|
# bool mark;
|
|
# }
|
|
|
|
#
|
|
# private functions:
|
|
#
|
|
|
|
sub split_enum_tokens($)
|
|
{
|
|
my ($token_string) = @_;
|
|
my @tokens = ();
|
|
# index of first opening double quotes between parens - beginning of a new
|
|
# token.
|
|
my $begin_token = 0;
|
|
# index of last closing double quotes between parens - end of a token.
|
|
my $end_token = 0;
|
|
# whether we are inside double quotes.
|
|
my $inside_dquotes = 0;
|
|
# whether we are inside double and then single quotes (for situations like
|
|
# "'"'").
|
|
my $inside_squotes = 0;
|
|
my $len = length($token_string);
|
|
# whether we found opening paren and we are expecting an opening double
|
|
# quotes.
|
|
my $near_begin = 0;
|
|
# count of double quotes pairs between parens.
|
|
my $dq_count = 0;
|
|
# whether previous char was a backslash - important only when being between
|
|
# double quotes.
|
|
my $backslash = 0;
|
|
for (my $index = 0; $index < $len; $index++)
|
|
{
|
|
my $char = substr($token_string, $index, 1);
|
|
if ($inside_dquotes)
|
|
{
|
|
# if prevous char was backslash, then current char is not important -
|
|
# we are still inside double or double/single quotes anyway.
|
|
if ($backslash)
|
|
{
|
|
$backslash = 0;
|
|
}
|
|
# if current char is backslash.
|
|
elsif ($char eq '\\')
|
|
{
|
|
$backslash = 1;
|
|
}
|
|
# if current char is unescaped double quotes and we are not inside single
|
|
# ones - means, we are going outside string. We mark this place as an end
|
|
# of the token in case we find a closing paren after this.
|
|
elsif ($char eq '"' and not $inside_squotes)
|
|
{
|
|
$inside_dquotes = 0;
|
|
$end_token = $index;
|
|
}
|
|
# if current char is single quote then switch being inside single quotes
|
|
# state.
|
|
elsif ($char eq '\'')
|
|
{
|
|
$inside_squotes = not $inside_squotes;
|
|
}
|
|
}
|
|
# current char is opening paren - this means we are near the beginning of
|
|
# a token (first double quotes after this paren).
|
|
elsif ($char eq '(')
|
|
{
|
|
$near_begin = 1;
|
|
}
|
|
# current char is closing paren - this means we reached end of a token at
|
|
# last closing double quotes.
|
|
elsif ($char eq ')')
|
|
{
|
|
my $token_len = $end_token + 1 - $begin_token;
|
|
my $token = substr($token_string, $begin_token, $token_len);
|
|
# there should be three pairs of double quotes.
|
|
if ($dq_count == 3)
|
|
{
|
|
push(@tokens, $token);
|
|
}
|
|
else
|
|
{
|
|
print STDERR "Wrong value statement while parsing ($token)\n";
|
|
}
|
|
$dq_count = 0;
|
|
}
|
|
# current char is opening double quotes - this can be a beginning of
|
|
# a token.
|
|
elsif ($char eq '"')
|
|
{
|
|
if ($near_begin)
|
|
{
|
|
$begin_token = $index;
|
|
$near_begin = 0;
|
|
}
|
|
$inside_dquotes = 1;
|
|
$dq_count++;
|
|
}
|
|
}
|
|
return @tokens;
|
|
}
|
|
|
|
#
|
|
# end of private functions.
|
|
#
|
|
|
|
sub new
|
|
{
|
|
my ($def) = @_;
|
|
my $self = {};
|
|
bless $self;
|
|
|
|
$def =~ s/^\(//;
|
|
$def =~ s/\)$//;
|
|
|
|
$$self{mark} = 0;
|
|
$$self{flags} = 0;
|
|
$$self{c_prefix} = "";
|
|
|
|
$$self{elem_names} = [];
|
|
$$self{elem_values} = [];
|
|
|
|
# snarf down the fields
|
|
|
|
if($def =~ s/^define-(enum|flags)-extended (\S+)//)
|
|
{
|
|
$$self{type} = $2;
|
|
$$self{flags} = 1 if($1 eq "flags");
|
|
}
|
|
|
|
$$self{module} = $1 if($def =~ s/\(in-module "(\S+)"\)//);
|
|
$$self{c_type} = $1 if($def =~ s/\(c-name "(\S+)"\)//);
|
|
|
|
# values are compound lisp statement
|
|
if($def =~ s/\(values((?: '\("\S+" "\S+" "[^"]+"\))*) \)//)
|
|
{
|
|
$self->parse_values($1);
|
|
}
|
|
|
|
if($def !~ /^\s*$/)
|
|
{
|
|
GtkDefs::error("Unhandled enum def ($def) in $$self{module}\::$$self{type}\n")
|
|
}
|
|
|
|
# this should never happen
|
|
warn if(scalar(@{$$self{elem_names}}) != scalar(@{$$self{elem_values}}));
|
|
|
|
return $self;
|
|
}
|
|
|
|
sub parse_values($$)
|
|
{
|
|
my ($self, $value) = @_;
|
|
|
|
my $elem_names = [];
|
|
my $elem_values = [];
|
|
my $common_prefix = undef;
|
|
# break up the value statements - it works with parens inside double quotes
|
|
# and handles triples like '("dq-token", "MY_SCANNER_DQ_TOKEN", "'"'").
|
|
foreach (split_enum_tokens($value))
|
|
{
|
|
if (/^"\S+" "(\S+)" "(.+)"$/)
|
|
{
|
|
my ($name, $value) = ($1, $2);
|
|
|
|
# detect whether there is module prefix common to all names, e.g. GTK_
|
|
my $prefix = $1 if ($name =~ /^([^_]+_)/);
|
|
|
|
if (not defined($common_prefix))
|
|
{
|
|
$common_prefix = $prefix;
|
|
}
|
|
elsif ($prefix ne $common_prefix)
|
|
{
|
|
$common_prefix = "";
|
|
}
|
|
|
|
push(@$elem_names, $name);
|
|
push(@$elem_values, $value);
|
|
}
|
|
else
|
|
{
|
|
GtkDefs::error("Unknown value statement ($_) in $$self{c_type}\n");
|
|
}
|
|
}
|
|
|
|
if ($common_prefix)
|
|
{
|
|
# cut off the module prefix, e.g. GTK_
|
|
s/^$common_prefix// foreach (@$elem_names);
|
|
|
|
# Save the common prefix.
|
|
$$self{c_prefix} = $common_prefix;
|
|
}
|
|
|
|
$$self{elem_names} = $elem_names;
|
|
$$self{elem_values} = $elem_values;
|
|
}
|
|
|
|
sub beautify_values($)
|
|
{
|
|
my ($self) = @_;
|
|
|
|
return if($$self{flags});
|
|
|
|
my $elem_names = $$self{elem_names};
|
|
my $elem_values = $$self{elem_values};
|
|
|
|
my $num_elements = scalar(@$elem_values);
|
|
return if($num_elements == 0);
|
|
|
|
my $first = $$elem_values[0];
|
|
return if($first !~ /^-?[0-9]+$/);
|
|
|
|
my $prev = $first;
|
|
|
|
# Continuous? (Aliases to prior enum values are allowed.)
|
|
foreach my $value (@$elem_values)
|
|
{
|
|
return if ($value =~ /[G-WY-Zg-wy-z_]/);
|
|
return if(($value < $first) || ($value > $prev + 1));
|
|
$prev = $value;
|
|
}
|
|
|
|
# This point is reached only if the values are a continuous range.
|
|
# 1) Let's kill all the superfluous values, for better readability.
|
|
# 2) Substitute aliases to prior enum values.
|
|
|
|
my %aliases = ();
|
|
|
|
for(my $i = 0; $i < $num_elements; ++$i)
|
|
{
|
|
my $value = \$$elem_values[$i];
|
|
my $alias = \$aliases{$$value};
|
|
|
|
if(defined($$alias))
|
|
{
|
|
$$value = $$alias;
|
|
}
|
|
else
|
|
{
|
|
$$alias = $$elem_names[$i];
|
|
$$value = "" unless($first != 0 && $$value == $first);
|
|
}
|
|
}
|
|
}
|
|
|
|
sub build_element_list($$$$)
|
|
{
|
|
my ($self, $ref_subst_in, $ref_subst_out, $indent) = @_;
|
|
|
|
my $elem_names = $$self{elem_names};
|
|
my $elem_values = $$self{elem_values};
|
|
|
|
my $num_elements = scalar(@$elem_names);
|
|
my $elements = "";
|
|
|
|
for(my $i = 0; $i < $num_elements; ++$i)
|
|
{
|
|
my $name = $$elem_names[$i];
|
|
my $value = $$elem_values[$i];
|
|
|
|
for(my $ii = 0; $ii < scalar(@$ref_subst_in); ++$ii)
|
|
{
|
|
$name =~ s/$$ref_subst_in[$ii]/$$ref_subst_out[$ii]/;
|
|
$value =~ s/$$ref_subst_in[$ii]/$$ref_subst_out[$ii]/;
|
|
}
|
|
|
|
# Skip this element, if its name has been deleted.
|
|
next if($name eq "");
|
|
|
|
$elements .= ",\n" if($elements ne "");
|
|
$elements .= "${indent}${name}";
|
|
$elements .= " = ${value}" if($value ne "");
|
|
}
|
|
|
|
return $elements;
|
|
}
|
|
|
|
sub dump($)
|
|
{
|
|
my ($self) = @_;
|
|
|
|
print "<enum module=\"$$self{module}\" type=\"$$self{type}\" flags=$$self{flags}>\n";
|
|
|
|
my $elem_names = $$self{elem_names};
|
|
my $elem_values = $$self{elem_values};
|
|
|
|
for(my $i = 0; $i < scalar(@$elem_names); ++$i)
|
|
{
|
|
print " <element name=\"$$elem_names[$i]\" value=\"$$elem_values[$i]\"/>\n";
|
|
}
|
|
|
|
print "</enum>\n\n";
|
|
}
|
|
|
|
1; # indicate proper module load.
|