1#!/usr/bin/env perl
2
3use strict;
4use warnings;
5use IO::All;
6
7sub 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
19sub 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
28sub 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
38sub build_extends {
39  my $base = join(', ', parse_header);
40  ($base ? "extends ${base};\n\n" : '');
41}
42
43sub sq { # short for 'strip quotes'
44  my $copy = $_[0];
45  $copy =~ s/^'(.*)'$/$1/;
46  $copy =~ s/^"(.*)"$/$1/;
47  $copy;
48}
49
50sub 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
60sub top { "use namespace::clean -except => [ qw(meta) ];\n" }
61sub tail { $_{type} eq 'class' ? "__PACKAGE__->meta->make_immutable;\n" : ""; }
62
63for (@ARGV) {
64  with_file {
65    with_class_or_role_block {
66      return top.build_extends.filtered_body.tail;
67    };
68  };
69}
70
711;
72