Sophie

Sophie

distrib > Mageia > 9 > armv7hl > media > core-release-src > by-pkgid > a1202d0fa67b8662e1530f321010d03a > files > 3

perl-Glib-Object-Introspection-0.49.0-5.mga9.src.rpm

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);