home *** CD-ROM | disk | FTP | other *** search
/ rtsi.com / 2014.01.www.rtsi.com.tar / www.rtsi.com / OS9 / FAQ / discus_admin_1357211388 / source / templint.pl < prev    next >
Text File  |  2009-11-06  |  43KB  |  969 lines
  1. # FILE: templint.pl
  2. # DESCRIPTION: Template Interpreter (actual conversion to Perl)
  3. #-------------------------------------------------------------------------------
  4. # DISCUS COPYRIGHT NOTICE
  5. #
  6. # Discus is copyright (c) 2002 by DiscusWare, LLC, all rights reserved.
  7. # The use of Discus is governed by the Discus License Agreement which is
  8. # available from the Discus WWW site at:
  9. #    http://www.discusware.com/discus/license
  10. #
  11. # Pursuant to the Discus License Agreement, this copyright notice may not be
  12. # removed or altered in any way.
  13. #-------------------------------------------------------------------------------
  14.  
  15. use strict;
  16. use vars qw($GLOBAL_OPTIONS $DCONF $PARAMS);
  17.  
  18. ###
  19. ### dtlperl
  20. ###
  21. ### Converts Discus template language into Perl code (manager subroutine)
  22. ###
  23.  
  24. sub dtlperl {
  25.     my $templatename = shift @_;
  26.     performance_string("* Calculating DTL->Perl for $templatename");
  27.     my @k = dtl_to_perl('text', 'substitutions', @_);
  28.     $templatename =~ s/\W/_/g;
  29.     unshift @k, "\$GLOBAL_OPTIONS = \$main::GLOBAL_OPTIONS;\n";
  30.     unshift @k, "\$DCONF = \$main::DCONF;\n";
  31.     unshift @k, "\$PARAMS = \$main::PARAMS;\n";
  32.     unshift @k, "use vars qw(\$GLOBAL_OPTIONS \$PARAMS \$DCONF);\n";
  33.     unshift @k, "use strict;\n";
  34.     unshift @k, "package $templatename;\n";
  35.     push @k, "return (\"\$text\\n\", \$substitutions);\n";
  36.     push @k, "}\n";
  37.     my @export = qw/element_array_grep getgmtoffset _minimath wordwrapper reference_array_from mathdefine program_sub does_part_exist template_error template_includer template_css_size file_includer case_l case_u remove_html template_js_prepare get_date_time maxcharcut nohtmllength substrnohtml safe_minus_one process_math read_language skin_includer picker form_escape escape unescape/;
  38.     foreach my $x (@export) {
  39.         push @k, "sub $x { return &main'$x }\n";
  40.     }
  41.     push @k, "1;\n";
  42.     return beautify(@k);
  43. }
  44.  
  45. ###
  46. ### beautify
  47. ###
  48. ### Produces more attractive Perl code (brackets in the right place)
  49. ###
  50.  
  51. sub beautify {
  52.     my @out = ();
  53.     my $indent = 0;
  54.     my @A = split(/\n/, join("", @_));
  55.     while (my $x = shift @A) {
  56.         $x = trim ($x);
  57.         if ($x =~ /^\}.*\{$/) {
  58.             push @out, join("", "\t" x ($indent-1), $x, "\n");
  59.         } elsif ($x =~ /\{$/) {
  60.             push @out, join("", "\t" x $indent, $x, "\n");
  61.             $indent += 1;
  62.         } elsif ($x =~ /\{\s*#/) {
  63.             push @out, join("", "\t" x $indent, $x, "\n");
  64.             $indent += 1;
  65.         } elsif ($x =~ /^\}(\s*)#/) {
  66.             push @out, join("", "\t" x ($indent-1), $x, "\n");
  67.             $indent -= 1;
  68.         } elsif ($x =~ /^\}$/) {
  69.             push @out, join("", "\t" x ($indent-1), $x, "\n");
  70.             $indent -= 1;
  71.         } else {
  72.             push @out, join("", "\t" x $indent, $x, "\n");
  73.         }
  74.     }
  75.     return @out;
  76. }
  77.  
  78. ###
  79. ### dtl_to_perl
  80. ###
  81. ### Actual conversion of template language into Perl
  82. ###
  83.  
  84. sub dtl_to_perl {
  85.     my $textvar = shift @_;
  86.     my $substvar = shift @_;
  87.     my @whilecond = ();
  88.     my @subroutine = ();
  89.     my @l = @_;
  90.     my @out = ();
  91.     my @outhead = ();
  92.     if ($textvar eq 'text') {
  93.         while (my $z = shift @l) {
  94.             last if $z =~ /^\s*<!--BEGIN-->\s*/i;
  95.         }
  96.         push @outhead, "sub process {\n";
  97.         push @outhead, "  my \$substitutions = shift \@_;\n";
  98.         push @outhead, "  my \$$textvar = \"\";\n";
  99.     }
  100.     my @ifs = ();
  101. WO:    while ($_ = shift @l) {
  102.         return (@subroutine, @outhead, @whilecond, @out) if /^\s*<!--END-->\s*$/i;
  103.         if (/^\rPERL\r/i) {
  104.             push @out, $';
  105.             next;
  106.         }
  107.         if (m|^\s*<#\s*dtl\s*off\s*#>\s*$|i) {
  108.             while (my $z = shift @l) {
  109.                 next WO if $z =~ m|^\s*<#\s*dtl\s*on\s*#>\s*$|i;
  110.                 $z =~ s/\\/\\\\/g; $z =~ s/'/\\'/g;
  111.                 push @out, join("", "\$$textvar .= '", $z, "';", "\n");
  112.             }
  113.         }
  114.         if (m|^\s*<#\s*perl\s*#>\s*$|i) {
  115.             while (my $z = shift @l) {
  116.                 next WO if $z =~ m|^\s*<#\s*/\s*perl\s*#>\s*$|i;
  117.                 push @out, $z;
  118.             }
  119.         } elsif (m|^\s*<#\s*no\s*perl\s*#>\s*$|i) {
  120.             while (my $z = shift @l) {
  121.                 next WO if $z =~ m|^\s*<#\s*/\s*no\s*perl\s*#>\s*$|i;
  122.             }
  123.         }
  124.         next if /^\s*<#\s*simple\s*variables\s*#>\s*$/i;
  125.         next if m|^\s*#|;
  126.         next if ! m|\S|;
  127.         $_ = join("", $`, "\n") if /\s*##/;
  128.         $_ = $` if /\s*\\\s*$/;
  129.         s/<#>/#/g;
  130.         if (m|^\s*<#sub \s*(.*)\s*#>\s*$|i) {
  131.             template_error("Subroutine definition in wrong place for $1") if $textvar ne 'text';
  132.             my $subargs = $1;
  133.             template_error("Illegal subroutine definition for $subargs") if $subargs !~ m|^(\w+)\s*\(([\s\$\w\,]*)\)\s*$|;
  134.             my ($subname, $subarg) = (lc($1), $2);
  135.             return () if defined $PARAMS->{subs}->{$subname};
  136.             $PARAMS->{arraycounter} += 1;
  137.             $PARAMS->{subs}->{$subname} = "SUBR$PARAMS->{arraycounter}";
  138.             push @subroutine, "sub SUBR$PARAMS->{arraycounter} {\n";
  139.             push @subroutine, "  my \$substitutions = shift \@_;\n";
  140.             push @subroutine, "  my \$subtextout = \"\";\n";
  141.             foreach my $arg (split /,/, $subarg) {
  142.                 $arg = trim($arg); $arg =~ s/^\$//;
  143.                 push @subroutine, "  \$substitutions->{\"_\"}->{$arg} = shift \@_;\n";
  144.             }
  145.             my @arr = ();
  146. SDEF:        while ($_ = shift @l) {
  147.                 last SDEF if m|^\s*<#\s*end\s*sub\s*#>\s*$|i;
  148.                 push @arr, $_;
  149.             }
  150.             push @subroutine, dtl_to_perl('subtextout', 'substitutions', @arr);
  151.             push @subroutine, "  return \$subtextout;\n";
  152.             push @subroutine, "} ## End of SUBR$PARAMS->{arraycounter} (name: $subname)\n";
  153.             next WO;
  154.         }
  155.         if (m%\s*<#define%) {
  156.             my $line = "";
  157.             if (m|^\s*<#define\s+\$(\w+)\s*=\s*"?(.*?)"?#>\s*$|i) {
  158.                 $line = "\$substitutions->{\"_\"}->{$1} = ";
  159.                 $line .= dtl_var_replace($2);
  160.                 $line .= ";\n";
  161.             } elsif (m|^\s*<#define\s+\$(\w+)\s*\[\s*(.*?)\s*\]\s*=\s*"?(.*?)"?#>\s*$|i) {
  162.                 $line = "if ( ";
  163.                 $line .= dtl_var_replace($2);
  164.                 $line .= " >= 0) {\n";
  165.                 $line .= "\$substitutions->{$1}->[-1+";
  166.                 $line .= dtl_var_replace($2);
  167.                 $line .= "] = ";
  168.                 $line .= dtl_var_replace($3);
  169.                 $line .= ";\n}\n";
  170.             } elsif (m|^\s*<#define\s*array\s*\@(\w+)\s*\(([\w\s,]+)\)\s*#>\s*$|i) {
  171.                 my ($arrayname, $fieldnames) = ($1, $2);
  172.                 $PARAMS->{arraycounter} += 1;
  173.                 my $arraycounter = $PARAMS->{arraycounter};
  174.                 $line .= "{\nmy \@ARRAY$arraycounter = ();\n";
  175.                 $line .= "my \$hashref;\n";
  176.                 $fieldnames =~ s/\s//g;
  177.                 my @fieldnames = split(/,/, $fieldnames);
  178.                 template_error("Array \@$arrayname does not have any field names defined!") if scalar(@fieldnames) < 1;
  179. WDEF:            while ($_ = shift @l) {
  180.                     if (m|^\s*<#/define#>\s*$|i) {
  181.                         $line .= "\$substitutions->{$arrayname} = \\\@ARRAY$arraycounter;\n}\n";
  182.                         push @out, $line;
  183.                         next WO;
  184.                     } elsif (m|^\s*<#define|) {
  185.                         template_error("Cannot nest definitions in defining \@$arrayname!");
  186.                     } elsif (m|^\s*<#if([^>]+)#>\s*$|i || m|^\s*<#else#>\s*$| || m|^\s*<#endif#>\s*$|i) {
  187.                         template_error("Block IF-THEN-ELSE statements not permitted within array definitions, in defining \@$arrayname!");
  188.                     } elsif (m|^\s*<#foreach\s*|i || m|^\s*<#endloop#>\s*$|i) {
  189.                         template_error("FOREACH statements not permitted within array definitions, in defining \@$arrayname!");
  190.                     } elsif (m|^\s*<#for\s*|i || $line =~ m|^\s*<#endfor#>\s*$|i) {
  191.                         template_error("FOR statements not permitted within array definitions, in defining \@$arrayname!");
  192.                     }
  193.                     chomp; my @linesplits = split(/\t/, $_);
  194.                     my $if_flag = 0;
  195.                     if ($linesplits[0] =~ m|^\s*<#if *(.*?)#>\s*$|i) {
  196.                         $if_flag = 1;
  197.                         $line .= dtl_if_replace($1);
  198.                         shift @linesplits;
  199.                     }
  200.                     $line .= "\$hashref = {};\n";
  201.                     foreach my $key (@fieldnames) {
  202.                         my $t = shift @linesplits;
  203.                         if ($t =~ /NO MATCHER[<\{]#if/) {
  204.                             $_ = $t;
  205.                             my @Q = ();
  206.                             if (my @z = m|^\s*(.*?)[<\{]#if (.*?)#[>\}]( *)(.*?)( *)[<\{]#else#[>\}]( *)(.*?)( *)[<\{]#endif#[>\}]( *)(.*?)(\s*)$|) {
  207.                                 unshift @z, "";
  208.                                 push @Q, join("", "\$hashref->{$key} .= ", dtl_var_replace($z[1]), ";\n") if $z[1] ne "";
  209.                                 push @Q, dtl_if_replace($z[2]);
  210.                                 push @Q, "\$hashref->{$key} .= \"$z[3]\";\n" if $z[3] ne "";
  211.                                 push @Q, join("", "\$hashref->{$key} .= ", dtl_var_replace($z[4]), ";\n") if $z[4] ne "";
  212.                                 push @Q, "\$hashref->{$key} .= \"$z[5]\";\n" if $z[5] ne "";
  213.                                 push @Q, "} else {\n";
  214.                                 push @Q, "\$hashref->{$key} .= \"$z[6]\";\n" if $z[6] ne "";
  215.                                 push @Q, join("", "\$hashref->{$key} .= ", dtl_var_replace($z[7]), ";\n") if $z[7] ne "";
  216.                                 push @Q, "\$hashref->{$key} .= \"$z[8]\";\n" if $z[8] ne "";
  217.                                 push @Q, "}\n";
  218.                                 push @Q, "\$hashref->{$key} .= \"$z[9]\";\n" if $z[9] ne "";
  219.                                 push @Q, join("", "\$hashref->{$key} .= ", dtl_var_replace($z[10]), ";\n") if $z[10] ne "";
  220.                                 push @Q, join("", "\$hashref->{$key} .= \"\\n\";\n") if $z[11] ne "";
  221.                             } elsif (my @z = m|^\s*(.*?)[<\{]#if (.*?)#[>\}]( *)(.*?)( *)[<\{]#endif#[>\}]( *)(.*?)(\s*)$|) {
  222.                                 unshift @z, "";
  223.                                 push @Q, join("", "\$hashref->{$key} .= ", dtl_var_replace($z[1]), ";\n") if $z[1] ne "";
  224.                                 push @Q, dtl_if_replace($z[2]);
  225.                                 push @Q, "\$hashref->{$key} .= \"$z[3]\";\n" if $z[3] ne "";
  226.                                 push @Q, join("", "\$hashref->{$key} .= ", dtl_var_replace($z[4]), ";\n") if $z[4] ne "";
  227.                                 push @Q, "\$hashref->{$key} .= \"$z[5]\";\n" if $z[5] ne "";
  228.                                 push @Q, "}\n";
  229.                                 push @Q, "\$hashref->{$key} .= \"$z[6]\";\n" if $z[6] ne "";
  230.                                 push @Q, join("", "\$hashref->{$key} .= ", dtl_var_replace($z[7]), ";\n") if $z[7] ne "";
  231.                                 push @Q, join("", "\$hashref->{$key} .= \"\\n\";\n") if $z[8] ne "";
  232.                             } elsif (my @z = m|^\s*(.*?)[<\{]#if (.*?)#[>\}]( *)(.*?)(\s*)$|) {
  233.                                 unshift @z, "";
  234.                                 push @Q, join("", "\$hashref->{$key} .= ", dtl_var_replace($z[1]), ";\n") if $z[1] ne "";
  235.                                 push @Q, dtl_if_replace($z[2]);
  236.                                 push @Q, "\$hashref->{$key} .= \"$z[3]\";\n" if $z[3] ne "";
  237.                                 push @Q, join("", "\$hashref->{$key} .= ", dtl_var_replace($z[4]), ";\n") if $z[4] ne "";
  238.                                 push @Q, join("", "\$hashref->{$key} .= \"\\n\";\n") if $z[5] ne "";
  239.                                 push @Q, "}\n";
  240.                             }
  241.                             $line .= join("", @Q);
  242.                         } else {
  243.                             $line .= "\$hashref->{$key} = ";
  244.                             $line .= dtl_var_replace($t);
  245.                             $line .= ";\n";
  246.                         }
  247.                     }
  248.                     $line .= "if (defined \$hashref->{'_index'}) {\n";
  249.                     $line .= "   \$ARRAY$arraycounter";
  250.                     $line .= "[\$hashref->{'_index'} - 1] = \$hashref;\n";
  251.                     $line .= "} else {\n";
  252.                     $line .= "   push \@ARRAY$arraycounter, \$hashref;\n";
  253.                     $line .= "}\n";
  254.                     $line .= "}\n" if $if_flag;
  255.                 }
  256.             } elsif (m|^\s*<#define\s*\$GLOBAL_OPTIONS(?:->)?\{(\w+)\}\s*=\s*"?(.*?)"?\s*#>\s*$|i) {
  257.                 $line .= "if (\$GLOBAL_OPTIONS->{skinvar_override_option} != 0) {\n";
  258.                 $line .= "   \$GLOBAL_OPTIONS->{$1} = \"";
  259.                 my $var_replace = dtl_var_replace($2);
  260.                 $var_replace = $2 if $var_replace =~ m|^(['"])(.*?)(\1)$|;
  261.                 $line .= $var_replace;
  262.                 $line .= "\";\n}\n";
  263.             }
  264.             push @out, $line;
  265.             next;
  266.         } elsif (! m|[<\{]#endif#[>\}]|i && m|^\s*<#if (.*)#>\s*$|) {
  267.             push @out, dtl_if_replace($1);
  268.             push @ifs, $1;
  269.             next;
  270.         } elsif (m|^\s*<#else#>\s*$|i) {
  271.             if ($#ifs >= 0) {
  272.                 push @out, "} else {\n";
  273.                 next;
  274.             }
  275.             template_error("Invalid <#else#> statement does not match <#if...#> statement");
  276.         } elsif (m|^\s*<#endif#>\s*$|i) {
  277.             if ($#ifs >= 0) {
  278.                 push @out, "}\n";
  279.                 pop @ifs;
  280.                 next;
  281.             }
  282.             template_error("Invalid <#endif#> statement does not match <#if...#> statement");
  283.         } elsif (my @z = m|^!\s*(.*?)[<\{]#if (.*?)#[>\}]( *)(.*?)( *)[<\{]#else#[>\}]( *)(.*?)( *)[<\{]#endif#[>\}]( *)(.*?)(\s*)$|) {
  284.             unshift @z, "";
  285.             push @out, join("", "\$$textvar .= ", dtl_var_replace($z[1]), ";\n") if $z[1] ne "";
  286.             push @out, dtl_if_replace($z[2]);
  287.             push @out, "\$$textvar .= \"$z[3]\";\n" if $z[3] ne "";
  288.             push @out, join("", "\$$textvar .= ", dtl_var_replace($z[4]), ";\n") if $z[4] ne "";
  289.             push @out, "\$$textvar .= \"$z[5]\";\n" if $z[5] ne "";
  290.             push @out, "} else {\n";
  291.             push @out, "\$$textvar .= \"$z[6]\";\n" if $z[6] ne "";
  292.             push @out, join("", "\$$textvar .= ", dtl_var_replace($z[7]), ";\n") if $z[7] ne "";
  293.             push @out, "\$$textvar .= \"$z[8]\";\n" if $z[8] ne "";
  294.             push @out, "}\n";
  295.             push @out, "\$$textvar .= \"$z[9]\";\n" if $z[9] ne "";
  296.             push @out, join("", "\$$textvar .= ", dtl_var_replace($z[10]), ";\n") if $z[10] ne "";
  297.             push @out, join("", "\$$textvar .= \"\\n\";\n") if $z[11] ne "";
  298.             next;
  299.         } elsif (my @z = m|^!\s*(.*?)[<\{]#if (.*?)#[>\}]( *)(.*?)( *)[<\{]#endif#[>\}]( *)(.*?)(\s*)$|) {
  300.             unshift @z, "";
  301.             push @out, join("", "\$$textvar .= ", dtl_var_replace($z[1]), ";\n") if $z[1] ne "";
  302.             push @out, dtl_if_replace($z[2]);
  303.             push @out, "\$$textvar .= \"$z[3]\";\n" if $z[3] ne "";
  304.             push @out, join("", "\$$textvar .= ", dtl_var_replace($z[4]), ";\n") if $z[4] ne "";
  305.             push @out, "\$$textvar .= \"$z[5]\";\n" if $z[5] ne "";
  306.             push @out, "}\n";
  307.             push @out, "\$$textvar .= \"$z[6]\";\n" if $z[6] ne "";
  308.             push @out, join("", "\$$textvar .= ", dtl_var_replace($z[7]), ";\n") if $z[7] ne "";
  309.             push @out, join("", "\$$textvar .= \"\\n\";\n") if $z[8] ne "";
  310.             next;
  311.         } elsif (my @z = m|^!\s*(.*?)[<\{]#if (.*?)#[>\}]( *)(.*?)(\s*)$|) {
  312.             unshift @z, "";
  313.             push @out, join("", "\$$textvar .= ", dtl_var_replace($z[1]), ";\n") if $z[1] ne "";
  314.             push @out, dtl_if_replace($z[2]);
  315.             push @out, "\$$textvar .= \"$z[3]\";\n" if $z[3] ne "";
  316.             push @out, join("", "\$$textvar .= ", dtl_var_replace($z[4]), ";\n") if $z[4] ne "";
  317.             push @out, join("", "\$$textvar .= \"\\n\";\n") if $z[5] ne "";
  318.             push @out, "}\n";
  319.             next;
  320.         } elsif (m|^\s*<#language\s*:\s*\$L(?:->)?\{(\w+)\}\s*=?\s*"(.*?)"\s*#>\s*$|i) {
  321.             push @out, "if (! defined \$PARAMS->{L}->{$1} ) {\n";
  322.             push @out, join("", "\$PARAMS->{L}->{$1} = ", dtl_var_replace($2), ";\n");
  323.             push @out, "}\n";
  324.             next;
  325.         } elsif (m|^\s*<#mathdefine:?\s*\$(\w+)\s*=\s*(.*?)\s*#>\s*$|i) {
  326.             push @out, join("", "\$substitutions->{\"_\"}->{$1} = mathdefine(", dtl_var_replace($2), ", \$substitutions);\n");
  327.             next;
  328.         } elsif (m|^\s*<#key\s+replace\s*\$(\w+)\s*"(.*?)"\s*[-=]\s*>\s*"(.*?)"\s*#>|i) {
  329.             push @out, join("", "\$substitutions->{$1}->{$3} = \$substitutions->{$1}->{$2};\n");
  330.             next;
  331.         } elsif (m|^\s*<#math:\s*(.*?)\s*#>\s*$|i) {
  332.             my ($one) = $1; $one =~ s/'/\\'/g;
  333.             push @out, "\$substitutions = process_math('$one', \$substitutions);\n";
  334.             next;
  335.         } elsif (m|^\s*<#\s*replace\s*"(.*?)"\s*with\s*"(.*?)"\s*in\s*\$(.*?)\s*#>\s*$|i) {
  336.             my ($oldpattern, $newpattern, $variablename) = ($1, $2, $3);
  337.             my $q = quotemeta($oldpattern);
  338.             my $Z = dtl_var_replace($newpattern);
  339.             if ($Z =~ /\r\"\r(.*)\r\"\r/) {
  340.                 $Z = join("", "join(\"\", \"", $1, "\")");
  341.             } elsif ($Z =~ /"(.*)"/) {
  342.                 $Z = "join(\"\", \"$1\")";
  343.             }
  344.             $Z =~ s/\//\\\//g;
  345.             push @out, "\$substitutions->{\"_\"}->{$variablename} =~ s/$q/$Z/ge;\n";
  346.             next;
  347.         } elsif (m|^\s*<#reference\s*array\s*\@(\w+)\s+from\s*(.*?)\s*except\s*(.*?)\s*=\s*\((.*?)\)\s*#>\s*$|i) {
  348.             my ($arrayname, $arrayfrom, $field, $except) = ($1, $2, $3, $4);
  349.             my $Z = dtl_var_replace($arrayfrom);
  350.             $Z = $1 if $Z =~ /"(.*)"/;
  351.             push @out, "\$substitutions = reference_array_from(\"$arrayname\", $Z, \"$field\", \"$except\", \$substitutions);\n";
  352.             next;
  353.         } elsif (m|^\s*<#reference\s*array\s*\@(\w+)\s+from\s*(.*?)\s*#>\s*$|i) {
  354.             my ($arrayname, $arrayfrom, $field) = ($1, $2, $3);
  355.             my $Z = dtl_var_replace($arrayfrom);
  356.             $Z = $1 if $Z =~ /"(.*)"/;
  357.             push @out, "\$substitutions = reference_array_from(\"$arrayname\", $Z, \"$field\", undef, \$substitutions);\n";
  358.             next;
  359.         } elsif (m|^\s*<#include file[= ]+"(.*)"\s*([\w, ]*)#>\s*$|) {
  360.             my $filename = dtl_var_replace($1);
  361.             push @out, "\$$textvar .= file_includer($filename, \"$2\");\n";
  362.             next;
  363.         } elsif (m|^\s*<#\s*insert\s*(once)?\s*part\s*\((.*?)\)\s*"([^"]+)"\s*\(?(1?)\)?\s*#>\s*$|i) {
  364.             my ($once, $topic, $part, $flag) = ($1, $2, $3, $4);
  365.             $topic = dtl_var_replace($topic) if $topic ne "";
  366.             $topic = "\"\"" if $topic eq "";
  367.             push @out, "{\nmy (\$textSKIN, \$subst) = skin_includer($topic, \"$part\", \$substitutions);\n";
  368.             push @out, "\$$textvar .= \$textSKIN; \$substitutions = \$subst;\n}\n";
  369.             next;
  370.         } elsif (m|^\s*<#\s*insert\s*template\s*"([^"]+)"\s*#>\s*$|i) {
  371.             my $template = dtl_var_replace($1);
  372.             push @out, "\$$textvar .= template_includer($template, \$substitutions);\n";
  373.             next;
  374.         } elsif (m|^\s*<#form\s*variables#>\s*$|) {
  375.             $PARAMS->{arraycounter} += 1;
  376.             my $line = "foreach my \$LOOPVAR$PARAMS->{arraycounter} (keys %{ \$substitutions->{FORMref}) {\n";
  377.             $line .= "  \$$textvar .= \"<input type=hidden name='\$LOOPVAR$PARAMS->{arraycounter}' value='\$substitutions->{FORMref}->{\$LOOPVAR$PARAMS->{arraycounter}";
  378.             $line .= "}'>\\n\";\n}\n";
  379.             push @out, $line;
  380.             next;
  381.         } elsif (m|^\s*<#form\s*variables\(([\w,]+)\)#>\s*$|) {
  382.             my @keylist = split(/,/, $1);
  383.             $PARAMS->{arraycounter} += 1;
  384.             my $line = "my \@FORMVARS$PARAMS->{arraycounter} = qw (";
  385.             $line .= join(" ", @keylist);
  386.             $line .= ");\n";
  387.             push @out, $line;
  388.             push @out, "foreach my \$LOOPVAR$PARAMS->{arraycounter} (\@FORMVARS$PARAMS->{arraycounter}) {\n";
  389.             push @out, "  \$$textvar .= \"<input type=hidden name='\$LOOPVAR$PARAMS->{arraycounter}' value='\$substitutions->{FORMref}->{\$LOOPVAR$PARAMS->{arraycounter}";
  390.             push @out, "}'>\\n\";\n}\n";
  391.             next;
  392.         } elsif (m|^\s*<#skipto\s*"?(\w+)"?#>\s*$|i) {
  393.             if (! defined $PARAMS->{labels}->{lc($1)}) {
  394.                 $PARAMS->{arraycounter} += 1;
  395.                 $PARAMS->{labels}->{lc($1)} = "LABEL$PARAMS->{arraycounter}";
  396.             }
  397.             push @out, join("", "last ", $PARAMS->{labels}->{lc($1)}, ";\n");
  398.             next;
  399.         } elsif (m|^\s*<#label "?(\w+)"?\s*#>\s*$|i) {
  400.             if (scalar @ifs) {
  401.                 my $z = pop @ifs;
  402.                 template_error("Label $1 not permitted within IF block <#if $z#>");
  403.             }
  404.             if (! defined $PARAMS->{labels}->{lc($1)}) {
  405.                 $PARAMS->{arraycounter} += 1;
  406.                 $PARAMS->{labels}->{lc($1)} = "LABEL$PARAMS->{arraycounter}";
  407.             }
  408.             push @out, join("", "last ", $PARAMS->{labels}->{lc($1)}, ";\n");
  409.             push @out, join("", "}  ## LABEL ", $PARAMS->{labels}->{lc($1)}, "\n");
  410.             unshift @whilecond, join("", $PARAMS->{labels}->{lc($1)}, ":  { ## '$1'\n");
  411.             next;
  412.  
  413.         } elsif (m|^\s*<#foreach\s+\$(\w+)\s+\(\@(\w+)\)#>\s*$|i) {
  414.             $PARAMS->{arraycounter} += 1;
  415.             my ($iterval, $arrayname) = ($1, $2);
  416.             push @out, "if (ref \$substitutions->{$arrayname} eq 'ARRAY') {\n";
  417.             my @t = (); my $fenest = 0;
  418. WSL:        while ($_ = shift @l) {
  419.                 if (m|^\s*<#foreach\s+\$(\w+)\s+\(\@(\w+)\)#>\s*$|i) {
  420.                     $fenest += 1; push @t, $_;
  421.                 } elsif (m|^\s*<#endloop#>\s*$|i) {
  422.                     $fenest -= 1;
  423.                     if ($fenest < 0) {
  424.                         my $achold = $PARAMS->{arraycounter};
  425.                         push @out, "  my \@ARRAY$PARAMS->{arraycounter} = \@{ \$substitutions->{$arrayname} };\n";
  426.                         push @out, "  my \$MAXINDEX$PARAMS->{arraycounter} = \$#ARRAY$PARAMS->{arraycounter};\n";
  427.                         push @out, "  my \$ITERATION$PARAMS->{arraycounter} = 1;\n";
  428.                         push @out, "  my \$TEXT$PARAMS->{arraycounter} = \"\";\n";
  429.                         push @out, "  my \$ITER$PARAMS->{arraycounter} = 1;\n";
  430.                         push @out, "  my \$HOLD$PARAMS->{arraycounter} = \$substitutions->{$iterval};\n";
  431.                         push @out, "LOOP$PARAMS->{arraycounter}:  for (my \$INDEX$PARAMS->{arraycounter} = 0; \$INDEX$PARAMS->{arraycounter} <= \$MAXINDEX$PARAMS->{arraycounter}; \$INDEX$PARAMS->{arraycounter} += 1) {\n";
  432.                         push @out, join("", "    \$substitutions->{$iterval} = \$ARRAY$PARAMS->{arraycounter}", "[\$INDEX$PARAMS->{arraycounter}];\n");
  433.                         push @out, "    \$substitutions->{$iterval}->{_internal_counter} = \$INDEX$PARAMS->{arraycounter};\n";
  434.                         push @out, "    \$substitutions->{$iterval}->{_is_last_element} = \$INDEX$PARAMS->{arraycounter} == \$MAXINDEX$PARAMS->{arraycounter} ? 1 : 0;\n";
  435.                         push @out, "    \$substitutions->{$iterval}->{_is_first_element} = \$INDEX$PARAMS->{arraycounter} == 0 ? 1 : 0;\n";
  436.                         push @out, join("", "    \$substitutions->{$iterval}->{_previous_element} = \$INDEX$PARAMS->{arraycounter} > 0 ? \$ARRAY$PARAMS->{arraycounter}", "[\$INDEX$PARAMS->{arraycounter}-1] : \$ARRAY$PARAMS->{arraycounter}", "[0];\n");
  437.                         push @out, join("", "    \$substitutions->{$iterval}->{_next_element} = \$INDEX$PARAMS->{arraycounter} < \$MAXINDEX$PARAMS->{arraycounter} ? \$ARRAY$PARAMS->{arraycounter}", "[\$INDEX$PARAMS->{arraycounter}+1] : \$ARRAY$PARAMS->{arraycounter}", "[\$MAXINDEX$PARAMS->{arraycounter}];\n");
  438.                         push @out, "    \$substitutions->{$iterval}->{_iteration} = \$ITERATION$PARAMS->{arraycounter};\n";
  439.                         push @out, "    \$substitutions->{$iterval}->{_iteration_minus1} = \$ITERATION$PARAMS->{arraycounter} - 1;\n";
  440.                         push @out, join("", dtl_to_perl("TEXT$achold", "fe$achold", @t));
  441.                         push @out, "    \$ITERATION$achold += \$ITER$achold;\n";
  442.                         push @out, "  } ## End of LOOP$achold\n  \$$textvar .= \$TEXT$achold;\n";
  443.                         push @out, "  \$substitutions->{$iterval} = \$HOLD$achold;\n";
  444.                         push @out, "} else {\n";
  445.                         push @out, "  template_error(\"foreach over '\\\@$arrayname' does not point to array\");\n";
  446.                         push @out, "}\n";
  447.                         next WO;
  448.                     } else {
  449.                         push @t, $_;
  450.                     }
  451.                 } elsif ($fenest == 0 && m|^\s*<#next#>\s*|i) {
  452.                     push @t, "\rPERL\rnext LOOP$PARAMS->{arraycounter};\n";
  453.                 } elsif ($fenest == 0 && m|^\s*<#last#>\s*|i) {
  454.                     push @t, "\rPERL\rlast LOOP$PARAMS->{arraycounter};\n";
  455.                 } elsif ($fenest == 0 && m|^\s*<#skip\s*iteration#>\s*$|i) {
  456.                     push @t, "\rPERL\r\$ITER$PARAMS->{arraycounter} = 0;\n";
  457.                 } else {
  458.                     push @t, $_;
  459.                 }
  460.             }
  461.             template_error("Unterminated <#foreach#> statement (iterating over $iterval)");
  462.  
  463.         } elsif (m|^\s*<#while\s*\((.*)\)\s*#>\s*$|i) {
  464.             $PARAMS->{arraycounter} += 1;
  465.             my $cond = $1;
  466.             my @t = (); my $fenest = 0;
  467.             while ($_ = shift @l) {
  468.                 if (m|^\s*<#while\s*\((.*)\)\s*#>\s*$|i) {
  469.                     $fenest += 1; push @t, $_;
  470.                 } elsif (m|^\s*<#/while#>\s*$|i) {
  471.                     $fenest -= 1;
  472.                     if ($fenest < 0) {
  473.                         my $achold = $PARAMS->{arraycounter};
  474.                         my $x = dtl_if_replace($cond);
  475.                         $x = $1 if $x =~ /^.*?\((.*)\)\s*\{\s*$/;
  476.                         push @out, "  my \$whilecounter$achold = 0;\n";
  477.                         push @out, "  my \$TEXT$achold = \"\";\n";
  478.                         push @out, "  LOOP$achold: while (\$whilecounter$achold <= 5000 && ($x)) {\n";
  479.                         push @out, "    \$whilecounter$achold += 1;\n";
  480.                         push @out, join("", dtl_to_perl("TEXT$achold", "wh$achold", @t));
  481.                         push @out, "  } ## End of LOOP$achold\n  \$$textvar .= \$TEXT$achold;\n";
  482.                         next WO;
  483.                     } else {
  484.                         push @t, $_;
  485.                     }
  486.                 } elsif ($fenest == 0 && m|^\s*<#next#>\s*|i) {
  487.                     push @t, "\rPERL\rnext LOOP$PARAMS->{arraycounter};\n";
  488.                 } elsif ($fenest == 0 && m|^\s*<#last#>\s*|i) {
  489.                     push @t, "\rPERL\rlast LOOP$PARAMS->{arraycounter};\n";
  490.                 } else {
  491.                     push @t, $_;
  492.                 }
  493.             }
  494.             template_error("Unterminated <#while#> statement (iterating over $cond)");
  495.  
  496.         } elsif (m|^\s*<#for\s+\$(\w+)\s*=\s*(.*?)\s+to\s+(.*?)\s+step\s+(.*?)\s*#>\s*$|i) {
  497.             $PARAMS->{arraycounter} += 1;
  498.             my ($varname, $start, $end, $step) = ($1, $2, $3, $4);
  499.             my @t = (); my $fenest = 0;
  500.             while ($_ = shift @l) {
  501.                 if (m|^\s*<#for\s+\$(\w+)\s*=\s*(.*?)\s+to\s+(.*?)\s+step\s+(.*?)\s*#>\s*$|i) {
  502.                     $fenest += 1; push @t, $_;
  503.                 } elsif (m|^\s*<#end\s*for#>\s*$|i) {
  504.                     $fenest -= 1;
  505.                     if ($fenest < 0) {
  506.                         my $achold = $PARAMS->{arraycounter};
  507.                         $start = dtl_var_replace($start);
  508.                         $end = dtl_var_replace($end);
  509.                         $step = dtl_var_replace($step);
  510.                         my $itervar = join("", "\$for", $achold, "iter");
  511.                         push @out, join("", "  my \$for$achold", "step = $step;\n");
  512.                         push @out, join("", "  template_error(\"Step size cannot be zero in for loop $varname\") if \$for$achold", "step == 0;\n");
  513.                         push @out, "my \@tarr = ();\n";
  514.                         push @out, join("", "  if (\$for$achold", "step < 0) {\n");
  515.                         push @out, join("", "for (my $itervar = $start; $itervar >= $end; $itervar += $step) {\n");
  516.                         push @out, "push \@tarr, $itervar;\n";
  517.                         push @out, "}\n";
  518.                         push @out, join("", "  } else {\n");
  519.                         push @out, join("", "for (my $itervar = $start; $itervar <= $end; $itervar += $step) {\n");
  520.                         push @out, "push \@tarr, $itervar;\n";
  521.                         push @out, "}\n";
  522.                         push @out, "}\n";
  523.                         push @out, "my \$counter = 1;\n";
  524.                         push @out, "my \$TEXT$achold = \"\";\n";
  525.                         push @out, "LOOP$achold: foreach my $itervar (\@tarr) {\n";
  526.                         push @out, "\$substitutions->{\"_\"}->{$varname} = $itervar;\n";
  527.                         push @out, "\$substitutions->{$varname}->{value} = $itervar;\n";
  528.                         push @out, "\$substitutions->{$varname}->{_internal_counter} = \$counter - 1;\n";
  529.                         push @out, "\$substitutions->{$varname}->{_iteration} = \$counter;\n";
  530.                         push @out, "\$substitutions->{$varname}->{_iteration_minus1} = \$counter - 1;\n";
  531.                         push @out, "\$substitutions->{$varname}->{_is_last_element} = \$counter == scalar \@tarr ? 1 : 0;\n";
  532.                         push @out, "\$substitutions->{$varname}->{_is_first_element} = \$counter == 0 ? 1 : 0;\n";
  533.                         push @out, dtl_to_perl("TEXT$achold", "for$achold", @t);
  534.                         push @out, "\$counter += 1;\n";
  535.                         push @out, join("", "  } ## end LOOP$achold\n");
  536.                         push @out, "\$$textvar .= \$TEXT$achold;\n";
  537.                         next WO;
  538.                     } else {
  539.                         push @t, $_;
  540.                     }
  541.                 } elsif ($fenest == 0 && m|^\s*<#next#>\s*|i) {
  542.                     push @t, "\rPERL\rnext LOOP$PARAMS->{arraycounter};\n";
  543.                 } elsif ($fenest == 0 && m|^\s*<#last#>\s*|i) {
  544.                     push @t, "\rPERL\rlast LOOP$PARAMS->{arraycounter};\n";
  545.                 } else {
  546.                     push @t, $_;
  547.                 }
  548.             }
  549.             template_error("Unterminated <#for#> statement (iterating over $varname)");
  550.         } elsif (/^\s*<#exit#>\s*$/i) {
  551.             push @out, "  return (\"\$$textvar\\n\", \$substitutions);\n";
  552.             next;
  553.         }
  554.         push @out, join("", "\$$textvar .= ", dtl_var_replace($_), ";\n");
  555.     }
  556.     return (@subroutine, @outhead, @whilecond, @out);
  557. }
  558.  
  559. ###
  560. ### dtl_if_replace
  561. ###
  562. ### Generates appropriate 'if' statements
  563. ###
  564.  
  565. sub dtl_if_replace {
  566.     my $hash = 0;
  567.     if (ref $_[0] eq 'HASH') {
  568.         $hash = 1; shift @_;
  569.     }
  570.     $_ = shift @_;
  571.     my $result = "";
  572.     my @u = split(/ *(?:\|\||\&\&) */, $_);
  573.     my @v = (); while (m/(\|\||\&\&)/g) { push @v, $1; }
  574.     my $flag = 0;
  575.     my $y = "==|!=|>|<|>=|<=|eq|ne|gt|ge|lt|le|rexp=~|rexp!~|=~|!~";
  576.     while (my $u = shift @u) {
  577.         my $v = shift @v;
  578.         next if $u !~ /\S/;
  579.         my $thisresult = "";
  580.         if ($u =~ /^\s*(\(?)\s*pro\s*(\)?)\s*$/) {
  581.             $result .= "$1 \$DCONF->{pro} == 1 $2";
  582.             $result .= $v if $v;
  583.         } elsif ($u =~ /^\s*(\(?)\s*!\s*pro\s*(\)?)\s*$/) {
  584.             $result .= "$1 \$DCONF->{pro} == 0 $2";
  585.             $result .= $v if $v;
  586.         } elsif ($u =~ /^\s*(\(?)\s*(.*?)\s+($y)\s+(.*?)\s*(\)?)\s*$/o) {
  587.             my ($paren1, $var1, $cond, $var2, $paren2) = ($1, $2, $3, $4, $5);
  588.             $var1 = $1 if $var1 =~ /^\s*"(.*?)"\s*$/;
  589.             $var2 = $1 if $var2 =~ /^\s*"(.*?)"\s*$/;
  590.             if ($paren2 eq ")" && $var2 =~ /^\s*match\s*\((.*?)\s+\)\s*$/i) {
  591.                 $var2 = $1;
  592.             } elsif ($paren2 eq ")" && $var2 =~ /^\s*match\s*\((.*?)\s*$/i) {
  593.                 $var2 = $1; $paren2 = "";
  594.             } elsif ($var2 =~ m|^\s*\[(.*?)\]\s*$|) {
  595.                 $var2 = join("", " _minimath(", dtl_var_replace({}, $1), ") ") if $hash;
  596.                 $var2 = join("", " _minimath(", dtl_var_replace($1), ") ") if ! $hash;
  597.             } else {
  598.                 $var2 = dtl_var_replace($var2) if ! $hash;
  599.                 $var2 = dtl_var_replace({}, $var2) if $hash;
  600.             }
  601.             if ($var1 =~ m%\s*exists:\s*"(.*?)"\s*%) {
  602.                 $var1 = join("", " -f ", dtl_var_replace($1));
  603.             } elsif ($var1 =~ m%\s*option_defined:\s*"(.*?)"\s*%) {
  604.                 $var1 = join("", " defined \$GLOBAL_OPTIONS->{", dtl_var_replace($1), "} ");
  605.             } elsif ($var1 =~ m|^\s*\[(.*?)\]\s*$|) {
  606.                 $var1 = join("", " _minimath(", dtl_var_replace({}, $1), ") ") if $hash;
  607.                 $var1 = join("", " _minimath(", dtl_var_replace($1), ") ") if ! $hash;
  608.             } else {
  609.                 $var1 = dtl_var_replace($var1) if ! $hash;
  610.                 $var1 = dtl_var_replace({}, $var1) if $hash;
  611.             }
  612.             if ($cond =~ /~/) {
  613.                 $var2 =~ s/\$(\w+)->\{(\w+)\}/\r\$substitutions->\{$1\}->\{$2\}\r/g;
  614.                 if ($cond eq '=~' || $cond eq '!~') {
  615.                     my $rexp = "";
  616.                     while ($var2 =~ /^(.*)\r(.*?)\r/) {
  617.                         $rexp .= quotemeta($1); $rexp .= $2; $var2 = $';
  618.                     }
  619.                     $rexp .= quotemeta($var2);
  620.                     $thisresult = " $var1 $cond /$rexp/i ";
  621.                 } else {
  622.                     $cond =~ s/^rexp//;
  623.                     $var2 =~ s%/%\\/%g;
  624.                     $thisresult = " $var1 $cond /$var2/i ";
  625.                 }
  626.             } elsif ($cond =~ /^\w+$/) {
  627.                 $thisresult .= " $var1 $cond $var2 ";
  628.             } else {
  629.                 if ($var2 !~ /\s*join\(/ && $var2 =~ /"(.*?)"/) {
  630.                     $thisresult .= " $var1 $cond $1 ";
  631.                 } else {
  632.                     $thisresult .= " $var1 $cond $var2 ";
  633.                 }
  634.             }
  635.             $thisresult = join($thisresult, $paren1, $paren2);
  636.             $thisresult .= $v if $v;
  637.             $result .= $thisresult;
  638.         } elsif ($u =~ /^\s*(\(?)\s*(.*?)\s*(\)?)\s*$/) {
  639.             my ($paren1, $var1, $paren2) = ($1, $2, $3);
  640.             $var1 = $1 if $var1 =~ /^\s*"\s*(.*?)\s*"\s*$/;
  641.             if ($var1 =~ m%\s*exists:\s*"(.*?)"\s*%) {
  642.                 $var1 = join("", " -f ", dtl_var_replace($1));
  643.             } elsif ($var1 =~ m%\s*option_defined:\s*"(.*?)"\s*%) {
  644.                 $var1 = join("", " defined \$GLOBAL_OPTIONS->{", dtl_var_replace({}, $1), "} ") if $hash;
  645.                 $var1 = join("", " defined \$GLOBAL_OPTIONS->{", dtl_var_replace($1), "} ") if ! $hash;
  646.             } elsif ($var1 =~ m|^\s*\[(.*?)\]\s*$|) {
  647.                 $var1 = dtl_var_replace({}, $1) if $hash;
  648.                 $var1 = dtl_var_replace($1) if ! $hash;
  649.                 if ($var1 =~ /^\s*join/) {
  650.                     $var1 = " _minimath($var1) ";
  651.                 } else {
  652.                     $var1 = " _minimath(\"$var1\") ";
  653.                 }
  654.             } else {
  655.                 $var1 = dtl_var_replace($var1);
  656.             }
  657.             $thisresult .= " $var1 >= 1 ";
  658.             $thisresult = join($thisresult, $paren1, $paren2);
  659.             $thisresult .= $v if $v;
  660.             $result .= $thisresult;
  661.         }
  662.     }
  663.     my $z = join("", "if (", $result, ") {\n");
  664.     return $z;
  665. }
  666.  
  667. ###
  668. ### dtl_var_replace
  669. ###
  670. ### Replaces variables and certain commands
  671. ###
  672.  
  673. sub dtl_var_replace {
  674.     my $K = 0;
  675.     if (ref $_[0] eq 'HASH') {
  676.         $_ = $_[1];
  677.         $K = 1 if /\r/;
  678.     } else {
  679.         $_ = $_[0];
  680.         s%^\s*%% if /\S/;
  681.         s%"%\r!\r%g;
  682.         $K = s%(\$|\{|\}|\\|<#|#>)%\r$1\r%g;
  683.     }
  684.     if (m%(?:\r<#\r|\r\{\r#|<#|\{#)\s*if%i) {
  685.         s%\r!\r%"%g; s%\r(\$|\{|\}|\\|<#|#>)\r%$1%g if $K;
  686.         if (my @z = m%[<\{]#if (.*?)#[>\}]( *)(.*?)( *)[<\{]#else#[>\}]( *)(.*?)( *)[<\{]#endif#[>\}](\s*)%) {
  687.             unshift @z, "";
  688.             my ($before, $after) = ($`, $');
  689.             if ($before =~ /.*[<\{]#[^>\}]*$/ && $after =~ /^[^<\{]*#[>\}]/) {
  690.                 template_error("Cannot nest in-line IF-THEN-ELSE within other template language commands", $_);
  691.             }
  692.             my $ifcond = dtl_if_replace($z[1]);
  693.             $ifcond = $1 if $ifcond =~ /\((.*)\)/;
  694.             my $line = "( $ifcond ? join(\"\", ";
  695.             my @out_1 = ();
  696.             push @out_1, "\"$z[2]\"" if $z[2] ne "";
  697.             push @out_1, dtl_var_replace($z[3]) if $z[3] ne "";
  698.             push @out_1, "\"$z[4]\"" if $z[4] ne "";
  699.             $z[8] =~ s/\n/\\n/g;
  700.             push @out_1, "\"$z[8]\"" if $z[8] ne "";
  701.             $line .= join(",", @out_1);
  702.             $line .= ") : join(\"\", ";
  703.             my @out_2 = ();
  704.             push @out_2, "\"$z[5]\"" if $z[5] ne "";
  705.             push @out_2, dtl_var_replace($z[6]) if $z[6] ne "";
  706.             push @out_2, "\"$z[7]\"" if $z[7] ne "";
  707.             push @out_2, "\"$z[8]\"" if $z[8] ne "";
  708.             $line .= join(",", @out_2);
  709.             $line .= "))";
  710.             return join("", "join(\"\", ", dtl_var_replace($before), ", $line, ", dtl_var_replace($after), ")");
  711.         } elsif (my @z = m%[<\{]#if (.*?)#[>\}]( *)(.*?)( *)[<\{]#endif#[>\}](\s*)%) {
  712.             unshift @z, "";
  713.             my ($before, $after) = ($`, $');
  714.             if ($before =~ /.*[<\{]#[^>\}]*$/ && $after =~ /^[^<\{]*#[>\}]/) {
  715.                 template_error("Cannot nest in-line IF-THEN-ELSE within other template language commands", $_);
  716.             }
  717.             my $ifcond = dtl_if_replace($z[1]);
  718.             $ifcond = $1 if $ifcond =~ /\((.*)\)/;
  719.             my $line = "( $ifcond ? join(\"\", ";
  720.             my @out_1 = ();
  721.             push @out_1, "\"$z[2]\"" if $z[2] ne "";
  722.             push @out_1, dtl_var_replace($z[3]) if $z[3] ne "";
  723.             push @out_1, "\"$z[4]\"" if $z[4] ne "";
  724.             $z[5] =~ s/\n/\\n/g;
  725.             push @out_1, "\"$z[5]\"" if $z[5] ne "";
  726.             $line .= join(",", @out_1);
  727.             $line .= ") : \"$z[5]\" ";
  728.             $line .= ")";
  729.             return join("", "join(\"\", ", dtl_var_replace($before), ", $line, ", dtl_var_replace($after), ")");
  730.         } elsif (my @z = m%[<\{]#if (.*?)#[>\}]( *)(.*?)( *)\s*$%) {
  731.             unshift @z, "";
  732.             my ($before, $after) = ($`, $');
  733.             if ($before =~ /.*[<\{]#[^>\}]*$/ && $after =~ /^[^<\{]*#[>\}]/) {
  734.                 template_error("Cannot nest in-line IF-THEN-ELSE within other template language commands", $_);
  735.             }
  736.             my $ifcond = dtl_if_replace($z[1]);
  737.             $ifcond = $1 if $ifcond =~ /\((.*)\)/;
  738.             my $line = "( $ifcond ? join(\"\", ";
  739.             my @out_1 = ();
  740.             push @out_1, "\"$z[2]\"" if $z[2] ne "";
  741.             push @out_1, dtl_var_replace($z[3]) if $z[3] ne "";
  742.             $z[4] =~ s/\n/\\n/g;
  743.             push @out_1, "\"$z[4]\"" if $z[4] ne "";
  744.             $line .= join(",", @out_1);
  745.             $line .= ", \"\\n\") : \"\" ";
  746.             $line .= ")";
  747.             return join("", "join(\"\", ", dtl_var_replace($before), ", $line)");
  748.         } else {
  749.             template_error("Invalid in-line IF statement", $_);
  750.         }
  751.     } elsif ($K) {
  752. ZLP:    while (m|\r<#\r|) {
  753.             my $flag = 0;
  754. IL1:        while (m%\r<#\rform\s*escape\s*\r!\r(.*?)\r!\r\s*\r#>\r%i) {
  755.                 my ($before, $after, $one) = ($`, $', $1);
  756.                 if ($one =~ /\r<#\r/) { $flag = 1; last IL1; }
  757.                 $_ = join("", $before, "\r\"\r", ", form_escape(", dtl_var_replace({}, $one), "), \r\"\r", $after);
  758.             }
  759. IL2:        while (m%\r<#\rrepeated +(.*?) *\r!\r(.*?)\r!\r\r#>\r%i) {
  760.                 my ($before, $after, $one, $two) = ($`, $', $1, $2);
  761.                 if ($one =~ /\r<#\r/) { $flag = 1; last IL2; }
  762.                 if ($two =~ /\r<#\r/) { $flag = 1; last IL2; }
  763.                 $one = dtl_var_replace({}, $one);
  764.                 $one = $1 if $one =~ /^"(.*?)"$/;
  765.                 $_ = join("", $before, "\r\"\r, ", dtl_var_replace({}, $two), " x ", $one, ", \r\"\r", $after);
  766.             }
  767. IL3:        while (m%\r<#\rescape \r!\r(.*?)\r!\r\r#>\r%i) {
  768.                 my ($before, $after, $one) = ($`, $', $1);
  769.                 if ($one =~ /\r<#\r/) { $flag = 1; last IL3; }
  770.                 $_ = join("", $before, "\r\"\r, escape(", dtl_var_replace({}, $one), "), \r\"\r", $after);
  771.             }
  772. IL4:        while (m%\r<#\runescape \r!\r(.*?)\r!\r\r#>\r%i) {
  773.                 my ($before, $after, $one) = ($`, $', $1);
  774.                 if ($one =~ /\r<#\r/) { $flag = 1; last IL4; }
  775.                 $_ = join("", $before, "\r\"\r, unescape(", dtl_var_replace({}, $one), "), \r\"\r", $after);
  776.             }
  777. IL5:        while (m%\r<#\rremove[_\s]*html \r!\r(.*?)\r!\r\r#>\r%i) {
  778.                 my ($before, $after, $one) = ($`, $', $1);
  779.                 if ($one =~ /\r<#\r/) { $flag = 1; last IL5; }
  780.                 $_ = join("", $before, "\r\"\r, remove_html(", dtl_var_replace({}, $one), "), \r\"\r", $after);
  781.             }
  782. IL6:        while (m%\r<#\rjavascript[ _]prepare \r!\r(.*?)\r!\r\r#>\r%i) {
  783.                 my ($before, $after, $one) = ($`, $', $1);
  784.                 if ($one =~ /\r<#\r/) { $flag = 1; last IL6; }
  785.                 $_ = join("", $before, "\r\"\r, template_js_prepare(", dtl_var_replace({}, $one), "), \r\"\r", $after);
  786.             }
  787. IL7:        while (m%\r<#\rmaxchar\s*(\S+)/(.*?)\s*\r!\r(.*?)\r!\r\r#>\r%i) {
  788.                 my ($before, $after, $one, $two, $three) = ($`, $', $1, $2, $3);
  789.                 if ($one =~ /\r<#\r/) { $flag = 1; last IL7; }
  790.                 if ($two =~ /\r<#\r/) { $flag = 1; last IL7; }
  791.                 if ($three =~ /\r<#\r/) { $flag = 1; last IL7; }
  792.                 $_ = join("", $before, "\r\"\r, maxcharcut(", dtl_var_replace({}, $one), ",", dtl_var_replace({}, $two), ",", dtl_var_replace({}, $three), "),\r\"\r", $after);
  793.             }
  794. IL8:        while (m%\r<#\rmaxchar\s*(.*?)\s*\r!\r(.*?)\r!\r\r#>\r%i) {
  795.                 my ($before, $after, $one, $two) = ($`, $', $1, $2);
  796.                 if ($one =~ /\r<#\r/) { $flag = 1; last IL8; }
  797.                 if ($two =~ /\r<#\r/) { $flag = 1; last IL8; }
  798.                 $_ = join("", $before, "\r\"\r, substrnohtml(", dtl_var_replace({}, $two), ",", dtl_var_replace({}, $one), "),\r\"\r", $after);
  799.             }
  800. IL9:        while (m%\r<#\rpart\s*\r!\r(.*?)\r!\r\s*\((.*?)\)\s*exists\s*\r#>\r%i) {
  801.                 my ($before, $after, $one, $two) = ($`, $', $1, $2);
  802.                 if ($one =~ /\r<#\r/) { $flag = 1; last IL9; }
  803.                 if ($two =~ /\r<#\r/) { $flag = 1; last IL9; }
  804.                 $_ = join("", $before, "\r\"\r, does_part_exist(", dtl_var_replace({}, $two), ",", dtl_var_replace({}, $one), "),\r\"\r", $after);
  805.             }
  806. IL10:        while (m%\r<#\rcss\s*size\s*\(([\-\+\d]+)\)\s*\r#>\r%i) {
  807.                 my ($before, $after, $one) = ($`, $', $1);
  808.                 if ($one =~ /\r<#\r/) { $flag = 1; last IL10; }
  809.                 $_ = join("", $before, "\r\"\r, template_css_size(", dtl_var_replace({}, $one), "),\r\"\r", $after);
  810.             }
  811. IL11:        while (m%\r<#\rprogram\s*sub\s*\r!\r(.*?)\r!\r\s*&(\w+)\s*\((.*?)\)\s*\r#>\r%i) {
  812.                 my ($before, $after, $one, $two, $three) = ($`, $', $1, $2, $3);
  813.                 if ($one =~ /\r<#\r/) { $flag = 1; last IL11; }
  814.                 if ($three =~ /\r<#\r/) { $flag = 1; last IL11; }
  815.                 $_ = join("", $before, "\r\"\r, program_sub(", dtl_var_replace({}, $one), ", \"$two\", ", dtl_var_replace({}, $three), "),\r\"\r", $after);
  816.             }
  817. IL12:        while (m%\r<#\rwordwrap\s*(\S+)\s*\r!\r(.*?)\r!\r\r#>\r%i) {
  818.                 my ($before, $after, $one, $two) = ($`, $', $1, $2);
  819.                 if ($one =~ /\r<#\r/) { $flag = 1; last IL12; }
  820.                 if ($two =~ /\r<#\r/) { $flag = 1; last IL12; }
  821.                 $_ = join("", $before, "\r\"\r, wordwrapper(", dtl_var_replace({}, $one), ", ", dtl_var_replace({}, $two), ", 0),\r\"\r", $after);
  822.             }
  823. IL13:        while (m%\r<#\rwordwrapX\s*(\S+)\s*\r!\r(.*?)\r!\r\r#>\r%i) {
  824.                 my ($before, $after, $one, $two) = ($`, $', $1, $2);
  825.                 if ($one =~ /\r<#\r/) { $flag = 1; last IL13; }
  826.                 if ($two =~ /\r<#\r/) { $flag = 1; last IL13; }
  827.                 $_ = join("", $before, "\r\"\r, wordwrapper(", dtl_var_replace({}, $one), ", ", dtl_var_replace({}, $two), ", 1),\r\"\r", $after);
  828.             }
  829. IL14:        while (m%\r<#\rrtpad (\d+) \r!\r(.*?)\r!\r\r#>\r%i) {
  830.                 my ($before, $after, $one, $two) = ($`, $', $1, $2);
  831.                 if ($two =~ /\r<#\r/) { $flag = 1; last IL14; }
  832.                 $_ = join("", $before, "\r\"\r, substr(join(\"\", ", dtl_var_replace({}, $two), ", \" \" x $one), 0, $one),\r\"\r", $after);
  833.             }
  834. IL15:        while (m%\r<#\rstrlength\s*\r!\r(.*?)\r!\r\r#>\r%i) {
  835.                 my ($before, $after, $one) = ($`, $', $1);
  836.                 if ($one =~ /\r<#\r/) { $flag = 1; last IL15; }
  837.                 $_ = join("", $before, "\r\"\r, length(", dtl_var_replace({}, $one), "),\r\"\r", $after);
  838.             }
  839. IL16:        while (m%\r<#\rlength\s*\r!\r(.*?)\r!\r\r#>\r%i) {
  840.                 my ($before, $after, $one) = ($`, $', $1);
  841.                 if ($one =~ /\r<#\r/) { $flag = 1; last IL16; }
  842.                 $_ = join("", $before, "\r\"\r, nohtmllength(", dtl_var_replace({}, $one), "),\r\"\r", $after);
  843.             }
  844. IL17:        while (m%\r<#\r\s*gmtoffset\s*\r#>\r%i) {
  845.                 $_ = join("", $`, "\r\"\r, getgmtoffset(), \r\"\r", $');
  846.             }
  847. IL18:        while (m|\r<#\rdate +(.*?) +format\s+\r!\r(.*?)\r!\r\s*\r#>\r|i) {
  848.                 my ($datenum, $format, $before, $after) = ($1, $2, $`, $');
  849.                 if ($datenum =~ /\r<#\r/) { $flag = 1; last IL18; }
  850.                 if ($format =~ /\r<#\r/) { $flag = 1; last IL18; }
  851.                 my $one = dtl_var_replace({}, $datenum);
  852.                 $_ = join("", $before, "\r\"\r, (", $one, ' =~ /^[0-9]+$/ ? get_date_time(', dtl_var_replace({}, $format), ", ", $one, ") : ' '), \r\"\r", $after);
  853.             }
  854.             s%\r<#\rpick\s*(\w+)?\s*(.*?)\s*from\s*\@(\w+)\s*\((.*?)\)\s*\r#>\r%\r\"\r, picker(\r\"\r$1\r\"\r, \r\"\r$2\r\"\r, \r\"\r$3\r\"\r, \r\"\r$4\r\"\r, \$substitutions), \r\"\r%g;
  855.             s%\r<#\rcurrent\s*time\r#>\r%\r"\r, time, \r"\r%g;
  856.             if (m%\r<#\r\s*&\s*(\w+)\s*\(([^\)]*)\s*\)\s*\r#>\r%i) {
  857.                 my ($subname, $args, $before, $after) = (lc($1), $2, $`, $');
  858.                 template_error("Subroutine $subname not defined prior to being called") if ! defined $PARAMS->{subs}->{$subname};
  859.                 my $subr = $PARAMS->{subs}->{$subname};
  860.                 my @sa = ();
  861.                 $args =~ s/\r!\r/"/g;
  862.                 while ($args =~ m|"([^"]*)"\s*,|) {
  863.                     $args = $';
  864.                     push @sa, dtl_var_replace({}, $1);
  865.                 }
  866.                 $_ = join("", $before, "\r\"\r, $subr(\$substitutions,", join(",", @sa), "),\r\"\r", $after);
  867.             }
  868.             last ZLP if $flag == 0;
  869.         }
  870.         s%\r\$\r0%\$0%g;
  871.         while (m%\r\$\rL\r(?:->)?\{\r(\w+)\r\}\r\[(.*?)\]%) {
  872.             my ($bef, $var, $arr, $aft) = ($`, $1, $2, $');
  873.             my $z = dtl_var_replace({}, $arr);
  874.             if ($z =~ /^\r\"\r(.*?)\r\"\r/) {
  875.                 $z = $1;
  876.             }
  877.             $_ = join("", $bef, "\r\"\r, read_language()->{'$var'}->[", $z, "], \r\"\r", $aft);
  878.         }
  879.         s%\r\{\r\|\r\}\r%\r"\r,\r"\r%g;
  880.         s%\r\$\rL\r(->)?\{\r(\w+)\r\}\r%\r"\r, read_language()->{'$2'}, \r"\r%g;
  881.         s%\r\$\rGLOBAL_OPTIONS(?:->)?\r\{\r(\w+)\r\}\r%\$GLOBAL_OPTIONS->{'$1'}%g;
  882.         s%\r\$\rGLOBAL_OPTIONS(?:->)?\r\{\r\r\$\r(\w+)\r\}\r%\$GLOBAL_OPTIONS->{\$substitutions->{_}->{'$1'}}%g;
  883.         s%\r\$\rENV\r\{\r(\w+)\r\}\r%\$ENV{'$1'}%g;
  884.         s%\r\$\r#(\w+)%\r"\r, ref \$substitutions->{$1} eq 'ARRAY' ? scalar \@{ \$substitutions->{'$1'} } : 0, \r"\r%g;
  885.         s%\r\$\rsubstitutions->\r\{\r(\w+)\r\}\r%\$substitutions->{'$1'}%g;
  886.         s%\r\$\r(\w+)\[\r\$\r(\w+)->\r\{\r(\w+)\r\}\r\]->\r\{\r(\w+)\r\}\r%\r\"\r, \$substitutions->{'$1'}->\[-1\+\(\$substitutions->{'$2'}->{'$3'}\)\]->{'$4'}, \r\"\r%g;
  887.         s%\r\$\r(\w+)\[\r\$\r(\w+)->\r\{\r(\w+)\r\}\r\]%\r"\r, \$substitutions->{'$1'}->\[safe_minus_one(\$substitutions->{'$2'}->{'$3'})\], \r"\r%g;
  888.         s%\r\$\r(\w+)\[(.*?)\]->\r\{\r(\w+)\r\}\r%join("", "\r\"\r, \$substitutions->{'$1'}", "->[safe_minus_one(", dtl_var_replace({}, $2), ")]->{'$3'}", ", \r\"\r")%ge;
  889.         s%\r\$\r(\w+)\[(.*?)\]%join("", "\r\"\r, \$substitutions->{$1}", "->[safe_minus_one(", dtl_var_replace({}, $2), ")] , \r\"\r")%ge;
  890.         s%\r\$\r(\w+)->\r\{\r(\w+)\r\}\r->\r\{\r(\w+)\r\}\r%\$substitutions->{'$1'}->{'$2'}->{'$3'}%g;
  891.         s%\r\$\r(\w+)->\r\{\r(\w+)\r\}\r->\r\{\r\r\$\r(\w+)\r\}\r%\$substitutions->{'$1'}->{'$2'}->{\$substitutions->{_}->{'$3'}}%g;
  892.         s%\r\$\r(\w+)->\r\{\r\r\$\r(\w+)\r\}\r%\$substitutions->{$1}->{\$substitutions->{_}->{'$2'}}%g;
  893.         s%\r\$\r(\w+)->\r\{\r\r\$\r(\w+)->\r\{\r(\w+)\r\}\r\s*?\r\}\r%\$substitutions->{$1}->{\$substitutions->{'$2'}->{'$3'}}%g;
  894.         s%\r\$\r(\w+)->\r\{\r(\w+)\r\}\r%\$substitutions->{'$1'}->{'$2'}%g;
  895.         s%\r\$\r\@(\w+)->\r\{\r(\w+):\s*(\w+)\s*=\s*\r!\r(.*?)\r!\r\r\}\r%join("", "\r\"\r", ", element_array_grep(\$substitutions, \"$3\",", dtl_var_replace({}, $4), ", \"$1\", \"$2\")", ", \r\"\r")%ge;
  896.         s%\r\$\r(\w+)%\$substitutions->{_}->{'$1'}%g;
  897.         s%\r\\\ru%\r^\ru%g;
  898.         s%\r\\\rl%\r^\rl%g;
  899.     } else {
  900.         s/\\/\\\\/g;
  901.         s/\r!\r/\\"/g;
  902.         s/\n/\\n/g;
  903.         s/\r\{\r(\|+)\r\}\r/" " x (length($1)-1)/ge;
  904.         s/\r\{\r(\|)tab(\|)\r\}\r/\\t/g;
  905.         s/\@/\\\@/g;
  906.         s/\r//g;
  907.         template_error( "X", $_ ) if /\{\|+\}/;
  908.         return "\"$_\"";
  909.     }
  910.     if (m%\r\"\r%) {
  911.         s/\\/\\\\/g;
  912.         s/\r!\r/\\"/g;
  913.         s/\r\^\r/\\/g;
  914.         $_ .= " ";
  915.         my @q = split(/\r\"\r/, $_);
  916.         chop $q[$#q];
  917.         foreach my $q7 (@q) {
  918.             $q7 =~ s/\r"\r/\\"/g;
  919.         }
  920.         my $zline = "join(\"\", ";
  921.         my $line = join("", "\"", join("\"", @q));
  922.         $line .= "\")";
  923.         while ($line =~ /\\([ul])"\s*,\s*(\w+)/) {
  924.             my ($before, $after, $one, $case) = ($`, $', $2, $1);
  925.             $before .= "\",";
  926.             my $hold = ""; $after = join("", $one, $after);
  927.             my $counter = 0; my $quoteon = 0;
  928. WX:            while ($after =~ /(.)/) {
  929.                 $after = $'; $hold .= $1;
  930.                 if ($1 eq "(") {
  931.                     $counter += 1 if ! $quoteon;
  932.                 } elsif ($1 eq ")") {
  933.                     $counter -= 1 if ! $quoteon;
  934.                 } elsif ($1 eq "\"") {
  935.                     $quoteon = ! $quoteon;
  936.                 } elsif ($1 eq "," && ! $quoteon && $counter == 0) {
  937.                     $hold =~ s/,$//;
  938.                     $line = join("", $before, "case_$case(", $hold, "),", $after);
  939.                     last WX;
  940.                 }
  941.             }
  942.         }
  943.         $line =~ s/\s*,""\s*\)$/\)/g;
  944.         $line =~ s/^\"\"\s*,\s*//g;
  945.         $line =~ s/\n/\\n/g;
  946.         $line =~ s/\r\{\r(\|+)\r\}\r/" " x (length($1)-1)/ge;
  947.         $line =~ s/\r\{\r(\|)tab(\|)\r\}\r/\\t/g;
  948.         $_ = join("", $zline, $line);
  949.         s/\r//g;
  950.         template_error( "Y", $_ ) if /\{\|+\}/;
  951.         return $_;
  952.     } else {
  953.         s/\\/\\\\/g;
  954.         s/\r!\r/\\"/g;
  955.         s/\r\^\r/\\/g;
  956.         s/\n/\\n/g;
  957.         s/^ *//g;
  958.         s/ *$//g;
  959.         s/\r\{\r(\|+)\r\}\r/" " x (length($1)-1)/ge;
  960.         s/\r\{\r(\|)tab(\|)\r\}\r/\\t/g;
  961.         s/\r//g;
  962.         s/\@/\\\@/g;
  963.         template_error( "Z", $_ ) if /\{\|+\}/;
  964.         return "\"$_\"";
  965.     }
  966. }
  967.  
  968. 1;
  969.