From 319bf4d0176dfdb8382fdecc607160ba3df38e73 Mon Sep 17 00:00:00 2001
From: matthewt <matthewt@03d0b0b2-0e1a-0410-a411-fdb2f4bd65d7>
Date: Tue, 24 Jun 2008 16:06:21 +0000
Subject: this is really pre-alpha and do not blame me if it eats your dog

---
 script/rclass_back_to_moose.pl | 69 ++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 69 insertions(+)
 create mode 100644 script/rclass_back_to_moose.pl

(limited to 'script')

diff --git a/script/rclass_back_to_moose.pl b/script/rclass_back_to_moose.pl
new file mode 100644
index 0000000..68dbd57
--- /dev/null
+++ b/script/rclass_back_to_moose.pl
@@ -0,0 +1,69 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use IO::All;
+
+sub with_file (&) {
+  my ($code) = @_;
+  my $fname = $_;
+  my $data < io($fname);
+  {
+    local $_ = $data;
+    $code->();
+    $data = $_;
+  }
+  $data > io($fname);
+}
+
+sub with_class_block (&) {
+  my ($code) = @_;
+  $_ =~ s{^class\s*(.*?)which\s*{(.*?)^};}
+         {
+           local *_ = { header => $1, body => $2 };
+           $code->();
+         }sme;
+}
+
+sub parse_header {
+  my $h = $_{header};
+  $h =~ s/^\s*\S+\s+// || die;
+  my @base;
+  while ($h =~ /is\s*(\S+?),?/g) {
+    push(@base, $1);
+  }
+  return @base;
+}
+
+sub build_extends {
+  my $base = join(', ', parse_header);
+  ($base ? "extends ${base};\n\n" : '');
+}
+
+sub sq { # short for 'strip quotes'
+  my $copy = $_[0];
+  $copy =~ s/^'(.*)'$/$1/;
+  $copy =~ s/^"(.*)"$/$1/;
+  $copy;
+}
+
+sub filtered_body {
+  local $_ = $_{body};
+  s/^  //g;
+  s/implements *(\S+).*?{/"sub ${\sq $1} {"/ge;
+  s/^does/with/g;
+  $_;
+}
+
+sub top { "use namespace::clean -except => [ qw(meta) ];\n" }
+sub tail { "__PACKAGE__->meta->make_immutable;\n"; }
+
+for ("lib/Reaction/InterfaceModel/Object.pm", "lib/Reaction/InterfaceModel/Action/DBIC/Result.pm") {
+  with_file {
+    with_class_block {
+      return top.build_extends.filtered_body.tail;
+    };
+  };
+}
+
+1;
-- 
cgit v1.2.3-54-g00ecf