diff options
Diffstat (limited to 'tools/pm')
| -rw-r--r-- | tools/pm/.cvsignore | 2 | ||||
| -rw-r--r-- | tools/pm/DocsParser.pm | 422 | ||||
| -rw-r--r-- | tools/pm/Enum.pm | 219 | ||||
| -rw-r--r-- | tools/pm/Function.pm | 343 | ||||
| -rw-r--r-- | tools/pm/FunctionBase.pm | 207 | ||||
| -rw-r--r-- | tools/pm/GtkDefs.pm | 629 | ||||
| -rw-r--r-- | tools/pm/Makefile.am | 10 | ||||
| -rw-r--r-- | tools/pm/Makefile_list_of_sources.am_fragment | 2 | ||||
| -rw-r--r-- | tools/pm/Object.pm | 72 | ||||
| -rw-r--r-- | tools/pm/Output.pm | 781 | ||||
| -rw-r--r-- | tools/pm/Property.pm | 94 | ||||
| -rw-r--r-- | tools/pm/Util.pm | 113 | ||||
| -rw-r--r-- | tools/pm/WrapParser.pm | 1197 |
13 files changed, 4091 insertions, 0 deletions
diff --git a/tools/pm/.cvsignore b/tools/pm/.cvsignore new file mode 100644 index 00000000..3dda7298 --- /dev/null +++ b/tools/pm/.cvsignore @@ -0,0 +1,2 @@ +Makefile.in +Makefile diff --git a/tools/pm/DocsParser.pm b/tools/pm/DocsParser.pm new file mode 100644 index 00000000..3a52f908 --- /dev/null +++ b/tools/pm/DocsParser.pm @@ -0,0 +1,422 @@ +# gtkmm - DocsParser module +# +# Copyright 2001 Free Software Foundation +# +# 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. +# + +# Based on XML::Parser tutorial found at http://www.devshed.com/Server_Side/Perl/PerlXML/PerlXML1/page1.html +# This module isn't properly Object Orientated because the XML Parser needs global callbacks. + +package DocsParser; +use XML::Parser; +use strict; +use warnings; + +# use Util; +use Function; +use GtkDefs; +use Object; + +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; + +##################################### + +use strict; +use warnings; + +##################################### + + +$DocsParser::refAppendTo = undef; # string reference to store the data into +$DocsParser::currentParam = undef; + +$DocsParser::objCurrentFunction = 0; #Function +%DocsParser::hasharrayFunctions = (); #Function elements +$DocsParser::bOverride = 0; #First we parse the C docs, then we parse the C++ override docs. + +$DocsParser::commentStart = " /** "; +$DocsParser::commentMiddleStart = " * "; +$DocsParser::commentEnd = " */"; + +sub read_defs($$$) +{ + my ($path, $filename, $filename_override) = @_; + + # check that the file is there. + my $filepath = "$path/$filename"; + if ( ! -r $filepath) + { + print "DocsParser.pm: Error: can't read defs file $filename\n"; + return; + } + + my $filepath_override = "$path/$filename_override"; + if ( ! -r $filepath_override) + { + print "DocsParser.pm: Error: can't read defs file $filename_override\n"; + return; + } + + my $objParser = new XML::Parser(); + $objParser->setHandlers(Start => \&parse_on_start, End => \&parse_on_end, Char => \&parse_on_cdata); + + # Parse the C docs: + $objParser->parsefile($filepath); + + # Parse the C++ overide docs: + $DocsParser::bOverride = 1; #The callbacks will act differently when this is set. + $objParser->parsefile($filepath_override); +} + +sub parse_on_start($$%) +{ + my ($objParser, $tag, %attr) = @_; + + $tag = lc($tag); + + if($tag eq "function") + { + my $functionName = $attr{name}; + + #Reuse existing Function, if it exists: + #(For instance, if this is the override parse) + $DocsParser::objCurrentFunction = $DocsParser::hasharrayFunctions{$functionName}; + if(!$DocsParser::objCurrentFunction) + { + #Make a new one if necessary: + $DocsParser::objCurrentFunction = Function::new_empty(); + } + + $$DocsParser::objCurrentFunction{name} = $functionName; + $$DocsParser::objCurrentFunction{description} = ""; + $$DocsParser::objCurrentFunction{param_names} = []; + $$DocsParser::objCurrentFunction{param_descriptions} = (); + $$DocsParser::objCurrentFunction{return_description} = ""; + $$DocsParser::objCurrentFunction{description_overridden} = $DocsParser::bOverride; + } + elsif($tag eq "parameter") + { + $DocsParser::currentParam = $attr{name}; + $$DocsParser::objCurrentFunction{param_descriptions}->{$DocsParser::currentParam} = ""; + } + elsif($tag eq "description") + { + # Set destination for parse_on_cdata(). + $DocsParser::refAppendTo = \$$DocsParser::objCurrentFunction{description}; + } + elsif($tag eq "parameter_description") + { + # Set destination for parse_on_cdata(). + my $param_desc = \$$DocsParser::objCurrentFunction{param_descriptions}; + $DocsParser::refAppendTo = \$$param_desc->{$DocsParser::currentParam}; + } + elsif($tag eq "return") + { + # Set destination for parse_on_cdata(). + $DocsParser::refAppendTo = \$$DocsParser::objCurrentFunction{return_description}; + } +} + + +sub parse_on_end($$) +{ + my ($parser, $tag) = @_; + + # Clear destination for parse_on_cdata(). + $DocsParser::refAppendTo = undef; + + $tag = lc($tag); + + if($tag eq "function") + { + # Store the Function structure in the array: + my $functionName = $$DocsParser::objCurrentFunction{name}; + $DocsParser::hasharrayFunctions{$functionName} = $DocsParser::objCurrentFunction; + $DocsParser::objCurrentFunction = undef; + } + elsif($tag eq "parameter") + { + # <parameter name="returns"> and <return> means the same. + if($DocsParser::currentParam eq "returns") + { + my $param_descriptions = \$$DocsParser::objCurrentFunction{param_descriptions}; + my $return_description = \$$DocsParser::objCurrentFunction{return_description}; + $$return_description = delete $$param_descriptions->{"returns"}; + } + else + { + # Append to list of parameters. + push(@{$$DocsParser::objCurrentFunction{param_names}}, $DocsParser::currentParam); + } + + $DocsParser::currentParam = undef; + } +} + + +sub parse_on_cdata($$) +{ + my ($parser, $data) = @_; + + if(defined $DocsParser::refAppendTo) + { + # Dispatch $data to the current destination string. + $$DocsParser::refAppendTo .= $data; + } +} + + +# $strCommentBlock lookup_documentation($strFunctionName) +sub lookup_documentation($) +{ + my ($functionName) = @_; + + my $objFunction = $DocsParser::hasharrayFunctions{$functionName}; + return "" if(!$objFunction); + + my $text = $$objFunction{description}; + + DocsParser::convert_docs_to_cpp($objFunction, \$text); + DocsParser::append_parameter_docs($objFunction, \$text); + DocsParser::append_return_docs($objFunction, \$text); + + + # Escape the space after "i.e." or "e.g." in the brief description. + $text =~ s/^([^.]*\b(?:i\.e\.|e\.g\.))\s/$1\\ /; + + # Convert to Doxygen-style comment. + $text =~ s/\n/\n${DocsParser::commentMiddleStart}/g; + $text = $DocsParser::commentStart . $text; + $text .= "\n${DocsParser::commentEnd}\n"; + + return $text; +} + + +sub append_parameter_docs($$) +{ + my ($obj_function, $text) = @_; + + my @param_names = @{$$obj_function{param_names}}; + my $param_descriptions = \$$obj_function{param_descriptions}; + + # Strip first parameter if this is a method. + my $defs_method = GtkDefs::lookup_method_dont_mark($$obj_function{name}); + shift(@param_names) if($defs_method && $$defs_method{class} ne ""); + + foreach my $param (@param_names) + { + my $desc = $$param_descriptions->{$param}; + DocsParser::convert_docs_to_cpp($obj_function, \$desc); + + if(length($desc) > 0) + { + $desc .= '.' unless($desc =~ /(?:^|\.)$/); + $$text .= "\n\@param ${param} \u${desc}"; + } + } +} + + +sub append_return_docs($$) +{ + my ($obj_function, $text) = @_; + + my $desc = $$obj_function{return_description}; + DocsParser::convert_docs_to_cpp($obj_function, \$desc); + + $desc =~ s/\.$//; + $$text .= "\n\@return \u${desc}." unless($desc eq ""); +} + + +sub convert_docs_to_cpp($$) +{ + my ($obj_function, $text) = @_; + + # Chop off leading and trailing whitespace. + $$text =~ s/^\s+//; + $$text =~ s/\s+$//; + +# if(!$$obj_function{description_overridden}) +# { + # Convert C documentation to C++. + DocsParser::convert_tags_to_doxygen($text); + DocsParser::substitute_identifiers($$obj_function{name}, $text); + + $$text =~ s/\bX\s+Window\b/X \%Window/g; + $$text =~ s/\bWindow\s+manager/\%Window manager/g; +# } +} + + +sub convert_tags_to_doxygen($) +{ + my ($text) = @_; + + for($$text) + { + # Replace format tags. + s"<(/?)emphasis>"<$1em>"g; + s"<(/?)literal>"<$1tt>"g; + s"<(/?)function>"<$1tt>"g; + + # Some argument names are suffixed by "_" -- strip this. + s" ?\@([_a-z]*[a-z])_?\b" \@a $1 "g; + s"^Note ?\d?: "\@note "mg; + + s"</?programlisting>""g; + s"<informalexample>"\@code"g; + s"</informalexample>"\@endcode"g; + s"<!>""g; + + # Remove all link tags. + s"</?u?link[^&]*>""g; + + # Remove all para tags (from tmpl sgml files). + s"</?para>""g; + + s"\b->\b"->"g; + + # Doxygen is too dumb to handle — + s"—" \@htmlonly—\@endhtmlonly "g; + + s"\%?FALSE\b"<tt>false</tt>"g; + s"\%?TRUE\b"<tt>true</tt>"g; + s"\%?NULL\b"<tt>0</tt>"g; + + s"#?\bgboolean\b"<tt>bool</tt>"g; + s"#?\bg(int|short|long)\b"<tt>$1</tt>"g; + s"#?\bgu(int|short|long)\b"<tt>unsigned $1</tt>"g; + + # For Gtk::TextIter. + s"(\\[rn])\b"<tt>\\$1</tt>"g; + } +} + + +sub substitute_identifiers($$) +{ + my ($doc_func, $text) = @_; + + for($$text) + { + # TODO: handle more than one namespace + + s/[#%]([A-Z][a-z]*)([A-Z][A-Za-z]+)\b/$1::$2/g; # type names + + s/[#%]([A-Z])([A-Z]*)_([A-Z\d_]+)\b/$1\L$2\E::$3/g; # enum values + + # Undo wrong substitutions. + s/\bHas::/HAS_/g; + s/\bNo::/NO_/g; + + # Replace C function names with C++ counterparts. + s/\b([a-z]+_[a-z][a-z\d_]+) ?\(\)/&DocsParser::substitute_function($doc_func, $1)/eg; + } +} + + +sub substitute_function($$) +{ + my ($doc_func, $name) = @_; + + if(my $defs_method = GtkDefs::lookup_method_dont_mark($name)) + { + if(my $defs_object = DocsParser::lookup_object_of_method($$defs_method{class}, $name)) + { + my $module = $$defs_object{module}; + my $class = $$defs_object{name}; + + DocsParser::build_method_name($doc_func, $module, $class, \$name); + } + } + else + { + # Not perfect, but better than nothing. + $name =~ s/^g_/Glib::/; + } + + return $name . "()"; +} + + +sub lookup_object_of_method($$) +{ + my ($object, $name) = @_; + + if($object ne "") + { + # We already know the C object name, because $name is a non-static method. + return GtkDefs::lookup_object($object); + } + + my @parts = split(/_/, $name); + pop(@parts); + + # (gtk, foo, bar) -> (Gtk, Foo, Bar) + foreach(@parts) { $_ = (length > 2) ? ucfirst : uc; } + + # Do a bit of try'n'error. + while(scalar(@parts) > 1) + { + my $try = join("", @parts); + + if(my $defs_object = GtkDefs::lookup_object($try)) + { return $defs_object; } + + pop(@parts); + } + + return undef; +} + + +sub build_method_name($$$$) +{ + my ($doc_func, $module, $class, $name) = @_; + + my $prefix = $module . $class; + + $prefix =~ s/([a-z])([A-Z])/$1_$2/g; + $prefix = lc($prefix) . '_'; + + if($$name =~ /^$prefix/) + { + my $scope = ""; + $scope = "${module}::${class}::" unless($doc_func =~ /^$prefix/); + + substr($$name, 0, length($prefix)) = $scope; + } +} + + +1; # indicate proper module load. diff --git a/tools/pm/Enum.pm b/tools/pm/Enum.pm new file mode 100644 index 00000000..51d118f6 --- /dev/null +++ b/tools/pm/Enum.pm @@ -0,0 +1,219 @@ +package Enum; + +use strict; +use warnings; + +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; +# +# bool mark; +# } + + +sub new +{ + my ($def) = @_; + my $self = {}; + bless $self; + + $def =~ s/^\(//; + $def =~ s/\)$//; + + $$self{mark} = 0; + $$self{flags} = 0; + + $$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) = @_; + + # break up the value statements + foreach(split(/\s*'*[()]\s*/, $value)) + { + next if($_ eq ""); + + if(/^"\S+" "(\S+)" "([^"]+)"$/) + { + my ($name, $value) = ($1, $2); + + # cut off the module prefix, e.g. GTK_ + $name =~ s/^[^_]+_//; + + push(@{$$self{elem_names}}, $name); + push(@{$$self{elem_values}}, $value); + } + else + { + GtkDefs::error("Unknown value statement ($_) in $$self{c_type}\n"); + } + } +} + +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 < $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_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*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; +} + +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/Function.pm b/tools/pm/Function.pm new file mode 100644 index 00000000..7544016c --- /dev/null +++ b/tools/pm/Function.pm @@ -0,0 +1,343 @@ +package Function; + +use strict; +use warnings; +use Util; +use FunctionBase; + +BEGIN { + use Exporter (); + our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS); + + # set the version for version checking + $VERSION = 1.00; + @ISA = qw(FunctionBase); + @EXPORT = qw(&func1 &func2 &func4); + %EXPORT_TAGS = ( ); + # your exported package globals go here, + # as well as any optionally exported functions + @EXPORT_OK = qw($Var1 %Hashit &func3); + } +our @EXPORT_OK; + +################################################## +### Function +# Commonly used algorithm for parsing a function declaration into +# its component pieces +# +# class Function : FunctionBase +# { +# string rettype; +# bool const; +# bool static; +# string name; e.g. gtk_accelerator_valid +# string c_name; +# string array param_type; +# string array param_name; +# string array param_default_value; +# string in_module; e.g. Gtk +# string signal_when. e.g. first, last, or both. +# string class e.g. GtkButton ( == of-object. Useful for signal because their names are not unique. +# string entity_type. e.g. method or signal +# } + +sub new_empty() +{ + my $self = {}; + bless $self; + + return $self; +} + +# $objFunction new($function_declaration, $objWrapParser) +sub new($$) +{ + #Parse a function/method declaration. + #e.g. guint gtk_something_set_thing(guint a, const gchar* something) + + my ($line, $objWrapParser) = @_; + + my $self = {}; + bless $self; + + #Initialize member data: + $$self{rettype} = ""; + $$self{rettype_needs_ref} = 0; #Often the gtk function doesn't do an extra ref for the receiver. + $$self{const} = 0; + $$self{name} = ""; + $$self{param_types} = []; + $$self{param_names} = []; + $$self{param_default_value} = []; + $$self{in_module} = ""; + $$self{class} = ""; + $$self{entity_type} = "method"; + + $line =~ s/^\s+//; # Remove leading whitespace. + $line =~ s/\s+/ /g; # Compress white space. + + if ($line =~ /^static\s+([^()]+)\s+(\S+)\s*\((.*)\)\s*$/) + { + $$self{rettype} = $1; + $$self{name} = $2; + $$self{c_name} = $2; + $self->parse_param($3); + $$self{static} = 1; + } + elsif ($line =~ /^([^()]+)\s+(\S+)\s*\((.*)\)\s*(const)*$/) + { + no warnings qw(uninitialized); # disable the uninitialize warning for $4 + $$self{rettype} = $1; + $$self{name} = $2; + $$self{c_name} = $2; + $self->parse_param($3); + $$self{const} = ($4 eq "const"); + } + else + { + $objWrapParser->error("fail to parse $line\n"); + } + + return $self; +} + + +# $objFunction new_ctor($function_declaration, $objWrapParser) +# Like new(), but the function_declaration doesn't need a return type. +sub new_ctor($$) +{ + #Parse a function/method declaration. + #e.g. guint gtk_something_set_thing(guint a, const gchar* something) + + my ($line, $objWrapParser) = @_; + + my $self = {}; + bless $self; + + #Initialize member data: + $$self{rettype} = ""; + $$self{rettype_needs_ref} = 0; + $$self{const} = 0; + $$self{name} = ""; + $$self{param_types} = []; + $$self{param_names} = []; + $$self{param_default_value} = []; + $$self{in_module} = ""; + $$self{class} = ""; + $$self{entity_type} = "method"; + + $line =~ s/^\s+//; # Remove leading whitespace. + $line =~ s/\s+/ /g; # Compress white space. + + if ($line =~ /^(\S+)\s*\((.*)\)\s*/) + { + $$self{name} = $1; + $$self{c_name} = $2; + $self->parse_param($2); + } + else + { + $objWrapParser->error("fail to parse $line\n"); + } + + return $self; +} + +# $num num_args() +sub num_args #($) +{ + my ($self) = @_; + my $param_types = $$self{param_types}; + return $#$param_types+1; +} + +# parses C++ parameter lists. +# forms a list of types, names, and initial values +# (we don't currently use values) +sub parse_param($$) +{ + my ($self, $line) = @_; + + + my $type = ""; + my $name = ""; + my $value = ""; + my $id = 0; + my $has_value = 0; + + my $param_types = $$self{param_types}; + my $param_names = $$self{param_names}; + my $param_default_values = $$self{param_default_value}; + + # clean up space and handle empty case + $line = string_trim($line); + $line =~ s/\s+/ /g; # Compress whitespace. + return if ($line =~ /^$/); + + # parse through argument list + my @str = (); + my $par = 0; + foreach (split(/([,=&*()])|(<[^,]*>)|(\s+)/, $line)) #special characters OR <something> OR whitespace. + { + next if ( !defined($_) or $_ eq "" ); + if ( $_ eq "(" ) + { + push(@str, $_); + $par++; + next; + } + elsif ( $_ eq ")" ) + { + push(@str, $_); + $par--; + next; + } + elsif ( $par || /^(const)|(<[^,]*>)|([*&])|(\s+)/ ) #TODO: What's happening here? + { + push(@str, $_); + next; + } + elsif ( $_ eq "=" ) #Default value + { + $type = join("", @str); #The type is everything before the = character. + @str = (); #Wipe it so that it will only contain the default value, which comes next. + $has_value = 1; + next; + } + elsif ( $_ eq "," ) #The end of one parameter: + { + if ($has_value) + { + $value = join("", @str); # If there's a default value, then it's the part before the next ",". + } + else + { + $type = join("", @str); + } + + if ($name eq "") + { + $name = sprintf("p%s", $#$param_types + 2) + } + + $type = string_trim($type); + + push(@$param_types, $type); + push(@$param_names, $name); + push(@$param_default_values, $value); + + #Clear variables, ready for the next parameter. + @str = (); + $type= ""; + $value = ""; + $has_value = 0; + $name = ""; + + $id = 0; + + next; + } + + if ($has_value) + { + push(@str, $_); + next; + } + + $id++; + $name = $_ if ($id == 2); + push(@str, $_) if ($id == 1); + + if ($id > 2) + { + print STDERR "Can't parse $line.\n"; + print STDERR " arg type so far: $type\n"; + print STDERR " arg name so far: $name\n"; + print STDERR " arg default value so far: $value\n"; + } + } + + # handle last argument (There's no , at the end.) + if ($has_value) + { + $value = join("", @str); + } + else + { + $type = join("", @str); + } + + if ($name eq "") + { + $name = sprintf("p%s", $#$param_types + 2) + } + + $type = string_trim($type); + + push(@$param_types, $type); + push(@$param_names, $name); + push(@$param_default_values, $value); +} + +# add_parameter_autoname($, $type, $name) +# Adds e.g "sometype somename" +sub add_parameter_autoname($$) +{ + my ($self, $type) = @_; + + add_parameter($self, $type, ""); +} + +# add_parameter($, $type, $name) +# Adds e.g GtkSomething* p1" +sub add_parameter($$$) +{ + my ($self, $type, $name) = @_; + $type = string_unquote($type); + $type =~ s/-/ /g; + + my $param_names = $$self{param_names}; + + if ($name eq "") + { + $name = sprintf("p%s", $#$param_names + 2); + } + + push(@$param_names, $name); + + my $param_types = $$self{param_types}; + + push(@$param_types, $type); + + return $self; +} + +# $string get_refdoc_comment() +# Generate a readable prototype for signals. +sub get_refdoc_comment($) +{ + my ($self) = @_; + + my $str = " /**\n"; + + $str .= " * \@par Prototype:\n"; + $str .= " * <tt>$$self{rettype} \%$$self{name}("; + + my $param_names = $$self{param_names}; + my $param_types = $$self{param_types}; + my $num_params = scalar(@$param_types); + + # List the parameters: + for(my $i = 0; $i < $num_params; ++$i) + { + $str .= $$param_types[$i] . ' ' . $$param_names[$i]; + $str .= ", " if($i < $num_params - 1); + } + + $str .= ")</tt>\n"; + $str .= " */"; + + return $str; +} + +1; # indicate proper module load. + diff --git a/tools/pm/FunctionBase.pm b/tools/pm/FunctionBase.pm new file mode 100644 index 00000000..12b89f66 --- /dev/null +++ b/tools/pm/FunctionBase.pm @@ -0,0 +1,207 @@ +package FunctionBase; + +use strict; +use warnings; +use Util; + +BEGIN { + use Exporter (); + our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS); + + # set the version for version checking + $VERSION = 1.00; + @ISA = qw(Exporter); + @EXPORT = qw(&func1 &func2 &func4); + %EXPORT_TAGS = ( ); + # your exported package globals go here, + # as well as any optionally exported functions + @EXPORT_OK = qw($Var1 %Hashit &func3); + } +our @EXPORT_OK; + +################################################## +### FunctionBase +# 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 Function : FunctionBase +# { +# string array param_types; +# string array param_names; +# string array param_documentation; +# string return_documention; +# } + + +# $string args_types_only($) +# comma-delimited argument types. +sub args_types_only($) +{ + my ($self) = @_; + + my $param_types = $$self{param_types}; + return join(", ", @$param_types); +} + +# $string args_names_only($) +sub args_names_only($) +{ + my ($self) = @_; + + my $param_names = $$self{param_names}; + return join(", ", @$param_names); +} + +# $string args_types_and_names($) +sub args_types_and_names($) +{ + my ($self) = @_; + + my $i; + + my $param_names = $$self{param_names}; + my $param_types = $$self{param_types}; + my @out; + + for ($i = 0; $i < $#$param_types + 1; $i++) + { + my $str = sprintf("%s %s", $$param_types[$i], $$param_names[$i]); + push(@out, $str); + } + + return join(", ", @out); +} + +# $string args_names_only_without_object($) +sub args_names_only_without_object2($) +{ + my ($self) = @_; + + 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; +} + +# $string args_types_and_names_without_object($) +sub args_types_and_names_without_object($) +{ + my ($self) = @_; + + 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); +} + +# $string args_names_only_without_object($) +sub args_names_only_without_object($) +{ + my ($self) = @_; + + 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; +} + +sub dump($) +{ + my ($self) = @_; + + 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"; +} + +#sub args_types_and_names_with_default_values($) +#{ +# my ($self) = @_; +# +# 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($$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/GtkDefs.pm b/tools/pm/GtkDefs.pm new file mode 100644 index 00000000..952e2a0b --- /dev/null +++ b/tools/pm/GtkDefs.pm @@ -0,0 +1,629 @@ +# gtkmm - GtkDefs module +# +# Copyright 2001 Free Software Foundation +# +# 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 GtkDefs; +use strict; +use warnings; + +use Util; +use Enum; +use Object; +use Property; +use FunctionBase; + +# +# Public functions +# read_defs(path, file) +# +# @ get_methods() +# @ get_signals() +# @ get_properties() +# +# $ lookup_enum(c_type) +# $ lookup_object(c_name) +# $ lookup_method(c_name) +# $ lookup_function(c_name) +# $ lookup_property(object, c_name) +# $ lookup_signal(object, c_name) +# + +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; + +##################################### + +use strict; +use warnings; + +##################################### + +%GtkDefs::enums = (); #Enum +%GtkDefs::objects = (); #Object +%GtkDefs::methods = (); #GtkDefs::Function +%GtkDefs::signals = (); #GtkDefs::Signal +%GtkDefs::properties = (); #Property + +@GtkDefs::read = (); +@GtkDefs::file = (); + + +##################################### +#prototype to get rid of warning +sub read_defs($$;$); + +sub read_defs($$;$) +{ + my ($path, $filename, $restrict) = @_; + $restrict = "" if ($#_ < 2); + + # check that the file is there. + if ( ! -r "$path/$filename") + { + print "Error: can't read defs file $filename\n"; + return; + } + + # break the tokens into lisp phrases up to three levels deep. + # WARNING: reading the following perl statement may induce seizures, + # please flush eyes with water immediately, and consult a mortician. + my @tokens = split( + m/( + \( + (?: + [^()]* + \( + (?: + [^()]* + \( + [^()]+ + \) + )* + [^()]* + \) + )* + [^()]* + \) + )/x, + read_file($path, $filename)); + + # scan through top level tokens + while ($#tokens > -1) + { + my $token = shift @tokens; + next if ($token =~ /^\s*$/); + + if ($token =~ /\(include (\S+)\)/) + { + read_defs($path,$1,$restrict); + next; + } + elsif ($token =~ /^\(define-flags-extended.*\)$/) + { on_enum($token); } + elsif ($token =~ /^\(define-enum-extended.*\)$/) + { on_enum($token); } + elsif ($token =~ /^\(define-flags.*\)$/) + { } + elsif ($token =~ /^\(define-enum.*\)$/) + { } + elsif ($token =~ /^\(define-object.*\)$/) + { on_object($token); } + elsif ($token =~ /^\(define-function.*\)$/) + { on_function($token); } + elsif ($token =~ /^\(define-method.*\)$/) + { on_method($token); } + elsif ($token =~ /^\(define-property.*\)$/) + { on_property($token); } + elsif ($token =~ /^\(define-signal.*\)$/) + { on_signal($token); } + elsif ($token =~ /^\(define-vfunc.*\)$/) + { on_vfunc($token); } + else + { + if ( $token =~ /^\(define-(\S+) (\S+)/) + { + # FIXME need to figure out the line number. + print STDERR "Broken lisp definition for $1 $2.\n"; + } + else + { + print "unknown token $token \n"; + } + } + } +} + + +sub read_file($$) +{ + my ($path, $filename)=@_; + my @buf = (); + + # don't read a file twice + foreach (@GtkDefs::read) + { + return "" if ($_ eq "$path/$filename"); + } + push @GtkDefs::read, "$path/$filename"; + + # read file while stripping comments + open(FILE, "$path/$filename"); + while (<FILE>) + { + s/^;.*$//; # remove comments + chop; # remove new lines + push(@buf, $_); + } + close(FILE); + + $_ = join("", @buf); + s/\s+/ /g; + return $_; +} + + +sub on_enum($) +{ + my $thing = Enum::new(shift(@_)); + $GtkDefs::enums{$$thing{c_type}} = $thing; +} + +sub on_object($) +{ + my $thing = Object::new(shift(@_)); + $GtkDefs::objects{$$thing{c_name}} = $thing; +} + +sub on_function($) +{ + my $thing = GtkDefs::Function::new(shift(@_)); + $GtkDefs::methods{$$thing{c_name}} = $thing; +} + +sub on_method($) +{ + my $thing = GtkDefs::Function::new(shift(@_)); + $GtkDefs::methods{$$thing{c_name}} = $thing if ($thing); +} + +sub on_property($) +{ + my $thing = Property::new(shift(@_)); + $GtkDefs::properties{"$$thing{class}::$$thing{name}"} = $thing; +} + +sub on_signal($) +{ + my $thing = GtkDefs::Signal::new(shift(@_)); + $GtkDefs::signals{"$$thing{class}::$$thing{name}"} = $thing; +} + +sub on_vfunc($) +{ + my $thing = GtkDefs::Signal::new(shift(@_)); + $GtkDefs::signals{"$$thing{class}::$$thing{name}"} = $thing; +} + +########################## + +sub get_enums +{ + return sort {$$a{c_type} cmp $$b{c_type}} values %GtkDefs::enums; +} +sub get_methods +{ + return sort {$$a{c_name} cmp $$b{c_name}} values %GtkDefs::methods; +} +sub get_signals +{ + return sort {$$a{name} cmp $$b{name}} values %GtkDefs::signals; +} +sub get_properties +{ + return sort {$$a{name} cmp $$b{name}} values %GtkDefs::properties; +} + +sub get_marked +{ + no warnings; + return grep {$$_{mark}==1} values %GtkDefs::methods; +} + +# This searches for items wrapped by this file and then tries to locate +# other functions/signal/properties which may have been left unmarked. +sub get_unwrapped +{ + # find methods which were used in for a _WRAP + my @targets; + push @targets,grep {$$_{entity_type} eq "method" & $$_{mark}==1} values %GtkDefs::methods; + push @targets,grep {$$_{mark}==1} values %GtkDefs::signals; + push @targets,grep {$$_{mark}==1} values %GtkDefs::properties; + + # find the classes which used them. + my @classes = join(" ", unique(map { $$_{class} } @targets)); + + # find methods which are in those classes which didn't get marked. + my @unwrapped; + my $class; + foreach $class (@classes) + { + push @unwrapped, grep {$$_{class} eq $class & $$_{mark}==0} values %GtkDefs::methods; + push @unwrapped, grep {$$_{class} eq $class & $$_{mark}==0} values %GtkDefs::properties; + push @unwrapped, grep {$$_{class} eq $class & $$_{mark}==0} values %GtkDefs::signals; + } + + return @unwrapped; +} + +########################## + +sub lookup_enum($) +{ + no warnings; + my ($c_type) = @_; + my $obj = $GtkDefs::enums{$c_type}; + return 0 if(!$obj); + $$obj{mark} = 1; + return $obj; +} + +sub lookup_object($) +{ + no warnings; + return $GtkDefs::objects{$_[0]}; +} + +# $objProperty lookup_property($name, $parent_object_name) +sub lookup_property($$) +{ + no warnings; + my ($parent_object_name, $name) = @_; + $name =~ s/-/_/g; + my $obj = $GtkDefs::properties{"${parent_object_name}::${name}"}; + return 0 if ($obj eq ""); + $$obj{mark} = 1; + return $obj; +} + +sub lookup_method_dont_mark($) +{ + no warnings; + my ($c_name) = @_; + $c_name =~ s/-/_/g; + + my $obj = $GtkDefs::methods{$c_name}; + return 0 if ($obj eq ""); + + return $obj; +} + +sub lookup_method($) +{ + my $obj = lookup_method_dont_mark($_); + + $$obj{mark} = 1 if($obj); + return $obj; +} + +sub lookup_function($) +{ + return lookup_method($_[0]); +} + +sub lookup_signal($$) +{ + no warnings; + my ($parent_object_name, $name) = @_; + + $name =~ s/-/_/g; + my $obj = $GtkDefs::signals{"${parent_object_name}::${name}"}; + return 0 if ($obj eq ""); + $$obj{mark} = 1; + return $obj; +} + +sub error +{ + my $format = shift @_; + printf STDERR "GtkDefs.pm: $format\n", @_; +} + + +######################################################################## +package GtkDefs::Function; +BEGIN { @GtkDefs::Function::ISA=qw(FunctionBase); } + +# 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; +# +# } + +# "new" can't have prototype +sub new +{ + my ($def) = @_; + my $whole = $def; + my $self = {}; + bless $self; + + $def =~ s/^\(//; + $def =~ s/\)$//; + $def =~ s/^\s*define-(\S+)\s+(\S+)\s*//; + $$self{entity_type} = $1; + $$self{name} = $2; + $$self{name} =~ s/-/_/g; # change - to _ + + # init variables + $$self{mark} = 0; + $$self{rettype} = "none"; + $$self{param_types} = []; + $$self{param_names} = []; + $$self{class} = ""; + + # snarf down lisp fields + $$self{c_name} = $1 if ($def=~s/\(c-name "(\S+)"\)//); + $$self{class} = $1 if ($def=~s/\(of-object "(\S+)"\)//); + + if ($def =~ s/\(return-type "(\S+)"\)//) + { + $$self{rettype} = $1; + $$self{rettype} =~ s/-/ /g; #e.g. replace const-gchar* with const gchar*. Otherwise it will be used in code. + } + + $$self{varargs} = 1 if ($def=~s/\(varargs\s+#t\)//); + $$self{rettype} = "void" if ($$self{rettype} eq "none"); + + # methods have a parameter not stated in the defs file + if ($$self{entity_type} eq "method") + { + push( @{$$self{param_types}}, "$$self{class}*" ); + push( @{$$self{param_names}}, "self" ); + } + + # parameters are compound lisp statement + if ($def =~ s/\(parameters(( '\("\S+" "\S+"\))*) \)//) + { + $self->parse_param($1); + } + + # is-constructor-of: + if ($def =~ s/\(is-constructor-of "(\S+)"\)//) + { + #Ignore them. + } + + GtkDefs::error("Unhandled function parameter ($def) in $$self{c_name}\n") + if ($def !~ /^\s*$/); + + return $self; +} + +sub parse_param($$) +{ + my ($self, $param) = @_; + + # break up the parameter statements + foreach (split(/\s*'*[()]\s*/, $param)) + { + next if ($_ eq ""); + if (/^"(\S+)" "(\S+)"$/) + { + my ($p1, $p2) = ($1,$2); + $p1 =~ s/-/ /; + push( @{$$self{param_types}}, $p1); + push( @{$$self{param_names}}, $p2); + } + else + { + GtkDefs::error("Unknown parameter statement ($_) in $$self{c_name}\n"); + } + } +} + + +# $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) = @_; + + my $rettype = $$self{rettype}; + if($rettype eq "gchar*" || $rettype eq "char*") + { + $rettype = "return-" . $rettype; + } + + return $rettype; +} + +sub get_param_names +{ + my ($self) = @_; + return @$self{param_names}; +} + +###################################################################### +package GtkDefs::Signal; +BEGIN { @GtkDefs::Signal::ISA=qw(GtkDefs::Function); } + +# class Signal : 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 +# } + +# "new" can't have prototype +sub new +{ + my ($def) = @_; + + my $whole = $def; + my $self = {}; + bless $self; + + #Remove first and last braces: + $def =~ s/^\(//; + $def =~ s/\)$//; + + $def =~ s/^\s*define-(\S+)\s+(\S+)\s*//; + $$self{entity_type} = $1; + $$self{name} = $2; + $$self{name} =~ s/-/_/g; #change - to _ + + # init variables + $$self{mark}=0; + $$self{rettype} = "none"; + $$self{param_types} = []; + $$self{param_names} = []; + $$self{when} = ""; + $$self{class} = ""; + + # snarf down lisp fields + if($def =~ s/\(of-object "(\S+)"\)//) + { + $$self{class} = $1; + } + else + { + GtkDefs::error("define-signal/define-vfunc without of-object (entity type: $$self{entity_type}): $whole"); + } + + if($def =~ s/\(return-type "(\S+)"\)//) + { + $$self{rettype} = $1; + $$self{rettype} =~ s/-/ /g; #e.g. replace const-gchar* with const gchar*. Otherwise it will be used in code. + } + + if($def =~ s/\(when "(\S+)"\)//) + { + $$self{when} = $1; + } + + if($$self{rettype} eq "none") + { + $$self{rettype} = "void" + } + + # signals always have a parameter + push(@{$$self{param_types}}, "$$self{class}*"); + push(@{$$self{param_names}}, "self"); + + # parameters are compound lisp statement + if ($def =~ s/\(parameters(( '\("\S+" "\S+"\))+) \)//) + { + $self->parse_param($1); + } + + if ($def!~/^\s*$/) + { + GtkDefs::error("Unhandled signal/vfunc def ($def) in $$self{class}::$$self{name}"); + } + + return $self; +} + +# 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. +} + +# 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/Makefile.am b/tools/pm/Makefile.am new file mode 100644 index 00000000..93c0b3fd --- /dev/null +++ b/tools/pm/Makefile.am @@ -0,0 +1,10 @@ + +include $(top_srcdir)/tools/pm/Makefile_list_of_sources.am_fragment + +EXTRA_DIST = Makefile_list_of_sources.am_fragment $(files_tools_pm) + +# Install the .pm, files: + +tools_pm_includedir = $(libdir)/gtkmm-2.0/proc/pm +tools_pm_include_HEADERS = $(files_tools_pm) + diff --git a/tools/pm/Makefile_list_of_sources.am_fragment b/tools/pm/Makefile_list_of_sources.am_fragment new file mode 100644 index 00000000..e8df8f44 --- /dev/null +++ b/tools/pm/Makefile_list_of_sources.am_fragment @@ -0,0 +1,2 @@ +files_tools_pm = DocsParser.pm GtkDefs.pm Enum.pm Function.pm FunctionBase.pm Object.pm Output.pm Property.pm Util.pm WrapParser.pm + diff --git a/tools/pm/Object.pm b/tools/pm/Object.pm new file mode 100644 index 00000000..aef72c39 --- /dev/null +++ b/tools/pm/Object.pm @@ -0,0 +1,72 @@ +package Object; + +use strict; +use warnings; + +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 Object +# { +# string name; +# string module; +# string parent; +# string c_name; +# string gtype_id; +# } + + +sub new +{ + my ($def) = @_; + + my $self = {}; + bless $self; + + $def =~ s/^\(//; + $def =~ s/\)$//; + + # snarf down the fields + $$self{name} = $1 if($def =~ s/^define-object (\S+)//); + $$self{module} = $1 if($def =~ s/\(in-module "(\S+)"\)//); + $$self{parent} = $1 if($def =~ s/\(parent "(\S+)"\)//); + $$self{c_name} = $1 if($def =~ s/\(c-name "(\S+)"\)//); + $$self{gtype_id} = $1 if($def =~ s/\(gtype-id "(\S+)"\)//); + + if($def !~ /^\s*$/) + { + GtkDefs::error("Unhandled object def ($def) in $$self{module}\::$$self{name}\n") + } + + return $self; +} + + +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/Output.pm b/tools/pm/Output.pm new file mode 100644 index 00000000..37aea976 --- /dev/null +++ b/tools/pm/Output.pm @@ -0,0 +1,781 @@ +# Gtkmmproc Output module +# +# Copyright 2001 Free Software Foundation +# +# 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 Output; +use strict; +BEGIN { @Namespace::ISA=qw(main); } + +# $objOutputter new() +sub new +{ + my ($m4path, $macrodirs) = @_; + my $self = {}; + bless $self; + + $$self{out} = []; + + $$self{source} = ""; + $$self{tmpdir} = "/tmp"; + $$self{destdir} = ""; + $$self{objDefsParser} = undef; # It will be set in set_defsparser() + + $$self{m4path} = $m4path; + $$self{m4args} = "-I"; + $$self{m4args} .= join(" -I", @$macrodirs); + + return $self; +} + +sub set_defsparser($$) +{ + my ($self, $objDefsParser) = @_; + + $$self{objDefsParser} = $objDefsParser; #Remember it so that we can use it in our output methods. +} + +sub m4args_append($$) +{ + my ($self, $str) = @_; + $$self{m4args} .= $str; +} + +sub append($$) +{ + my ($self, $str) = @_; + + push(@{$$self{out}}, $str); +} + +# void output_wrap_failed($cname, $error) +# Puts a comment in the header about the error during code-generation. +sub output_wrap_failed($$$) +{ + my ($self, $cname, $error) = @_; + + my $str = sprintf("//gtkmmproc error: %s : %s", $cname, $error); + print STDERR "Output.pm: $cname : $error\n"; + $self->append($str); +} + +sub error +{ + my $format=shift @_; + printf STDERR "Output.pm: $format",@_; +} + +### Convert _WRAP to a virtual +# _VFUNC_H(signame,rettype,`<cppargs>') +# _VFUNC_PH(gtkname,crettype,cargs and names) +# void output_wrap_vfunc_h($filename, $line_num, $objCppfunc, $objCDefsFunc) +sub output_wrap_vfunc_h($$$$$) +{ + my ($self, $filename, $line_num, $objCppfunc, $objCDefsFunc) = @_; + + my $str = sprintf("_VFUNC_H(%s,%s,\`%s\')dnl\n", + $$objCppfunc{name}, + $$objCppfunc{rettype}, + $objCppfunc->args_types_and_names() + ); + $self->append($str); + + #The default callback, which will call *_impl, which will then call the base default callback. + #Declares the callback in the private *Class class and sets it in the class_init function. + + my $str = sprintf("_VFUNC_PH(%s,%s,\`%s\')dnl\n", + $$objCDefsFunc{name}, + $$objCDefsFunc{rettype}, + $objCDefsFunc->args_types_and_names() + ); + $self->append($str); +} + +# _VFUNC_CC(signame,gtkname,rettype,crettype,`<cppargs>',`<cargs>') +sub output_wrap_vfunc_cc($$$$$$) +{ + my ($self, $filename, $line_num, $objCppfunc, $objDefsSignal) = @_; + + my $cname = $$objDefsSignal{name}; + + # e.g. Gtk::Button::draw_indicator: + + #Use a different macro for Interfaces, to generate an extra convenience method. + + my $refreturn = ""; + $refreturn = "refreturn" if($$objCppfunc{rettype_needs_ref}); + + my $str = sprintf("_VFUNC_CC(%s,%s,%s,%s,\`%s\',\`%s\',%s)dnl\n", + $$objCppfunc{name}, + $cname, + $$objCppfunc{rettype}, + $$objDefsSignal{rettype}, + $objCppfunc->args_types_and_names(), + convert_args_cpp_to_c($objCppfunc, $objDefsSignal, 0, $line_num), #$objCppfunc->args_names_only(), + $refreturn); + + $self->append($str); + + # e.g. Gtk::ButtonClass::draw_indicator(): + + my $refreturn_ctype = ""; + $refreturn_ctype = "refreturn_ctype" if($$objDefsSignal{rettype_needs_ref}); + + my $str = sprintf("_VFUNC_PCC(%s,%s,%s,%s,\`%s\',\`%s\',\`%s\',%s,%s)dnl\n", + $$objCppfunc{name}, + $cname, + $$objCppfunc{rettype}, + $$objDefsSignal{rettype}, + $objDefsSignal->args_types_and_names(), + $objDefsSignal->args_names_only(), + convert_args_c_to_cpp($objDefsSignal, $objCppfunc, $line_num), + ${$objDefsSignal->get_param_names()}[0], + $refreturn_ctype); + + $self->append($str); +} + +### Convert _WRAP to a virtual +# _SIGNAL_H(signame,rettype,`<cppargs>') +# _SIGNAL_PH(gtkname,crettype,cargs and names) +# void output_wrap_default_signal_handler_h($filename, $line_num, $objCppfunc, $objCDefsFunc, @args) +sub output_wrap_default_signal_handler_h($$$$$$) +{ + my ($self, $filename, $line_num, $objCppfunc, $objCDefsFunc, $bImplement) = @_; + + my $str = sprintf("_SIGNAL_H(%s,%s,\`%s\')dnl\n", + $$objCppfunc{name}, + $$objCppfunc{rettype}, + $objCppfunc->args_types_and_names() + ); + $self->append($str); + + + #The default callback, which will call *_impl, which will then call the base default callback. + #Declares the callback in the private *Class class and sets it in the class_init function. + + $str = sprintf("_SIGNAL_PH(%s,%s,\`%s\')dnl\n", + $$objCDefsFunc{name}, + $$objCDefsFunc{rettype}, + $objCDefsFunc->args_types_and_names() + ); + $self->append($str); +} + +# _SIGNAL_CC(signame,gtkname,rettype,crettype,`<cppargs>',`<cargs>') +sub output_wrap_default_signal_handler_cc($$$$$) +{ + my ($self, $filename, $line_num, $objCppfunc, $objDefsSignal, $bImplement) = @_; + my $cname = $$objDefsSignal{name}; + # $cname = $1 if ($args[3] =~ /"(.*)"/); #TODO: What's this about? + + # e.g. Gtk::Button::on_clicked: + if($bImplement eq 1) + { + my $str = sprintf("_SIGNAL_CC(%s,%s,%s,%s,\`%s\',\`%s\',%s)dnl\n", + $$objCppfunc{name}, + $cname, + $$objCppfunc{rettype}, + $$objDefsSignal{rettype}, + $objCppfunc->args_types_and_names(), + convert_args_cpp_to_c($objCppfunc, $objDefsSignal, 0, $line_num), #$objCppfunc->args_names_only(), + $$objCppfunc{const}); + $self->append($str); + } + + + # e.g. Gtk::ButtonClass::on_clicked(): + + #Callbacks always take the object instance as the first argument: +# my $arglist_names = "object"; +# my $arglist_names_extra = $objDefsSignal->args_names_only(); +# if ($arglist_names_extra) +# { +# $arglist_names .= ", "; +# $arglist_names .= $arglist_names_extra; +# } + + my $str = sprintf("_SIGNAL_PCC(%s,%s,%s,%s,\`%s\',\`%s\',\`%s\',%s)dnl\n", + $$objCppfunc{name}, + $cname, + $$objCppfunc{rettype}, + $$objDefsSignal{rettype}, + $objDefsSignal->args_types_and_names(), + $objDefsSignal->args_names_only(), + convert_args_c_to_cpp($objDefsSignal, $objCppfunc, $line_num), + ${$objDefsSignal->get_param_names()}[0]); + $self->append($str); +} + +### Convert _WRAP to a method +# _METHOD(cppname,cname,cpprettype,crettype,arglist,cargs,const) +# void output_wrap_meth($filename, $line_num, $objCppFunc, $objCDefsFunc, $cppMethodDecl, $documentation) +sub output_wrap_meth($$$$$$) +{ + my ($self, $filename, $line_num, $objCppfunc, $objCDefsFunc, $cppMethodDecl, $documentation) = @_; + my $objDefsParser = $$self{objDefsParser}; + + # Doxygen documentation before the method declaration: + $self->append("\n${documentation}"); + + #Declaration: + $self->append(" ${cppMethodDecl};"); + + my $refneeded = ""; + if($$objCDefsFunc{rettype_needs_ref}) + { + $refneeded = "refreturn" + } + my $errthrow = ""; + if($$objCDefsFunc{throw_any_errors}) + { + $errthrow = "errthrow" + } + + #Implementation: + my $str; + if ($$objCppfunc{static}) { + $str = sprintf("_STATIC_METHOD(%s,%s,%s,%s,\`%s\',\`%s\',%s,%s)dnl\n", + $$objCppfunc{name}, + $$objCDefsFunc{c_name}, + $$objCppfunc{rettype}, + $objCDefsFunc->get_return_type_for_methods(), + $objCppfunc->args_types_and_names(), + convert_args_cpp_to_c($objCppfunc, $objCDefsFunc, 1, $line_num, $errthrow), #1 means it's static, so it has 'object'. + $refneeded, + $errthrow); + } else { + $str = sprintf("_METHOD(%s,%s,%s,%s,\`%s\',\`%s\',%s,%s,%s)dnl\n", + $$objCppfunc{name}, + $$objCDefsFunc{c_name}, + $$objCppfunc{rettype}, + $objCDefsFunc->get_return_type_for_methods(), + $objCppfunc->args_types_and_names(), + convert_args_cpp_to_c($objCppfunc, $objCDefsFunc, 0, $line_num, $errthrow), + $$objCppfunc{const}, + $refneeded, + $errthrow); + } + + + $self->append($str); +} + +### Convert _WRAP_CTOR to a ctor +# _METHOD(cppname,cname,cpprettype,crettype,arglist,cargs,const) +# void output_wrap_ctor($filename, $line_num, $objCppFunc, $objCDefsFunc, $cppMethodDecl) +sub output_wrap_ctor($$$$$) +{ + my ($self, $filename, $line_num, $objCppfunc, $objCDefsFunc, $cppMethodDecl) = @_; + my $objDefsParser = $$self{objDefsParser}; + + #Ctor Declaration: + #TODO: Add explicit. + $self->append("explicit " . $cppMethodDecl . ";"); + + #Implementation: + my $str = sprintf("_CTOR_IMPL(%s,%s,\`%s\',\`%s\')dnl\n", + $$objCppfunc{name}, + $$objCDefsFunc{c_name}, + $objCppfunc->args_types_and_names(), + get_ctor_properties($objCppfunc, $objCDefsFunc, $line_num) + ); + + $self->append($str); +} + +sub output_wrap_create($$$) +{ + my ($self, $args_type_and_name_with_default_values, $objWrapParser) = @_; + + #Re-use Function in a very hacky way, to separate the argument types_and_names. + my $fake_decl = "void fake_func(" . $args_type_and_name_with_default_values . ")"; + + my $objFunction = &Function::new($fake_decl, $objWrapParser); + my $args_names_only = $objFunction->args_names_only(); + my $args_type_and_name = $objFunction->args_types_and_names(); + + my $str = sprintf("_CREATE_METHOD(\`%s\',\`%s\')dnl\n", + $args_type_and_name, $args_names_only); + + $self->append($str) +} + +# _SIGNAL_IMPL(return_type,func_name,`<args>',cname) +# sub output_wrap_sig_impl($$$$) +# { +# my ($self, $filename, $line_num, $objCppfunc) = @_; +# +# my $str; +# $str = sprintf("_SIGNAL_IMPL(%s,%s,\`%s\')dnl\n", +# $$objCppfunc{rettype}, +# $$objCppfunc{name}, +# $objCppfunc->args_types_only() +# ); +# +# $self->append($str); +# } + + +# void output_wrap_sig_decl($filename, $line_num, $objCSignal, $objCppfunc, $signal_name) +# custom_signalproxy_name is "" when no type conversion is required - a normal templates SignalProxy will be used instead. +sub output_wrap_sig_decl($$$$$$) +{ + my ($self, $filename, $line_num, $objCSignal, $objCppfunc, $signal_name) = @_; + +# _SIGNAL_PROXY(c_signal_name, c_return_type, `<c_arg_types_and_names>', +# cpp_signal_name, cpp_return_type, `<cpp_arg_types>',`<c_args_to_cpp>', +# refdoc_comment) + + my $str = sprintf("_SIGNAL_PROXY(%s,%s,\`%s\',%s,%s,\`%s\',\`%s\',\`%s\')dnl\n", + $signal_name, + $$objCSignal{rettype}, + $objCSignal->args_types_and_names_without_object(), + $$objCppfunc{name}, + $$objCppfunc{rettype}, + $objCppfunc->args_types_only(), + convert_args_c_to_cpp($objCSignal, $objCppfunc, $line_num), + $objCppfunc->get_refdoc_comment() + ); + + $self->append($str); +} + +# void output_wrap_enum($filename, $line_num, $cpp_type, $c_type, $comment, @flags) +sub output_wrap_enum($$$$$$$) +{ + my ($self, $filename, $line_num, $cpp_type, $c_type, $comment, @flags) = @_; + + my $objEnum = GtkDefs::lookup_enum($c_type); + if(!$objEnum) + { + $self->output_wrap_failed($c_type, "enum defs lookup failed."); + return; + } + + $objEnum->beautify_values(); + + my $no_gtype = ""; + my $elements = $objEnum->build_element_list(\@flags, \$no_gtype, " "); + + if(!$elements) + { + $self->output_wrap_failed($c_type, "unknown _WRAP_ENUM() flag"); + return; + } + + my $value_suffix = "Enum"; + $value_suffix = "Flags" if($$objEnum{flags}); + + my $str = sprintf("_ENUM(%s,%s,%s,\`%s\',\`%s\',\`%s\')dnl\n", + $cpp_type, + $c_type, + $value_suffix, + $elements, + $no_gtype, + $comment + ); + + $self->append($str); +} + +# void output_wrap_gerror($filename, $line_num, $cpp_type, $c_enum, $domain, @flags) +sub output_wrap_gerror($$$$$$$) +{ + my ($self, $filename, $line_num, $cpp_type, $c_enum, $domain, @flags) = @_; + + my $objDefsParser = $$self{objDefsParser}; + + my $objEnum = GtkDefs::lookup_enum($c_enum); + if(!$objEnum) + { + $self->output_wrap_failed($c_enum, "enum defs lookup failed."); + return; + } + + # Shouldn't happen, and if it does, I'd like to know that. + warn if($$objEnum{flags}); + + $objEnum->beautify_values(); + + # cut off the module prefix, e.g. GDK_ + my $prefix = $domain; + $prefix =~ s/^[^_]+_//; + + # Chop off the domain prefix, because we put the enum into the class. + unshift(@flags, "s#^${prefix}_##"); + + my $no_gtype = ""; + my $elements = $objEnum->build_element_list(\@flags, \$no_gtype, " "); + + my $str = sprintf("_GERROR(%s,%s,%s,\`%s\',%s)dnl\n", + $cpp_type, + $c_enum, + $domain, + $elements, + $no_gtype + ); + + $self->append($str); +} + +# _PROPERTY_PROXY(name, cpp_type) +# void output_wrap_property($filename, $line_num, $name, $cpp_type) +sub output_wrap_property($$$$$$) +{ + my ($self, $filename, $line_num, $name, $cpp_type, $c_class) = @_; + + my $objDefsParser = $$self{objDefsParser}; + + my $objProperty = GtkDefs::lookup_property($c_class, $name); + if($objProperty eq 0) #If the lookup failed: + { + $self->output_wrap_failed($name, "property defs lookup failed."); + } + elsif($objProperty->get_construct_only() eq 1) + { + $self->output_wrap_failed($name, "Attempt to wrap a construct-only property."); + } + else + { + # We use a suffix to specify a particular Glib::PropertyProxy* class. + my $proxy_suffix = ""; + + # Read/Write: + if($objProperty->get_readable() ne 1) + { + $proxy_suffix = "_WriteOnly"; + } + elsif($objProperty->get_writable() ne 1) + { + $proxy_suffix = "_ReadOnly"; + } + + $name =~ s/-/_/g; + + my $str = sprintf("_PROPERTY_PROXY(%s,%s,%s)dnl\n", + $name, + $cpp_type, + $proxy_suffix + ); + + $self->append($str); + } +} + +# vpod output_temp_g1($filename, $section) e.g. output_temp_g1(button, gtk) +sub output_temp_g1($$) +{ + my ($self, $section) = @_; + + # Write out *.g1 temporary file + open(FILE, '>', "$$self{tmpdir}/gtkmmproc_$$.g1"); # $$ is the Process ID + + print FILE "include(base.m4)dnl\n"; + + my $module = $section; + my $module_canonical = Util::string_canonical($module); #In case there is a / character in the module. + print FILE "_START($$self{source},$module,$module_canonical)dnl\n"; + print FILE join("", @{$$self{out}}); + print FILE "_END()\n"; + close(FILE); +} + +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'"); + return ($? >> 8); +} + +# void write_sections_to_files() +# This is where we snip the /tmp/gtkmmproc*.g2 file into sections (,h, .cc, _private.h) +sub write_sections_to_files() +{ + my ($self) = @_; + + my $fname_h = "$$self{destdir}/$$self{source}.h"; + my $fname_ph = "$$self{destdir}/private/$$self{source}_p.h"; + my $fname_cc = "$$self{destdir}/$$self{source}.cc"; + + open(INPUT, '<', "$$self{tmpdir}/gtkmmproc_$$.g2"); # $$ is the process ID. + + # open tempory file for each section + open(OUTPUT_H, '>', "$fname_h.tmp"); + open(OUTPUT_PH, '>', "$fname_ph.tmp"); + open(OUTPUT_CC, '>', "$fname_cc.tmp"); + + my $oldfh = select(OUTPUT_H); + my $blank = 0; + + while(<INPUT>) + { + # section switching + if(/^#S 0/) { select(OUTPUT_H); next; } + if(/^#S 1/) { select(OUTPUT_PH); next; } + if(/^#S 2/) { select(OUTPUT_CC); next; } + + # get rid of bogus blank lines + if(/^\s*$/) { ++$blank; } else { $blank = 0; } + next if($blank > 2); + + print $_; + } + + select($oldfh); + close(INPUT); + close(OUTPUT_H); + close(OUTPUT_PH); + close(OUTPUT_CC); + + foreach($fname_h, $fname_ph, $fname_cc) + { + # overwrite the source file only if it has actually changed + system("cmp -s '$_.tmp' '$_' || cp '$_.tmp' '$_' ; rm -f '$_.tmp'"); + } +} + + +sub remove_temp_files($) +{ + my ($self) = @_; + + system("rm -f \"$$self{tmpdir}/gtkmmproc_$$.g1\""); + system("rm -f \"$$self{tmpdir}/gtkmmproc_$$.g2\""); +} + + + +# procedure for generating CONVERT macros +# $string convert_args_cpp_to_c($objCppfunc, $objCDefsFunc, $static, $wrap_line_number,$automatic_error) +sub convert_args_cpp_to_c($$$$;$) +{ + my ($objCppfunc, $objCDefsFunc, $static, $wrap_line_number, $automatic_error) = @_; + + $automatic_error = "" unless defined $automatic_error; + + my $cpp_param_names = $$objCppfunc{param_names}; + my $cpp_param_types = $$objCppfunc{param_types}; + my $c_param_types = $$objCDefsFunc{param_types}; + + my @result; + + my $num_c_args_expected = scalar(@{$c_param_types}); + if( !($static) ) { $num_c_args_expected--; } #The cpp method will need an Object* paramater at the start. + + my $num_cpp_args = scalar(@{$cpp_param_types}); + + # add implicit last error parameter; + if ( $automatic_error ne "" && + $num_cpp_args == ($num_c_args_expected - 1) && + ${$c_param_types}[-1] eq "GError**" ) + { + $num_cpp_args++; + $cpp_param_names = [@{$cpp_param_names},"error"]; + $cpp_param_types = [@{$cpp_param_types},"GError*&"]; + } + + if ( $num_cpp_args != $num_c_args_expected ) + { + Output::error( "convert_args_cpp_to_c(): Incorrect number of arguments. (%d != %d)\n", + $num_cpp_args, + $num_c_args_expected ); + $objCppfunc->dump(); + $objCDefsFunc->dump(); + + return ""; + } + + + # Loop through the cpp parameters: + my $i; + my $cpp_param_max = $num_cpp_args; + # if( !($static) ) { $cpp_param_max++; } + + for ($i = 0; $i < $cpp_param_max; $i++) + { + #index of C parameter: + my $iCParam = $i; + if( !($static) ) { $iCParam++; } + + my $cppParamType = $$cpp_param_types[$i]; + $cppParamType =~ s/ &/&/g; #Remove space between type and & + $cppParamType =~ s/ \*/*/g; #Remove space between type and * + + my $cppParamName = $$cpp_param_names[$i]; + my $cParamType = $$c_param_types[$iCParam]; + + if ($cppParamType ne $cParamType) #If a type conversion is needed. + { + + + push(@result, sprintf("_CONVERT(%s,%s,%s,%s)", + $cppParamType, + $cParamType, + $cppParamName, + $wrap_line_number) ); + } + else + { + push(@result, $cppParamName); + } + } + + return join(", ", @result); +} + +# procedure for generating CONVERT macros +# Ignores the first C 'self' argument. +# $string convert_args_c_to_cpp($objCDefsFunc, $objCppFunc, $wrap_line_number) +sub convert_args_c_to_cpp($$$) +{ + my ($objCDefsFunc, $objCppfunc, $wrap_line_number) = @_; + + my $cpp_param_types = $$objCppfunc{param_types}; + my $c_param_types = $$objCDefsFunc{param_types}; + my $c_param_names = $$objCDefsFunc{param_names}; + + my @result; + + my $num_c_args = scalar(@{$c_param_types}); + + my $num_cpp_args = scalar(@{$cpp_param_types}); + + if ( ($num_cpp_args + 1) != $num_c_args ) + { + Output::error( "convert_args_c_to_cpp(): Incorrect number of arguments. (%d != %d)\n", + $num_cpp_args + 1, + $num_c_args); + $objCppfunc->dump(); + $objCDefsFunc->dump(); + + return ""; + } + + + # Loop through the c parameters: + my $i; + my $c_param_max = $num_c_args; + + for ($i = 1; $i < $c_param_max; $i++) + { + #index of C parameter: + my $iCppParam = $i - 1; + + my $cppParamType = $$cpp_param_types[$iCppParam]; + $cppParamType =~ s/ &/&/g; #Remove space between type and &. + $cppParamType =~ s/ \*/*/g; #Remove space between type and * + + my $cParamName = $$c_param_names[$i]; + my $cParamType = $$c_param_types[$i]; + + if ($cParamType ne $cppParamType) #If a type conversion is needed. + { + push(@result, sprintf("_CONVERT(%s,%s,%s,%s)\n", + $cParamType, + $cppParamType, + $cParamName, + $wrap_line_number) ); + } + else + { + push(@result, $cParamName); + } + } + + return join(", ",@result); +} + + +# generates the XXX in g_object_new(get_type(), XXX): A list of property names and values. +# Uses the cpp arg name as the property name. +# $string get_ctor_properties($objCppfunc, $objCDefsFunc, $wrap_line_number) +sub get_ctor_properties($$$$) +{ + my ($objCppfunc, $objCDefsFunc, $wrap_line_number) = @_; + + my $cpp_param_names = $$objCppfunc{param_names}; + my $cpp_param_types = $$objCppfunc{param_types}; + my $c_param_types = $$objCDefsFunc{param_types}; + + my @result; + + my $num_args = scalar(@{$c_param_types}); + + my $num_cpp_args = scalar(@{$cpp_param_types}); + if ( $num_cpp_args != $num_args ) + { + Output::error("get_ctor_properties(): Incorrect number of arguments. (%d != %d)\n", + $num_cpp_args, + $num_args ); + return ""; + } + + + # Loop through the cpp parameters: + my $i = 0; + + for ($i = 0; $i < $num_args; $i++) + { + my $cppParamType = $$cpp_param_types[$i]; + $cppParamType =~ s/ &/&/g; #Remove space between type and & + $cppParamType =~ s/ \*/*/g; #Remove space between type and * + + my $cppParamName = $$cpp_param_names[$i]; + my $cParamType = $$c_param_types[$i]; + + # Property name: + push(@result, "\"" . $cppParamName . "\""); + + # C property value: + if ($cppParamType ne $cParamType) #If a type conversion is needed. + { + push(@result, sprintf("_CONVERT(%s,%s,%s,%s)", + $cppParamType, + $cParamType, + $cppParamName, + $wrap_line_number) ); + } + else + { + push(@result, $cppParamName); + } + } + + return join(", ", @result); +} + +### Convert _WRAP to a corba method +# _CORBA_METHOD(retype, method_name,args, arg_names_only) - implemented in libbonobomm. +# void output_wrap_corba_method($filename, $line_num, $objCppFunc) +sub output_wrap_corba_method($$$$) +{ + my ($self, $filename, $line_num, $objCppfunc) = @_; + + my $str = sprintf("_CORBA_METHOD(%s,%s,\`%s\',\`%s\')dnl\n", + $$objCppfunc{rettype}, + $$objCppfunc{name}, + $objCppfunc->args_types_and_names(), + $objCppfunc->args_names_only() + ); + + $self->append($str); +} + + +1; # indicate proper module load. diff --git a/tools/pm/Property.pm b/tools/pm/Property.pm new file mode 100644 index 00000000..1f446015 --- /dev/null +++ b/tools/pm/Property.pm @@ -0,0 +1,94 @@ +package Property; + +use strict; +use warnings; + +BEGIN { + use Exporter (); + our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS); + + # set the version for version checking + $VERSION = 1.00; + @ISA = qw(Exporter); + @EXPORT = qw(&func1 &func2 &func4); + %EXPORT_TAGS = ( ); + # your exported package globals go here, + # as well as any optionally exported functions + @EXPORT_OK = qw($Var1 %Hashit &func3); + } +our @EXPORT_OK; + +# class Property +# { +# string name; +# string class; +# string type; +# bool readable; +# bool writable; +# bool construct_only; +# } + + +sub new +{ + my ($def) = @_; + my $self = {}; + bless $self; + + $def=~s/^\(//; + $def=~s/\)$//; + # snarf down the fields + $$self{mark} = 0; + $$self{name} = $1 if ($def =~ s/^define-property (\S+)//); + $$self{class} = $1 if ($def =~ s/\(of-object "(\S+)"\)//); + $$self{type} = $1 if ($def =~ s/\(prop-type "(\S+)"\)//); + $$self{readable} = ($1 eq "#t") if ($def =~ s/\(readable (\S+)\)//); + $$self{writable} = ($1 eq "#t") if ($def =~ s/\(writable (\S+)\)//); + $$self{construct_only} = ($1 eq "#t") if ($def =~ s/\(construct-only (\S+)\)//); + + $$self{name} =~ s/-/_/g; # change - to _ + + GtkDefs::error("Unhandled property def ($def) in $$self{class}\::$$self{name}\n") + if ($def !~ /^\s*$/); + + return $self; +} + +sub dump($) +{ + my ($self) = @_; + + print "<property>\n"; + + foreach (keys %$self) + { print " <$_ value=\"$$self{$_}\"/>\n"; } + + print "</property>\n\n"; +} + +sub get_construct_only($) +{ + my ($self) = @_; + return $$self{construct_only}; +} + +sub get_type($) +{ + my ($self) = @_; + return $$self{type}; +} + +sub get_readable($) +{ + my ($self) = @_; + return $$self{readable}; +} + +sub get_writable($) +{ + my ($self) = @_; + return $$self{writable}; +} + + +1; # indicate proper module load. diff --git a/tools/pm/Util.pm b/tools/pm/Util.pm new file mode 100644 index 00000000..c3076b4e --- /dev/null +++ b/tools/pm/Util.pm @@ -0,0 +1,113 @@ +# gtkmm - Util module +# +# Copyright 2001 Free Software Foundation +# +# 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. +# +# +# This file holds basic functions used throughout gtkmmproc modules. +# Functions in this module are exported so there is no need to +# request them by module name. +# +package Util; +use strict; +use warnings; + +BEGIN { + use Exporter (); + our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS); + + # set the version for version checking + $VERSION = 1.00; + @ISA = qw(Exporter); + @EXPORT = qw(&string_unquote &string_trim &string_canonical + &trace &unique); + %EXPORT_TAGS = ( ); + + # your exported package globals go here, + # as well as any optionally exported functions + #@EXPORT_OK = qw($Var1 %Hashit &func3); + } +our @EXPORT_OK; + + +#$ string_unquote($string) +# Removes leading and trailing quotes. +sub string_unquote($) +{ + my ($str) = @_; + + $str =~ s/^['`"]// ; + $str =~ s/['`"]$// ; + + return $str; +} + +# $ string_trim($string) +# Removes leading and trailing white space. +sub string_trim($) +{ + ($_) = @_; + s/^\s+//; + s/\s+$//; + return $_; +} + +# $ string_canonical($string) +# Convert - to _. +sub string_canonical($) +{ + ($_) = @_; + s/-/_/g ; # g means 'replace all' + s/\//_/g ; # g means 'replace all' + return $_; +} + +# +# Back tracing utility. +# Prints the call stack. +# +# void trace() +sub trace() +{ + my ($package, $filename, $line, $subroutine, $hasargs, + $wantarray, $evaltext, $is_require, $hints, $bitmask) = caller(1); + + no warnings qw(uninitialized); + + my $i = 2; + print "Trace on ${subroutine} called from ${filename}:${line}\n"; + while (1) + { + ($package, $filename, $line, $subroutine) = caller($i); + $i++; + next if ($line eq ""); + print " From ${subroutine} call from ${filename}:${line}\n"; + } +} + +sub unique(@) +{ + my %hash; + foreach (@_) + { + $hash{$_}=1; + } + + return keys %hash; +} + +1; # indicate proper module load. + diff --git a/tools/pm/WrapParser.pm b/tools/pm/WrapParser.pm new file mode 100644 index 00000000..ce0a5604 --- /dev/null +++ b/tools/pm/WrapParser.pm @@ -0,0 +1,1197 @@ +# gtkmm - WrapParser module +# +# Copyright 2001 Free Software Foundation +# +# 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 WrapParser; +use strict; +use warnings; +use Util; +use GtkDefs; +use Function; +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; + +############################################################################ + +my @tokens = (); + +# $objWrapParser new($objOutputter) +sub new($) +{ + my ($objOutputter) = @_; + + my $self = {}; + bless $self; + + #Initialize member data: + $$self{objOutputter} = $objOutputter; + $$self{filename} = "(none)"; + $$self{line_num} = 0; + $$self{mergecdocs} = 0; + + $$self{level} = 0; + $$self{class} = ""; + $$self{c_class} = ""; + $$self{in_class} = 0; + $$self{first_namespace} = 1; + $$self{namespace} = []; + $$self{in_namespace} = []; + + $$self{defsdir} = "."; + + $$self{module} = ""; #e.g. "gtkmm" + + $$self{type} = "GTKOBJECT"; # or "BOXEDTYPE", or "GOBJECT" - wrapped differently. + + return $self; +} + +# void parse_and_build_output() +sub parse_and_build_output($) +{ + my ($self) = @_; + + my $objOutputter = $$self{objOutputter}; + + # Parse the tokens. + my $token; + while ( scalar(@tokens) ) + { + $token = $self->extract_token(); + my $bAppend = 1; + + # we need to monitor the depth of braces + if ($token eq '{') { $self->on_open_brace(); } + if ($token eq '}') { $self->on_close_brace(); $bAppend = 0;} + + # protect `' from the source file from m4 + if ($token eq "`") { $objOutputter->append("`'__BT__`'"); next; } + if ($token eq "'") { $objOutputter->append("`'__FT__`'"); next; } + + if ($token eq '"') { $objOutputter->append($self->on_string_literal()); next; } + if ($token eq '//') { $objOutputter->append($self->on_comment_cpp()); next; } + if ($token eq '/*') { $objOutputter->append($self->on_comment_c()); next; } + + # handle #m4begin ... #m4end + if ($token eq "#m4begin") { $objOutputter->append($self->on_m4_section()); next;} + + # handle #m4 ... \n + if ($token eq "#m4") { $objOutputter->append($self->on_m4_line()); next;} + + if ($token eq "_DEFS") { $self->on_defs(); next;} #Read the defs file. + if ($token eq "_IGNORE") { $self->on_ignore(); next;} #Ignore a function. + if ($token eq "_IGNORE_SIGNAL") { $self->on_ignore_signal(); next;} + if ($token eq "_WRAP_METHOD") { $self->on_wrap_method(); next;} + if ($token eq "_WRAP_CORBA_METHOD") { $self->on_wrap_corba_method(); next;} #Used in libbonobo*mm. + if ($token eq "_WRAP_SIGNAL") { $self->on_wrap_signal(); next;} + if ($token eq "_WRAP_PROPERTY") { $self->on_wrap_property(); next;} + if ($token eq "_WRAP_VFUNC") { $self->on_wrap_vfunc(); next;} + if ($token eq "_WRAP_CTOR") { $self->on_wrap_ctor(); next;} + if ($token eq "_WRAP_CREATE") { $self->on_wrap_create(); next;} + + if ($token eq "_WRAP_ENUM") { $self->on_wrap_enum(); next;} + if ($token eq "_WRAP_GERROR") { $self->on_wrap_gerror(); next;} + + my $prefix_class = "_CLASS_"; # e.g. _CLASS_GTKOBJECT + my $token_prefix = substr($token, 0, length($prefix_class)); + if ($token_prefix eq $prefix_class) + { + $self->on_class($token); + next; + + # e.g.: + # _CLASS_GENERIC + # _CLASS_GOBJECT + # _CLASS_GTKOBJECT + # _CLASS_BOXEDTYPE + # _CLASS_BOXEDTYPE_STATIC + # _CLASS_INTERFACE + # _CLASS_OPAQUE_COPYABLE + # _CLASS_OPAQUE_REFCOUNTED + } + + if ($token eq "namespace") { $self->on_namespace() }; + + # After all token manipulations + if($bAppend) + { + $objOutputter->append($token); + } + } +} + +sub error($$) +{ + my ($self, $format) = @_; + + $format = "$$self{filename}:$$self{line_num}: $format"; + printf STDERR $format,@_; +} + +###################################################################### +##### 1.1 parser subroutines + +######################################## +### returns the next token, ignoring some stuff. +# $string extract_token() +sub extract_token($) +{ + my ($self) = @_; + + while ( scalar(@tokens) ) + { + $_ = shift @tokens; + + # skip empty tokens + next if ( !defined($_) or $_ eq "" ); + + # eat line statements. TODO: e.g.? + if ( /^#l (\S+)\n/) + { + $$self{line_num} = $1; + next; + } + + # eat file statements. TODO: e.g.? + if ( /^#f (\S+)\n/) + { + $$self{filename} = $1; + next; + } + + return $_; + } + + return ""; +} + +# bool tokens_remaining() +sub tokens_remaining($) +{ + my ($self) = @_; + return scalar(@tokens)!=0; +} + + +######################################## +### we pass strings literally with quote substitution +# void on_string_literal() +sub on_string_literal($) +{ + my ($self) = @_; + + my @out; + push (@out, '"'); + while ( scalar(@tokens) ) + { + $_ = $self->extract_token(); + if ($_ eq "`") { push(@out, "`'__BT__`'"); next; } + if ($_ eq "'") { push(@out, "`'__FT__`'"); next; } + push (@out, $_); + + return join("",@out) if ($_ eq '"'); + } + + my $line_num = $$self{line_num}; + my $filename = $$self{filename}; + print STDERR "$filename:$line_num: Hit eof while in string\n"; +} + + +######################################## +### we pass comments literally with quote substitution +# void on_comment_cpp() +sub on_comment_cpp($) +{ + my ($self) = @_; + + my @out; + push (@out,"//\`"); + while ( scalar(@tokens) ) + { + $_ = $self->extract_token(); + if ($_ eq "`") { push(@out,"\'__BT__\`"); next; } + if ($_ eq "'") { push(@out,"\'__FT__\`"); next; } + if ($_ eq "\n") + { + push (@out,"\'\n"); + return join("",@out) + } + + if ($_ =~ /^_[A-Z]+$/) {$_="_$_";} # wipe out potential macros + + push (@out,$_); + } +} + + +######################################## +### we pass C comments literally with quote substitution +# void on_comment_c() +sub on_comment_c($) +{ + my ($self) = @_; + + my @out; + push (@out,"/*\`"); + while ( scalar(@tokens) ) + { + $_ = $self->extract_token(); + if ($_ eq "`") { push(@out,"\'__BT__\`"); next; } + if ($_ eq "'") { push(@out,"\'__FT__\`"); next; } + if ($_ eq "*/") + { + push (@out,"\'*/"); + return join("",@out) + } + + push (@out,$_); + } +} + + +######################################## +### handle #m4begin ... #m4end +# we don't substitute ` or ' in #m4begin +# void on_m4_section() +sub on_m4_section($) +{ + my ($self) = @_; + + my @value; + my $token; + + while ( scalar(@tokens) ) + { + $token = $self->extract_token(); + return join("", @value) if ($token eq "#m4end"); + push(@value, $token); + } + + my $line_num = $$self{line_num}; + my $filename = $$self{filename}; + print STDERR "$filename:$line_num: Hit eof looking for #m4end\n"; + next; +} + + +######################################## +### handle #m4 ... /n +# we don't substitute ` or ' in #m4 +# void on_m4_line() +sub on_m4_line ($) +{ + my ($self) = @_; + + my @value; + my $token; + while ( scalar(@tokens) ) + { + $token = $self->extract_token(); + push(@value,$token); # push first, so we don't eat the newline + return join("",@value) if ($token eq "\n"); + } +} + + +######################################## +# m4 needs to know when we entered a namespace +# void on_namespace() +sub on_namespace($) +{ + my ($self) = @_; + my $objOutputter = $$self{objOutputter}; + + my $number = 0; + my $token; + my $arg; + + # we need to peek ahead to figure out what type of namespace + # declaration this is. + while ( $number < scalar(@tokens) ) + { + $token = $tokens[$number]; + $number++; + next if (!defined($token) or $token eq ""); +# print "> $token\n"; + + if ($token eq '{') + { + $arg = string_trim($arg); + + if ($$self{first_namespace}) + { + $objOutputter->append("_SECTION(SECTION_HEADER2)\n"); + $$self{first_namespace} = 0; + } + + $objOutputter->append("_NAMESPACE($arg)"); + unshift(@{$$self{namespace}}, $arg); + unshift(@{$$self{in_namespace}}, $$self{level}+1); + return; + } + + next if ( $token =~ /^#[lf] \S+\n/); + return if ($token eq ';'); + + $arg .= $token; #concatenate + } +} + + +######################################## +### we don't want to report every petty function as unwrapped +# void on_ignore($) +sub on_ignore($) +{ + my ($self) = @_; + my $str = $self->extract_bracketed_text(); + my @args = split(/\s+|,/,$str); + foreach (@args) + { + next if ($_ eq ""); + GtkDefs::lookup_function($_); #Pretend that we've used it. + } +} + +sub on_ignore_signal($) +{ + my ($self) = @_; + my $str = $self->extract_bracketed_text(); + my @args = split(/\s+|,/,$str); + foreach (@args) + { + next if ($_ eq ""); + GtkDefs::lookup_signal($$self{c_class}, $_); #Pretend that we've used it. + } +} + +######################################## +### we have certain macros we need to insert at end of statements +# void on_class($, $strClassCommand) +sub on_class($$) +{ + my ($self, $class_command) = @_; + + my $objOutputter = $$self{objOutputter}; + + $$self{in_class} = $$self{level}; + + #Remember the type of wrapper required, so that we can append the correct _END_CLASS_* macro later. + { + my $str = $class_command; + $str =~ s/^_CLASS_//; + $$self{type} = $str; + } + + my $str = $self->extract_bracketed_text(); + my ($class, $c_class) = split(',',$str); + $class = string_trim($class); + $c_class = string_trim($c_class); + + $$self{class} = $class; + $$self{c_class} = $c_class; + + my @back; + push(@back, $class_command); + push(@back, "($str)"); + + # When we hit _CLASS, we walk backwards through the output to find "class" + my $token; + while ( scalar(@{$$objOutputter{out}}) > 0) + { + $token = pop @{$$objOutputter{out}}; + unshift(@back, $token); + if ($token eq "class") + { + $objOutputter->append("_CLASS_START()"); + + my $strBack = join("", @back); + + $objOutputter->append($strBack); + return; + } + } + + $self->error("$class_command outside of class.\n"); + exit(-1); +} + + +# order to read the defs file +# void on_defs() +sub on_defs($) +{ + my ($self) = @_; + + my $str = $self->extract_bracketed_text(); + my ($module, $defsfile) = split(/,/, $str); #e.g. _DEFS(gtkmm,gtk), where gtkmm is the module name, and gtk is the defs file name. + # $$self{section} = $section; #Save it so that we can reuse it in read_defs_included. + $$self{module} = $module; #Use it later in call to output_temp_g1(). + + GtkDefs::read_defs("$$self{defsdir}", "$defsfile.defs"); + + #Read the documentation too, so that we can merge it into the generated C++ code: + if($$self{mergecdocs}) + { + my $docs_filename = $defsfile . "_docs.xml"; + my $docs_filename_override = $defsfile . "_docs_override.xml"; + DocsParser::read_defs("$$self{defsdir}", $docs_filename, $docs_filename_override); + } +} + +# void on_open_brace() +sub on_open_brace($) +{ + my ($self) = @_; + + $$self{level}++; +} + +# void on_close_brace($) +sub on_close_brace($) +{ + my ($self) = @_; + my $objOutputter = $$self{objOutputter}; + + #push(@out, "($$self{level})"); + + $self->on_end_class() + if ($$self{in_class} && $$self{in_class} == $$self{level}); + + $objOutputter->append("}"); #We append it here instead of after we return, so that we can end the namespace after it. + + $self->on_end_namespace() + if ( (scalar(@{$$self{in_namespace}}) > 0) && (@{$$self{in_namespace}}[0] == $$self{level}) ); + + $$self{level}--; +} + + +######################################## +### denote the end of a class +# void on_end_class($) +sub on_end_class($) +{ + my ($self) = @_; + my $objOutputter = $$self{objOutputter}; + + # Examine $$self{type}, which was set in on_class() + # And append the _END_CLASS_* macro, which will, in turn, output the m4 code. + { + my $str = $$self{type}; + $objOutputter->append("`'_END_CLASS_$str()\n"); + } + + $$self{class} = ""; + $$self{c_class} = ""; + $$self{in_class} = 0; +} + + +######################################## +### +# void on_end_namespace($) +sub on_end_namespace($) +{ + my ($self) = @_; + my $objOutputter = $$self{objOutputter}; + + $objOutputter->append("`'_END_NAMESPACE()"); + shift( @{$$self{namespace}} ); + shift( @{$$self{in_namespace}} ); +} + + +###################################################################### +##### some utility subroutines + +######################################## +### takes (\S+) from the tokens (smart) +# $string extract_bracketed_text() +sub extract_bracketed_text($) +{ + my ($self) = @_; + + my $level = 1; + my $str = ""; + + # Move to the first "(": + while ( scalar(@tokens) ) + { + my $t = $self->extract_token(); + last if ($t eq "("); + } + + # Concatenate until the corresponding ")": + while ( scalar(@tokens) ) + { + my $t = $self->extract_token(); + $level++ if ($t eq "("); + $level-- if ($t eq ")"); + + return $str if (!$level); + $str .= $t; + } + + return ""; +} + + +######################################## +### breaks up a string by commas (smart) +# @strings string_split_commas($string) +sub string_split_commas($) +{ + my ($in) = @_; + + my @out; + my $level = 0; + my $str = ""; + my @in = split(/([,()])/, $in); + + while ($#in > -1) + { + my $t = shift @in; + + next if ($t eq ""); + $level++ if ($t eq "("); + $level-- if ($t eq ")"); + + # skip , inside functions Ie. void (*)(int,int) + if ( ($t eq ",") && !$level) + { + push(@out, $str); + $str=""; + next; + } + + $str .= $t; + } + + push(@out,$str); + return @out; +} + + +######################################## +### reads in the preprocessor files +# we insert line and file directives for later stages +# void read_file() +sub read_file($$$) +{ + my ($self, $srcdir, $source) = @_; + + my $line; + my @in; + + if ( ! -r "${srcdir}/${source}.hg") + { + print "Unable to find header file $srcdir/$source.hg\n"; + exit(-1); + } + + # Read header file: + open(FILE, "${srcdir}/${source}.hg"); +# push(@in, "#f ${source}.hg\n"); #TODO: What does #f do? + $line = 1; + while (<FILE>) + { +# push(@in, "#l $line\n"); #TODO: What does #l do? + push(@in, $_); + $line++; + } + close(FILE); + push(@in, "\n_SECTION(SECTION_SRC_CUSTOM)\n"); + + # Source file is optional. + if ( -r "${srcdir}/${source}.ccg") + { + open(FILE, "${srcdir}/${source}.ccg"); + $line = 1; +# push(@in, "#f ${source}.ccg\n"); #TODO: What does #f do? + while (<FILE>) + { +# push(@in, "#l $line\n"); #TODO: What does #l do? + push(@in, $_); + $line++; + } + close(FILE); + } + + my $strIn = join("", @in); + + # Break the file into tokens. Token is + # any group of #, A to z, 0 to 9, _ + # /* + # *. + # // + # any char proceeded by \ + # symbols ;{}"`'() + # newline + @tokens = split(/(\#[lf] \S+\n)|([#A-Za-z0-9_]+)|(\/\*)|(\*\/)|(\/\/)|(\\.)|([;{}"'`()])|(\n)/, + $strIn); +} + + +sub class_prefix($) +{ + my ($self) = @_; + + my $str = $$self{class}; + $str =~ s/([a-z])([A-Z])/$1_$2/g; + $str =~ tr/A-Z/a-z/; + return $str; +} + + +###################################################################### +##### 2.1 subroutines for _WRAP + +######################################## + +# $bool check_for_eof() +sub check_for_eof($) +{ + my ($self) = @_; + + my $filename = $$self{filename}; + my $line_num = $$self{line_num}; + + if (!(scalar(@tokens))) + { + print STDERR "$filename:$line_num:hit eof in _WRAP\n"; + return 0; #EOF + } + + return 1; # No EOF +} + +# void on_wrap_method() +sub on_wrap_method($) +{ + my ($self) = @_; + my $objOutputter = $$self{objOutputter}; + + if( !($self->check_for_eof()) ) + { + return; + } + + my $filename = $$self{filename}; + my $line_num = $$self{line_num}; + + my $str = $self->extract_bracketed_text(); + my @args = string_split_commas($str); + + my $entity_type = "method"; + + if (!$$self{in_class}) + { + print STDERR "$filename:$line_num:_WRAP macro encountered outside class\n"; + return; + } + + my $objCfunc; + my $objCppfunc; + + # handle first argument + my $argCppMethodDecl = $args[0]; + if ($argCppMethodDecl =~ /^\S+$/ ) #Checks that it's not empty and that it contains no whitespace. + { + print STDERR "$filename:$line_num:_WRAP can't handle unspecified method $argCppMethodDecl\n"; + return; + } + else + { + #Parse the method decaration and build an object that holds the details: + $objCppfunc = &Function::new($argCppMethodDecl, $self); + } + + + # handle second argument: + + my $argCFunctionName = $args[1]; + $argCFunctionName = string_trim($argCFunctionName); + + #Get the c function's details: + + #Checks that it's not empty and that it contains no whitespace. + if ($argCFunctionName =~ /^\S+$/ ) + { + #c-name. e.g. gtk_clist_set_column_title + $objCfunc = GtkDefs::lookup_function($argCFunctionName); + + if(!$objCfunc) #If the lookup failed: + { + $objOutputter->output_wrap_failed($argCFunctionName, "method defs lookup failed (1)"); + return; + } + } + + # Extra ref needed? + while(scalar(@args) > 2) # If the optional ref/err arguments are there. + { + my $argRef = string_trim(pop @args); + if($argRef eq "refreturn") + { + $$objCfunc{rettype_needs_ref} = 1; + } + if($argRef eq "errthrow") + { + $$objCfunc{throw_any_errors} = 1; + } + } + + my $commentblock = ""; + $commentblock = DocsParser::lookup_documentation($argCFunctionName); + + $objOutputter->output_wrap_meth($filename, $line_num, $objCppfunc, $objCfunc, $argCppMethodDecl, $commentblock); +} + +sub on_wrap_ctor($) +{ + my ($self) = @_; + my $objOutputter = $$self{objOutputter}; + + if( !($self->check_for_eof()) ) + { + return; + } + + my $filename = $$self{filename}; + my $line_num = $$self{line_num}; + + my $str = $self->extract_bracketed_text(); + my @args = string_split_commas($str); + + my $entity_type = "method"; + + if (!$$self{in_class}) + { + print STDERR "$filename:$line_num:_WRAP_CTOR macro encountered outside class\n"; + return; + } + + my $objCfunc; + my $objCppfunc; + + # handle first argument + my $argCppMethodDecl = $args[0]; + if ($argCppMethodDecl =~ /^\S+$/ ) #Checks that it's not empty and that it contains no whitespace. + { + print STDERR "$filename:$line_num:_WRAP_CTOR can't handle unspecified method $argCppMethodDecl\n"; + return; + } + else + { + #Parse the method decaration and build an object that holds the details: + $objCppfunc = &Function::new_ctor($argCppMethodDecl, $self); + } + + + # handle second argument: + + my $argCFunctionName = $args[1]; + $argCFunctionName = string_trim($argCFunctionName); + + #Get the c function's details: + if ($argCFunctionName =~ /^\S+$/ ) #Checks that it's not empty and that it contains no whitespace. + { + $objCfunc = GtkDefs::lookup_function($argCFunctionName); #c-name. e.g. gtk_clist_set_column_title + if(!$objCfunc) #If the lookup failed: + { + $objOutputter->output_wrap_failed($argCFunctionName, "ctor defs lookup failed (2)"); + return; + } + } + + $objOutputter->output_wrap_ctor($filename, $line_num, $objCppfunc, $objCfunc, $argCppMethodDecl); +} + +sub on_wrap_create($) +{ + my ($self) = @_; + + if( !($self->check_for_eof()) ) + { + return; + } + + my $str = $self->extract_bracketed_text(); + + my $objOutputter = $$self{objOutputter}; + $objOutputter->output_wrap_create($str, $self); +} + +sub on_wrap_signal($) +{ + my ($self) = @_; + + if( !($self->check_for_eof()) ) + { + return; + } + + my $str = $self->extract_bracketed_text(); + my @args = string_split_commas($str); + + #Get the arguments: + my $argCppDecl = $args[0]; + my $argCName = $args[1]; + $argCName = string_trim($argCName); + $argCName = string_unquote($argCName); + + my $bCustomDefaultHandler = 0; + if(scalar(@args) > 2) # If the optional argument is there. + { + my $argRef = string_trim($args[2]); + if($argRef eq "custom_default_handler") + { + $bCustomDefaultHandler = 1; + } + } + + my $bImplement = 1; + if( $bCustomDefaultHandler eq 1) { $bImplement = 0 }; + + $self->output_wrap_signal( $argCppDecl, $argCName, $$self{filename}, $$self{line_num}, $bImplement); +} + +# void on_wrap_vfunc() +sub on_wrap_vfunc($) +{ + my ($self) = @_; + + if( !($self->check_for_eof()) ) + { + return; + } + + my $str = $self->extract_bracketed_text(); + my @args = string_split_commas($str); + + #Get the arguments: + my $argCppDecl = $args[0]; + my $argCName = $args[1]; + $argCName = string_trim($argCName); + $argCName = string_unquote($argCName); + + my $refreturn = 0; + my $refreturn_ctype = 0; + + # Extra ref needed? + while(scalar(@args) > 2) # If the optional ref/err arguments are there. + { + my $argRef = string_trim(pop @args); + + if($argRef eq "refreturn") + { $refreturn = 1; } + elsif($argRef eq "refreturn_ctype") + { $refreturn_ctype = 1; } + } + + $self->output_wrap_vfunc($argCppDecl, $argCName, $refreturn, $refreturn_ctype, + $$self{filename}, $$self{line_num}); +} + +sub on_wrap_enum($) +{ + my ($self) = @_; + + return if(!$self->check_for_eof()); + + my $outputter = $$self{objOutputter}; + my $out = \@{$$outputter{out}}; + + # Look back for a Doxygen comment for this _WRAP_ENUM. If there is one, + # remove it from the output and pass it to the m4 _ENUM macro instead. + my $comment = ""; + + if(scalar(@$out) >= 2) + { + # steal the last two tokens + my @back = splice(@$out, -2); + local $_ = $back[0]; + + # Check for /*[*!] ... */ or //[/!] comments. The closing */ _must_ + # be the last token of the previous line. Apart from this restriction, + # anything else should work, including multi-line comments. + + if($back[1] eq "\n" && (m#^/\*`[*!](.+)'\*/#s || m#^//`[/!](.+)'$#)) + { + $comment = $1; + $comment =~ s/\s+$//; + } + else + { + # restore stolen tokens + push(@$out, @back); + } + } + + # get the arguments + my @args = string_split_commas($self->extract_bracketed_text()); + + my $cpp_type = string_trim(shift(@args)); + my $c_type = string_trim(shift(@args)); + + # The remaining elements in @args could be flags or s#^FOO_## substitutions. + + $outputter->output_wrap_enum( + $$self{filename}, $$self{line_num}, $cpp_type, $c_type, $comment, @args); +} + +sub on_wrap_gerror($) +{ + my ($self) = @_; + + return if(!$self->check_for_eof()); + + # get the arguments + my @args = string_split_commas($self->extract_bracketed_text()); + + my $cpp_type = string_trim(shift(@args)); + my $c_enum = string_trim(shift(@args)); + my $domain = string_trim(shift(@args)); + + # The remaining elements in @args could be flags or s#^FOO_## substitutions. + + $$self{objOutputter}->output_wrap_gerror( + $$self{filename}, $$self{line_num}, $cpp_type, $c_enum, $domain, @args); +} + +sub on_wrap_property($) +{ + my ($self) = @_; + my $objOutputter = $$self{objOutputter}; + + if( !($self->check_for_eof()) ) + { + return; + } + + my $str = $self->extract_bracketed_text(); + my @args = string_split_commas($str); + + #Get the arguments: + my $argPropertyName = $args[0]; + $argPropertyName = string_trim($argPropertyName); + $argPropertyName = string_unquote($argPropertyName); + my $argCppType = $args[1]; + $argCppType = string_trim($argCppType); + $argCppType = string_unquote($argCppType); + + my $filename = $$self{filename}; + my $line_num = $$self{line_num}; + + $objOutputter->output_wrap_property($filename, $line_num, $argPropertyName, $argCppType, $$self{c_class}); +} + + +sub output_wrap_check($$$$$$) +{ + my ($self, $CppDecl, $signal_name, $filename, $line_num, $macro_name) = @_; + + #Some checks: + + + if (!$$self{in_class}) + { + print STDERR "$filename:$line_num: $macro_name macro encountered outside class\n"; + return; + } + + if ($CppDecl =~ /^\S+$/ ) #If it's not empty and it contains no whitespace. + { + print STDERR "$filename:$line_num:$macro_name can't handle unspecified entity $CppDecl\n"; + return; + } + + +} + +# void output_wrap($CppDecl, $signal_name, $filename, $line_num) +# Also used for vfunc. +sub output_wrap_signal($$$$$$) +{ + my ($self, $CppDecl, $signal_name, $filename, $line_num, $bImplement) = @_; + + #Some checks: + $self->output_wrap_check($CppDecl, $signal_name, $filename, $line_num, "WRAP_SIGNAL"); + + # handle first argument + + #Parse the method decaration and build an object that holds the details: + my $objCppSignal = &Function::new($CppDecl, $self); + $$objCppSignal{class} = $$self{class}; #Remeber the class name for use in Outputter::output_wrap_signal(). + + + # handle second argument: + my $objCSignal = undef; + + my $objOutputter = $$self{objOutputter}; + + #Get the c function's details: + if ($signal_name ne "" ) #If it's not empty and it contains no whitespace. + { + $objCSignal = GtkDefs::lookup_signal($$self{c_class}, $signal_name); + + # Check for failed lookup. + if($objCSignal eq 0) + { + print STDERR "$signal_name\n"; + $objOutputter->output_wrap_failed($signal_name, + " signal defs lookup failed"); + return; + } + } + + #If the C types and C++ types are different, then create a custom SignalProxy, + #which will do the C-to-C++ conversion in its C callback. +# my $no_type_conversion = $objCSignal->has_same_types($objCppSignal); +# my $custom_signalproxy_name = ""; +# if($no_type_conversion ne 1) +# { +# $custom_signalproxy_name = $$objCppSignal{class} . "_" . $$objCppSignal{name}; +# $objOutputter->output_wrap_sig_custom($filename, $line_num, $objCSignal, $objCppSignal, $custom_signalproxy_name); +# } + + $objOutputter->output_wrap_sig_decl($filename, $line_num, $objCSignal, $objCppSignal, $signal_name); + $objOutputter->output_wrap_default_signal_handler_h($filename, $line_num, $objCppSignal, $objCSignal); + $objOutputter->output_wrap_default_signal_handler_cc($filename, $line_num, $objCppSignal, $objCSignal, $bImplement); +} + +# void output_wrap($CppDecl, $signal_name, $filename, $line_num) +# Also used for vfunc. +sub output_wrap_vfunc($$$$$$$) +{ + my ($self, $CppDecl, $vfunc_name, $refreturn, $refreturn_ctype, $filename, $line_num) = @_; + + #Some checks: + $self->output_wrap_check($CppDecl, $vfunc_name, $filename, $line_num, "VFUNC"); + + # handle first argument + + #Parse the method decaration and build an object that holds the details: + my $objCppVfunc = &Function::new($CppDecl, $self); + + + # handle second argument: + my $objCVfunc = undef; + + my $objOutputter = $$self{objOutputter}; + + #Get the c function's details: + if ($vfunc_name =~ /^\S+$/ ) #If it's not empty and it contains no whitespace. + { + $objCVfunc = GtkDefs::lookup_signal($$self{c_class},$vfunc_name); + if(!$objCVfunc) #If the lookup failed: + { + $objOutputter->output_wrap_failed($vfunc_name, " vfunc defs lookup failed"); + return; + } + } + + # Write out the appropriate macros. + # These macros are defined in vfunc.m4: + + $$objCppVfunc{rettype_needs_ref} = $refreturn; + $$objCppVfunc{name} .= "_vfunc"; #All vfuncs should have the "_vfunc" prefix, and a separate easily-named invoker method. + + $$objCVfunc{rettype_needs_ref} = $refreturn_ctype; + + $objOutputter->output_wrap_vfunc_h($filename, $line_num, $objCppVfunc, $objCVfunc); + $objOutputter->output_wrap_vfunc_cc($filename, $line_num, $objCppVfunc, $objCVfunc); +} + +# give some sort of weights to sorting attibutes +sub byattrib() +{ + my %attrib_value = ( + "virtual_impl" ,1, + "virtual_decl" ,2, + # "sig_impl" ,3, + "sig_decl" ,4, + "meth" ,5 + ); + + # $a and $b are hidden parameters to a sorting function + return $attrib_value{$b} <=> $attrib_value{$a}; +} + + +# void on_wrap_corba_method() +sub on_wrap_corba_method($) +{ + my ($self) = @_; + my $objOutputter = $$self{objOutputter}; + + if( !($self->check_for_eof()) ) + { + return; + } + + my $filename = $$self{filename}; + my $line_num = $$self{line_num}; + + my $str = $self->extract_bracketed_text(); + my @args = string_split_commas($str); + + my $entity_type = "method"; + + if (!$$self{in_class}) + { + print STDERR "$filename:$line_num:_WRAP macro encountered outside class\n"; + return; + } + + my $objCfunc; + my $objCppfunc; + + # handle first argument + my $argCppMethodDecl = $args[0]; + if ($argCppMethodDecl =~ /^\S+$/ ) #Checks that it's not empty and that it contains no whitespace. + { + print STDERR "$filename:$line_num:_WRAP can't handle unspecified method $argCppMethodDecl\n"; + return; + } + else + { + #Parse the method decaration and build an object that holds the details: + $objCppfunc = &Function::new($argCppMethodDecl, $self); + } + + $objOutputter->output_wrap_corba_method($filename, $line_num, $objCppfunc); +} + + +1; # return package loaded okay. |