File Coverage

lib/MKDoc/Control_List.pm

Criterion	Covered	Total	%
statement	71	71	100.0
branch	9	12	75.0
condition	6	11	54.5
subroutine	13	13	100.0
pod	0	2	0.0
total	99	109	90.8

# ------------------------------------------------------------------
# MKDoc::Control_List
# ------------------------------------------------------------------
# Author: Jean-Michel Hiver
# Description: Access Control List generalization
# ------------------------------------------------------------------
package MKDoc::Control_List;
use strict;
use warnings;

our $VERSION = '0.31';


sub new
{
    my $class = shift;
    return bless { @_ }, $class;
}


sub process
{
    my $self = shift;
    $self->{'caller'} = caller;
    my $code = $self->_compile();
    my @res  = $code->();
    return @res;
}


sub _read_data
{
    my $self = shift;
    return $self->{data} || $self->_read_file();
}


sub _read_file
{
    my $self = shift;
    my $file = $self->{file};
    open FP, "<:utf8", $file || die "Cannot read-open $file. Reason: $@";
    my $data = join '', ;
    close FP;
    return $data;
}


sub _compile
{
    my $self = shift;
    $self->{_code} ||= do {
	my $code = $self->_build_code();
	my $VAR1 = undef;
	eval $code;
	$@ && die $@;
	$VAR1;
    };

    return $self->{_code};
}


sub _build_code
{
    my $self = shift;
    my $data = $self->_read_data();
    my @res  = ();

    push @res, $self->_build_code_header();
    my $count = 0;
    foreach my $line (split /\n/, $data)
    {
	$count++;
	chomp ($line);
	$line =~ s/^\s+//;
	$line =~ s/\s+$//;
	$line =~ /^#/  && next;
	$line          || next;

	push @res, $self->_build_code_condition ($line)   ||
	           $self->_build_code_ret_value ($line)   ||
		   $self->_build_code_rule ($line)        || do {
		       warn "Cannot parse line $count.\n$line";
		       next;
		   };
    }
    push @res, $self->_build_code_footer();
    return join "\n", @res;
}


sub _build_code_header
{
    my $self = shift;
    my $caller = $self->{'caller'};
    return (
	"\$VAR1 = sub { package $caller;",
       );
}


sub _build_code_condition
{
    my $self = shift;
    my $line = shift;
    $line =~ /^\s*CONDITION\s+/ || return;
    $line =~ s/^\s*CONDITION\s+(\w+)\s+(.*)$/my \$cnd_$1 = do { $2 };/;
    return $line;
}


sub _build_code_ret_value
{
    my $self = shift;
    my $line = shift;
    $line =~ /^\s*RET_VALUE\s+/ || return;
    $line =~ s/^\s*RET_VALUE\s+(\w+)\s+(.*)$/my \$ret_$1 = do { $2 };/;
    return $line;
}


sub _build_code_rule
{
    my $self = shift;
    my $line = shift;
    $line =~ /^\s*RULE\s+.+?\s+WHEN\s+.+\s*/ || return;

    my ($ret_values, $conditions) = $line =~ /^\s*RULE\s+(.+?)\s+WHEN\s+(.+?)\s*$/;
    my @ret_values = $ret_values =~ /(\w+)/g;
    my @conditions = $conditions =~ /(\w+)/g;

    my $code = join ' && ', map { "\$cnd_$_" } @conditions;
    $code   .= ' && return ( '  . join ', ', map { "\$ret_$_" } @ret_values;
    $code   .= ' );';
    return $code;
}


sub _build_code_footer
{
    my $self = shift;
    return ( 'return;',
	     '};' );
}


1;


__END__