package BlockBin;

# BlockBin, a Perl module to build web pages from templates.
# Copyright (C) 2001 Tom Rathborne
# Copyright (C) 2001 Convoke Communications Corp.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

####### Documentation ########################################################

=head1 NAME

BlockBin - Renders template data stored in hashes

=head1 SYNOPSIS

my %template;
tie %template, 'Source_of_template::hash';
my $print = sub { print (@_) };

my $page = new BlockBin (\%template, $print);

$page->global ({ setting => 'value' });
$page->header ({ title => 'My Title' });
$page->block ('foo', { bar => 'baz' });
$page->print ('<b>HTML</b>');
$page->footer ();

=head1 DESCRIPTION

BlockBin provides various functions to facilitate the complete separation
of code and layout. The primary purpose is of course to keep HTML and Perl
separate in web applications.

=head1 METHODS

=cut

require 5.005;
use strict;

####### Public methods #######################################################

=head2 my $page = new BlockBin (\%template, [sub { ... }]);

Makes a new page which will render elements from %template and print them via
the print subroutine. The default subroutine is C<sub { print (@_) }>.

=cut

sub new ($$;$) { # creates new BlockBin object
    my $class = shift;
    my $self = {};

    $self->{'bin'} = shift || die 'No block bin supplied';
    die 'Bin is not a hashref' unless ref $self->{'bin'} eq 'HASH';

    $self->{'print'} = shift || sub { print (@_) };

    $self->{'globals'} = {};
    $self->{'done_head'} = 0;
    $self->{'done_foot'} = 0;

    return bless $self, $class;
}

=head2 $page->print($stuff, $morestuff, ...);

Prints given stuff via the page's print sub if the header has been printed and
the footer hasn't.

=cut

sub print ($@) { # passes arguments to print handler verbatim
    my $self = shift;

    return 1 unless ($self->{'done_head'} and !$self->{'done_foot'});

    &{$self->{'print'}} (@_)
        if $self->{'done_head'} == 1 and $self->{'done_foot'} == 0;

    return;
}

=head2 $page->global ({ foo => 'bar', baz => 'quux' });

Stores the given name/value pairs as global settings to be passed to all blocks
printed from now on.

=cut

sub global ($$) { # sets variables for remainder of page
    my $self = shift;
    my $hash = shift || {};
 
    $self->{'globals'}{$_} = $hash->{$_} foreach (keys %{$hash});

    return;
}

=head2 $page->block ('blockname', [{ foo => 'bar'}] );

Retrieves the specified block and prints it, filling in variables from the
globals and/or the specified values which override the globals.

=cut

sub block ($$;$) { # prints a block with optional additional variables
    my $self = shift;

    return 1 unless ($self->{'done_head'} and !$self->{'done_foot'});

  # implicit else

    my $block = shift;
    my $data = shift || {};

    $self->print ($self->render_block ($self->{'bin'}{$block}, $data));

    return;
}

=head2 $page->header ([{ foo => 'bar' }]);

Prints the _header block, with variable substitutions or unless it's already
been printed.

=cut

sub header ($;$) { # prints header and sets header flag - must be done first
    my $self = shift;

    return 1 if $self->{'done_head'};

  # implicit else

    my $data = shift || {};
    $self->{'done_head'} = 1;
    $self->block ('_header', $data);

    return;
}

=head2 $page->footer ([{ foo => 'bar' }]);

Prints the _footer block, with variable substitutions unless the header hasn't
been printed or the foot already has.

=cut

sub footer ($;$) { # prints footer and sets footer flag - must be done last
    my $self = shift;

    return 1 unless ($self->{'done_head'} and !$self->{'done_foot'});

  # implicit else

    my $data = shift || {};
    $self->block ('_footer', $data);
    $self->{'done_foot'} = 1;

    return;
}

####### Private methods ######################################################

#
# $self->escape_html ($string);
#
# simple naive HTML-escaping thing
#

sub escape_html ($$) { # handles the important entities
    my $self = shift;
    my $string = shift;

    $string =~ s/</&lt;/g;
    $string =~ s/>/&gt;/g;
    $string =~ s/&/&amp;/g;
    $string =~ s/"/&quot;/g;

    return $string;
}

#
# $self->unescape_html ($string);
#
# simple naive HTML-unescaping thing
#

sub unescape_html ($$) { # handles the important entities
    my $self = shift;
    my $string = shift;

    $string =~ s/&lt;/</g;
    $string =~ s/&gt;/>/g;
    $string =~ s/&amp;/&/g;
    $string =~ s/&quot;/"/g;

    return $string;
}

