File Coverage

blib/lib/CGI/WebToolkit.pm

Criterion	Covered	Total	%
statement	24	697	3.4
branch	0	364	0.0
condition	0	48	0.0
subroutine	8	70	11.4
pod	24	24	100.0
total	56	1203	4.6

package CGI::WebToolkit;

use 5.008006;
use strict;
use warnings;

use CGI qw(param header);
use CGI::Carp qw(fatalsToBrowser);
use Data::Dump qw(dump);
use DBI;
use Digest::MD5 qw(md5_hex);

our $VERSION = '0.08';

our $WTK = undef;

our @XHTML_TAGS
	= qw(a abbr acronym address applet area b base bdo big blockquote
		 body br button caption cite code col colgroup dd del dfn div
		 dl DOCTYPE dt em fieldset form frame frameset h1 h2 h3 h4 h5
		 h6 head hr html i iframe img input ins kbd label legend li
		 link map meta noframes noscript object ol optgroup option p
		 param pre q samp script select small span strong style sub sup
		 table tbody td textarea tfoot th thead title tr tt ul var marquee
		 section header footer nav article
		 emph);

# ------------------------------------------------------------------------------
# ------------------------------------------------------------------------------
# constructor

sub new
{
	my ($class, @args) = @_;
	my $self = bless {}, $class;
	return $self->__init( @args );
}

# ------------------------------------------------------------------------------
# ------------------------------------------------------------------------------
# methods

