script/rclass_back_to_moose.pl

   1 #!/usr/bin/env perl
   2
   3 use strict;
   4 use warnings;
   5 use IO::All;
   6
   7 sub with_file (&) {
   8   my ($code) = @_;
   9   my $fname = $_;
  10   my $data < io($fname);
  11   {
  12     local $_ = $data;
  13     $code->();
  14     $data = $_;
  15   }
  16   $data > io($fname);
  17 }
  18
  19 sub with_class_or_role_block (&) {
  20   my ($code) = @_;
  21   $_ =~ s{^(class|role)\s*(.*?)which\s*{(.*?)^};}
  22          {
  23            local *_ = { type => $1, header => $2, body => $3 };
  24            $code->();
  25          }sme;
  26 }
  27
  28 sub parse_header {
  29   my $h = $_{header};
  30   $h =~ s/^\s*\S+\s+// || die;
  31   my @base;
  32   while ($h =~ /is\s*([^ ,]+),?/g) {
  33     push(@base, $1);
  34   }
  35   return @base;
  36 }
  37
  38 sub build_extends {
  39   my $base = join(', ', parse_header);
  40   ($base ? "extends ${base};\n\n" : '');
  41 }
  42
  43 sub sq { # short for 'strip quotes'
  44   my $copy = $_[0];
  45   $copy =~ s/^'(.*)'$/$1/;
  46   $copy =~ s/^"(.*)"$/$1/;
  47   $copy;
  48 }
  49
  50 sub filtered_body {
  51   my $is_widget = m/WidgetClass/;
  52   local $_ = $_{body};
  53   s/^  //g;
  54   s/^\s*implements *(\S+).*?{/"sub ${\sq $1} {"/ge unless $is_widget;
  55   s/^\s*does/with/g;
  56   s/^\s*overrides/override/g;
  57   $_;
  58 }
  59
  60 sub top { "use namespace::clean -except => [ qw(meta) ];\n" }
  61 sub tail { $_{type} eq 'class' ? "__PACKAGE__->meta->make_immutable;\n" : ""; }
  62
  63 for (@ARGV) {
  64   with_file {
  65     with_class_or_role_block {
  66       return top.build_extends.filtered_body.tail;
  67     };
  68   };
  69 }
  70
  71 1;