#============================================================= -*-Perl-*-
#
# Template::Filters
#
# DESCRIPTION
# Defines filter plugins as used by the FILTER directive.
#
# AUTHORS
# Andy Wardley <abw@kfs.org>, with a number of filters contributed
# by Leslie Michael Orchard <deus_x@nijacode.com>
#
# COPYRIGHT
# Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved.
# Copyright (C) 1998-2000 Canon Research Centre Europe Ltd.
#
# This module is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
#----------------------------------------------------------------------------
#
# $Id: Filters.pm,v 2.4 2000/12/01 15:29:35 abw Exp $
#
#============================================================================
package Template::Filters;
require 5.004;
use strict;
use base qw( Template::Base );
use vars qw( $VERSION $DEBUG $FILTERS );
use Template::Constants;
$VERSION = sprintf("%d.%02d", q$Revision: 2.4 $ =~ /(\d+)\.(\d+)/);
#------------------------------------------------------------------------
# standard filters, defined in one of the following forms:
# name => \&static_filter
# name => [ \&subref, $is_dynamic ]
# If the $is_dynamic flag is set then the sub-routine reference
# is called to create a new filter each time it is requested; if
# not set, then it is a single, static sub-routine which is returned
# for every filter request for that name.
#------------------------------------------------------------------------
$FILTERS = {
# static filters
'html' => \&html_filter,
'html_para' => \&html_paragraph,
'html_break' => \&html_break,
'upper' => sub { uc $_[0] },
'lower' => sub { lc $_[0] },
'stderr' => sub { print STDERR @_; return '' },
# dynamic filters
'format' => [ \&format_filter_factory, 1 ],
'truncate' => [ \&truncate_filter_factory, 1 ],
'repeat' => [ \&repeat_filter_factory, 1 ],
'replace' => [ \&replace_filter_factory, 1 ],
'remove' => [ \&remove_filter_factory, 1 ],
'eval' => [ \&eval_filter_factory, 1 ],
'evaltt' => [ \&eval_filter_factory, 1 ], # alias
'perl' => [ \&perl_filter_factory, 1 ],
'evalperl' => [ \&perl_filter_factory, 1 ], # alias
'redirect' => [ \&redirect_filter_factory, 1 ],
'file' => [ \&redirect_filter_factory, 1 ], # alias
};
#========================================================================
# -- PUBLIC METHODS --
#========================================================================
#------------------------------------------------------------------------
# fetch($name, \@args, $context)
#
# Attempts to instantiate or return a reference to a filter sub-routine
# named by the first parameter, $name, with additional constructor
# arguments passed by reference to a list as the second parameter,
# $args. A reference to the calling Template::Context object is
# passed as the third paramter.
#
# Returns a reference to a filter sub-routine or a pair of values
# (undef, STATUS_DECLINED) or ($error, STATUS_ERROR) to decline to
# deliver the filter or to indicate an error.
#------------------------------------------------------------------------
sub fetch {
my ($self, $name, $args, $context) = @_;
my ($factory, $is_dynamic, $filter, $error);
# retrieve the filter factory
return (undef, Template::Constants::STATUS_DECLINED)
unless ($factory = $self->{ FILTERS }->{ $name }
|| $FILTERS->{ $name });
if (ref $factory eq 'ARRAY') {
($factory, $is_dynamic) = @$factory;
}
else {
$is_dynamic = 0;
}
if (ref $factory eq 'CODE') {
if ($is_dynamic) {
# if the dynamic flag is set then the sub-routine is a
# factory which should be called to create the actual
# filter...
eval {
($filter, $error) = &$factory($context, $args ? @$args : ());
};
$error ||= $@;
$error = "invalid FILTER for '$name' (not a CODE ref)"
unless $error || ref($filter) eq 'CODE';
}
else {
# ...otherwise, it's a static filter sub-routine
$filter = $factory;
}
}
else {
$error = "invalid FILTER entry for '$name' (not a CODE ref)";
}
if ($error) {
return $self->{ TOLERANT }
? (undef, Template::Constants::STATUS_DECLINED)
: ($error, Template::Constants::STATUS_ERROR) ;
}
else {
return $filter;
}
}
#------------------------------------------------------------------------
# store($name, \&filter)
#
# Stores a new filter in the internal FILTERS hash. The first parameter
# is the filter name, the second a reference to a subroutine or
# array, as per the standard $FILTERS entries.
#------------------------------------------------------------------------
sub store {
my ($self, $name, $filter) = @_;
$self->{ FILTERS }->{ $name } = $filter;
return 1;
}
#========================================================================
# -- PRIVATE METHODS --
#========================================================================
#------------------------------------------------------------------------
# _init(\%config)
#
# Private initialisation method.
#------------------------------------------------------------------------
sub _init {
my ($self, $params) = @_;
$self->{ FILTERS } = $params->{ FILTERS } || { };
$self->{ TOLERANT } = $params->{ TOLERANT } || 0;
return $self;
}
#------------------------------------------------------------------------
# _dump()
#
# Debug method - does nothing much atm.
#------------------------------------------------------------------------
sub _dump {
my $self = shift;
return "$self\n";
}
#========================================================================
# -- STATIC FILTER SUBS --
#========================================================================
#------------------------------------------------------------------------
# html_filter() [% FILTER html %]
#
# Convert any '<', '>' or '&' characters to the HTML equivalents, '<',
# '>' and '&', respectively.
#------------------------------------------------------------------------
sub html_filter {
my $text = shift;
for ($text) {
s/&/&/g;
s/</</g;
s/>/>/g;
}
$text;
}
#------------------------------------------------------------------------
# html_paragraph() [% FILTER html_para %]
#
# Wrap each paragraph of text (delimited by two or more newlines) in the
# <p>...</p> HTML tags.
#------------------------------------------------------------------------
sub html_paragraph {
my $text = shift;
return "<p>\n"
. join("\n</p>\n\n<p>\n", split(/(?:\r?\n){2,}/, $text))
. "</p>\n";
}
#------------------------------------------------------------------------
# html_break() [% FILTER html_break %]
#
# Wrap each paragraph of text (delimited by two or more newlines) in the
# <p>...</p> HTML tags.
#------------------------------------------------------------------------
sub html_break {
my $text = shift;
$text =~ s/(\r?\n){2,}/$1<br>$1<br>$1/g;
return $text;
}
#========================================================================
# -- DYNAMIC FILTER FACTORIES --
#========================================================================
#------------------------------------------------------------------------
# format_filter_factory() [% FILTER format(format) %]
#
# Create a filter to format text according to a printf()-like format
# string.
#------------------------------------------------------------------------
sub format_filter_factory {
my ($context, $format) = @_;
$format = '%s' unless defined $format;
return sub {
my $text = shift;
$text = '' unless defined $text;
return join("\n", map{ sprintf($format, $_) } split(/\n/, $text));
}
}
#------------------------------------------------------------------------
# repeat_filter_factory($n) [% FILTER repeat(n) %]
#
# Create a filter to repeat text n times.
#------------------------------------------------------------------------
sub repeat_filter_factory {
my ($context, $iter) = @_;
$iter = 1 unless defined $iter and length $iter;
return sub {
my $text = shift;
$text = '' unless defined $text;
return join('\n', $text) x $iter;
}
}
#------------------------------------------------------------------------
# replace_filter_factory($s, $r) [% FILTER replace(search, replace) %]
#
# Create a filter to replace 'search' text with 'replace'
#------------------------------------------------------------------------
sub replace_filter_factory {
my ($context, $search, $replace) = @_;
$replace = '' unless defined $replace;
return sub {
my $text = shift;
$text = '' unless defined $text;
$text =~ s/$search/$replace/g;
return $text;
}
}
#------------------------------------------------------------------------
# remove_filter_factory($text) [% FILTER remove(text) %]
#
# Create a filter to remove 'search' string from the input text.
#------------------------------------------------------------------------
sub remove_filter_factory {
my ($context, $search) = @_;
return sub {
my $text = shift;
$text = '' unless defined $text;
$text =~ s/$search//g;
return $text;
}
}
#------------------------------------------------------------------------
# truncate_filter_factory($n) [% FILTER truncate(n) %]
#
# Create a filter to truncate text after n characters.
#------------------------------------------------------------------------
sub truncate_filter_factory {
my ($context, $len) = @_;
$len = 32 unless defined $len;
return sub {
my $text = shift;
return $text if length $text < $len;
return substr($text, 0, $len - 3) . "...";
}
}
#------------------------------------------------------------------------
# eval_filter_factory [% FILTER eval %]
#
# Create a filter to evaluate template text.
#------------------------------------------------------------------------
sub eval_filter_factory {
my $context = shift;
return sub {
my $text = shift;
$context->process(\$text);
}
}
#------------------------------------------------------------------------
# perl_filter_factory [% FILTER perl %]
#
# Create a filter to process Perl text iff the context EVAL_PERL flag
# is set.
#------------------------------------------------------------------------
sub perl_filter_factory {
my $context = shift;
my $stash = $context->stash;
return (undef, Template::Exception->new('perl', 'EVAL_PERL is not set'))
unless $context->eval_perl();
return sub {
my $text = shift;
$Template::Perl::context = $context;
$Template::Perl::stash = $stash;
my $out = eval <<EOF;
package Template::Perl;
\$stash = \$context->stash();
$text
EOF
$context->throw($@) if $@;
return $out;
}
}
#------------------------------------------------------------------------
# redirect_filter_factory($context, $file) [% Filter redirect(file) %]
#
# Create a filter to redirect the block text to a file.
#------------------------------------------------------------------------
sub redirect_filter_factory {
my ($context, $file) = @_;
my $outpath = $context->config->{ OUTPUT_PATH };
return (undef, Template::Exception->new('file', 'OUTPUT_PATH is not set'))
unless $outpath;
sub {
my $text = shift;
my $outpath = $context->config->{ OUTPUT_PATH }
|| return '';
$outpath .= "/$file";
local *FP;
open(FP, ">$outpath")
|| die Template::Exception->new('file', "$file: $!");
print FP $text;
close(FP);
return '';
}
}
1;