File Coverage

blib/lib/ifdef.pm

Criterion	Covered	Total	%
statement	50	58	86.2
branch	32	42	76.1
condition	6	11	54.5
subroutine	8	9	88.8
pod	3	3	100.0
total	99	123	80.4

package ifdef;

$VERSION= '0.09';

# be strict from now on
use strict;

# take all =begin CAPITALS pod sections
my $ALL;

# output all source to be output as diff to STDERR
BEGIN {
    my $diff= $ENV{'IFDEF_DIFF'} || 0;
    eval "sub DIFF () { $diff }";
} #BEGIN

# get the necessary modules
use IO::File ();

# set up source filter for the initial script
use Filter::Util::Call ();

# initializations
my $STATUS;     # status as returned by source filter
my $ACTIVATING; # whether we're inside a =begin section being activated
my $INPOD;      # whether we're inside any =pod section
my $DEPTH;      # depth of conditionals
my @STATE;      # state of each level
my %IFDEF;      # filename conversion hash

# install an @INC handler
unshift( @INC, sub {
    my ( $ref, $filename, $path )= @_;

    # return what we know of this module
    if ( !ref $ref ) {
        $ref =~ s#/#::#;
        return $IFDEF{$ref};
    }

    # check all directories and handlers
    foreach (@INC) {

        # let that INC handle do it if it is an INC handle and it's not us
        if (ref) {
            goto &$_ unless $_ eq $ref;
        }

        # we found the file
        elsif ( -f ( $path= "$_/$filename" ) ) {

            # create temp file
            open( my $in, $path ) or next;
            my $out= IO::File->new_tmpfile
              or die "Failed to create temporary file for '$path': $!\n";
            $filename =~ s#/#::#;
            $IFDEF{$filename}= $path;

            # process all lines
            local $_= \my $foo; # current state of localizing $_ ?
            while ( readline $in ) {
                &oneline;
                print $out $_;
            }
            close $in;
            &reset;

            # make sure we start reading from start again
            $out->seek( 0, 0 ) or die "Failed to seek: $!\n";

            return $out;
        }
    }

    # indicate that the rest should be searched (which will fail)
    return;
} );

# satisfy require
1;

#---------------------------------------------------------------------------
# process
#
# Process a string (consisting of many lines)
#
#  IN: 1 string to process
# OUT: 1 processed string (in place change if called in void context)

sub process {

    # process all lines
    my @line= split m#(?<=$/)#, $_[0];
    &reset;
    local $_= \my $foo;
    &oneline foreach @line;

    # close of activating section (e.g. when called by "load")
    push @line,"}$/" if $ACTIVATING;

    # return if not in void context
    return join( '', @line ) if defined wantarray;

    # change in place
    $_[0]= join( '',@line );

    return undef;
} #process

#---------------------------------------------------------------------------
# reset
#
# Reset all internal variables to a known state

sub reset { $ACTIVATING= $INPOD= $DEPTH= 0 } #reset

#---------------------------------------------------------------------------
# oneline
#
# Process one line in $_ in place

sub oneline {

    # let the world know if we should
    print STDERR "<$_" if DIFF;

    # it's a pod marker
    if ( m#^=(\w+)# ){

        # going back to source
        if ( $1 eq 'cut' ) {
            $_= $ACTIVATING ? "}$/" : $/;
            &reset;
        }

        # beginning potentially special pod section
        elsif ( $1 eq 'begin' ) {
            if ( m#^=begin\s+([A-Z_0-9]+)\b# ) {

                # activating
                if ( $ALL or $ENV{$1} ) {
                    $_= $ACTIVATING ? "}{$/" : "{;$/";
                    $ACTIVATING= 1;
                    $INPOD=      0;
                }

                # not activating now
                else {
                    $_= $ACTIVATING ? "}$/" : $/;
                    $ACTIVATING= 0;
                    $INPOD=      1;
                }
            }

            # normal begin of pod
            else {
                $_= $/;
                $INPOD= 1;
            }
        }

        # at the end of a possibly activated section
        elsif ( $1 eq 'end' ) {
            $_ = $ACTIVATING ? "}$/" : $/;
            $ACTIVATING= 0;
            $INPOD=      1;
        }

        # it's another pod directive
        else {
            $_= $/;
            $INPOD= 1;
        }
    }

    # already inside pod
    elsif ($INPOD) {
        $_= $/;
    }

    # looks like comment, make it normal line if so indicated
    elsif ( m/^#\s+([A-Z_0-9]+)\b/ ) {
         s/^#\s+(?:[A-Z_0-9]+)\b// if $ENV{$1};
    }

    # let the world know if we should
    print STDERR ">$_" if DIFF;
} #oneline

#---------------------------------------------------------------------------

# Perl specific subroutines

#---------------------------------------------------------------------------
#  IN: 1 class (ignored)
#      2..N keys to watch for

sub import {

    # being called from source (unless it's from the test-suite)
    warn "The '".
          __PACKAGE__.
          "' pragma is not supposed to be called from source\n"
           if ( (caller)[2] ) and ( $_[0] ne '_testing_' and !shift );

    # lose the class
    shift;

    # check all parameters
    my @ignored;
    foreach (@_) {
        # it's all
        if ( m#^:?all$# ) {
            $ALL= 1;
        }

        # not all
        elsif ( m#^:?selected$# ) {
            $ALL= 0;
        }

        # looks like an environment var reference
        elsif ( m#^[A-Z_0-9]+$# ) {
            $ENV{$_}= 1;
        }

        # huh?
        else {
            push @ignored, $_;
        }
    }

    # huh?
    warn "Ignored parameters: @ignored\n" if @ignored;

    # make sure we start with a clean slate
    &reset;

    # set up source filter
    return Filter::Util::Call::filter_add( sub {
        if ( ( $STATUS= Filter::Util::Call::filter_read() ) > 0 ) {
            &oneline;
        }
        $STATUS;
    } );
} #import

#---------------------------------------------------------------------------

__END__