File Coverage

blib/lib/Acme/Metification.pm

Criterion	Covered	Total	%
statement	41	42	97.6
branch	11	20	55.0
condition			n/a
subroutine	9	9	100.0
pod			n/a
total	61	71	85.9

package Acme::Metification;

use 5.006;
use strict;
use warnings;

use vars qw /$VERSION/;
$VERSION = '1.01';

use Filter::Simple;

# Call the filter routine supplied by Filter::Simple.
# It is time to read the Filter::Simple man page now if you
# haven't done so yet.

# Then pray :) This is ugly.

FILTER_ONLY
   all  => \&_filter_all,     # Used to get the source code lines
   code => \&_filter_recurse, # Used to filter recursive replacements
                             # of limited depth
   code => \&_filter_meta;#,    # Used to filter replacements
#   all => sub {my $co=0;my $c=$_;$c=~s/\n/$co++."\n"/sge;print $c;$_};

my @src_lines;

sub _filter_all {
   if (@src_lines) {
      die "Filter invoked multiple times. Not supported in this version!";
   }
   @src_lines = split /\n/;

   $_;
};


sub _filter_meta {
   while (
          s{^\s*meta\s*(.*)}{
                               _replace_meta($1)
                            }mge
         ) {}
}

sub _filter_recurse {

    while (
       s{^\s*recursemeta\s*depth\s*\=\>\s*(\d+)\s*,\s*(.+)}!
          my $depth = $1-1;
          my $rep = _replace_meta($2);
          if ($depth > 0) {
             $rep =~ s{^\s*recursemeta\s*depth\s*\=\>\s*(\d+)\s*,\s*(.+)}|
                "recursemeta depth => " . ($depth) . ", $2"
             |mge;
          } else { $rep =~ s{^\s*recursemeta\s*depth\s*\=\>\s*(\d+)\s*,\s*(.+)}||mg }
         $rep;
       !mge
    ) {}
}

sub _replace_meta {
   my $match = shift;
   $match =~ /(\d+)\s*,\s*(\d+)/ or $match =~ /(\d+)/;

   my ($start, $end) = ($1, $2);

   return '' if not defined $start;

   $start = int $start;
   $start = @src_lines + $start if $start < 0;
   $start = $#src_lines if $start > $#src_lines;

   return $src_lines[$start] if not defined $end;

   $end   = int $end;
   $end   = @src_lines + $end if $end   < 0;
   $end   = $#src_lines if $end > $#src_lines;

   ($start, $end) = ($end, $start) if $start > $end;

   return join "\n", (@src_lines[($start .. $end)]);
}

1;

__END__