our $VERSION = '0.001001';
sub stripspace {
my ($text) = @_;
$text =~ /^(\s+)/ && $text =~ s/^$1//mg;
$text;
}
sub usage {
print <<'USAGE';
sigfix [OPTIONS] [FILES]
sigfix -t signatures perl526file >perl528file
sigfix -t oldsignatures perl528file >perl526file
sigfix -t plain perlfile >perl58file
sigfix -i -t signatures upgradethisfile
sigfix -t signatures --pmc lib/My/Module.pm >lib/My/Module.pmc
sigfix -i -t signatures --pmc lib/My/Module.pm
sigfix -i --pmc eval $(find lib -name '*.pm') # multi-target fat pmc
Options:
-t, --target Target: 'signatures', 'oldsignatures', 'plain'
-i, --inplace Modify target file(s) in place
--pmc Generate .pmc (without -t, triple target pmc)
-h This usage message
USAGE
exit(255);
}
{
my $cs = Babble::Plugin::CoreSignatures->new;
my @target_selectors = (
[ 'signatures', '($] >= 5.020 and $] < 5.022) or $] >= 5.028' ],
[ 'oldsignatures', '$] >= 5.022 and $] < 5.028' ],
[ 'plain' ],
);
sub process_source {
my ($source, $opt) = @_;
if (my $target = $opt->{target}) {
my $top = Babble::Match->new(
top_rule => 'Document',
text => $source,
);
my $transform = "transform_to_${target}";
unless ($cs->can($transform)) {
print STDERR "Invalid transform target ${target}";
usage;
}
$cs->$transform($top);
return $top->text;
}
my $preamble = stripspace <<' PREAMBLE';
# This code generated by App::sigfix
BEGIN {
my %options;
PREAMBLE
my @segments;
foreach my $target (map $_->[0], @target_selectors) {
my $top = Babble::Match->new(
top_rule => 'Document',
text => $source,
);
$cs->${\"transform_to_${target}"}($top);
my $data = $top->text;
s/^/ /mg, s/(?<!\n)\z/\n/ for $data;
my $doc_name = uc join '_', 'CODE_FOR', $target;
push @segments, join '',
qq{ \$options{'${target}'} = '#line '.(1+__LINE__).' "'.__FILE__."\\"\\n".<<'$doc_name';\n},
$data, $doc_name, "\n";
}
my $select = join "\n",
' my $chosen =',
(map {
my ($choice, $cond) = @$_;
if ($cond) {
" $cond ? '$choice' :"
} else {
" '$choice';"
}
} @target_selectors),
'';
my $postamble = stripspace <<' POSTAMBLE';
require Filter::Util::Call;
Filter::Util::Call::filter_add(sub {
Filter::Util::Call::filter_del();
1 while Filter::Util::Call::filter_read();
$_ = $options{$chosen};
});
POSTAMBLE
$postamble =~ s/^/ /mg;
return join '',
$preamble,
@segments,
$select,
$postamble,
"}\n0; # should never get here\n";
}
}
sub process_file {
my ($file, $opt) = @_;
my $source = do {
open my $in, '<', $file or die "Couldn't open ${file} for read: $!\n";
local $/; <$in>;
};
my $processed = process_source $source, $opt;
my $out_file = $file.($opt->{pmc} ? 'c' : '');
open my $out, '>', $out_file
or die "Couldn't open ${out_file} for write: $!\n";
print $out $processed;
return;
}
sub options {
my %opt;
GetOptions(
't|target=s', \$opt{target},
'i|inplace', \$opt{inplace},
'pmc', \$opt{pmc},
'help', \$opt{help}
);
if ($opt{help}) {
usage;
}
if (not $opt{target} and not $opt{pmc}) {
print STDERR "Must supply at least one of -t/--target or --pmc\n";
usage;
}
if ($opt{inplace} and not @ARGV) {
print STDERR "In-place operation requires a list of files\n";
usage;
}
if ($opt{inplace} and $opt{pmc} and grep !/\.pm$/, @ARGV) {
print STDERR "In-place pmc generation requires a list of .pm files\n";
usage;
}
return \%opt;
}
sub main {
my $opt = options;
if ($opt->{inplace}) {
foreach my $file (@ARGV) {
process_file $file, $opt;
}
return;
}
(my $source = do { local $/; <> }) ||= '';
print process_source $source, $opt;
return;
}
1;