Commit | Line | Data |
319bf4d0 |
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 | |
b134d5b6 |
19 | sub with_class_or_role_block (&) { |
319bf4d0 |
20 | my ($code) = @_; |
c28a7901 |
21 | $_ =~ s{^(class|role)\s*(.*?)which\s*{(.*?)^};} |
319bf4d0 |
22 | { |
c28a7901 |
23 | local *_ = { type => $1, header => $2, body => $3 }; |
319bf4d0 |
24 | $code->(); |
25 | }sme; |
26 | } |
27 | |
28 | sub parse_header { |
29 | my $h = $_{header}; |
30 | $h =~ s/^\s*\S+\s+// || die; |
31 | my @base; |
c28a7901 |
32 | while ($h =~ /is\s*([^ ,]+),?/g) { |
319bf4d0 |
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 { |
a3c28d59 |
51 | my $is_widget = m/WidgetClass/; |
319bf4d0 |
52 | local $_ = $_{body}; |
53 | s/^ //g; |
a3c28d59 |
54 | s/^\s*implements *(\S+).*?{/"sub ${\sq $1} {"/ge unless $is_widget; |
c28a7901 |
55 | s/^\s*does/with/g; |
56 | s/^\s*overrides/override/g; |
319bf4d0 |
57 | $_; |
58 | } |
59 | |
60 | sub top { "use namespace::clean -except => [ qw(meta) ];\n" } |
c28a7901 |
61 | sub tail { $_{type} eq 'class' ? "__PACKAGE__->meta->make_immutable;\n" : ""; } |
319bf4d0 |
62 | |
c28a7901 |
63 | for (@ARGV) { |
319bf4d0 |
64 | with_file { |
b134d5b6 |
65 | with_class_or_role_block { |
319bf4d0 |
66 | return top.build_extends.filtered_body.tail; |
67 | }; |
68 | }; |
69 | } |
70 | |
71 | 1; |