[glibmm/gmmproc-refactor] Splitted some stuff in separate classes.
- From: Krzesimir Nowak <krnowak src gnome org>
- To: commits-list gnome org
- Cc:
- Subject: [glibmm/gmmproc-refactor] Splitted some stuff in separate classes.
- Date: Mon, 31 Jan 2011 20:37:04 +0000 (UTC)
commit f25cbca8842a05609acb7a0c848810e56059a164
Author: Krzesimir Nowak <qdlacz gmail com>
Date: Mon Jan 31 21:36:04 2011 +0100
Splitted some stuff in separate classes.
General more clean OO work done.
tools/pm/Base/Entity.pm | 96 +++++++++++
tools/pm/Base/Enum.pm | 95 +++++++++++
tools/pm/Base/Function.pm | 303 ++++++++++++++++++++++++++++++++++
tools/pm/Base/Object.pm | 96 +++++++++++
tools/pm/Base/Property.pm | 132 +++++++++++++++
tools/pm/Defs/Common.pm | 56 +++++++
tools/pm/Defs/Enum.pm | 395 +++++++++++++++++++++++++++++++++++++++++++++
tools/pm/Defs/Function.pm | 202 +++++++++++++++++++++++
tools/pm/Defs/Named.pm | 55 +++++++
tools/pm/Defs/Object.pm | 113 +++++++++++++
tools/pm/Defs/Property.pm | 123 ++++++++++++++
tools/pm/Defs/Signal.pm | 208 ++++++++++++++++++++++++
tools/pm/Output.pm | 6 +-
tools/pm/Util.pm | 15 ++-
tools/pm/WrapParser.pm | 2 +-
15 files changed, 1892 insertions(+), 5 deletions(-)
---
diff --git a/tools/pm/Base/Entity.pm b/tools/pm/Base/Entity.pm
new file mode 100644
index 0000000..8d52dea
--- /dev/null
+++ b/tools/pm/Base/Entity.pm
@@ -0,0 +1,96 @@
+# gmmproc - Base::Entity module
+#
+# Copyright 2011 glibmm development team
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
+#
+
+package Base::Entity;
+
+use strict;
+use warnings;
+
+# class Base::Entity
+# {
+# bool marked;
+# string entity;
+# string c_name
+# }
+
+my $g_m = 'marked';
+my $g_e = 'entity';
+my $g_c_n = 'c_name';
+
+sub new ($)
+{
+ my $type = shift;
+ my $class = (ref ($type) or $type or "Base::Entity");
+ my $self =
+ {
+ $g_m => 0,
+ $g_e => '',
+ $g_c_n => ''
+ };
+
+ bless ($self, $class);
+ return $self;
+}
+
+sub get_entity ($)
+{
+ my $self = shift;
+
+ return $self->{$g_e};
+}
+
+sub set_entity ($$)
+{
+ my $self = shift;
+ my $entity = shift;
+
+ $self->{$g_e} = $entity;
+}
+
+sub is_marked ($)
+{
+ my $self = shift;
+
+ return ($self->{$g_m} ? 1 : 0);
+}
+
+sub set_marked ($$)
+{
+ my $self = shift;
+ my $mark = shift;
+
+ $self->{$g_m} = ($mark ? 1 : 0);
+}
+
+sub get_c_name ($)
+{
+ my $self = shift;
+
+ return $self->{$g_c_n};
+}
+
+sub set_c_name ($$)
+{
+ my $self = shift;
+ my $c_name = shift;
+
+ $self->{$g_c_n} = $c_name;
+}
+
+1; #indicate proper module load.
diff --git a/tools/pm/Base/Enum.pm b/tools/pm/Base/Enum.pm
new file mode 100644
index 0000000..3268de8
--- /dev/null
+++ b/tools/pm/Base/Enum.pm
@@ -0,0 +1,95 @@
+# gmmproc - Base::Enum module
+#
+# Copyright 2011 glibmm development team
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
+#
+
+package Base::Enum;
+
+use strict;
+use warnings;
+use parent qw (Base::Entity);
+
+# class Base::Enum : public Base::Entity
+# {
+# bool flags;
+# string array element_names;o
+# string array element_values;
+# }
+
+my $g_f = 'flags';
+my $g_e_n = 'element_names';
+my $g_e_v = 'element_values';
+
+sub new ($)
+{
+ my $type = shift;
+ my $class = (ref ($type) or $type or "Enum");
+ my $self = $class->SUPER->new ();
+
+ $self->{$g_f} = 0;
+ $self->{$g_e_n} = [];
+ $self->{$g_e_v} = [];
+
+ return bless ($self, $class);
+}
+
+sub is_flags ($)
+{
+ my $self = shift;
+
+ return $self->{$g_f};
+}
+
+sub set_flags ($$)
+{
+ my $self = shift;
+ my $flags = shift;
+
+ $self->{$g_f} = ($flags ? 1 : 0);
+}
+
+sub get_element_names ($)
+{
+ my $self = shift;
+
+ return $self->{$g_e_n};
+}
+
+sub set_element_names ($$)
+{
+ my $self = shift;
+ my $element_names = shift;
+
+ $self->{$g_e_n} = $element_names;
+}
+
+sub get_element_values ($)
+{
+ my $self = shift;
+
+ return $self->{$g_e_v};
+}
+
+sub set_element_values ($$)
+{
+ my $self = shift;
+ my $element_values = shift;
+
+ $self->{$g_e_v} = $element_values;
+}
+
+1; # indicate proper module load.
diff --git a/tools/pm/Base/Function.pm b/tools/pm/Base/Function.pm
new file mode 100644
index 0000000..1671649
--- /dev/null
+++ b/tools/pm/Base/Function.pm
@@ -0,0 +1,303 @@
+# gmmproc - Base::Function module
+#
+# Copyright 2011 glibmm development team
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
+#
+
+package Base::Function;
+
+use strict;
+use warnings;
+use parent qw (Base::Entity);
+use Util;
+
+##################################################
+### Function
+# Contains data and methods used by both Function (C++ declarations) and GtkDefs::Function (C defs descriptions)
+# Note that GtkDefs::Signal inherits from GtkDefs::Function so it get these methods too.
+#
+# class Base::Function : public Base::Entity
+# {
+# string array param_types;
+# string array param_names;
+# string ret_type;
+# string c_name;
+# }
+
+my $g_p_t = 'param_types';
+my $g_p_n = 'param_names';
+my $g_r_t = 'ret_type';
+my $g_c_n = 'c_name';
+
+sub new ($)
+{
+ my $type = shift;
+ my $class = (ref ($type) or $type or "Base::Function");
+ my $self = $class->SUPER->new ();
+
+ $self->{$g_p_t} = [];
+ $self->{$g_p_n} = [];
+ $self->{$g_r_t} = '';
+ $self->{$g_c_n} = '';
+
+ bless ($self, $class);
+ return $self;
+}
+
+sub get_param_types ($)
+{
+ my $self = shift;
+
+ return $self->{$g_p_t};
+}
+
+sub set_param_types ($$)
+{
+ my $self = shift;
+ my $param_types = shift;
+
+ $self->{$g_p_t} = shift;
+}
+
+sub get_param_names ($)
+{
+ my $self = shift;
+
+ return $self->{$g_p_n};
+}
+
+sub set_param_names ($$)
+{
+ my $self = shift;
+ my $param_names = shift;
+
+ $self->{$g_p_n} = shift;
+}
+
+sub get_param_count ($)
+{
+ my $self = shift;
+
+ return scalar (@{$self->{$g_p_t}});
+}
+
+sub get_ret_type ($)
+{
+ my $self = shift;
+
+ return $self->{$g_r_t};
+}
+
+sub set_ret_type ($$)
+{
+ my $self = shift;
+ my $ret_type = shift;
+
+ $self->{$g_r_t} = $ret_type;
+}
+
+sub get_c_name ($)
+{
+ my $self = shift;
+
+ return $self->{$g_c_n};
+}
+
+sub set_c_name ($$)
+{
+ my $self = shift;
+ my $c_name = shift;
+
+ $self->{$g_c_n} = $c_name;
+}
+
+# TODO: should be moved elsewhere.
+# $string args_types_only($)
+# comma-delimited argument types.
+sub args_types_only($)
+{
+ my $self = shift;
+
+ return join(", ", @{$self->{$g_p_t}});
+}
+
+# TODO: should be moved elsewhere.
+# $string args_names_only($)
+sub args_names_only($)
+{
+ my $self = shift;
+
+ return join(", ", @{$self->{$g_p_n}});
+}
+
+# TODO: should be moved elsewhere.
+# $string args_types_and_names($)
+sub args_types_and_names($)
+{
+ my $self = shift;
+ my $param_types = $self->{$g_p_t};
+ my $param_names = $self->{$g_p_n};
+ my @out;
+
+ for (my $i = 0; $i < @{$param_types}; ++$i)
+ {
+ my $str = sprintf("%s %s", $$param_types[$i], $$param_names[$i]);
+ push(@out, $str);
+ }
+
+ my $result = join(", ", @out);
+ return $result;
+}
+
+# TODO: this is used nowhere.
+# $string args_names_only_without_object($)
+#sub args_names_only_without_object2($)
+#{
+# my $self = shift;
+
+# my $param_names = $$self{param_names};
+
+# my $result = "";
+# my $bInclude = 0; #Ignore the first (object) arg.
+# foreach (@{$param_names})
+# {
+# # Add comma if there was an arg before this one:
+# if( $result ne "")
+# {
+# $result .= ", ";
+# }
+
+# # Append this arg if it's not the first one:
+# if($bInclude)
+# {
+# $result .= $_;
+# }
+
+# $bInclude = 1;
+# }
+
+# return $result;
+#}
+
+#TODO: should be moved elsewhere.
+# $string args_types_and_names_without_object($)
+sub args_types_and_names_without_object($)
+{
+ my $self = shift;
+
+ my $param_names = $$self{param_names};
+ my $param_types = $$self{param_types};
+ my $i = 0;
+ my @out;
+
+ for ($i = 1; $i < $#$param_types + 1; $i++) #Ignore the first arg.
+ {
+ my $str = sprintf("%s %s", $$param_types[$i], $$param_names[$i]);
+ push(@out, $str);
+ }
+
+ return join(", ", @out);
+}
+# TODO: this is used nowhere.
+# $string args_names_only_without_object($)
+#sub args_names_only_without_object($)
+#{
+# my $self = shift;
+
+# my $param_names = $$self{param_names};
+
+# my $result = "";
+# my $bInclude = 0; #Ignore the first (object) arg.
+# foreach (@{$param_names})
+# {
+# # Add comma if there was an arg before this one:
+# if( $result ne "")
+# {
+# $result .= ", ";
+# }
+
+# # Append this arg if it's not the first one:
+# if($bInclude)
+# {
+# $result .= $_;
+# }
+
+# $bInclude = 1;
+# }
+
+# return $result;
+#}
+
+# TODO: should be moved elsewhere.
+sub dump($)
+{
+ my $self = shift;
+
+ my $param_types = $$self{param_types};
+ my $param_names = $$self{param_names};
+
+ print "<function>\n";
+ foreach (keys %$self)
+ {
+ print " <$_ value=\"$$self{$_}\"/>\n" if (!ref $$self{$_} && $$self{$_} ne "");
+ }
+
+ if (scalar(@$param_types)>0)
+ {
+ print " <parameters>\n";
+
+ for (my $i = 0; $i < scalar(@$param_types); $i++)
+ {
+ print " \"$$param_types[$i]\" \"$$param_names[$i]\" \n";
+ }
+
+ print " </parameters>\n";
+ }
+
+ print "</function>\n\n";
+}
+
+# TODO: should be moved elsewhere.
+sub args_types_and_names_with_default_values($)
+{
+ my $self = shift;
+
+ my $i;
+
+ my $param_names = $$self{param_names};
+ my $param_types = $$self{param_types};
+ my $param_default_values = $$self{param_default_values};
+ my @out;
+
+ for ($i = 0; $i < $#$param_types + 1; $i++)
+ {
+ my $str = sprintf("%s %s", $$param_types[$i], $$param_names[$i]);
+
+ if(defined($$param_default_values[$i]))
+ {
+ if($$param_default_values[$i] ne "")
+ {
+ $str .= " = " . $$param_default_values[$i];
+ }
+ }
+
+ push(@out, $str);
+ }
+
+ return join(", ", @out);
+}
+
+1; # indicate proper module load.
diff --git a/tools/pm/Base/Object.pm b/tools/pm/Base/Object.pm
new file mode 100644
index 0000000..661b241
--- /dev/null
+++ b/tools/pm/Base/Object.pm
@@ -0,0 +1,96 @@
+# gmmproc - Base::Object module
+#
+# Copyright 2011 glibmm development team
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
+#
+
+package Base::Object;
+
+use strict;
+use warnings;
+use parent qw (Base::Entity);
+
+# class Base::Object : public Base::Entity
+# {
+# string parent;
+# string gtype_id;
+# string array implemented_interfaces
+# }
+
+my $g_p = 'parent';
+my $g_g_i = 'gtype_id';
+my $g_i_i = 'implemented_interfaces';
+
+sub new ($)
+{
+ my $type = shift;
+ my $class = (ref ($type) or $type or "Base::Object");
+ my $self = $class->SUPER->new ();
+
+ $self->{$g_p} = '';
+ $self->{$g_g_i} = '';
+ $self->{$g_i_i} = [];
+
+ bless ($self, $class);
+ return $self;
+}
+
+sub get_parent ($)
+{
+ my $self = shift;
+
+ return $self->{$g_p};
+}
+
+sub set_parent ($$)
+{
+ my $self = shift;
+ my $parent = shift;
+
+ $self->{$g_p} = $parent;
+}
+
+sub get_gtype_id ($)
+{
+ my $self = shift;
+
+ return $self->{$g_g_i};
+}
+
+sub set_gtype_id ($$)
+{
+ my $self = shift;
+ my $gtype_id = shift;
+
+ $self->{$g_g_i} = $gtype_id;
+}
+
+sub get_implemented_interfaces ($)
+{
+ my $self = shift;
+
+ return $self->{$g_i_i};
+}
+
+sub set_implemented_interfaces ($$)
+{
+ my $self = shift;
+ my $gtype_id = shift;
+
+ $self->{$g_g_i} = $gtype_id;
+}
+
+1; # indicate proper module load.
diff --git a/tools/pm/Base/Property.pm b/tools/pm/Base/Property.pm
new file mode 100644
index 0000000..bab6032
--- /dev/null
+++ b/tools/pm/Base/Property.pm
@@ -0,0 +1,132 @@
+# gmmproc - Base::Property module
+#
+# Copyright 2011 glibmm development team
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
+#
+
+package Base::Property;
+
+use strict;
+use warnings;
+use parent qw (Base::Entity);
+
+# class Base::Property : public Base::Entity
+# {
+# string class;
+# string type;
+# bool readable;
+# bool writable;
+# bool construct_only;
+# }
+
+my $g_t = 'type';
+my $g_c = 'class';
+my $g_r = 'readable';
+my $g_w = 'writable';
+my $g_c_o = 'construct_only';
+
+sub new ($)
+{
+ my $type = shift;
+ my $class = (ref ($type) or $type or "Base::Property");
+ my $self = $class->SUPER->new ();
+
+ $self->{$g_t} = '';
+ $self->{$g_c} = '';
+ $self->{$g_r} = 0;
+ $self->{$g_w} = 0;
+ $self->{$g_c_o} = 0;
+
+ bless ($self, $class);
+ return $self;
+}
+
+sub get_type ($)
+{
+ my $self = shift;
+
+ return $self->{$g_t};
+}
+
+sub set_type ($$)
+{
+ my $self = shift;
+ my $type = shift;
+
+ $self->{$g_t} = $type;
+}
+
+sub get_class ($)
+{
+ my $self = shift;
+
+ return $self->{$g_c};
+}
+
+sub set_class ($$)
+{
+ my $self = shift;
+ my $class = shift;
+
+ $self->{$g_c} = ($class ? 1 : 0);
+}
+
+sub get_readable ($)
+{
+ my $self = shift;
+
+ return $self->{$g_r};
+}
+
+sub set_readable ($$)
+{
+ my $self = shift;
+ my $readable = shift;
+
+ $self->{$g_r} = ($readable ? 1 : 0);
+}
+
+sub get_writable ($)
+{
+ my $self = shift;
+
+ return $self->{$g_w};
+}
+
+sub set_writable ($$)
+{
+ my $self = shift;
+ my $writable = shift;
+
+ $self->{$g_w} = ($writable ? 1 : 0);
+}
+
+sub get_construct_only ($)
+{
+ my $self = shift;
+
+ return $self->{$g_c_o};
+}
+
+sub set_construct_only ($$)
+{
+ my $self = shift;
+ my $construct_only = shift;
+
+ $self->{$g_c_o} = ($construct_only ? 1 : 0);
+}
+
+1; # indicate proper module load.
diff --git a/tools/pm/Defs/Common.pm b/tools/pm/Defs/Common.pm
new file mode 100644
index 0000000..ee22499
--- /dev/null
+++ b/tools/pm/Defs/Common.pm
@@ -0,0 +1,56 @@
+# gmmproc - Defs::Common module
+#
+# Copyright 2011 glibmm development team
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
+#
+
+package Defs::Common;
+
+our $gc_p_t = 'common_param_types';
+our $gc_p_n = 'common_param_names';
+
+sub parse_params ($)
+{
+ my $params = shift;
+ my $param_types = [];
+ my $param_names = [];
+ my $params_hr =
+ {
+ $gc_p_t = $param_types,
+ $gc_p_n = $param_names
+ };
+
+ # break up the parameter statements
+ for my $part (split (/\s*'*[()]\s*/, $param))
+ {
+ next unless ($part);
+ if (/^"(\S+)" "(\S+)"$/)
+ {
+ my ($p1, $p2) = ($1, $2);
+ $p1 =~ s/-/ /;
+ push (@{${param_types}}, $p1);
+ push (@{${param_names}}, $p2);
+ }
+ else
+ {
+ return {};
+ #GtkDefs::error("Unknown parameter statement ($_) in $$self{c_name}\n");
+ }
+ }
+ return $params_h_r;
+}
+
+1; # indicate proper module load.
diff --git a/tools/pm/Defs/Enum.pm b/tools/pm/Defs/Enum.pm
new file mode 100644
index 0000000..9c67cb2
--- /dev/null
+++ b/tools/pm/Defs/Enum.pm
@@ -0,0 +1,395 @@
+# gmmproc - Defs::Enum module
+#
+# Copyright 2011 glibmm development team
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
+#
+
+package Defs::Enum;
+
+use strict;
+use warnings;
+use parent qw (Base::Enum Defs::Named);
+
+# class Defs::Enum : public Base::Enum, public Defs::Named
+# {
+# string module;
+# }
+
+#
+# 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;
+}
+
+my $gi_e_n = 'internal_element_names';
+my $gi_e_v = 'internal_element_values';
+
+sub parse_values($)
+{
+ my $value = shift;
+ my $element_names = [];
+ my $element_values = [];
+ my $elements_h_r =
+ {
+ $gi_e_n => $element_names,
+ $gi_e_v => $element_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", "'"'").
+ for my $line (split_enum_tokens ($value))
+ {
+ if ($line =~ /^"\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(@{$element_names}, $name);
+ push(@{$element_values}, $value);
+ }
+ else
+ {
+ return {};
+ #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 (@{$element_names});
+ }
+
+ return $elements_h_r;
+}
+
+#
+# end of private functions.
+#
+
+my $g_m = 'module';
+
+sub new ($)
+{
+ my $type = shift;
+ my $class = (ref ($type) or $type or "Defs::Enum");
+ my $self = $class->SUPER->new ();
+
+ $self->{$g_m} = '';
+
+ return bless ($self, $class);
+}
+
+sub parse ($$)
+{
+ my $self = shift;
+ my $def = shift;
+ my $flags = 0;
+ my $c_name = '';
+ my $name = '';
+ my $element_names = [];
+ my $element_values = [];
+ my $module = '';
+
+ $def =~ s/^\(//;
+ $def =~ s/\)$//;
+
+ # snarf down the fields
+ if($def =~ s/^define-(enum|flags)-extended (\S+)//)
+ {
+ $name = $2;
+ $flags = 1 if ($1 eq 'flags');
+ }
+
+ $module = $1 if ($def =~ s/\(in-module "(\S+)"\)//);
+ $c_name = $1 if ($def =~ s/\(c-name "(\S+)"\)//);
+
+ # values are compound lisp statement
+ if($def =~ s/\(values((?: '\("\S+" "\S+" "[^"]+"\))*) \)//)
+ {
+ my $elements_h_r = parse_values ($1);
+
+ unless (keys (%{$elements_h_r}))
+ {
+ return 0;
+ }
+ $element_names = $elements_h_r->{$gi_e_n};
+ $element_values = $elements_h_r->{$gi_e_v};
+ }
+
+ if($def !~ /^\s*$/)
+ {
+ return 0;
+ #GtkDefs::error("Unhandled enum def ($def) in $$self{module}\::$$self{type}\n")
+ }
+
+ # this should never happen
+ if (scalar (@{$element_names}) != scalar (@{$element_values}))
+ {
+ return 0;
+ }
+
+ $self->set_flags ($flags);
+ $self->set_c_name ($c_name);
+ $self->set_name ($name);
+ $self->set_element_names ($element_names);
+ $self->set_element_values ($element_values);
+ $self->set_module ($module);
+
+ return 1;
+}
+
+sub get_module ($)
+{
+ my $self = shift;
+
+ return $self->{$g_m};
+}
+
+sub set_module ($$)
+{
+ my $self = shift;
+ my $module = shift;
+
+ $self->${g_m} = $module;
+}
+
+# TODO: should be moved elsewhere.
+sub beautify_values($)
+{
+ my $self = shift;
+
+ 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);
+ }
+ }
+}
+
+# TODO: should be moved elsewhere.
+sub build_element_list($$$$)
+{
+ my ($self, $ref_flags, $ref_no_gtype, $indent) = @_;
+
+ my @subst_in = [];
+ my @subst_out = [];
+
+ # Build a list of custom substitutions, and recognize some flags too.
+
+ foreach(@$ref_flags)
+ {
+ if(/^\s*(NO_GTYPE)\s*$/)
+ {
+ $$ref_no_gtype = $1;
+ }
+ elsif(/^\s*(get_type_func=)(\s*)\s*$/)
+ {
+ my $part1 = $1;
+ my $part2 = $2;
+ }
+ elsif(/^\s*s#([^#]+)#([^#]*)#\s*$/)
+ {
+ push(@subst_in, $1);
+ push(@subst_out, $2);
+ }
+ elsif($_ !~ /^\s*$/)
+ {
+ return undef;
+ }
+ }
+
+ 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(@subst_in); ++$ii)
+ {
+ $name =~ s/${subst_in[$ii]}/${subst_out[$ii]}/;
+ $value =~ s/${subst_in[$ii]}/${subst_out[$ii]}/;
+ }
+
+ $elements .= "${indent}${name}";
+ $elements .= " = ${value}" if($value ne "");
+ $elements .= ",\n" if($i < $num_elements - 1);
+ }
+
+ return $elements;
+}
+
+#TODO: should be moved elsewhere.
+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.
diff --git a/tools/pm/Defs/Function.pm b/tools/pm/Defs/Function.pm
new file mode 100644
index 0000000..c2a2f8a
--- /dev/null
+++ b/tools/pm/Defs/Function.pm
@@ -0,0 +1,202 @@
+# gmmproc - Defs::Function module
+#
+# Copyright 2011 glibmm development team
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
+#
+
+package Defs::Function;
+
+use strict;
+use warnings;
+use parent qw (Base::Function Defs::Named);
+use Defs::Common;
+
+# class Function : FunctionBase
+#
+# {
+# string name; e.g. gtk_accelerator_valid
+# string c_name;
+# string class e.g. GtkButton
+#
+# string rettype;
+# string array param_types;
+# string array param_names;
+#
+# string entity_type. e.g. method or signal
+#
+# bool varargs;
+# bool mark;
+#
+# }
+
+my $g_c = 'class';
+my $g_n = 'name';
+my $g_v = 'varargs';
+
+sub new ($)
+{
+ my $type = shift;
+ my $class = (ref ($type) or $type or "Defs::Function");
+ my $self = $class->SUPER->new ();
+
+ $self->{$g_c} = '';
+ $self->{$g_n} = '';
+ $self->{$g_v} = 0;
+
+ bless ($self, $class);
+ return $self;
+}
+
+sub parse ($$)
+{
+ my $self = shift;
+ my $def = shift;
+ my $whole = $def;
+ my $entity = '';
+ my $name = '';
+ my $c_name = '';
+ my $class = '';
+ my $ret_type = 'void';
+ my $varargs = 0;
+ my $param_types = [];
+ my $param_names = [];
+
+ $def =~ s/^\(//;
+ $def =~ s/\)$//;
+ $def =~ s/^\s*define-(\S+)\s+(\S+)\s*//;
+ $entity = $1;
+ $name = $2;
+ $name =~ s/-/_/g;
+ # snarf down lisp fields
+ if ($def =~ s/\(c-name "(\S+)"\)//)
+ {
+ $c_name = $1;
+ }
+ if ($def=~s/\(of-object "(\S+)"\)//)
+ {
+ $class = $1;
+ }
+ if ($def =~ s/\(return-type "(\S+)"\)//)
+ {
+ $ret_type = $1;
+ $ret_type =~ s/-/ /g;
+ if ($ret_type eq 'none' or $ret_type eq 'None')
+ {
+ $ret_type = 'void';
+ }
+ }
+
+ if ($def =~ s/\(varargs\s+#t\)//)
+ {
+ $varargs = 1;
+ }
+
+ # methods have a parameter not stated in the defs file
+ if ($entity eq 'method')
+ {
+ push (@{$param_types}, $class . '*');
+ push (@{$param_names}, 'self');
+ }
+
+ # parameters are compound lisp statement
+ if ($def =~ s/\(parameters(( '\("\S+" "\S+"\))*) \)//)
+ {
+ my $params_h_r = Defs::Common::parse_params ($1);
+
+ unless (keys (%{$params_h_r}))
+ {
+ return 0;
+ }
+ push (@{$param_types}, @{$params_h_r->{$Defs::Common::gc_p_t}});
+ push (@{$param_names}, @{$params_h_r->{$Defs::Common::gc_p_n}});
+ }
+
+ # is-constructor-of:
+ if ($def =~ s/\(is-constructor-of "(\S+)"\)//)
+ {
+ #Ignore them.
+ }
+
+ # of-object
+ if ($def =~ s/\(of-object "(\S+)"\)//)
+ {
+ #Ignore them.
+ }
+
+ if ($def !~ /^\s*$/)
+ {
+ #GtkDefs::error("Unhandled function parameter ($def) in $$self{c_name}\n");
+ return 0;
+ }
+
+ $self->set_entity ($entity);
+ $self->set_name ($name);
+ $self->set_c_name ($c_name);
+ $self->set_class ($class);
+ $self->set_ret_type ($ret_type);
+ $self->set_varargs ($varargs);
+ $self->set_param_types ($param_types);
+ $self->set_param_names ($param_names);
+
+ return 1;
+}
+
+sub get_class ($)
+{
+ my $self = shift;
+
+ return $self->{$g_c};
+}
+
+sub set_class ($$)
+{
+ my $self = shift;
+ my $class = shift;
+
+ $self->{$g_c} = $class;
+}
+
+sub has_varargs ($)
+{
+ my $self = shift;
+
+ return $self->{$g_v};
+}
+
+sub set_varargs ($$)
+{
+ my $self = shift;
+ my $varargs = shift;
+
+ $self->{$g_v} = $varargs;
+}
+
+# $string get_return_type_for_methods().
+# Changes gchar* (not const-gchar*) to return-gchar* so that _CONVERT knows that it needs to be freed.
+sub get_return_type_for_methods ($)
+{
+ my $self = shift;
+ my $ret_type = $self->get_ret_type ();
+
+ if($ret_type eq "gchar*" or $ret_type eq "char*")
+ {
+ $ret_type = "return-" . $ret_type;
+ }
+
+ return $ret_type;
+}
+
+1; # indicate proper module load.
diff --git a/tools/pm/Defs/Named.pm b/tools/pm/Defs/Named.pm
new file mode 100644
index 0000000..d058db2
--- /dev/null
+++ b/tools/pm/Defs/Named.pm
@@ -0,0 +1,55 @@
+# gmmproc - Defs::Named module
+#
+# Copyright 2011 glibmm development team
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
+#
+
+package Defs::Named;
+
+use strict;
+use warnings;
+
+my $g_n = 'name';
+
+sub new ($)
+{
+ my $type = shift;
+ my $class = (ref ($type) or $type or 'Defs::Named');
+ my $self =
+ {
+ $g_n = ''
+ };
+
+ bless ($self, $class);
+ return $self;
+}
+
+sub get_name ($)
+{
+ my $self = shift;
+
+ return $self->{$g_n};
+}
+
+sub set_name ($$)
+{
+ my $self = shift;
+ my $name = shift;
+
+ $self->{$g_n} = $name;
+}
+
+1; # indicate proper module load.
diff --git a/tools/pm/Defs/Object.pm b/tools/pm/Defs/Object.pm
new file mode 100644
index 0000000..70a0aaa
--- /dev/null
+++ b/tools/pm/Defs/Object.pm
@@ -0,0 +1,113 @@
+# gmmproc - Defs::Object module
+#
+# Copyright 2011 glibmm development team
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
+#
+
+package Defs::Object;
+
+use strict;
+use warnings;
+use parent qw (Base::Object Defs::Named);
+
+# class Defs::Object : public Base::Object
+# {
+# string name;
+# string module;
+# }
+
+my $g_n = 'name';
+my $g_m = 'module';
+
+sub new ($)
+{
+ my $type = shift;
+ my $class = (ref ($type) or $type or 'Defs::Object');
+ my $self = $class->SUPER->new ();
+
+ $self->{$g_n} = '';
+ $self->{$g_m} = '';
+
+ bless ($self, $class);
+ return $self;
+}
+
+sub parse ($$)
+{
+ my $self = shift;
+ my $def = shift;
+ my $name = '';
+ my $module = '';
+ my $parent = '';
+ my $c_name = '';
+ my $gtype_id = '';
+
+ $def =~ s/^\(//;
+ $def =~ s/\)$//;
+
+ # snarf down the fields
+ $name = $1 if ($def =~ s/^define-object (\S+)//);
+ $module = $1 if ($def =~ s/\(in-module "(\S+)"\)//);
+ $parent = $1 if($def =~ s/\(parent "(\S+)"\)//);
+ $c_name = $1 if($def =~ s/\(c-name "(\S+)"\)//);
+ $gtype_id = $1 if($def =~ s/\(gtype-id "(\S+)"\)//);
+ #TODO: get a list of implemenented interfaces.
+
+ if ($def !~ /^\s*$/)
+ {
+ return 0;
+ #GtkDefs::error("Unhandled object def ($def) in $$self{module}\::$$self{name}\n")
+ }
+
+ $self->set_name ($name);
+ $self->set_module ($module);
+ $self->set_parent ($parent);
+ $self->set_c_name ($c_name);
+ $self->set_gtype_id ($gtype_id);
+
+ return 1;
+}
+
+sub get_module ($)
+{
+ my $self = shift;
+
+ return $self->{$g_m};
+}
+
+sub set_module ($$)
+{
+ my $self = shift;
+ my $module = shift;
+
+ $self->{$g_m} = $module;
+}
+
+#TODO: should be moved elsewhere.
+sub dump($)
+{
+ my ($self) = @_;
+
+ print "<object>\n";
+
+ foreach(keys %$self)
+ { print " <$_ value=\"$$self{$_}\"/>\n"; }
+
+ print "</object>\n\n";
+}
+
+
+1; # indicate proper module load.
diff --git a/tools/pm/Defs/Property.pm b/tools/pm/Defs/Property.pm
new file mode 100644
index 0000000..45654b5
--- /dev/null
+++ b/tools/pm/Defs/Property.pm
@@ -0,0 +1,123 @@
+# gmmproc - Defs::Property module
+#
+# Copyright 2011 glibmm development team
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
+#
+
+package Defs::Property;
+
+use strict;
+use warnings;
+use parent qw (Base::Property Defs::Named);
+
+# class Defs::Property : public Base::Property
+# {
+# string name;
+# string docs;
+# }
+
+my $g_n = 'name';
+my $g_d = 'docs';
+
+sub new ($)
+{
+ my $type = shift;
+ my $class = (ref ($type) or $type or 'Defs::Property');
+ my $self = $class->SUPER->new ();
+
+ $self->{$g_n} = '';
+ $self->{$g_d} = '';
+
+ bless ($self, $class);
+ return $self;
+}
+
+sub parse ($$)
+{
+ my $self = shift;
+ my $def = shift;
+ my $name = '';
+ my $class = '';
+ my $type = '';
+ my $readable = 0;
+ my $writable = 0;
+ my $construct_only = 0;
+ my $docs = '';
+
+ $def =~ s/^\(//;
+ $def =~ s/\)$//;
+ # snarf down the fields
+ $name = $1 if ($def =~ s/^define-property (\S+)//);
+ $name =~ s/-/_/g;
+ $class = $1 if ($def =~ s/\(of-object "(\S+)"\)//);
+ $type = $1 if ($def =~ s/\(prop-type "(\S+)"\)//);
+ $readable = ($1 eq "#t") if ($def =~ s/\(readable (\S+)\)//);
+ $writable = ($1 eq "#t") if ($def =~ s/\(writable (\S+)\)//);
+ $construct_only = ($1 eq "#t") if ($def =~ s/\(construct-only (\S+)\)//);
+ $docs = $1 if ($def =~ s/\(docs "([^"]*)"\)//);
+ # Add a full-stop if there is not one already:
+ if (defined ($docs) and $docs =~ /\.$/)
+ {
+ $docs = $docs . ".";
+ }
+
+ if ($def !~ /^\s*$/)
+ {
+ return 0;
+ #GtkDefs::error("Unhandled property def ($def) in $$self{class}\::$$self{name}\n");
+ }
+
+ $self->set_name ($name);
+ $self->set_class ($class);
+ $self->set_type ($type);
+ $self->set_readable ($readable);
+ $self->set_writable ($writable);
+ $self->set_construct_only ($construct_only);
+ $self->set_docs ($docs);
+ $self->set_entity ('property');
+
+ return 1;
+}
+
+sub get_docs ($)
+{
+ my $self = shift;
+
+ return $self->{$g_d};
+}
+
+sub set_docs ($$)
+{
+ my $self = shift;
+ my $docs = shift;
+
+ $self->{$g_d} = $docs;
+}
+
+#TODO: should be moved elsewhere.
+sub dump($)
+{
+ my ($self) = @_;
+
+ print "<property>\n";
+
+ foreach (keys %$self)
+ { print " <$_ value=\"$$self{$_}\"/>\n"; }
+
+ print "</property>\n\n";
+}
+
+1; # indicate proper module load.
diff --git a/tools/pm/Defs/Signal.pm b/tools/pm/Defs/Signal.pm
new file mode 100644
index 0000000..7f8fbab
--- /dev/null
+++ b/tools/pm/Defs/Signal.pm
@@ -0,0 +1,208 @@
+# gmmproc - Defs::Signal module
+#
+# Copyright 2011 glibmm development team
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
+#
+
+package Defs::Signal;
+
+use strict;
+use warnings;
+use parent qw (Defs::Function);
+use Defs::Common;
+
+# class Defs::Signal : Defs::Function
+# {
+# string name; e.g. gtk_accelerator_valid
+# string class e.g. GtkButton ( == of-object.)
+#
+# string rettype;
+#
+# string when. e.g. first, last, or both.
+# string entity_type. e.g. method or signal
+# }
+
+my $g_w = 'when';
+
+sub new ($)
+{
+ my $type = shift;
+ my $class = (ref ($type) or $type or 'Defs::Signal');
+ my $self = $class->SUPER->new ();
+
+ $self->{$g_w} = '';
+
+ bless ($self, $class);
+ return $self;
+}
+
+sub parse ($$)
+{
+ my $self = shift;
+ my $def = shift;
+ my $whole = $def;
+ my $entity = '';
+ my $name = '';
+ my $ret_type = 'void';
+ my $param_types = [];
+ my $param_names = [];
+ my $when = '';
+ my $class = '';
+
+ #Remove first and last braces:
+ $def =~ s/^\(//;
+ $def =~ s/\)$//;
+ $def =~ s/^\s*define-(\S+)\s+(\S+)\s*//;
+ $entity = $1;
+ $name = $2;
+ $name =~ s/-/_/g; #change - to _
+
+ # snarf down lisp fields
+ if ($def =~ s/\(of-object "(\S+)"\)//)
+ {
+ $class = $1;
+ }
+ else
+ {
+ return 0;
+ #GtkDefs::error("define-signal/define-vfunc without of-object (entity type: $$self{entity_type}): $whole");
+ }
+
+ if ($def =~ s/\(return-type "(\S+)"\)//)
+ {
+ $ret_type = $1;
+ $ret_type =~ s/-/ /g; #e.g. replace const-gchar* with const gchar*. Otherwise it will be used in code.
+ if ($ret_type eq 'none' or $ret_type eq 'None')
+ {
+ $ret_type = 'void';
+ }
+ }
+
+ if ($def =~ s/\(when "(\S+)"\)//)
+ {
+ $when = $1;
+ }
+
+ # signals always have a parameter
+ push (@{$param_types}, $class . '*');
+ push (@{$param_names}, 'self');
+
+ # parameters are compound lisp statement
+ if ($def =~ s/\(parameters(( '\("\S+" "\S+"\))+) \)//)
+ {
+ my $params_h_r = Defs::Common::parse_params ($1);
+
+ unless (keys (%{$params_h_r}))
+ {
+ return 0;
+ }
+ push (@{$param_types}, @{$params_h_r->{$Defs::Common::gc_p_t}});
+ push (@{$param_names}, @{$params_h_r->{$Defs::Common::gc_p_n}});
+ }
+
+ if ($def !~ /^\s*$/)
+ {
+ return 0;
+ #GtkDefs::error("Unhandled signal/vfunc def ($def) in $$self{class}::$$self{name}");
+ }
+
+ $self->set_entity ($entity);
+ $self->set_name ($name);
+ $self->set_class ($class);
+ $self->set_ret_type ($ret_type);
+ $self->set_param_types ($param_types);
+ $self->set_param_names ($param_names);
+ $self->set_when ($when);
+
+ return 1;
+}
+
+sub get_when ($)
+{
+ my $self = shift;
+
+ return $self->{$g_w};
+}
+
+sub set_when ($$)
+{
+ my $self = shift;
+ my $when = shift;
+
+ $self->${g_w} = $when;
+}
+
+# TODO: this is unused.
+# bool has_same_types($objFunction)
+# Compares return types and argument types
+#sub has_same_types($$)
+#{
+# my ($self, $objFuncOther) = @_;
+
+# #Compare return types:
+# if($self->types_are_equal($$self{rettype}, $$objFuncOther{rettype}) ne 1)
+# {
+# # printf("debug: different return types: %s, %s\n", $$self{rettype}, $$objFuncOther{rettype});
+# return 0; #Different types found.
+# }
+
+# #Compare arguement types:
+# my $i = 0;
+# my $param_types = $$self{param_types};
+# my $param_types_other = $$objFuncOther{param_types};
+# for ($i = 1; $i < $#$param_types + 1; $i++)
+# {
+# my $type_a = $$param_types[$i];
+# my $type_b = $$param_types_other[$i-1];
+
+# if($self->types_are_equal($type_a, $type_b) ne 1)
+# {
+# # printf("debug: different arg types: %s, %s\n", $type_a, $type_b);
+# return 0; #Different types found.
+# }
+# }
+
+# return 1; #They must all be the same for it to get this far.
+#}
+
+# TODO: this is used in unused function.
+# bool types_are_equal($a, $b)
+# Compares types, ignoring gint/int differences, etc.
+#sub types_are_equal($$$)
+#{
+# #TODO: Proper method of getting a normalized type name.
+
+# my ($self, $type_a, $type_b) = @_;
+
+# if($type_a ne $type_b)
+# {
+# #Try adding g to one of them:
+# if( ("g" . $type_a) ne $type_b )
+# {
+# #Try adding g to the other one:
+# if( $type_a ne ("g" . $type_b) )
+# {
+# #After all these checks it's still not equal:
+# return 0; #not equal.
+# }
+# }
+# }
+
+# # printf("DEBUG: types are equal: %s, %s\n", $$type_a, $$type_b);
+# return 1; #They must be the same for it to get this far.
+#}
+
+1; # indicate proper module load.
diff --git a/tools/pm/Output.pm b/tools/pm/Output.pm
index 511ea41..389f885 100644
--- a/tools/pm/Output.pm
+++ b/tools/pm/Output.pm
@@ -642,7 +642,7 @@ sub make_g2_from_g1($)
my ($self) = @_;
# Execute m4 to get *.g2 file:
- system("$$self{m4path} $$self{m4args} \"$$self{tmpdir}/gtkmmproc_$$.g1\" > \"$$self{tmpdir}/gtkmmproc_$$.g2\"");
+ system("$$self{m4path} $$self{m4args} \"$$self{tmpdir}/gtkmmproc_$$.g1\" > \"$$self{tmpdir}/gtkmmproc_$$.g2\""); #"
return ($? >> 8);
}
@@ -703,8 +703,8 @@ sub remove_temp_files($)
{
my ($self) = @_;
- system("rm -f \"$$self{tmpdir}/gtkmmproc_$$.g1\"");
- system("rm -f \"$$self{tmpdir}/gtkmmproc_$$.g2\"");
+ system("rm -f \"$$self{tmpdir}/gtkmmproc_$$.g1\"");#"
+ system("rm -f \"$$self{tmpdir}/gtkmmproc_$$.g2\"");#"
}
diff --git a/tools/pm/Util.pm b/tools/pm/Util.pm
index edf48dc..aa74e4e 100644
--- a/tools/pm/Util.pm
+++ b/tools/pm/Util.pm
@@ -41,7 +41,7 @@ sub string_unquote($)
# $ string_trim($string)
# Removes leading and trailing white space.
-sub string_trim($)
+sub string_trim ($)
{
($_) = @_;
s/^\s+//;
@@ -49,6 +49,19 @@ sub string_trim($)
return $_;
}
+# Removes leading and trailing white spaces and replaces all whitespace groups
+# into single spaces.
+sub string_simplify ($)
+{
+ my $str = shift;
+
+ $str =~ s/^\s+//;
+ $str =~ s/\s+$//;
+ $str =~ s/\s+/ /;
+
+ return $str;
+}
+
# $ string_canonical($string)
# Convert - to _.
sub string_canonical($)
diff --git a/tools/pm/WrapParser.pm b/tools/pm/WrapParser.pm
index 34799ee..262b7c2 100644
--- a/tools/pm/WrapParser.pm
+++ b/tools/pm/WrapParser.pm
@@ -1445,4 +1445,4 @@ sub on_wrap_corba_method($)
}
-1; # return package loaded okay.
+1; # indicate proper module load.
[
Date Prev][
Date Next] [
Thread Prev][
Thread Next]
[
Thread Index]
[
Date Index]
[
Author Index]
