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