File Coverage

blib/lib/Text/Bind.pm

Criterion	Covered	Total	%
statement	86	126	68.2
branch	21	50	42.0
condition	7	17	41.1
subroutine	8	8	100.0
pod	0	3	0.0
total	122	204	59.8

##---------------------------------------------------------------------------##
##  File:
##      @(#) Bind.pm 1.5 99/07/07 21:53:55
##  Author:
##      Earl Hood       [e-mail]
##  Description:
##	Class for supporting HTML template pages for perl CGI programs.
##	More explanation at end of source file.
##---------------------------------------------------------------------------##
##  Copyright (C) 1997-1999	Earl Hood, [e-mail]
##	All rights reserved.
##
##  This program is free software; you can redistribute it and/or
##  modify it under the same terms as Perl itself.
##---------------------------------------------------------------------------##

package Text::Bind;

use strict;
use vars '$VERSION';
$VERSION = '0.04';

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

use Carp;
use FileHandle;

###############################################################################
##	Public Class Methods
###############################################################################

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

sub new {
    my $this	= { };
    my $mod	= shift;	# Name of module
    my $file	= shift;	# Text input
    my $class	= ref($mod) || $mod;

    $this->{'file'} = $file;
    bless $this, $class;
    $this;
}

###############################################################################
##	Public Object Methods
###############################################################################

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

sub bind_site {
    my $this	= shift;
    my $site	= shift;	# Site name
    my $bind	= shift;	# Bind value to site

    $this->{'site'}{$site} = $bind;
    $this->{'args'}{$site} = [ @_ ];
}

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

sub read_text {
    my $this	= shift;
    my $outfh	= shift(@_) || \*STDOUT;	# Output stream (optional)
    my $file	= shift(@_) || $this->{'file'};	# File to read (optional)

    # Open file.  If unable, generate error message and return zero status.
    my($fh);
    if (ref $file) {
	$fh = $file;
    } else {
	$fh = new FileHandle $file;
	if (not defined $fh) {
	    carp qq|Unable to open "$file": $!|;
	    return 0;
	}
    }

    # Parse file
    my(@list);
    my($buf, $notone);

    local($_);
    while (<$fh>) {
	@list = split(/##PL_(?i)beginloop##/o, $_, 2);
	if (@list < 2) {
	    $this->_eval_bindings($outfh, $list[0]);
	    next;
	}
	$notone = 0;
	$this->_eval_bindings($outfh, shift(@list));
	$_ = shift(@list);  $buf = "";
	while (!/##PL_(?i)endloop##/) {
	    $buf .= $_;
	    last  unless defined($_ = <$fh>);
	    $notone = 1;
	}
	@list = split(/##PL_(?i)endloop##/o, $_, 2);
	if ($notone) {
	    $buf .= shift(@list);
	} else {
	    $buf = shift(@list);
	}
	1 while $this->_eval_bindings($outfh, $buf);
	$this->_eval_bindings($outfh, shift(@list))  if defined $list[0];

    } # End while (<$fh>)

    1;
}

###############################################################################
##	Private Functions
###############################################################################

sub _eval_bindings {
    my $this	= shift;
    my $outfh	= shift;
    my $text	= shift;

    return 0  unless defined($outfh) && defined($text);

    # Split on data site markup
    my @list = split(/##PL_([^#]+)##/, $text);

    # First item of list is regular data, so just output.
    my $data = shift(@list);
    print $outfh $data  if defined($data);

    # If other items are still in the list, then there are data
    # sites to resolve.
    my($site, $name, $value, $bind, $status, $tmp);
    my $retval = 0;

    LINE: while (@list) {
	$site = shift @list;
	$data = shift @list;
	if ($site =~ /^(\w+)\s*=\s*(.+)/) {
	    ($name, $value) = (lc $1, $2);
	} else {
	    next LINE;
	}

	# Check on type of data site
	SITE: {

	    # File site: open file and include contents where data
	    # site is located.  Filename could also include trailing
	    # pipe to allow a program to be invoked.
	    if ($name eq "file") {
		my $incfh = new FileHandle $value;
		if (defined $incfh) {
		    while (<$incfh>) {
			print $outfh $_;
		    }
		}
		undef $incfh;	# closes file
		last SITE;
	    }

	    # Named site: check if binding registered for value of
	    # site.  If so, execute binding.
	    if ($name eq "site") {
		$value =~ s/\s//g;	# strip any whitespace
		$bind = $this->{site}{$value};

		if (defined $bind) {
		    BIND: {
			# Function: Call if defined.  If not, silently
			# ignore.
			if (ref($bind) eq 'CODE') {
			    $retval = &$bind($this, $outfh, $value,
				             @{$this->{args}{$value}})
				if defined &$bind;
			    last BIND;
			}

			# Array: shift through the items in the array
			if (ref($bind) eq 'ARRAY') {
			    $tmp = shift(@{$bind});
			    $retval = scalar(@{$bind})  unless $retval;
			    last BIND  unless defined $tmp;
			    ARRAY: {
				if (ref($tmp) eq 'CODE') {
				    &$tmp($this, $outfh, $value,
					  @{$this->{args}{$value}})
					if defined &$tmp;
				    last ARRAY;
				}
				if (ref($tmp) && $tmp =~ /GLOB/) {
				    local $_; while (<$tmp>) {
					print $outfh $_;
				    }
				    last ARRAY;
				}
				if (ref($tmp)) {
				    $tmp->fill_site($this, $outfh, $site,
						    @{$this->{args}{$value}});
				    last ARRAY;
				}
				print $outfh $tmp;
				last ARRAY;
			    }
			    last BIND;
			}

			# Filehandle: Have to use regex to check
			# for filehandle in case a filehandle class
			# is in use.
			if (ref($bind) && $bind =~ /GLOB/) {
			    local $_;
			    while (<$bind>) {
				print $outfh $_;
			    }
			    last BIND;
			}

			# Object: Call the method that the object
			# should define to work with this class.  We
			# only check if $bind is a reference.  Other
			# relevant reference types are checked above.
			if (ref($bind)) {
			    $retval = $bind->fill_site($this, $outfh, $site,
					           @{$this->{args}{$value}});
			    last BIND;
			}

			# String: Fallback case; just output string
			print $outfh $bind;
			last BIND;

		    } # End BIND
		}
		last SITE;
	    }

	} # End SITE

    } continue {
	print $outfh $data  if defined($data);

    } # End while (@list)

    $retval;
}

##---------------------------------------------------------------------------##
1;

__END__