sub handle
{
	my ($self) = __parse_args(@_);

	# clear cache
	$self->__clear_cache()
		if $self->{'allowclearcache'} == 1
			&& defined param($self->{'clearcacheparam'});

	# determine name of workflow function
	my $workflow_function_name = param($self->{'workflowparam'});
	   $workflow_function_name = $self->{'entryaction'}
	   		unless defined $workflow_function_name;

	my $mimetype = '';
	my $message = '';
	my $function_name = $workflow_function_name;
	my $args = [];
	while (1) {

		my $result = $self->call( $function_name, @{$args} );

		__die("function '$function_name' returned invalid result.".
			 " Use the methods output() or followup() to generate a valid result.")
			if ref $result ne 'HASH' || !exists $result->{'type'};

		if ($result->{'type'} eq 'output') {
			if (exists $result->{'status'} && $result->{'status'} == 1) {

				__die("missing mimetype in result from function '$function_name'")
					unless exists $result->{'mimetype'};
				__die("missing content in result from function '$function_name'")
					unless exists $result->{'content'};

				$mimetype = $result->{'mimetype'};
				$message  = $result->{'content'};

				if ($mimetype eq 'text/html') {
					# replace any {...:...} placeholders with their default values
					$message =~ s/\{[a-zA-Z0-9\.\_]+\:([^\}]*)\}/$1/mg;

					# replace any {...} placeholders with empty string
					$message =~ s/\{[a-zA-Z0-9\.\_]+\}//mg;
				}

				last;
			}
			else {
				$function_name = 'core.error';
			}
		}
		elsif ($result->{'type'} eq 'followup') {

			__die("missing followup function name in result from function '$function_name'")
				unless exists $result->{'function_name'};

			$function_name = $result->{'function_name'};
			$args = $result->{'arguments'} if exists $result->{'arguments'};
		}
		else {
			__die("function '$function_name' returned unknown type of result.".
			     " Use the methods output() or followup() to generate a valid result.");
		}
	}

	$| = 1;

	# add session to every link that points to the cgi script
	if (exists $ENV{'SCRIPT_NAME'}) {
		my $script = quotemeta $ENV{'SCRIPT_NAME'};
		my $url_addon  = $self->{'idparam'}.'='.$self->{'session_id'}.'&';
		my $form_addon =
			'
116
				.'" value="'.$self->{'session_id'}.'"/>'.
			'
118
				.'" value="1"/>';

		if ($mimetype eq 'text/html') {
			# add session id to internal links
			$message =~ s/(href=[\"\']($script)?\?)/$1$url_addon/mig;
			$message =~ s/(href=[\"\']$script)/$1?$url_addon/mig;

			# add session id as hidden field to internal forms
			$message =~ s/(]*action=[\"\']$script[^\>]*>)/$1$form_addon/mig;
		}
	}

	$self->__cleanup();

	return header( -type => $mimetype ).$message;
}

sub call
{
	my ($self, $function_name, @args) = __parse_args(@_);

	# check if user is allowed to execute workflow function
	$function_name = $self->{'entryaction'}
		if $self->{'checkrights'} == 1 && !$self->allowed($function_name);

	# check for cache entry
	my $cachehash;
	if ($self->{'cachetable'} ne '') {
		$cachehash = $self->__get_cache_hash($function_name, @args);
		my $result = $self->__load_cache($cachehash);
		return $result if defined $result;
	}

	unless (exists $self->{"workflow_function_cache"}->{$function_name}) {

		my $function_filename
			= $self->__get_external_function_filename('workflows', $function_name);

		if (defined $function_filename) {
			# load function ref. into cache
			$self->{"workflow_function_cache"}->{$function_name}
				= __load_file_as_subref($function_filename)
					unless exists $self->{'workflow_function_cache'}->{$function_name};
		}
		else {
			# define error function
			$self->{"workflow_function_cache"}->{$function_name}
				= sub { __die("failed to load function '$function_name'") };
		}
	}

	# load library path for modules
	my $libpath = $self->{'privatepath'}.'/modules';
	eval('use lib "'.$libpath.'"');
	__die("loading of library path '$libpath' failed: $@") if $@;

	# load all modules for workflow function
	foreach my $module (@{$self->{'modules'}}) {
		eval('use '.$module);
		__die("loading of module '$module' failed: $@") if $@;
	}

	# call workflow function
	$self->{'current_workflow_function'} = $function_name;
	my $result =
		$self->{"workflow_function_cache"}->{$function_name}->(
			$self, @args );
	$self->{'current_workflow_function'} = undef;

	# save result to cache
	if ($self->{'cachetable'} ne '') {
		$self->__save_cache($cachehash, $result);
	}

	return $result;
}

sub output
{
	my ($self, $status, $info, $content, $mimetype) = __parse_args(@_);
	$status   = 1 			unless defined $status;
	$info     = 'ok' 		unless defined $info;
	$content  = '' 			unless defined $content;
	$mimetype = 'text/html' unless defined $mimetype;
	return {
		'type'     => 'output',
		'status'   => $status,
		'info'     => $info,
		'content'  => $content,
		'mimetype' => $mimetype,
	};
}

sub followup
{
	my ($self, $function_name, @args) = __parse_args(@_);
	return {
		'type'          => 'followup',
		'function_name' => $function_name,
		'arguments'     => [ @args ],
	};
}

# ------------------------------------------------------------------------------

sub get
{
	my ($self, $varname) = __parse_args(@_);
	return 1 if $self->{'sessiontable'} eq '';

	if (exists $self->{'session'}->{$varname}) {
		return $self->{'session'}->{$varname};
	} else {
		return undef;
	}
}

sub set
{
	my ($self, $varname, $value) = __parse_args(@_);
	return 1 if $self->{'sessiontable'} eq '';

	$self->{'session'}->{$varname} = (defined $value ? $value : '');
	return 1;
}

sub unset
{
	my ($self, $name) = __parse_args(@_);
	return 1 if $self->{'sessiontable'} eq '';

	delete $self->{'session'}->{$name}
		if exists $self->{'session'}->{$name};

	return 1;
}

# ------------------------------------------------------------------------------

sub fill
{
	my ($self, $template_name, $data) = __parse_args(@_);
	my @data = (ref($data) eq 'ARRAY' ? @{$data} : ($data));

	my $filename1 = $self->__get_external_function_filename( 'generators', $template_name );
	my $filename2 = $self->__get_external_function_filename( 'generators', 'core.'.$template_name );

	if (defined $filename1) {
		# load function ref. into cache
		$self->{"template_function_cache"}->{$template_name}
			= __load_file_as_subref($filename1)
				unless exists $self->{'template_function_cache'}->{$template_name};
	}
	elsif (defined $filename2) {
		# load function ref. into cache
		$self->{"template_function_cache"}->{$template_name}
			= __load_file_as_subref($filename2)
				unless exists $self->{'template_function_cache'}->{$template_name};
	}
	else {
		# load static template file from theme

		my @fallback_themes = @{$self->{'templatefallbacks'}};

		# check for specific theme
		if ($template_name =~ /^([^\:]+)\:(.*)$/) {
			my ($theme, $name) = $template_name =~ /^([^\:]+)\:(.*)$/;
			@fallback_themes = ($theme);
			$template_name = $name;
		}

		# look into themes for file
		my $filename;
		foreach my $theme (@fallback_themes) {
			$filename = __identifier_to_filename(
							$self->{'privatepath'}.'/templates/'.$theme.'/',
							$template_name, '.html');
			last if -f $filename;
		}

		# load file
		open TMPLFILE, '<'.$filename or __die("failed to open file '$filename': $!");
		my $content = join '', ;
		close TMPLFILE;

		# create generic function to parse the content
		$self->{"template_function_cache"}->{$template_name} =
			sub {
				my ($self, @data) = @_;
				my $result = '';
				foreach my $data (@data) {
					my $tmpl = $content;
					# expand macros
					$self->__expand_macros(\$tmpl) if $self->{'allowmacros'} == 1;
					# replace variables
					__replace_placeholders(\$tmpl, $data);
					# replace common variables
					__replace_placeholders(\$tmpl, $self->{'common_placeholders'});
					$result .= $tmpl;
				}
				return $result;
			}
	}

	# call template function
	return
		$self->{"template_function_cache"}->{$template_name}->(
			$self, @data );
}

# ------------------------------------------------------------------------------

sub _
{
	my ($self, $phrase, $language) = __parse_args(@_);
	return '' unless defined $phrase;

	return $phrase
		if $self->{'phrasetable'} eq '';

	$language = $self->get('language') unless defined $language;
	$language = $self->{'defaultlanguage'} unless defined $language;

	# query db for phrase
	my $query
		= $self->find(
			-tables => [$self->{'phrasetable'}],
			-where  => {'name' => $phrase},
		);

	if (my $row = $query->fetchrow_hashref()) {
		if ($row->{'language'} eq $language) {
			return $phrase;
		}
		else {
			# look for translation
			my $translation = __find_translation($row->{'translations'}, $language);
			return (defined $translation ? $translation : $phrase);
		}
	}
	else {
		return $phrase;
	}
}

# ------------------------------------------------------------------------------

sub lang
{
	my ($self, $language) = __parse_args(@_);
	if (defined $language) {
		# set
		$self->set($language);
	}
	# get
	my $lang = $self->get('language');
	return (defined $lang ? $lang : $self->{'defaultlanguage'});
}

# ------------------------------------------------------------------------------

sub translate
{
	my ($self, @pairs) = __parse_args(@_);
	return 0
		if $self->{'phrasetable'} eq '';

	__die("translate() expects language/phrase pairs as parameters")
		if scalar(@pairs) % 2 == 1 || scalar(@pairs) < 4;

	# erease any bad characters
	foreach my $p (0..$#pairs) {
		$pairs[$p] =~ s/[\n\r\:]//g;
	}

	# create real tuples
	my ($key_language, $key_phrase) = (shift(@pairs), shift(@pairs));
	my %phrases;
	for (my $i = 0; $i < scalar @pairs; $i += 2) {
		$phrases{$pairs[$i]} = $pairs[$i + 1];
	}

	# query db for phrase entry
	my $query
		= $self->find(
			-tables => [$self->{'phrasetable'}],
			-where  => {'name' => $key_phrase, 'language' => $key_language},
		);

	if (my $row = $query->fetchrow_hashref()) {
		# update
		my $translations = __find_translation($row->{'translations'});
		foreach my $lang (keys %phrases) {
			$translations->{$lang} = $phrases{$lang};
		}
		$self->update(
			-table => $self->{'phrasetable'},
			-set => {
				'name' => $key_phrase,
				'language' => $key_language,
				'translations' => join("\n", map { $_.':'.$translations->{$_} } keys %{$translations}),
			},
			-where => {'name' => $key_phrase, 'language' => $key_language},
		);
	}
	else {
		# insert
		$self->create(
			-table => $self->{'phrasetable'},
			-row => {
				'name' => $key_phrase,
				'language' => $key_language,
				'translations' => join("\n", map { $_.':'.$phrases{$_} } keys %phrases),
			},
		);
	}
}

# ------------------------------------------------------------------------------

sub find
{
	my ($self, %options) = __parse_args(@_);
	my $opts = __parse_params( \%options,
		{
			tables 		=> [],
			where 		=> {},
			wherelike 	=> {},
			group 		=> [],
			order 		=> [],
			limit 		=> 0,
			distinct 	=> 0,
			columns		=> [],
			joins		=> {},
			sortdir		=> 'asc', # 'asc' or 'desc'
		});

	my @tables = map { $self->__quotename($_) } @{$opts->{'tables'}};

	my @columns = map { $self->__quotename($_) } @{$opts->{'columns'}};

	my @joins =
		map {
			$self->__quotename($_).' = '.$self->__quotename($opts->{'joins'}->{$_});
		}
		keys %{$opts->{'joins'}};

	my @group = map { $self->__quotename($_) } @{$opts->{'group'}};

	my @order = map { $self->__quotename($_) } @{$opts->{'order'}};

	my $sql
		= 'SELECT'
		.(defined $opts->{'distinct'} ? ' DISTINCT' : '')
		.' '.(scalar @columns ? join(', ', @columns) : '*')
		.' FROM '.join(', ', @tables)
		.' WHERE '
		.(scalar keys %{$opts->{'where'}} ?
			$self->__make_sql_where_clause($opts->{'where'})
			: '1')
		.(scalar keys %{$opts->{'wherelike'}} ?
			' AND '.$self->__make_sql_where_clause($opts->{'wherelike'}, 1)
			: '')
		.(scalar @joins ? ' AND '.join(' AND ', @joins) : '')
		.(scalar @group ? ' GROUP BY '.join(', ', @group) : '')
		.(scalar @order ? ' ORDER BY '.join(', ', @order).' '.uc($opts->{'sortdir'}) : '')
		.($opts->{'limit'} > 0 ? ' LIMIT '.$opts->{'limit'} : '');

	return $self->query($sql);
}

sub create
{
	my ($self, %options) = __parse_args(@_);
	my $opts = __parse_params( \%options,
		{
			table => undef,
			row => {},
		});

	my @columns;
	my @values;
	map {
		push @columns, $self->__quotename($_);
		push @values,  $self->__quote($opts->{'row'}->{$_});
	}
	keys %{$opts->{'row'}};

	my $sql
		= 'INSERT'
			.' INTO '.$self->__quotename($opts->{'table'})
			.' ('.join(', ', @columns).')'
			.' VALUES ('.join(', ', @values).')';

	$self->query($sql);
	return $self->{'dbh'}->last_insert_id(undef, undef, $opts->{'table'}, 'id');
}

sub update
{
	my ($self, %options) = __parse_args(@_);
	my $opts = __parse_params( \%options,
		{
			table => '',
			set => {},
			where => {},
			wherelike => {},
		});

	my @sets =
		map {
			$self->__quotename($_).' = '.$self->__quote($opts->{'set'}->{$_});
		}
		keys %{$opts->{'set'}};

	my $sql
		= 'UPDATE'
			.' '.$self->__quotename($opts->{'table'})
			.' SET '.join(', ', @sets)
			.' WHERE '
			.(scalar keys %{$opts->{'where'}} ?
				$self->__make_sql_where_clause($opts->{'where'})
				: '1')
			.(scalar keys %{$opts->{'wherelike'}} ?
				' AND '.$self->__make_sql_where_clause($opts->{'wherelike'}, 1)
				: '');

	return $self->query($sql);
}

sub remove
{
	my ($self, %options) = __parse_args(@_);
	my $opts = __parse_params( \%options,
		{
			table => '',
			where => {},
			wherelike => {},
		});

	my $sql
		= 'DELETE'
			.' FROM '.$self->__quotename($opts->{'table'})
			.' WHERE '
			.(scalar keys %{$opts->{'where'}} ?
				$self->__make_sql_where_clause($opts->{'where'})
				: '1')
			.(scalar keys %{$opts->{'wherelike'}} ?
				' AND '.$self->__make_sql_where_clause($opts->{'wherelike'}, 1)
				: '');

	return $self->query($sql);
}

sub load
{
	my ($self, $group, $recordset, $tablename) = __parse_args(@_);

	my $records	= __load_data_file($self->{'privatepath'}.'/data/'.$group.'/'.$recordset.'.txt');

	my $inserted = 0;
	foreach my $record (@{$records}) {
		__die("record does not have an id field, in data file '$group/$recordset'")
			unless exists $record->{'id'};

		my $query
			= $self->find(
				-tables => [$tablename],
				-where  => {'id' => $record->{'id'}},
				-limit  => 1,
			);

		if (my $row = $query->fetchrow_hashref()) {
			# do nothing
		}
		else {
			# insert
			$self->create(
				-table => $tablename,
				-row   => $record,
			);
			$inserted ++;
		}
	}
	return (scalar @{$records}, $inserted);
}

sub query
{
	my ($self, $sql) = __parse_args(@_);
	$self->__connect_to_db();
	my $query = $self->{'dbh'}->prepare($sql);
	$query->execute()
		or __die('the query ['.$sql.'] failed: '.DBI->errstr());
	return $query;
}

# ------------------------------------------------------------------------------

sub getparam
{
	my ($self, $name, $default, $regex) = __parse_args(@_);
	$regex = '.*' unless defined $regex;
	my $value = param($name);
	return (defined $value && $value =~ /$regex/ ? $value : $default);
}

# ------------------------------------------------------------------------------

sub login
{
	my ($self, $loginname, $password) = __parse_args(@_);
	return 1 if $self->{'usertable'} eq '';

	return 0 unless defined $loginname;
	return 0 unless defined $password;

	return 0 if $self->{'usertable'} eq '';

	my $query
		= find(
			-tables => [$self->{'usertable'}],
			-where  => {
				'loginname' => $loginname,
				'password' => md5_hex($password),
			},
			-limit  => 1,
		);

	if (my $user = $query->fetchrow_hashref()) {
		return 0 if $user->{'active'} == 0;

		# associate session with user id
		set('user', $user);

		# set language
		$self->set('language', $user->{'ui_language'})
			if $user->{'ui_language'} ne '';
	}
	else {
		return 0;
	}
}

# ------------------------------------------------------------------------------

sub logout
{
	my ($self) = __parse_args(@_);
	return 1 if $self->{'usertable'} eq '';

	$self->unset('user');
	return 1;
}

# ------------------------------------------------------------------------------

sub allowed
{
	my ($self,
		$function_name,	# workflow function name
		$loginname,		# loginname of user
		) = __parse_args(@_);

	return 1 if $self->{'accessconfig'} eq '';

	# load access config from /accessconfigs/.txt
	# $mappings = {  => , ... }
	my $mappings
		= __load_config_file(
			$self->{'privatepath'}.'/accessconfigs/'.$self->{'accessconfig'}.'.txt');

	# determine and call appropriate access check function(s)
	my $has_access = 0;
	foreach my $rgx (keys %{$mappings}) {
		if ($function_name =~ /$rgx/) {
			my $check_function_name = $mappings->{$rgx};
			my $filename =
				$self->__get_external_function_filename(
					'accesschecks', $check_function_name);

			# load function as subroutine
			$self->{"access_function_cache"}->{$check_function_name}
				= __load_file_as_subref($filename)
					unless exists $self->{"access_function_cache"}->{$check_function_name};

			my $check_function = $self->{"access_function_cache"}->{$check_function_name};

			$has_access = $has_access && $check_function->( $self, $function_name, $loginname );
		}
	}

	return $has_access;
}

# ------------------------------------------------------------------------------

sub logmsg
{
	my ($self, $msg, $priority) = __parse_args(@_);

	$msg .= "\r\n" if $msg !~ /\r?\n$/;

	$priority = 'DEBUG'
		if !defined $priority
		|| !scalar
				grep { $_ eq uc($priority) }
					qw(DEBUG INFO WARNING ERROR FATAL);

	# log to priority-logfile
	my $logfile = $self->{'privatepath'}.'/logs/'.uc($priority).'.txt';
	__file_append($logfile, $msg);

	if (defined $self->{'current_workflow_function'}) {
		# log to workflow-function-specific logfile as well
		my $logfile2 = $self->{'privatepath'}.'/logs/'.uc($self->{'current_workflow_function'}).'.txt';
		__file_append($logfile2, $msg);
	}
}

# ------------------------------------------------------------------------------

sub fail
{
	my ($self, $msg) = __parse_args(@_);
	__die($msg);
}

# ------------------------------------------------------------------------------

sub upload
{
	my ($self, $paramname, $groupname) = __parse_args(@_);

	# retrieve file from parameters
	my $file = $self->getparam($paramname, undef);

	__die("cannot retrieve upload via unknown parameter '$paramname'")
		unless defined $file;

	my $now = time();

	my $upload_info = CGI::uploadInfo($file);
	my $ending = $upload_info->{'Content-Disposition'};
	   $ending =~ s/^.*\.//;
	   $ending =~ s/\"$//;

	# generate filename
	my $filepath = $self->{'publicpath'}.'/uploads/'.$groupname.'/';
	my $filename = $self->{'session_id'}.'_'.$now.'.'.$ending;

	# write data to file
	open UPLOAD, '>'.$filepath.$filename
		or __die("failed to write upload to file '$filepath$filename': $!");

	# Dateien in den Binaer-Modus schalten
	binmode $file;
	binmode UPLOAD;

	my $info = {
		'status' => 1,
		'info'   => 'The file has been successfully saved.',
	};

	my $data;
	my $bytes_written = 0;
	while (read $file, $data, 1024) {
		print UPLOAD $data;
		$bytes_written += 1024;
		if ($bytes_written > $self->{'uploadmaxsize'}) {
			$info->{'status'} = 0;
			$info->{'info'} =
				'The filesize exceeded the maximum upload size. '.
				'Aborted after '.$bytes_written.' Bytes.';
			last;
		}
	}
	close UPLOAD;

	my $mimetype = $upload_info->{'Content-Type'};
	my $original_filename = $upload_info->{'Content-Disposition'};
	   $original_filename =~ s/^.*filename\=\"(.*)\"$/$1/;

	# success
	if ($info->{'status'} == 1) {
		$info->{'path'}     = $filepath;
		$info->{'filename'} = $filename;
		$info->{'created'}  = $now;
		$info->{'mimetype'} = $mimetype;
		$info->{'original_filename'} = $original_filename;
	}

	# save info in session
	push @{$self->{'session'}->{'uploads'}}, $info;

	return $info->{'status'};
}

# ------------------------------------------------------------------------------

sub AUTOLOAD
{
	my ($self, @args) = __parse_args(@_);

	my $function_name = $CGI::WebToolkit::AUTOLOAD;
	   $function_name =~ s/.*\://g;

	if ($function_name eq 'DESTROY') {
		return SUPER::DESTROY(@args);
	}
	elsif ($function_name =~ /^\_[^\_]/) {
		# module function execution call

		# try to find subroutine in
		$function_name =~ s/^\_//;
		foreach my $module (@{$self->{'modules'}}) {
			my $is_sub = 0;
			eval('$is_sub = (defined &CGI::WebToolkit::Modules::'.ucfirst($module).'::'.$function_name.')');
			__die("eval failed: $@") if $@;
			if ($is_sub) {
				# call subroutine
				my @result;
				eval('@result = CGI::WebToolkit::Modules::'.ucfirst($module).'::'.$function_name.'($self, @args)');
				__die("eval for subroutine call failed: $@") if $@;
				return (wantarray ? @result : (scalar @result ? $result[0] : undef));
			}
		}
		__die("could not find subroutine named 'CGI::WebToolkit::Modules::*::".$function_name."'");
	}
	elsif ($function_name =~ /^[A-Z]/) {
		# template loading call

		my ($theme, $template_name) = split /\_/, $function_name;
		unless (defined $template_name) {
			$template_name = $theme;
			$theme = '';
		}
		$theme = lc $theme;

		# create template name
	    $template_name =~ s/([A-Z])/_$1/g;
	    $template_name =~ s/^\_//g;
	    $template_name =~ s/\_/./g;
	    $template_name = lc $template_name;

		return
			$self->fill(
				(length $theme ? $theme.':' : '').$template_name,
				{ @args },
			);
	}
	else {
		__die("Unknown function/method called '$function_name'.");
	}
}

# ------------------------------------------------------------------------------
# ------------------------------------------------------------------------------
# cleanup

sub __cleanup
{
	my ($self) = @_;

	$self->__save_session();
	$self->__disconnect_from_db();
}

# ------------------------------------------------------------------------------
# ------------------------------------------------------------------------------
# internal helper functions/methods

sub __expand_macros
{
	my ($self, $stringref) = @_;
	my $string = ${$stringref};

	my $tokens = __tokenize_xml($string);

	# the generated tokens are now beeing expanded

	my $parsed = '';
	my $t = 0; # offset of current token
	my $abort = 0;
	while (1) {
		last if $t >= scalar @{$tokens};

		my $token = $tokens->[$t];

		if (!ref $token) {
			$parsed .= $token;
			$t ++;
		}
		else {
			my ($type, $name, $attribs) = @{$token};
			if ($type eq 'start' || $type eq 'single') {

				my $data = __attribs_to_hash($attribs);
				$data->{'content'} = '';

				my $t_span = 1; # assume a "single" tag
				if ($type eq 'start') {
					# find end tag
					$t_span = __get_token_span($tokens, $t);
					unless (defined $t_span) {
						# if no end tag: tag end is end of tokens
						$t_span = scalar(@{$tokens}) - $t;
					}

					# get tokens from start tag till end tag
					my @subtokens = splice @{$tokens}, $t, $t_span;
					shift @subtokens;
					pop @subtokens;

					# convert sub-tokenlist back to xml
					$data->{'content'} = __render_tokens(\@subtokens);
				}
				elsif ($type eq 'single') {
					splice @{$tokens}, $t, 1;
				}

				# fill template
				my $filled = $self->fill($name, $data);

				# tokenize template
				my $sub_tokens = __tokenize_xml($filled);

				# replace tag with sub-tokenlist
				splice @{$tokens}, $t, 0, @{$sub_tokens};

				# restart expanding at previous token
			}
			elsif ($type eq 'end') {
				# this end tag actually belongs to a start tag
				# which is out of the scope of this token list
				# -> ignore this end tag
				$t ++;
			}
		}
		$abort ++;
		__die("macro expansion ran into endless loop.") if $abort == 100;
	}

	${$stringref} = $parsed;
	return 1;
}

sub __render_tokens
{
	my ($tokens) = @_;
	my $string = '';
	foreach my $token (@{$tokens}) {
		if (ref $token) {
			$string .=
				'<'.($token->[0] eq 'end' ? '/' : '').
				$token->[1].($token->[0] eq 'end' ? '' : ' '.$token->[2]).
				($token->[0] eq 'single' ? '/' : '').'>';
		}
		else {
			$string .= $token;
		}
	}
	return $string;
}

sub __attribs_to_hash
{
	my ($attribs) = @_;
	my %hash;
	my @pairs = split /[\s\t]+/, $attribs;
	foreach my $pair (@pairs) {
		my ($key, $value) = split /\=/, $pair;
		$value =~ s/^[\"\']?//;
		$value =~ s/[\"\']?$//;
		$hash{$key} = $value;
	}
	return \%hash;
}

sub __get_token_span
{
	my ($tokens, $t) = @_;
	my $found = 0;
	my $open = 0; # open tags with same name as token at position $t
	my $s;
	foreach my $i ($t+1..scalar(@{$tokens})-1) {
		$s = $i;
		next unless ref $tokens->[$s];
		if ($tokens->[$s]->[1] eq $tokens->[$t]->[1]) {
			if ($tokens->[$s]->[0] eq 'start') {
				$open ++;
			}
			elsif ($tokens->[$s]->[0] eq 'end') {
				if ($open <= 0) {
					$found = 1;
					last;
				}
				else {
					$open --;
				}
			}
		}
	}
	my $span = ($found ? ($s - $t + 1) : undef);
	return $span;
}

sub __dump_tokens
{
	my ($tokens) = @_;
	my $s = "[\n";
	my $i = 0;
	map {
		if (!ref $_) {
			$s .= "  [".sprintf('%0d',$i)."] ...\n";
		}
		elsif ($_->[0] eq 'start') {
			$s .= "  [".sprintf('%0d',$i)."] <".$_->[1].">\n";
		}
		elsif ($_->[0] eq 'end') {
			$s .= "  [".sprintf('%0d',$i)."] [1].">\n";
		}
		elsif ($_->[0] eq 'single') {
			$s .= "  [".sprintf('%0d',$i)."] <".$_->[1]."/>\n";
		}
		$i ++;
	} @{$tokens};
	return $s."]\n";
}

sub __tokenize_xml
{
	my ($string) = @_;

	# remove comments
	$string =~ s///sg;

	# this regex parses an xml tag (sloppy...)
	my $tagregex = '^(\/?)([a-zA-Z0-9\:\_\.]+)([\s\t\n\r]*)([^\>]*[^\/])?(\/?)>(.*)$';

	# what follows is actually a very rudimentary tokenizer
	# that splits the source into an array of tokens, either
	# tag (start-tag, end-tag or single-tag) and strings

	my @tokens = ('');
	foreach my $tag (split /

		if ($tag =~ /$tagregex/s) {
			my ($is_end, $tagname, $space, $attribs, $is_single, $rest)
				= $tag =~ /$tagregex/s;

			$space     = '' unless defined $space;
			$attribs   = '' unless defined $attribs;
			$is_single = '' unless defined $is_single;
			$rest      = '' unless defined $rest;

			if (scalar grep { $tagname eq $_ } @XHTML_TAGS) {
				# normal html tag
				ref $tokens[-1] ? push(@tokens,'<'.$tag) : ($tokens[-1] .= '<'.$tag);
			}
			else {
				# macro
				if (length $is_end) {
					# end tag
					push @tokens, ['end', $tagname];
				}
				elsif (length $is_single) {
					# single tag
					push @tokens, ['single', $tagname, $attribs];
				}
				else {
					# start tag
					push @tokens, ['start', $tagname, $attribs];
				}
				ref $tokens[-1] ? push(@tokens,$rest) : ($tokens[-1] .= $rest);
			}
		}
		else {
			ref $tokens[-1] ? push(@tokens,$tag) : ($tokens[-1] .= $tag);
		}
	}

	return \@tokens;
}

sub __load_data_file
{
	my ($datafilename) = @_;

	if (-f $datafilename && -r $datafilename) {
		open DATAFILE, '<'.$datafilename
			or _die("failed to open file '$datafilename': $!");

		my @records;
		my $current_id     = undef;
		my $current_field  = undef;
		my $current_record = {};
		foreach my $line () {

			if (defined $current_id && defined $current_field && $line =~ /^[\s\t]/) {
				# possibly field value line
				$line =~ s/^[\s\t]//;
				$current_record->{$current_field} .= $line;
			}
			else {
				if ($line =~ /^\[(\d+)\][\s\t\n\r]*$/) {
					# id line
					if (defined $current_id) {
						# save previous record
						push @records, $current_record;
					}
					# reset
					$current_id = $line;
					$current_id =~ s/^\[(\d+)\][\s\t\n\r]*$/$1/;
					$current_record = { 'id' => $current_id };
				}
				elsif ($line =~ /^(\w+)[\s\t]*([\:\.])(.*)\n\r?$/) {
					# field line
					my ($fieldname, $type, $value)
						= $line =~ /^(\w+)[\s\t]*([\:\.])(.*)\n\r?$/;
					if ($type eq ':') {
						$current_record->{$fieldname} = $value;
						$current_field = undef;
					}
					else {
						$current_record->{$fieldname} = '';
						$current_field = $fieldname;
					}
				}
			}
		}
		if (defined $current_id) {
			# save last record
			push @records, $current_record;
		}
		return \@records;
	}
	else {
		__die("failed to open file '$datafilename': no file or not readable");
	}
}

sub __parse_translations
{
	my ($translations) = @_;
	my %phrases;
	foreach my $translation (split /\n/, @{$translations}) {
		my ($language, $phrase) =~ /^([^\:]+)\:(.*)$/;
		$phrases{$language} = $phrase;
	}
	return \%phrases;
}

sub __find_translation
{
	my ($translations, $find_language) = @_;
	foreach my $translation (split /\n\r?/, $translations) {
		my ($language, $phrase) = $translation =~ /^([^\:]+)\:(.*)$/;
		return $phrase
			if $language eq $find_language;
	}
	return undef;
}

sub __get_cache_hash
{
	my ($self, $function_name, @args) = @_;

	# string of which hash is computed
	my $string = '';

	my $cfgfile = $self->{'privatepath'}.'/cacheconfigs/'.$function_name.'.txt';
	if (-f $cfgfile) {
		# open cache config
		my $cfg
			= __read_config_file($cfgfile, {
					'session'  => [],
					'params'   => [],
					'lifetime' => 3600,
				});

		map { $string .= __serialize($self->get($_)) } @{$cfg->{'session'}};
		map { $string .= __serialize(param($_))      } @{$cfg->{'params'}};
		$string .= __serialize(\@args);
	}
	else {
		# hash is created out of complete session, post/get and arguments

		# commented, because makes cache renew too often...
		#map { $string .= __serialize($self->get($_)) } keys %{$self->{'session'}};

		map {
			$string .=
				($_ eq $self->{'idparam'} || $_ eq $self->{'clearcacheparam'} ?
					'' : __serialize(param($_)));
		} param();
		$string .= __serialize(\@args);
	}

	return md5_hex($string);
}

sub __load_cache
{
	my ($self, $cachehash) = @_;
	my $query
		= $self->find(
			-tables => [$self->{'cachetable'}],
			-where  => {'hash' => $cachehash},
			-limit  => 1,
		);

	if (my $entry = $query->fetchrow_hashref()) {
		return __deserialize($entry->{'content'});
	}
	else {
		return undef;
	}
}

sub __save_cache
{
	my ($self, $cachehash, $data) = @_;

	$self->create(
		-table => $self->{'cachetable'},
		-row   => {
			'content' 	  => __serialize($data),
			'hash' 		  => $cachehash,
			'last_update' => time(),
		},
	);

	return 1;
}

sub __clear_cache
{
	my ($self) = @_;
	return 1 if $self->{'cachetable'} eq '';
	$self->remove( -table => $self->{'cachetable'} );
}

sub __file_append
{
	my ($filename, $text) = @_;
	open OUTFILE, '>>'.$filename or __die("failed to open file '$filename': $!");
	print OUTFILE $text;
	close OUTFILE;
	return 1;
}

# returns the args array with the
# current CGI::WebToolkit instance as first argument
sub __parse_args
{
	if (scalar @_ && ref($_[0]) eq 'CGI::WebToolkit') {
		return @_;
	} else {
		return ($WTK, @_);
	}
}

sub __replace_placeholders
{
	my ($stringref, $hash) = @_;
	foreach my $key (keys %{$hash}) {
		my $cleankey = $key;
		   $cleankey =~ s/[^a-zA-Z0-9\_]//g;
		${$stringref} =~ s/\{$cleankey[^\}]*\}/$hash->{$key}/mig;
	}
	return undef;
}

sub __make_sql_where_clause
{
	my ($self, $where, $use_like) = @_;
	$use_like = 0 unless defined $use_like;

	my @parts =
		map {
			my $fieldname  = $self->__quotename($_);
			my $fieldvalue = $self->__quote($where->{$_});

			my $s  = $fieldname;
			   $s .= ($use_like == 1 ? ' LIKE ' : ' = ');
			   $s .= ''.$fieldvalue;
			$s;
		}
		keys %{$where};

	return join(' AND ', @parts);
}

sub __quote
{
	my ($self, @args) = @_;
	$self->__connect_to_db();

	return $self->{'dbh'}->quote(@args)
		or __die('quote failed: '.DBI->errstr());
}

# escapes a CGI::WebToolkit field identifier, e.g. "mytable.myfield" or "myfield" etc.
sub __quotename
{
	my ($self, $fieldname) = @_;
	$self->__connect_to_db();

	my @parts = split /\./, $fieldname;

	my $quoted;
	if (scalar @parts == 1) {
		#$quoted = $self->{'dbh'}->quote_identifier(undef, undef, $parts[0])
		#	or _die("quote_identifier() failed: ".DBI->errstr());
		$quoted = '`'.$parts[0].'`';
	}
	else {
		#$quoted = $self->{'dbh'}->quote_identifier(undef, $parts[0], $parts[1])
		#	or _die("quote_identifier() failed: ".DBI->errstr());
		$quoted = '`'.$parts[0].'`'.'.'.'`'.$parts[1].'`';
	}
	return $quoted;
}

sub __get_external_function_filename
{
	my ($self,
		$type,	# "functions" or "templates" or other subdirectory in
		$name,	# name of function in dot-syntax, e.g. "page.home.default"
		)
		= @_;

	# untaint name
	$name =~ s/^(([a-z\_]+)(\.([a-z\_]+))*).*$/$1/;

	my $filename = __identifier_to_filename(
						$self->{'privatepath'}.'/'.$type.'/', $name, '.pl');

	if (-f $filename) {
		return $filename;
	} else {
		return undef;
	}
}

# bla.bla.bla -> bla/bla/bla
sub __identifier_to_filename
{
	my ($prefix, $identifier, $suffix) = @_;
	$suffix = '' unless defined $suffix;

	my $filename = $identifier;
	   $filename =~ s#\.#/#g;

	return $prefix.$filename.$suffix;
}

# loads an external file into an anonymous perl function ref.
# and returns this ref.
sub __load_file_as_subref
{
	my ($filename) = @_;

	__die("cannot load file '$filename': does not exist.")  unless -f $filename;
	__die("cannot load file '$filename': is not readable.") unless -r $filename;

	my $subref = undef;
	open PERLFILE, '<'.$filename or __die("failed to open file '$filename': $!");
	my $code = join '', ;
	   $code =~ /^(.*).*$/sm; # untaint
	   $code = "$1";
	   $code = '$subref = sub { my ($wtk, @args) = @_;'."\n".$code."\n".'}';
	close PERLFILE;
	eval($code);
	__die("function (file '$filename') failed to load with error: $@") if $@;

	return $subref;
}

sub __load_session
{
	my ($self) = @_;
	return 1 if $self->{'sessiontable'} eq '';

	# determine session id
	$self->{'session_id'} =
		$self->getparam( $self->{'idparam'}, undef, '^[a-zA-Z0-9]{32}$' );

	$self->{'session_id'} = md5_hex( time() )
		unless defined $self->{'session_id'};

	# try to find it in db
	my $query =
		$self->find(
			-tables => [ $self->{'sessiontable'} ],
			-where => { 'session_id' => $self->{'session_id'} },
		);

	my $sessionstart = 0;
	if (my $session = $query->fetchrow_hashref()) {
		if (time() - $session->{'last_update'} < $self->{'sessiontimeout'}) {
			$self->{'session'} = __deserialize($session->{'content'});
		} else {
			# session timed out
			$self->{'session_id'} = md5_hex( time() ); # gets new session id!
			$self->{'session'} = {};

			$self->set('session_timed_out', 1);

			$sessionstart = 1;
		}
	}
	else {
		# create empty session
		$self->{'session'} = {};

		$sessionstart = 1;
	}

	# trigger callback
	$self->call($self->{'onsessionstart'})
		if $sessionstart && $self->{'onsessionstart'} ne '';
}

sub __save_session
{
	my ($self) = @_;
	return 1 if $self->{'sessiontable'} eq '';

	# check if session row exists in database
	my $query =
		$self->find(
			-tables => [ $self->{'sessiontable'} ],
			-where => { 'session_id' => $self->{'session_id'} },
		);

	if (my $session = $query->fetchrow_hashref()) {
		# update
		$self->update(
			-table => $self->{'sessiontable'},
			-set => {
				'content' => __serialize($self->{'session'}),
				'last_update' => time(),
			},
			-where => {	'session_id' => $self->{'session_id'} },
		);
	}
	else {
		# insert
		$self->create(
			-table => $self->{'sessiontable'},
			-row => {
				'session_id' => $self->{'session_id'},
				'content' => __serialize($self->{'session'}),
				'last_update' => time(),
			},
		);
	}
}

sub __serialize
{
	my ($structure) = @_;
	return dump($structure);
}

sub __deserialize
{
	my ($string) = @_;
	return {} unless length $string;
	my $structure = undef;
	eval('$structure = '.$string);
	__die("deserialization of string failed: $@") if $@;
	return $structure;
}

sub __connect_to_db
{
    my ($self) = @_;
	return 1 if defined $self->{'dbh'}; # && ref($self->{'dbh'}) eq 'DBI';

    $self->{'dbh'}
        = DBI->connect(
            "DBI:".$self->{'engine'}.":".$self->{'name'}.":".$self->{'host'},
            $self->{'user'}, $self->{'password'},
            {
				#PrintError => 1,
				#RaiseError => 1,
				#AutoCommit => 1,
				#PrintWarn  => 1,
			})
	    or __die("Could not connect to database");

    return 1;
}

sub __disconnect_from_db
{
	my ($self) = @_;

	return $self->{'dbh'}->disconnect();
}

sub __init
{
	my ($self, %options) = @_;

	my $optdefaults =
		{
			# path parameters
			publicpath => '',
			publicurl => '',
			privatepath => '',
			cgipath => '',
			cgiurl => '',

			# configuration parameters
			config => "",

			# database parameters
			engine => "mysql",
			user => "guest",
			name => "",
			password => "",
			host => "localhost",
			port => "",

			# template parameters
			templatefallbacks => ['core'],
			allowmacros => 1,

			# form creation parameters
			# ...

			# session parameters
			idparam => 'sid',
			sessiontable => '',
			sessiontimeout => 1800,

			# user/rights management
			usertable => '',
			checkrights => 0,

			# caching
			cachetable => '',
			allowclearcache => 1,
			clearcacheparam => 'clearcache',

			# locale
			phrasetable =>'',
			defaultlanguage => 'en_GB',

			# workflow parameters
			workflowparam => 'to',
			entryaction => 'core.default',
			modules => [],

			# combinable files
			cssfiles => [],
			jsfiles => [],

			# triggers
			onsessionstart => '',
			onsessionoutofdate => '',

			# uploads
			uploadmaxsize => (1024 * 1024 * 6), # 6MB
		};

	# check if config filename is given -> if so, load it first
	# (so that it can be overwritten by settings from %options later!)
	my $cfgopts = $optdefaults;
	foreach my $key (keys %options) {
		my $name = lc $key;
		   $name =~ s/^\-*//;
		if ($name eq 'config') {
			$cfgopts = __load_config_file( $options{$key}, $optdefaults );
		}
	}

	my $opts = __parse_params( \%options, $cfgopts );
	map { $self->{$_} = $opts->{$_} } keys %{$opts};

	# add 'default' theme as last fallback if not already added
	push @{$self->{'templatefallbacks'}}, 'core'
		if !scalar @{$self->{'templatefallbacks'}}
			|| $self->{'templatefallbacks'}->[-1] ne 'core';

	$self->{'dbh'} = undef;
	$self->{'session'} = undef;
	$self->{'session_id'} = undef;

	# caches for function refs.
	$self->{'workflow_function_cache'} = {};
	$self->{"template_function_cache"} = {};
	$self->{"access_function_cache"}   = {};

	$self->__load_session();

	# common placeholders
	$self->{'common_placeholders'} = {
		'script_url' 	 => (exists $ENV{'SCRIPT_NAME'} ? $ENV{'SCRIPT_NAME'} : '?'),
		'public_url' 	 => $self->{'publicurl'},
		'clear'			 => '',
		'session_id'	 => $self->{'session_id'},
		'do_nothing_url' => 'javascript:void(1);',
		'javascript_url' => (exists $ENV{'SCRIPT_NAME'} ? $ENV{'SCRIPT_NAME'} : '').'?to=core.combine.javascript',
		'css_url' 		 => (exists $ENV{'SCRIPT_NAME'} ? $ENV{'SCRIPT_NAME'} : '').'?to=core.combine.css',
	};

	# name of workflow function that is currently executed
	$self->{'current_workflow_function'} = undef;

	# set current language
	$self->set('language', $self->{'defaultlanguage'});

	# uploads info
	$self->{'session'}->{'uploads'} = [];

	# save global CGI::WebToolkit instance
	$WTK = $self;

	return $self;
}

sub __load_config_file
{
	my ($filename, $defaults) = @_;

	open CFGFILE, '<'.$filename
		or _die("failed to load config file '$filename': $!");
	my $options = {};
	if (defined $defaults) {
		# copy defaults
		map { $options->{$_} = $defaults->{$_} } keys %{$defaults};
	}
	while () {
		chomp;
		s/^(.*)\#.*$/$1/g;
		next if /^[\s\t\n\r]*$/;
		s/^[\s\t\n\r]*//g;
		s/[\s\t\n\r]*$//g;
		my $rgx =
			(defined $defaults ?
				'^([a-zA-Z0-9\_]+)[\s\t]*\:[\s\t]*(.*)$' :
				'^([^\:]+)[\s\t]*\:[\s\t]*(.*)$');
		if (/$rgx/) {
			my ($key, $value) = $_ =~ /$rgx/;
			$key = lc $key;
			$key =~ s/^\-*//g;

			if (defined $defaults) {
				if (ref $defaults->{$key} eq 'ARRAY') {
					# array variable
					$options->{$key} = [ split(/\s*\,\s*/, $value) ]
						if exists $defaults->{$key};
				}
				else {
					# string variable
					$options->{$key} = $value
						if exists $defaults->{$key};
				}
			}
			else {
				$options->{$key} = $value;
			}
		}
	}
	close CFGFILE;
	return $options;
}

# dumps data to browser
sub __dd
{
	print header();
	print ''.dump($_[0]).'';
}

sub __parse_params
{
	my ($params, $defaults) = @_;
	my $values = {};
	foreach my $key (keys %{$defaults}) {
		$values->{$key} = $defaults->{$key};
	}
	foreach my $key (keys %{$params}) {
		my $cleankey = lc $key;
		   $cleankey =~ s/^\-//;
		$values->{$cleankey} = $params->{$key}
			if exists $defaults->{$cleankey};
	}
	return $values;
}

sub __die
{
	my ($msg) = @_;
	print header();
	print
		'Lowlevel Error'.
			'Lowlevel Error: '.$msg.''.
		'';
	exit;
}

# ------------------------------------------------------------------------------
# ------------------------------------------------------------------------------
1;
__END__