#
# $self->render_cmd ($command, [\%data]);
#
# "parses" commands and returns substituted data
#

sub render_cmd ($$;$) { # renders a magical {|cmd|} tag
    my $self = shift;
    my $cmd = shift;
    my $data = shift || {};

    if ($cmd =~ /^-([^:]+):(.*)-$/) { # -block:P0^...^Pn- => block P0...Pn
        my @parameters = split /\^/, $2;
        @$data{map "P$_", 0..$#parameters} =
          map { $self->render_block ($parameters[$_], $data) } 0..$#parameters;
        return ($self->render_block ($self->{'bin'}{$1}, $data));

    } elsif ($cmd =~ /^-(.*)-$/) { # -block- => render block
        return ($self->render_block ($self->{'bin'}{$1}, $data));

    } elsif ($cmd =~ /^=(.*)=$/) { # substitute a variable without escape
        return (exists $data->{$1} and defined $data->{$1})
            ? $data->{$1}
            : '';

    } elsif ($cmd =~ /^([^:]+):(%.*)$/s) { # arg:%foo => printf command
        return '' unless (exists $data->{$1} and defined $data->{$1});
        return $self->escape_html (sprintf($2, $data->{$1}));

    } elsif ($cmd =~ /^([^:]*):&(.*)$/s
             and exists $data->{$2}
             and ref($data->{$2}) eq 'CODE') { # arg1:&arg2 => &arg2(arg1)
        return (&{$data->{$2}} ($self, $self->render_block ($1, $data)));

    } elsif ($cmd =~ /^([^:]+):x(.*)$/s) { # foo:x10 => 'foo' x 10
        return '' unless (exists $data->{$2} and defined $data->{$2});
        return (($self->render_block ($1, $data)) x $data->{$2});

    } elsif ($cmd =~ /^(.*?)\|\?\|(.*)\|:\|(.*)$/s) { # conditional command
                                                  # condition|?|true|:|false
        my ($cond, $true, $false) = ($1, $2, $3);
        my $ret;

        if ($cond =~ /^(.*)=(.*)$/o) { # test equality
            my ($lhs, $rhs) = ($1, $2);

            if (exists $data->{$lhs} and
                defined $data->{$lhs}) {
                $lhs = $data->{$lhs};

                if ($rhs =~ /^\d+(\.\d+)?$/) { # numerical comparison
                    $ret = ($lhs == $rhs) ? $true : $false;
                } else { # string comparison
                    $rhs = $self->render_block ($rhs, $data);

                    if ($rhs =~ /^~(.*)$/) { # regex/case insensitive
                        $rhs = $1;

                        $ret = ($lhs =~ /$rhs/i) ? $true : $false;
                    } else { # full string
                        $ret = ($lhs eq $rhs) ? $true : $false;
                    }
                }
            } else { # lhs not defined - assume false
                $ret = $false;
            }
        } elsif ($cond =~ /^(.*)%(\d+)$/s) { # test modulus
            $ret = (((exists $data->{$1} and defined $data->{$1})
                        ? $data->{$1}
                        : 0) % $2)
                            ? $true
                            : $false;

        } elsif (exists $data->{$cond}
                 and defined $data->{$cond}
                 and $data->{$cond} ne ''
                 and $data->{$cond} !~ /^0+\.?0*$/s) { # simple arg truth
            $ret = $true;

        } else { # failed!
            $ret = $false;
        }

        return $self->render_block ($ret, $data);

    } else { # substitute a variable with escape
        return (exists $data->{$cmd} and defined $data->{$cmd})
            ? $self->escape_html($data->{$cmd})
            : '';
    }
}

#
# $self->render_block ($block, [\%data]);
#
# finds commands and replaces them with render_cmd results
#

sub render_block ($$;$) { # renders a block via render_cmd
    my $self = shift;
    my $block = shift;
    $block = '' unless defined $block;
    my $data = shift || {};
    $data = {} unless ref ($data) =~ /HASH/;

    foreach (keys %{$self->{'globals'}}) {
        $data->{$_} = $self->{'globals'}{$_}
            unless exists $data->{$_};
    }

    $block =~ s/\{([^\|]*)\|(.+?)\|\1\}/$self->render_cmd($2, $data)/seg;

    # sample block: {|foo_?_{=|bar|=}_:_{-|baz|-}|}
    # this is like: escape_html ($data->{$data->{'foo'} ? 'bar' : 'baz'}});

    return $block;
}

####### End of Code ##########################################################

1; # Return true

=head1 AUTHOR

Tom Rathborne <tomr@aceldama.com>

=cut

####### EOF ##################################################################
