our
@ISA
=
qw(Exporter)
;
our
%EXPORT_TAGS
= (
'all'
=> [
qw(
)
] );
our
@EXPORT_OK
= ( @{
$EXPORT_TAGS
{
'all'
} } );
our
@EXPORT
=
qw(
convert
print_params
)
;
our
$VERSION
=
'0.04'
;
sub
parse_opts {
my
$argsref
=
shift
;
my
$options
=
shift
;
for
(
my
$x
= 0;
$x
< @{
$argsref
};
$x
+= 2) {
defined
(${
$argsref
}[(
$x
+ 1)]) or croak(
"function called with odd number of option parameters - should be of the form option => value"
);
$options
->{
lc
(${
$argsref
}[
$x
])} = ${
$argsref
}[(
$x
+ 1)];
}
return
$options
;
}
sub
convert {
my
$source
;
my
$fname
=
shift
;
if
(
ref
(
$fname
)) {
$source
=
$fname
;
}
else
{
open
FH,
$fname
or
die
$!;
undef
$/;
$source
= <FH>;
}
my
@chunk
=
split
/(?=<)/,
$source
;
close
FH;
my
$opts
= {};
%$opts
= (
loop_context_vars
=> 0,
generate_params
=> 0,
);
$opts
= parse_opts([
@_
],
$opts
);
my
$text
;
my
(
$tag
,
$test
);
my
@stack
;
my
%push
= (
VAR
=> 0,
LOOP
=> 1,
INCLUDE
=> 0,
IF
=> 1,
ELSE
=> 0,
UNLESS
=> 1
);
my
%ctx_vars
;
@ctx_vars
{
qw/__first__ __last__ __counter__/
} =
qw/loop.first loop.last loop.count/
;
$ctx_vars
{__odd__} =
'loop.count mod 2'
;
$ctx_vars
{__inner__} =
'1 - (loop.first + loop.last - loop.first*loop.last)'
;
my
$gen_params
= {};
for
(
@chunk
) {
my
(
$name
,
$default
,
%escape
);
if
(/^<
(?:!--\s*)?
(?:
(?i:TMPL_
(VAR|LOOP|INCLUDE|IF|UNLESS|ELSE)
)
\s*
)
(.*?)
(?:--)?>
(.*)
/sx) {
my
(
$tag
,
$rest
) = (
uc
$1, $3);
$_
= $2;
pos
= 0;
while
(/\G
(?i:
\b
(DEFAULT|NAME|ESCAPE)
\s*=\s*
)?
(?:
"([^"
]+)"
|
'([^'
]+)'
|
([^\s]+)
)
\s*
/xgc)
{
my
$val
=
defined
$2? $2:
defined
$3? $3: $4;
chomp
$val
;
if
(
defined
$1 and
uc
$1 ne
'NAME'
) {
if
(
uc
$1 eq
'DEFAULT'
) {
die
"DEFAULT parameter has already defined"
if
defined
$default
;
$default
=
$val
;
}
else
{
die
"Invalid ESCAPE parameter"
unless
$val
=~ /0|1|html|url|js|none/i;
$escape
{
lc
$val
} = 1;
}
}
else
{
die
"NAME parameter has already defined"
if
defined
$name
;
$name
=
$val
;
}
}
my
$case_name
=
$name
;
$name
=
$ctx_vars
{
lc
$name
}
if
exists
$ctx_vars
{
lc
$name
} and
$opts
->{loop_context_vars};
die
"Invalid parameter syntax($1)"
.
pos
if
/\G(.+)/g;
push
@stack
,
$tag
if
$push
{
$tag
};
if
(
$tag
eq
'VAR'
) {
$text
.=
"[% DEFAULT $name = '$default' %]"
if
defined
$default
;
my
$filter
=
''
;
$filter
.=
" | html | replace('\\\'', '\'')"
if
exists
$escape
{html} or
exists
$escape
{1};
$filter
.=
" | uri"
if
exists
$escape
{url};
$filter
.=
" | replace('\\'', '\\\\\\'')"
.
" | replace('\"', '\\\"')"
.
" | replace('\\n', '\\\\n')"
.
" | replace('\\r', '\\\\r')"
if
exists
$escape
{js};
die
"Empty 'NAME' parameter"
if
$name
eq
''
;
$text
.=
"[% $name$filter %]"
;
$gen_params
->{
$name
} =
$name
;
}
elsif
(
$tag
eq
'LOOP'
) {
$text
.=
"[% FOREACH $name %]"
if
$name
or
die
"Empty 'NAME' parameter"
;
my
$sub_params
= {
'parent hash'
=>
$gen_params
,
'child name'
=>
$name
};
$gen_params
=
$sub_params
;
}
elsif
(
$tag
eq
'INCLUDE'
) {
$text
.= convert(
$case_name
,
%$opts
)
if
$name
or
die
"Empty 'NAME' parameter"
;
%$gen_params
= (
%$gen_params
, %${
$opts
->{gen_params}})
if
ref
$opts
->{gen_params};
}
elsif
(
$tag
eq
'IF'
or
$tag
eq
'UNLESS'
) {
die
"Empty 'NAME' parameter"
if
$name
eq
''
;
$text
.=
"[% $tag $name %]"
;
}
else
{
die
"ELSE tag without IF/UNLESS first"
unless
@stack
and
$stack
[
$#stack
] =~ /IF|UNLESS/;
$text
.=
'[% ELSE %]'
;
}
$text
.=
$rest
;
}
elsif
(/^<(?:!--\s*)?\/TMPL_(LOOP|IF|UNLESS)\s*(?:--)?>(.*)/si) {
$tag
=
uc
$1;
die
"/TMPL_$tag tag without TMPL_$tag first"
unless
@stack
;
die
"Unexpected /TMPL_$tag tag "
unless
$tag
=
pop
@stack
;
$text
.=
"[% END %]$2"
;
if
(
uc
$tag
eq
'LOOP'
) {
my
$sub_param
=
$gen_params
;
$gen_params
=
$sub_param
->{
'parent hash'
};
my
$key
=
$$sub_param
{
'child name'
};
delete
$$sub_param
{
'parent hash'
};
delete
$$sub_param
{
'child name'
};
$gen_params
->{
$key
} = [
$sub_param
];
}
}
else
{
die
"Syntax error in TMPL_* tag"
if
/^<(?:!--\s*)\/?TMPL_/i;
$text
.=
$_
;
}
}
${
$opts
->{gen_params}} =
$gen_params
if
ref
$opts
->{gen_params};
return
$text
;
}
sub
print_params {
$\ =
"\n"
;
my
$hash
=
shift
;
my
$outline
=
shift
;
$outline
=
''
unless
defined
$outline
;
for
(
keys
%$hash
) {
my
$val
=
$$hash
{
$_
};
if
(
ref
(
$val
) eq
'ARRAY'
) {
print
"$outline$_ =>"
;
print_params(
$_
,
$outline
.
"\t"
)
for
(
@$val
);
}
else
{
print
"$outline'$_'"
;
}
}
undef
$\
unless
$outline
;
}
1;