blob: 68dbd5754c18fa4bdc5f3c7310a453ce100d2f00 (
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
|
#!/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;
|
