File Coverage

blib/lib/PerlIO/via/Include.pm

Criterion	Covered	Total	%
statement	26	37	70.2
branch	9	14	64.2
condition			n/a
subroutine	8	9	88.8
pod	3	5	60.0
total	46	65	70.7

package PerlIO::via::Include;

$VERSION= '0.05';

# be as strict as possible
use strict;

# initializations
my $before= '^#include ';
my $after=  $/;
my $regexp;

# satisfy -require-
1;

#-------------------------------------------------------------------------------
#
# Class methods
#
#-------------------------------------------------------------------------------
#  IN: 1 class (ignored)
#      2 new value for default before string
# OUT: 1 current default before string

sub before {

    # set before string
    if ( @_ > 1 ) {
        $before= $_[1];
        $regexp= undef;
    }

    return $before;
} #before

#-------------------------------------------------------------------------------
#  IN: 1 class (ignored)
#      2 new value for default after string
# OUT: 1 current default after string

sub after {

    # set after string
    if ( @_ > 1 ) {
        $after=  $_[1];
        $regexp= undef;
    }

    return $after;
} #after

#-------------------------------------------------------------------------------
#  IN: 1 class (ignored)
#      2 new value for default regular expression string
# OUT: 1 current default regular expression string

sub regexp {

    # set new regexp
    if ( @_ > 1 ) {
        $regexp= $_[1];
        $before= $after= undef;
    }

    return $regexp;
} #regexp

#-------------------------------------------------------------------------------
#
# Standard Perl features
#
#-------------------------------------------------------------------------------
#  IN: 1 class to bless with
#      2 mode string (ignored)
#      3 file handle of PerlIO layer below (ignored)
# OUT: 1 blessed object

sub PUSHED {

    # create the object with the right attributes
    return bless {
      regexp => $regexp ? $regexp : qr/$before(.*?)$after/,
    } ,$_[0];
} #PUSHED

#-------------------------------------------------------------------------------
#  IN: 1 instantiated object
#      2 handle to read from
# OUT: 1 processed string or undef

sub FILL {

    # process line if there is one
    my $regexp= $_[0]->{'regexp'};
    if ( defined( my $line= readline( $_[1] ) ) ) {
        $line =~ s#$regexp#_include( $1 )#gse;
	return $line;
    }

    return undef;
} #FILL

#-------------------------------------------------------------------------------
#  IN: 1 instantiated object
#      2 buffer to be written
#      3 handle to write to
# OUT: 1 number of bytes written

sub WRITE {

    # process lines, return if failure
    my $regexp= $_[0]->{'regexp'};
    foreach ( split( m#(?<=$/)#, $_[1] ) ) {
	s#$regexp#_include($1)#gse;

        return -1 if !print { $_[2] } $_;
    }

    return length( $_[1] );
} #WRITE

#-------------------------------------------------------------------------------
#  IN: 1 class for which to import
#      2..N parameters passed with -use-

sub import {
    my ( $class, %param )= @_;

    # set using mutators
    $class->$_( $param{$_} ) foreach keys %param;

    return;
} #import

#-------------------------------------------------------------------------------
#
# Internal Subroutines
#
#-------------------------------------------------------------------------------
#  IN: 1 filename to open and include
# OUT: 1 contents of the whole file

sub _include {

    # huh?
    open( my $handle,"<:via(Include)",$_[0] )
     or return "*** Could not open '$_[0]': $! ***";

    # get the contents
    my $contents= '';
    local($_);
    $contents .= $_ while readline( $handle );

    return $contents;
} #_include

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

__END__