qcsrc/menu/auto-super.pl

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