qcsrc/menu/auto-super.pl

   1 my %classoffile = ();
   2 my %classes = ();
   3 my %baseclass = ();
   4 my %methods = ();
   5 my %attrs = ();
   6 my %methodnames = ();
   7 my %old2new = ();
   8
   9 print STDERR "Scanning...\n";
  10 for my $f(@ARGV)
  11 {
  12         open my $fh, '<', $f;
  13         while(<$fh>)
  14         {
  15                 if(/^CLASS\(([^)]*)\)(?:\s*EXTENDS\(([^)]*)\))?/)
  16                 {
  17                         $classes{$1} = defined($2) ? $2 : "Object";
  18                         $classoffile{$f} = $1;
  19                 }
  20                 if(/^\s*METHOD\(([^),]*),\s*([^),]*)/)
  21                 {
  22                         $methods{$1}{$2} = $1;
  23                         $methodnames{"$1"."_"."$2"} = $f;
  24                         $old2new{"$2$1"} = "$1"."_"."$2";
  25                 }
  26                 if(/^\s*ATTRIB(?:ARRAY)?\(([^),]*),\s*([^),]*)/)
  27                 {
  28                         $attrs{$1}{$2} = $1;
  29                 }
  30         }
  31         close $fh;
  32 }
  33
  34 # propagate down methods etc.
  35 print STDERR "Propagating...\n";
  36 for my $class(keys %classes)
  37 {
  38         print STDERR "$class";
  39         my $base = $class;
  40         for(;;)
  41         {
  42                 $base = $classes{$base};
  43                 last if not defined $base;
  44                 print STDERR " -> $base";
  45                 while(my ($method, $definingclass) = each %{$methods{$base}})
  46                 {
  47                         $methods{$class}{$method} = $definingclass
  48                                 if not defined $methods{$class}{$method};
  49                 }
  50                 while(my ($attr, $definingclass) = each %{$attrs{$base}})
  51                 {
  52                         $attrs{$class}{$attr} = $definingclass
  53                                 if not defined $attrs{$class}{$attr};
  54                 }
  55         }
  56         print STDERR "\n";
  57 }
  58
  59 # change all calls to base method to super, complain about skipping
  60 print STDERR "Fixing...\n";
  61 for my $f(@ARGV)
  62 {
  63         open my $fh, '<', $f;
  64         my $s = do { undef local $/; <$fh>; };
  65         my $s0 = $s;
  66         close $fh;
  67
  68         my $class = $classoffile{$f};
  69         my $base = $classes{$class};
  70         next if not defined $base;
  71
  72         for(keys %old2new)
  73         {
  74                 $s =~ s/\b$_\b/$old2new{$_}/g;
  75         }
  76
  77         my @methods_super = map { [ $methods{$base}{$_} . "_" . $_, "SUPER($class).$_" ]; } keys %{$methods{$base}};
  78         for(@methods_super)
  79         {
  80                 my ($search, $replace) = @$_;
  81                 my $n = ($s =~ s/\b$search\b/$replace/g);
  82                 print STDERR "[$f] $search -> $replace... $n replacements\n"
  83                         if $n;
  84         }
  85
  86         for(grep { $methodnames{$_} ne $f } keys %methodnames)
  87         {
  88                 if($s =~ /\b$_\b/)
  89                 {
  90                         print STDERR "[$f] calls non-super external method directly: $_\n";
  91                 }
  92         }
  93
  94         if($s ne $s0)
  95         {
  96                 print STDERR "Rewriting $f...\n";
  97                 open my $fh, '>', $f;
  98                 print $fh $s;
  99                 close $fh;
 100         }
 101 }