package HTML::Template::Filters;

use strict;
use warnings;
use Exporter;
use Carp;
use vars qw(@ISA @EXPORT);
our $VERSION = '0.02';

@ISA = qw(Exporter);
@EXPORT = qw(
  HT_FILTER_ALLOW_TRAILING_SLASH
  HT_FILTER_SSI_INCLUDE_VIRTUAL
  HT_FILTER_TMPL_COMMENT
  HT_FILTER_TMPL_FIXME
  HT_FILTER_TMPL_SET
);

use constant HT_FILTER_ALLOW_TRAILING_SLASH => 'allow_trailing_slash';
use constant HT_FILTER_SSI_INCLUDE_VIRTUAL => 'ssi_include_virtual';
use constant HT_FILTER_TMPL_COMMENT => 'tmpl_comment';
use constant HT_FILTER_TMPL_FIXME => 'tmpl_fixme';
use constant HT_FILTER_TMPL_SET => 'tmpl_set';

#
# Example: get_filters(HT_FILTER_ALLOW_TRAILING_SLASH,HT_FILTER_TMPL_COMMENT);
#
sub get_filters {
  croak "Invalid arguments to HTML::Template::Filters->get_filters()" unless (@_ > 1);
  my $pkg = shift;
  my @wanted_filters = @_;

  # get the requested filters
  my @filter_subs;
  foreach my $wanted_filter (@wanted_filters) {
    next unless (defined $wanted_filter and length $wanted_filter);
    croak "Unknown filter: $wanted_filter" unless ($pkg->can($wanted_filter));
    my $filter = $pkg->$wanted_filter();
    push @filter_subs, {
      'sub' => $filter,
      'format' => 'scalar',
    };
  }

  return \@filter_subs;
}

#
# allow trailing slash in <TMPL_xxx /> tags
#
sub allow_trailing_slash {
  my $filter = sub {
    my $text_ref = shift;
    my $match = qr/(<[Tt][Mm][Pp][Ll]_[^>]+)\/>/;
    $$text_ref =~ s/$match/$1>/g;
  };
  return $filter;
}

#
# Translate the SSI "include virtual" into a template include:
#
sub ssi_include_virtual {
  my $filter = sub {
    my $text_ref = shift;
    my $match = qr/<!--\s*#include virtual="[\/]?(.+?)"\s*-->/i;
    $$text_ref =~ s/$match/<TMPL_INCLUDE NAME="$1">/g;
  };
  return $filter;
}

#
# strip out <TMPL_COMMENT>...</TMPL_COMMENT> entries
#
sub tmpl_comment {
  my $filter = sub {
    my $text_ref = shift;
    my $match  = qr/<(?:\!--\s*)?[Tt][Mm][Pp][Ll]_[Cc][Oo][Mm][Mm][Ee][Nn][Tt]\s*(?:--)?>.*?<(?:\!--\s*)?\/[Tt][Mm][Pp][Ll]_[Cc][Oo][Mm][Mm][Ee][Nn][Tt]\s*(?:--)?>/s;
    $$text_ref  =~ s/$match//g;
  };
  return $filter;
}

#
# strip out <TMPL_FIXME>...</TMPL_FIXME> entries
#
sub tmpl_fixme {
  my $filter = sub {
    my $text_ref = shift;
    my $match  = qr/<(?:\!--\s*)?[Tt][Mm][Pp][Ll]_[Ff][Ii][Xx][Mm][Ee]\s*(?:--)?>.*?<(?:\!--\s*)?\/[Tt][Mm][Pp][Ll]_[Ff][Ii][Xx][Mm][Ee]\s*(?:--)?>/s;
    $$text_ref  =~ s/$match//g;
  };
  return $filter;
}

