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