view release on metacpan or  search on metacpan

IfLoop.pm  view on Meta::CPAN

package IfLoop;

use 5.006;
use strict;
use warnings;

use Filter::Util::Call;
use Text::Balanced;

#require Exporter;
#our @ISA = qw(Exporter);
# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use IfLoop ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
#our %EXPORT_TAGS = ( 'all' => [ qw( ) ] );
#our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
#our @EXPORT = qw();

our $VERSION = '0.03';
our $DEBUG   = 0;

# Helps tell us about where in the file we are.
my $offset;

#---------------------------------------------------------------------------
#---------------------------------------------------------------------------
sub line
{
    my ($pretext,$offset) = @_;
    ($pretext=~tr/\n/\n/)+($offset||0);
}

#---------------------------------------------------------------------------
#---------------------------------------------------------------------------
sub import
{
    my($type, @arguments) = @_ ;

    if(scalar(@arguments) == 0)
    {
	@arguments = qw(while until);
    }
    
    my $tmp = join ':1:', @arguments,':1';
    @arguments = split ':', $tmp;

    $offset = (caller)[2]+1;
    filter_add({@arguments}) ;
}

#---------------------------------------------------------------------------
#---------------------------------------------------------------------------
sub unimport
{	
    filter_del();
}

#---------------------------------------------------------------------------
#---------------------------------------------------------------------------
sub handle_filehandles
{
    my $bool_condition = shift;
    my $r_source       = shift;
    my $line           = shift;

    my @pos = Text::Balanced::_match_codeblock(\$bool_condition,
					       qr/\s*/,
					       qr/\(/,qr/\)/,
					       qr/[(<]/,qr/[>)]/,
					       undef);
    if(@pos)
    {
	my $tmp = substr($bool_condition,$pos[0],$pos[4]-$pos[0]);
	if($tmp =~ m/(<.*>)/)
	{
	    my $file_access = $`.$1;
	    if($file_access !~ m/\$\_\s*=\s*<.*>/o)
	    {
		die "Filehandles \"<FILE>\" must be used like \"\$_ = <FILE>\"\n".
		    "Like the normal \"if-elsif-else\" syntax. \$_ is not set automagically!\n".
		    "Check bool statement: $bool_condition part of chain near line# ".
		    &line(substr($$r_source,0,pos $$r_source),$line)."\n";
	    }
	}
    }
}

#---------------------------------------------------------------------------
#---------------------------------------------------------------------------
sub filter
{
    my $self = shift ;
    my $status;
    
    $status = filter_read(100_000);
    return $status if($status < 0);

    $_ = &filter_blocks($self,$_,$offset);

    $status ;
}

#---------------------------------------------------------------------------
#---------------------------------------------------------------------------
sub filter_blocks
{
    #Many a regex shamelessly stolen from Damian's Switch module.