#
# allow <TMPL_SET NAME="variable" VALUE="value">
# note this only works for TMPL_VAR's
#
sub tmpl_set {
  my $filter = sub {
    my $text_ref = shift;
    my $match = qr/<(?:\!--\s*)?[Tt][Mm][Pp][Ll]_[Ss][Ee][Tt]\s*[Nn][Aa][Mm][Ee]\s*=(.*?)\s*[Vv][Aa][Ll][Uu][Ee]\s*=(.*?)\s*(?:--)?>/;
    my @taglist = $$text_ref =~ m/$match/g;
    return unless (@taglist > 0);
    my $strip = qr/^(?:'(.*)')|(?:"(.*)")$/;
    my %set_params;
    while (@taglist) {
      my ($t,$v) = (shift @taglist,shift @taglist);
      $t =~ m/$strip/;
      $t = defined $1 ? $1 : defined $2 ? $2 : $t;
      $v =~ m/$strip/;
      $v = defined $1 ? $1 : defined $2 ? $2 : $v;
      $set_params{$t} = $v;
    }
    $$text_ref =~ s/$match//g;
    my $split = qr/(?=<(?:\!--\s*)?[Tt][Mm][Pp][Ll]_[Vv][Aa][Rr]\s+)/;
    my @chunks = split ($split, $$text_ref);
    return unless (@chunks > 0);
    my @output;
    my $chunker = qr/^(?=
                      <(?:!--\s*)?
                      [Tt][Mm][Pp][Ll]_[Vv][Aa][Rr]\s+(?:[Nn][Aa][Mm][Ee]\s*=\s*)?
                      (?:
                        "([^">]*)"
                        |
                        '([^'>]*)'
                        |
                        ([^\s=>]*)
                      )
                      \s*(?:[^>])?(?:--)?>
                      (.*)
                   )/sx;
    foreach my $chunk (@chunks) {
      if ($chunk =~ $chunker) {
        my $name = defined $1 ? $1 : defined $2 ? $2 : defined $3 ? $3 : undef;
        if (defined $name and exists $set_params{$name}) {
          $chunk = $set_params{$name};
          $chunk .= $4 if $4;
        }
      }
      push @output, $chunk;
    }
    $$text_ref = join '',@output;
  };
  return $filter;
}

1;
__END__
=pod

=head1 NAME

HTML::Template::Filters - HTML::Template support module, which
contains some useful filters.

=head1 SYNOPSIS

  use HTML::Template::Filters qw(get_filters);

  my $filters = get_filters(
    HT_FILTER_ALLOW_TRAILING_SLASH,
    HT_FILTER_TMPL_COMMENT,
    HT_FILTER_TMPL_SET,
  );
  my $ht = new HTML::Template(
    filename => 'somefile.tmpl',
    filter => $filters,
  );

=head1 DESCRIPTION

This is a support module for HTML::Template, which contains a
collection of filters that can be applied to a HTML::Template
object.

Current filters available (detailed below):
 - HT_FILTER_ALLOW_TRAILING_SLASH
 - HT_FILTER_SSI_INCLUDE_VIRTUAL
 - HT_FILTER_TMPL_COMMENT
 - HT_FILTER_TMPL_FIXME
 - HT_FILTER_TMPL_SET

=head2 Trailing slash

Enable HTML::Template to support the parsing of a trailing
slash within template tags, for example:

  <TMPL_IF somevar />
    <TMPL_VAR anothervar />
  </TMPL_IF />

=head2 SSI (server side includes) virtual includes

Translate SSI virtual includes, into H::T includes.

  <!-- #include virtual="some_include" -->

 becomes

  <TMPL_INCLUDE NAME="some_include">

=head2 TMPL_COMMENT

Allows the TMPL_COMMENT tag so that any text between the
start/end tag is stripped, as in:

  <TMPL_COMMENT>Any text between comments
  is stripped</TMPL_COMMENT>

=head2 TMPL_FIXME

Same as TMPL_COMMENT (makes for searching of FIXME's)

=head2 TMPL_SET

Allows the following syntax within templates:

  <TMPL_SET NAME="template_var" VALUE="some_value">

This will then translate all <TMPL_VAR NAME="template_var">'s
into "some_value".  Doesn't work for <TMPL_LOOP ..>'s as loops
require the template variable to be an array (rather than a
scalar).  Also, dont specify ESCAPE or DEFAULT arguments to the
TMPL_VAR as, they make no sense when used with TMPL_SET.

=head1 BUGS

You can send bug reports to the HTML::Template mailing-list. To join
the list, visit:

  http://lists.sourceforge.net/lists/listinfo/html-template-users

=head1 CREDITS

The users of the HTML::Template mailing list contributed the idea
and some patterns for the implementation of this module.

=head1 AUTHOR

Mathew Robertson <mathew@users.sf.net>

=head1 LICENSE

This module is released under the same license that HTML::Template
is released under.