+my %classoffile = ();
+my %classes = ();
+my %baseclass = ();
+my %methods = ();
+my %attrs = ();
+my %methodnames = ();
+my %old2new = ();
+
+print STDERR "Scanning...\n";
+for my $f(@ARGV)
+{
+ open my $fh, '<', $f;
+ while(<$fh>)
+ {
+ if(/^CLASS\(([^)]*)\)(?:\s*EXTENDS\(([^)]*)\))?/)
+ {
+ $classes{$1} = defined($2) ? $2 : "Object";
+ $classoffile{$f} = $1;
+ }
+ if(/^\s*METHOD\(([^),]*),\s*([^),]*)/)
+ {
+ $methods{$1}{$2} = $1;
+ $methodnames{"$1"."_"."$2"} = $f;
+ $old2new{"$2$1"} = "$1"."_"."$2";
+ }
+ if(/^\s*ATTRIB(?:ARRAY)?\(([^),]*),\s*([^),]*)/)
+ {
+ $attrs{$1}{$2} = $1;
+ }
+ }
+ close $fh;
+}
+
+# propagate down methods etc.
+print STDERR "Propagating...\n";
+for my $class(keys %classes)
+{
+ print STDERR "$class";
+ my $base = $class;
+ for(;;)
+ {
+ $base = $classes{$base};
+ last if not defined $base;
+ print STDERR " -> $base";
+ while(my ($method, $definingclass) = each %{$methods{$base}})
+ {
+ $methods{$class}{$method} = $definingclass
+ if not defined $methods{$class}{$method};
+ }
+ while(my ($attr, $definingclass) = each %{$attrs{$base}})
+ {
+ $attrs{$class}{$attr} = $definingclass
+ if not defined $attrs{$class}{$attr};
+ }
+ }
+ print STDERR "\n";
+}
+
+# change all calls to base method to super, complain about skipping
+print STDERR "Fixing...\n";
+for my $f(@ARGV)
+{
+ open my $fh, '<', $f;
+ my $s = do { undef local $/; <$fh>; };
+ my $s0 = $s;
+ close $fh;
+
+ my $class = $classoffile{$f};
+ my $base = $classes{$class};
+ next if not defined $base;
+
+ for(keys %old2new)
+ {
+ $s =~ s/\b$_\b/$old2new{$_}/g;
+ }
+
+ my @methods_super = map { [ $methods{$base}{$_} . "_" . $_, "SUPER($class).$_" ]; } keys %{$methods{$base}};
+ for(@methods_super)
+ {
+ my ($search, $replace) = @$_;
+ my $n = ($s =~ s/\b$search\b/$replace/g);
+ print STDERR "[$f] $search -> $replace... $n replacements\n"
+ if $n;
+ }
+
+ for(grep { $methodnames{$_} ne $f } keys %methodnames)
+ {
+ if($s =~ /\b$_\b/)
+ {
+ print STDERR "[$f] calls non-super external method directly: $_\n";
+ }
+ }
+
+ if($s ne $s0)
+ {
+ print STDERR "Rewriting $f...\n";
+ open my $fh, '>', $f;
+ print $fh $s;
+ close $fh;
+ }
+}