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_block (&) {
  20   my ($code) = @_;
  21   $_ =~ s{^class\s*(.*?)which\s*{(.*?)^};}
  22          {
  23            local *_ = { header => $1, body => $2 };
  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*(\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   local $_ = $_{body};
  52   s/^  //g;
  53   s/implements *(\S+).*?{/"sub ${\sq $1} {"/ge;
  54   s/^does/with/g;
  55   $_;
  56 }
  57
  58 sub top { "use namespace::clean -except => [ qw(meta) ];\n" }
  59 sub tail { "__PACKAGE__->meta->make_immutable;\n"; }
  60
  61 for ("lib/Reaction/InterfaceModel/Object.pm", "lib/Reaction/InterfaceModel/Action/DBIC/Result.pm") {
  62   with_file {
  63     with_class_block {
  64       return top.build_extends.filtered_body.tail;
  65     };
  66   };
  67 }
  68
  69 1;