Examples for generating various perl_checker's fake packages: generate_perl_checker=1 perl -MGlib::Object::Introspection -e 'Glib::Object::Introspection->setup(basename => "Atk", version => "1.0", package => "Atk"); Glib::Object::Introspection::generate_perl_checker()' generate_perl_checker=1 perl -MGlib::Object::Introspection -e 'Glib::Object::Introspection->setup(basename => "Gio", version => "2.0", package => "Gio"); Glib::Object::Introspection::generate_perl_checker()' generate_perl_checker=1 perl -MGlib::Object::Introspection -e 'Glib::Object::Introspection->setup(basename => "GObject", version => "2.0", package => "GObject"); Glib::Object::Introspection::generate_perl_checker()' #generate_perl_checker=1 perl -MGlib::Object::Introspection -e 'Glib::Object::Introspection->setup(basename => "Notify", version => "0.7", package => "Notify"); Glib::Object::Introspection::generate_perl_checker()' generate_perl_checker=1 perl -MGlib::Object::Introspection -e 'Glib::Object::Introspection->setup(basename => "GdkX11", version => "3.0", package => "Gtk3::GdkX11"); Glib::Object::Introspection::generate_perl_checker()' #generate_perl_checker=1 perl -MGtk3::Notify -e 'Glib::Object::Introspection::generate_perl_checker()' generate_perl_checker=1 perl -MGtk4 -e 'Glib::Object::Introspection::generate_perl_checker()' #generate_perl_checker=1 perl -MGlib::Object::Introspection -e 'Glib::Object::Introspection->setup(basename => "Gtk", version => "4.0", package => "Gtk"); Glib::Object::Introspection::generate_perl_checker()' generate_perl_checker=1 perl -MGtk3 -e 'Glib::Object::Introspection::generate_perl_checker()' generate_perl_checker=1 perl -MGlib::IO -e 'Glib::Object::Introspection::generate_perl_checker()' generate_perl_checker=1 perl -MGtk3::WebKit2 -e 'Glib::Object::Introspection::generate_perl_checker()' generate_perl_checker=1 perl -MGtk3::WebKit -e 'Glib::Object::Introspection::generate_perl_checker()' --- ./lib/Glib/Object/Introspection.pm.tv 2015-12-21 19:12:53.000000000 +0100 +++ ./lib/Glib/Object/Introspection.pm 2016-11-04 15:20:50.059819251 +0100 @@ -69,6 +69,8 @@ } } +use experimental 'smartmatch'; +my (%done, %packages, @packages, $Package); sub setup { my ($class, %params) = @_; my $basename = $params{basename}; @@ -76,6 +77,8 @@ my $package = $params{package}; my $search_path = $params{search_path} || undef; my $name_corrections = $params{name_corrections} || {}; + $Package ||= $package; + push @packages, $package; # remember all packages that are set up # Avoid repeating setting up a library as this can lead to issues, e.g., due # to types being registered more than once with perl-Glib. In particular, @@ -126,6 +129,11 @@ if (defined &{$corrected_name}) { next NAME; } + # remember widget methods for perl_checker fake packages: + if ($ENV{generate_perl_checker}) { + my ($pkg, $f) = $corrected_name =~ /(.*)::([^:]*)$/; + push @{$packages{$pkg}}, $f; + } *{$corrected_name} = _create_invoker_sub ( $basename, $is_namespaced ? $namespace : undef, $name, $shift_package_name_for{$corrected_name}, @@ -139,6 +147,11 @@ my $corrected_name = exists $name_corrections->{$auto_name} ? $name_corrections->{$auto_name} : $auto_name; + # remember constants accessors for perl_checker fake packages: + if ($ENV{generate_perl_checker}) { + my ($pkg, $f) = $corrected_name =~ /(.*)::([^:]*)$/; + push @{$packages{$pkg}}, $f; + } # Install a sub which, on the first invocation, calls _fetch_constant and # then overrides itself with a constant sub returning that value. *{$corrected_name} = sub { @@ -156,6 +169,11 @@ my $corrected_name = exists $name_corrections->{$auto_name} ? $name_corrections->{$auto_name} : $auto_name; + # remember struct accessors for perl_checker fake packages: + if ($ENV{generate_perl_checker}) { + my ($pkg, $f) = $corrected_name =~ /(.*)::([^:]*)$/; + push @{$packages{$pkg}}, $f; + } *{$corrected_name} = sub { my ($invocant, $new_value) = @_; my $old_value = __PACKAGE__->_get_field($basename, $namespace, @@ -194,6 +212,76 @@ return; } +sub get_classe_relations { + my ($pkg) = @_; + my $basename = $pkg; + my ($version) = $1 if $pkg =~ /([0-9]+)/; + $basename =~ s/Glib::IO/Gio/; # fix finding Glib::IO + $basename =~ s/[0-9]*$//; # normalize + $basename =~ s/.*:://; # normalize + my %deps = (); + use MDK::Common; + my %classes; + my $curr_class; + my @files = glob("/usr/share/gir-1.0/$basename-${version}*.gir"); + # guess latest version: + foreach (cat_($files[-1])) { + if (/<class name="(.*)"/) { + $curr_class = $1; + } elsif (my ($parent) = /^\s+parent="(.*)"/) { + $parent =~ s/\./::/g; + # fix some issues: + $parent = "${pkg}::$parent" if $parent !~ /::/; # we obviously lack namespace + $parent =~ s/^Gtk::/Gtk3::/; #fix for WebKit2 that herits from Gtk3 but doesn't known about G::O::I shift + $classes{"${pkg}::$curr_class"} = $parent if $parent !~ /^Gtk.::CellAccessible$/; # fix "can't find package Gtk3::CellAccessible" in Gtk3 + #$classes{"${pkg}::$curr_class"} = $parent if !member($parent, qw(GObject::Object GObject::InitiallyUnowned)); #FIXED by including GObject in perl_checker + } + } + %classes; +} + +sub generate_perl_checker { + # write perl_checker's fake package: + if ($ENV{generate_perl_checker}) { + # get classe relations + # (eg: https://developer.gnome.org/gtk3/stable/ch02.html) + my %classes = map { get_classe_relations($_) } @packages; + + my $f = "/tmp/${Package}.pm"; + # do not overwrite on second pass (this happen for eg: Gtk3::Gdk) + my $mode; + if ($done{$f}) { + $mode = ">>$f"; + } else { + $mode = ">$f"; + $done{$f} = 1; + } + open(my $F, $mode) or die "output in file $f failed: $!\n"; + foreach my $pkg (sort keys %packages) { + # get functions, but exclude Gdk/Gtk internal symbols (eg: _gdk_reserved1): + my @functions = grep { !/_g.k_reserved/ } @{$packages{$pkg}}; + next if !@functions; + # special cases for our patch (for mygtk3): + push @functions, 'enable_exceptions' if $pkg =~ /^Gtk[34]$/; + # fix some issues: + $pkg = "Gtk3::$pkg" if $pkg =~ /^Notify/; # fix because of perl-Gtk3-Notify + $pkg =~ s/Class$// if member($pkg, 'GObject::InitiallyUnownedClass'); # help perl_checker + print $F "package $pkg;\n"; + print $F "use Atk;\nuse Glib;\nuse Gio;\nuse GObject;\n" if $pkg eq 'Gtk3'; + if (my $parent = $classes{$pkg}) { + print $F "our \@ISA = qw($parent);\n"; + } + + foreach my $f (sort @functions) { + my @blacklist = qw(foreach print use x); + $f = "${pkg}::$f" if $f ~~ @blacklist; # else perl_checker will choke + print $F "sub $f { }\n"; + } + print $F "\n"; + } + } +} + INIT { no strict qw(refs);