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