# FILE: templnew.pl
# DESCRIPTION: Template Interpreter (convert to Perl and run)
#-------------------------------------------------------------------------------
# DISCUS COPYRIGHT NOTICE
#
# Discus is copyright (c) 2002 by DiscusWare, LLC, all rights reserved.
# The use of Discus is governed by the Discus License Agreement which is
# available from the Discus WWW site at:
#    http://www.discusware.com/discus/license
#
# Pursuant to the Discus License Agreement, this copyright notice may not be
# removed or altered in any way.
#-------------------------------------------------------------------------------

use strict;
use vars qw($GLOBAL_OPTIONS $DCONF $PARAMS);

###
### dtl_interpret
###
### Handler for output of text
###

sub dtl_interpret {
	my ($filename, $substitutions) = @_;
	if ($filename =~ /^\*/) {
		return dtl_interpret_skin($', $substitutions);
	} else {
		return dtl_interpret_template($filename, $substitutions);
	}
}

###
### dtl_interpret_skin
###
### Skin interpreter
###

sub dtl_interpret_skin {
	my ($filename, $substitutions, $skip) = @_;
	$filename =~ s/\W/_/g;
	my $topic = 0; my $after = $'; my $skininit = "";
	if (! defined $substitutions->{'_ALTCOLOR'}) {
		$substitutions = basic_substitutions($substitutions);
	}
	if (! defined $substitutions->{'color_override'}) {
		$substitutions = color_substitutions($substitutions);
	}
	if ($filename =~ /^(\d+)/ && $1 > 0) {
		$filename = join("", "SKIN_$1", "_$'");
		$topic = $1;
		$after = $filename;
		$skininit = join("", "SKIN_$topic", "_INIT");
	} else {
		$filename = "SKIN_$filename";
		$after = $filename;
		$skininit = join("", "SKIN_INIT");
	}
	my $d = "$DCONF->{admin_dir}/data/tcache";
	if (defined $PARAMS->{templates}->{$filename} && defined $PARAMS->{templates}->{$skininit}) {
		return 1 if $skip;
		performance_string("* Using cached skin for $filename");
		my $varname1 = join('::', $PARAMS->{templates}->{$skininit}, 'process');
		$substitutions = (&{\&{$varname1}}($substitutions))[1];
		my $varname2 = join('::', $PARAMS->{templates}->{$filename}, 'process');
		return &{\&{$varname2}}($substitutions);
	} else {
		if (! -e "$DCONF->{admin_dir}/data/tcache") {
			if (mkdir "$DCONF->{admin_dir}/data/tcache", oct($DCONF->{perms0777})) {
				chmod oct($DCONF->{perms0777}), "$DCONF->{admin_dir}/data/tcache";
			} else {
				barf_tcache($!);
			}
		}
		my $skinpath = dtl_grab_skin($topic);
		my $default = "$DCONF->{admin_dir}/skins/$GLOBAL_OPTIONS->{'skinchoice'}.tmpl";
		if ($topic != 0 && $skinpath eq $default) {
			 my $z = join("", "$d/SKIN_$topic", "_$after.pl");
			 if (! -e $z && open (FILE, "< $d/SKIN_$after.pl")) {
			 	open (FILEOUT, "> $z");
			 	while (<FILE>) {
			 		print FILEOUT;
			 	}
			 	close (FILE);
			 	close (FILEOUT);
			}
		}
		my $z = "$d/$after.pl";
		if (dtl_check_mtime($skinpath, $z)) {
			if (defined $PARAMS->{templates}->{$skininit}) {
				return 1 if $skip;
				my $varname = join('::', $PARAMS->{templates}->{$skininit}, 'process');
				$substitutions = (&{\&{$varname}}($substitutions))[1];
			} elsif (-e "$d/$skininit.pl" && require "$d/$skininit.pl") {
				$PARAMS->{templates}->{$skininit} = $skininit;
				return 1 if $skip;
				my $varname = join('::', $PARAMS->{templates}->{$skininit}, 'process');
				$substitutions = (&{\&{$varname}}($substitutions))[1];
			}
			if (-e $z && require "$z") {
				performance_string("* Using cached skin for $filename");
				$PARAMS->{templates}->{$filename} = $filename;
				return 1 if $skip;
				my $varname = join('::', $PARAMS->{templates}->{$filename}, 'process');
				return &{\&{$varname}}($substitutions);
			} else {
				unlink $z;
			}
		}
		my @parts = ();
		if (open (SKIN, "< $skinpath")) {
			my @skin = <SKIN>;
			close (SKIN);
			my @z = ();
			my $flag = "";
			foreach my $line (@skin) {
				if ($line =~ m|^\s*<#part "([^"]+)"#>\s*$|i) {
					$flag = $1; $flag =~ s/\W/_/g;
					push @z, "<!--BEGIN-->\n";
				} elsif ($line =~ m|^\s*<#/part#>\s*$|i) {
					push @z, "<!--END-->\n";
					my @t = @z;
					push @parts, { part => $flag, content => \@t };
					$flag = "";
					@z = ();
				} elsif ($flag ne "") {
					push @z, $line;
				}
			}
			my $prefix = $topic == 0 ? "SKIN_" : join("", "SKIN_", $topic, "_");
			dreq("templint");
			foreach my $file (@parts) {
				my $z = join("", $prefix, $file->{part});
				my @fileout = dtlperl($z, @{$file->{content}});
				open (FILEOUT, "> $DCONF->{admin_dir}/data/tcache/$z.pl");
				print FILEOUT @fileout;
				close (FILEOUT);
				chmod oct($DCONF->{perms0666}), "$DCONF->{admin_dir}/data/tcache/$z.pl";
			}
			if (defined $PARAMS->{templates}->{$skininit}) {
				return 1 if $skip;
				my $varname = join('::', $PARAMS->{templates}->{$skininit}, 'process');
				$substitutions = (&{\&{$varname}}($substitutions))[1];
			} elsif (-e "$d/$skininit.pl" && require "$d/$skininit.pl") {
				$PARAMS->{templates}->{$skininit} = $skininit;
				return 1 if $skip;
				my $varname = join('::', $PARAMS->{templates}->{$skininit}, 'process');
				$substitutions = (&{\&{$varname}}($substitutions))[1];
			}
			if (defined $PARAMS->{templates}->{$filename}) {
				return 1 if $skip;
				my $varname = join('::', $PARAMS->{templates}->{$filename}, 'process');
				return &{\&{$varname}}($substitutions);
			} elsif (-e "$DCONF->{admin_dir}/data/tcache/$filename.pl" && require "$DCONF->{admin_dir}/data/tcache/$filename.pl") {
				$PARAMS->{templates}->{$filename} = $filename;
				return 1 if $skip;
				my $varname = join('::', $PARAMS->{templates}->{$filename}, 'process');
				return &{\&{$varname}}($substitutions);
			} else {
				unlink "$DCONF->{admin_dir}/data/tcache/$filename.pl";
				my @str = ("Failed skin require on $filename: $!");
				my $i = 0;
				while (my ($pack, $file, $line, $subname, $hasargs, $wantarray) = caller($i++)) {
  					$file = $' if $file =~ /.*[\\\/]/;
  					push @str, "$file :: $line :: $subname";
  				}
  				template_error(@str);
			}
		} else {
			template_error("Skin Open Error", "Could not open skin $skinpath!", $!);
		}
	}
}

###
### dtl_check_mtime
###
### Checks modification times on templates, results, and this script itself
### to determine whether to force the template to be re-interpreted
###

sub dtl_check_mtime {
	my ($template_path, $interpreted_path) = @_;
	return 1 if $PARAMS->{'dtl_check_mtime'}->{$template_path} == 1;
	return 0 if ! -e $interpreted_path;
	if ($PARAMS->{mtime}->{'templint.pl'} == 0) {
		$PARAMS->{mtime}->{'templint.pl'} = (stat "$DCONF->{admin_dir}/source/templint.pl")[9];
	}
	if ($PARAMS->{mtime}->{$template_path} == 0) {
		$PARAMS->{mtime}->{$template_path} = (stat $template_path)[9];
	}
	if ($PARAMS->{mtime}->{$interpreted_path} == 0) {
		$PARAMS->{mtime}->{$interpreted_path} = (stat $interpreted_path)[9];
	}
	return 0 if $PARAMS->{mtime}->{'templint.pl'} > $PARAMS->{mtime}->{$interpreted_path};
	return 0 if $PARAMS->{mtime}->{$template_path} > $PARAMS->{mtime}->{$interpreted_path};
	$PARAMS->{'dtl_check_mtime'}->{$template_path} = 1;
	return 1;
}

###
### dtl_grab_skin
###
### Gives the full path for the appropriate customized skin file for a topic
###

sub dtl_grab_skin {
	my ($topic) = @_;
	return $PARAMS->{'dtl_grab_skin'}->{$topic} if defined $PARAMS->{'dtl_grab_skin'}->{$topic};
	if ($topic > 0) {
		if ($DCONF->{"registered_skin_$topic"} ne "") {
			my $filepath = $DCONF->{"registered_skin_$topic"};
			if (-e $filepath && -r $filepath) {
				$PARAMS->{'dtl_grab_skin'}->{$topic} = $filepath;
				return $filepath;
			}
		}
		my $path = get_message_path($topic);
		if (-e "$path/default.tmpl" && -r "$path/default.tmpl") {
			$PARAMS->{'dtl_grab_skin'}->{$topic} = "$path/default.tmpl";
			return "$path/default.tmpl";
		}
	}
	my $default = "$DCONF->{admin_dir}/skins/$GLOBAL_OPTIONS->{'skinchoice'}.tmpl";
	$PARAMS->{'dtl_grab_skin'}->{$topic} = $default;
	return $default if -e $default && -r $default;
	template_error("Skin Error", "Could not find valid skin for topic $topic (skin choice: $GLOBAL_OPTIONS->{skinchoice})");
}

###
### template_includer
###
### For including a template within a file
###

sub template_includer {
	my ($templatename, $substitutions) = @_;
	$PARAMS->{template_includer_counter} += 1;
	template_error("Recursive condition detected inserting $templatename") if $PARAMS->{template_includer_counter} > 50;
	my $z = dtl_interpret_template($templatename, $substitutions);
	$PARAMS->{template_includer_counter} -= 1;
	return join("", $z, "\n");
}

###
### getgmtoffset
###
### Calculates GMT offset for <#gmtoffset#> command code
###

sub getgmtoffset {
	my $time = time;
	my ($s1, $m1, $hr1, $mo1, $dy1, $yr1) = localtime($time);
	my ($s2, $m2, $hr2, $mo2, $dy2, $yr2) = gmtime($time);
	my $offset = ($s1 - $s2);
	$offset += 60 * ($m1 - $m2);
	$offset += 60 * 60 * ($hr1 - $hr2);
	$offset += 24 * 60 * 60 if ($mo1 > $mo2);
	$offset -= 24 * 60 * 60 if ($mo1 < $mo2);
	$offset += 24 * 60 * 60 if ($mo1 == $mo2 && $dy1 > $dy2);
	$offset -= 24 * 60 * 60 if ($mo1 == $mo2 && $dy1 < $dy2);
	return $offset;
}

###
### dtl_interpret_template
###
### Template interpreter
###

sub dtl_interpret_template {
	my ($filename, $substitutions, $skip) = @_;
	if (! defined $substitutions->{'_ALTCOLOR'}) {
		$substitutions = basic_substitutions($substitutions);
	}
	if (! defined $substitutions->{'color_override'}) {
		$substitutions = color_substitutions($substitutions);
	}
	if (defined $PARAMS->{templates}->{$filename}) {
		my $varname = join('::', $PARAMS->{templates}->{$filename}, 'process');
		return (&{\&{$varname}}($substitutions))[0];
	} else {
		if (! -e "$DCONF->{admin_dir}/data/tcache") {
			if (mkdir "$DCONF->{admin_dir}/data/tcache", oct($DCONF->{perms0777})) {
				chmod oct($DCONF->{perms0777}), "$DCONF->{admin_dir}/data/tcache";
			} else {
				barf_tcache($!);
			}
		}
		my $fn = $filename; $fn =~ s/\W/_/g;
		my @dirs = map { join("/", $DCONF->{admin_dir}, "template", $_) } ('custom', 'pro', 'admin', 'ui', 'mailmesg');
		my $actual_path = "";
		if (-e "$DCONF->{admin_dir}/data/tcache/$fn.pl") {
			foreach my $z (@dirs) {
				if (-e "$z/$filename.tmpl") {
					$actual_path = "$z/$filename.tmpl";
					@dirs = ($z);
					last;
				}
			}
			if (dtl_check_mtime($actual_path, "$DCONF->{admin_dir}/data/tcache/$fn.pl")) {
				if (require "$DCONF->{admin_dir}/data/tcache/$fn.pl") {
					$PARAMS->{templates}->{$filename} = $fn;
					return 1 if $skip;
					performance_string("* Using cached template for $fn");
					my $varname = join('::', $PARAMS->{templates}->{$filename}, 'process');
					return (&{\&{$varname}}($substitutions))[0];
				} else {
					unlink "$DCONF->{admin_dir}/data/tcache/$fn.pl";
				}
			} else {
				unlink "$DCONF->{admin_dir}/data/tcache/$fn.pl";
			}
		}
		foreach my $dir (@dirs) {
			if ($actual_path ne "" || -e "$dir/$filename.tmpl") {
				open (FILEOPEN, "< $dir/$filename.tmpl");
				my @file = <FILEOPEN>;
				close (FILEOPEN);
				my $fn = $filename; $fn =~ s/\W/_/g;
				dreq("templint");
				my @fileout = dtlperl($fn, @file);
				if (open (FILEOUT, "> $DCONF->{admin_dir}/data/tcache/$fn.pl")) {
					print FILEOUT @fileout;
					close (FILEOUT);
				} else {
					template_error("Could not write to template cache directory 'tcache' file '$fn.pl': $!");
				}
				chmod oct($DCONF->{perms0666}), "$DCONF->{admin_dir}/data/tcache/$fn.pl";
				if (require "$DCONF->{admin_dir}/data/tcache/$fn.pl") {
					$PARAMS->{templates}->{$filename} = $fn;
					return 1 if $skip;
					my $varname = join('::', $PARAMS->{templates}->{$filename}, 'process');
					return (&{\&{$varname}}($substitutions))[0];
				} else {
					unlink "$DCONF->{admin_dir}/data/tcache/$fn.pl";
					my @str = ("Failed template require on $filename: $!");
					my $i = 0;
					while (my ($pack, $file, $line, $subname, $hasargs, $wantarray) = caller($i++)) {
	  					$file = $' if $file =~ /.*[\\\/]/;
   						push @str, "$file :: $line :: $subname";
   					}
   					template_error(@str);
   				}
			}
		}
	}
}

###
### barf_tcache
###
### Helpful error messages for many Windows customers whose permissions won't
### be set up right
###

sub barf_tcache {
	my $errcode = shift @_;
	my @msg = ();
	push @msg, "<font color=#ff0000>Directory creation error</font>";
	push @msg, "Discus cannot create a 'tcache' directory under 'data'";
	push @msg, "Reason from operating system is: <u>$errcode</u>";
	push @msg, "For troubleshooting hints on this error message, consult:";
	push @msg, "<a href=\"http://support.discusware.com/center/resources/errors/dce.html\" target=\"_blank\">Directory creation error help</a>";
	template_error(@msg);
}

###
### does_part_exist
###
### Sees if a part of a skin exists (for <#part "xxx" () exists#> code)
###

sub does_part_exist {
	my ($topicnum, $part) = @_;
	my $prefix = $topicnum > 0 ? "SKIN_$topicnum" : "SKIN";
	my $fn = join("", $prefix, "_", $part);
	return 1 if defined $PARAMS->{templates}->{$fn};
	return 1 if -e "$DCONF->{admin_dir}/data/tcache/$fn.pl";
	my $x = join("_", $prefix, "page");
	return 0 if -e "$DCONF->{admin_dir}/data/tcache/$x.pl";
	my $y = dtl_interpret_skin("$topicnum$part", {}, 1);
	return 1 if defined $PARAMS->{templates}->{$fn};
	return 1 if -e "$DCONF->{admin_dir}/data/tcache/$fn.pl";
	return 0;
}

###
### picker
###
### Picks an element of an array (for <#pick ... #> code)
###

sub picker {
	my ($pick, $item_no, $arrayname, $item_choice, $substitutions) = @_;
	if (ref $substitutions->{$arrayname} ne "ARRAY") {
		template_error("Use of undefined array \@$arrayname in pick statement!");
	}
	$item_choice =~ s/\s//g;
	my @item_choose = split(/,/, $item_choice);
	if ($item_choice eq "*") {
		if (scalar(@{ $substitutions->{$arrayname} }) > 0) {
			@item_choose = (1 .. scalar(@{ $substitutions->{$arrayname} }));
		} else {
			template_error("Invalid array '\@$arrayname' does not have any elements!");
		}
	}
	if (scalar(@item_choose) == 0) {
		template_error("Invalid selection index '$item_choice' in pick statement on \@$arrayname!");
	}
	my $arrindex = ($item_no - 1) % scalar(@item_choose);
	template_error("Use of undefined index [ $item_choose[$arrindex] ] for array index $arrindex in item choices ($item_choice)!") unless (@{ $substitutions->{$arrayname} })[ $item_choose[$arrindex] - 1 ];
	my $text = ( (@{ $substitutions->{$arrayname} })[ $item_choose[$arrindex] - 1 ])->{$pick};
	return $text;
}

###
### skin_includer
###
### For including a part of a skin within the currently executing skin or template
###

sub skin_includer {
	my ($topic, $part, $substitutions) = @_;
	$topic = "" if $topic !~ /^\d+$/;
	return dtl_interpret_skin("$topic$part", $substitutions);
}

###
### case_u
###
### Capitalizes the first letter of a string
###

sub case_u {
	my ($text) = @_;
	return "" if length($text) eq "";
	return join("", uc(substr($text, 0, 1)), substr($text, 1, length($text)-1));
}

###
### case_l
###
### Lower-cases the first letter of a string
###

sub case_l {
	my ($text) = @_;
	return "" if length($text) eq "";
	return join("", lc(substr($text, 0, 1)), substr($text, 1, length($text)-1));
}

###
### file_includer
###
### Includes a file from the file system into a template
###

sub file_includer {
	my ($filename, $px) = @_;
	return "" if $PARAMS->{cache}->{notfound}->{$filename};
	$px =~ s/\s+/,/g;
	my %hashref = map { $_, 1 } split(/,/, $px);
	if (-f $filename && -r $filename) {
		my $text = "";
		my $flag = 0;
		open(FILE, "< $filename");
		while (<FILE>) {
			s%<IMG SRC="icons/%<IMG SRC="$DCONF->{html_url}/$DCONF->{icon_dir}/%gi;
			s%<IMG SRC="$DCONF->{icon_dir}/%<IMG SRC="$DCONF->{html_url}/$DCONF->{icon_dir}/%gi;
			if ($hashref{'BODY'} && m|^<BODY|) {
				$flag = 1;
			} elsif ($hashref{'BODY'} && $flag) {
				$text .= $_;
			} elsif ($hashref{'BODY'} && !$flag) {
				next;
			} else {
				$text .= $_;
			}
		}
		close (FILE);
		return $text;
	} else {
		$PARAMS->{cache}->{notfound}->{$filename} = 1;
		template_error("Failed to open required file to generate this portion of the display.") if $hashref{'FATAL'};
		return "";
	}
}

###
### reference_array_from
###
### Handles <#reference array ... #> code
###

sub reference_array_from {
	my ($arrayname, $arrayfrom, $field, $except, $substitutions) = @_;
	my %e = map { trim($_), 1 } split(/,/, trim($except));
	$field = trim($field);
	my @z = ();
	if (ref $arrayfrom eq 'ARRAY') {
		if ($field eq '') {
			@z = @{ $arrayfrom };
		} else {
			@z = grep { $e{$_->{$field}} == 0 } @{$arrayfrom};
		}
	}
	$substitutions->{$arrayname} = \@z;
	return $substitutions;
}

1;
