File Coverage

blib/lib/CIPP/Compile/Generator.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

# $Id: Generator.pm,v 1.40 2006/05/19 08:03:37 joern Exp $

package CIPP::Compile::Generator;

@ISA = qw ( CIPP::Compile::Parser );

use strict;
use Carp;
use Config;
use CIPP::Compile::Parser;
use IO::String;
use FileHandle;

#---------------------------------------------------------------------
# These methods the skeleton of CIPP programs, Includes and Modules,
# so they are not directly related to CIPP commands.
#---------------------------------------------------------------------

sub generate_start_program {
	croak "generate_start_program not implemented";
}

sub generate_project_handler {
	croak "generate_project_handler not implemented";
}

sub generate_open_exception_handler {
	my $self = shift; $self->trace_in;

	$self->write (
		"# generic exception handler eval\n",
		"eval {\n\n"
	);

	1;
}

sub generate_open_request {
	my $self = shift; $self->trace_in;

	$self->write (
		'$_cipp_project->new_request ('."\n",
		'    program_name => "'.$self->get_program_name.'"'."\n",
		');'."\n"
	);

	1;
}

sub generate_close_exception_handler {
	my $self = shift; $self->trace_in;

	$self->writef (
		"\n".
		"}; # end of generic exception handler eval\n\n".
		'# check for an exception (filters  exception)'."\n".
		'if ( $@ and $@ !~ /_cipp_exit_command/ ) {'."\n".
		'    $CIPP::request->error ('."\n".
		'        message      => $@,'."\n".
		'    ) if defined $CIPP::request;'."\n".
		'}'."\n\n",
		$self->get_program_name,
	);

	1;
}

sub generate_close_request {
	my $self = shift; $self->trace_in;

	$self->write (
		'$CIPP::request->close if defined $CIPP::request;'."\n"
	);

	1;
}

sub generate_debugging_code {
	my $self = shift; $self->trace_in;

	# no debugging code für closed tags, var context and the
	# expression tag (which is the tag with the empty name).
	return if $self->context =~ /^var/ or
		  $self->get_current_tag_closed or
		  $self->get_current_tag eq '';

	$self->write (
		'# cipp_line_nr='.
		$self->get_current_tag_line_nr." ".
		$self->get_current_tag."\n"
	);

	1;
}

sub generate_include_open {
	my $self = shift; $self->trace_in;

	my $package = $self->get_program_name;
	my $i = 0;
	$package =~ s/\./_/g;
	$package =~ s/\W/++$i/ge;

	$package = "main";

	# An Include is a subroutine
	$self->writef (
		'package %s;'."\n\n".
		'use strict;'."\n".
		'sub {'."\n",
		$package
	);

	my $interface = $self->get_state->{incinterface};

	# code for input parameters
	foreach my $var ( values %{$interface->{input}} ) {
		my $name = $var;
		$name =~ s/^(.)//;
		my $deref = $1;

		if ( $deref eq '$' ) {
			$self->write ("    my $var = ".'$_[0]->{'.$name.'};'."\n");
		} else {
			$self->write ("    my $var = $deref\{".'$_[0]->{'.$name.'}};'."\n");
		}
	}

	# code for optional parameters
	foreach my $var ( values %{$interface->{optional}}) {
		my $name = $var;
		$name =~ s/^(.)//;
		my $deref = $1;

		if ( $deref eq '$' ) {
			$self->write ("    my $var = ".'$_[0]->{'.$name.'};'."\n");
		} else {
			# don't write: my $var = ${$foo} if defined $foo
			# this produce strange behaviour (at least unter Perl 5.6.0)
			# The dereferenced memory seems to live outside the
			# scope of this subroutine.
			$self->write ("    my $var;\n");
			$self->write ("    $var = $deref\{".'$_[0]->{'.$name.'}} if defined $_[0]->{'.$name.'};'."\n");
		}
	}

	# declaration of output parameters
	if ( keys %{$interface->{output}} ) {
		my $code;
		foreach my $var ( values %{$interface->{output}} ) {
			$code .= "$var,";
		}
		$code =~ s/,$//;
		$self->write ("    my ($code);\n");
	}

	1;
}

sub generate_include_close {
	my $self = shift; $self->trace_in;

	my $interface = $self->get_state->{incinterface};

	# return output parameter
	if ( values %{$interface->{output}} ) {
		my $code;
		my $name;
		foreach my $var ( values %{$interface->{output}} ) {
			$name = $var;
			$name =~ s/^(.)//;
			$code .= "$name => \\$var, ";
		}
		$code =~ s/,$//;
		$self->write ("    return { $code};\n");
	}

	# close subroutine
	$self->write (
		'}'."\n"
	);

	1;
}

sub generate_module_open {
	my $self = shift; $self->trace_in;

	$self->write (
		"use strict;\n",
#		'my $_cipp_line_nr;'."\n",
	);

	1;
}

sub generate_module_close {
	my $self = shift; $self->trace_in;

	$self->write (
		'1;'."\n",
	);

	1;
}

#---------------------------------------------------------------------
# This method processes all text blocks between tags
#---------------------------------------------------------------------

sub process_text {
	my $self = shift; $self->trace_in;
	my ($text) = @_;

	$self->debug("GOT TEXT: '$$text'\n");

	$self->set_last_text_block($$text);

	my $context   = $self->context;
	my $autoprint = $self->get_state->{autoprint};

	if ( ($autoprint and $context eq 'html') or $context eq 'force_html' ) {
		if ( $$text ne '' and $$text =~ /\S/ ) {
			# print only if the chunk isn't empty or contains
			# not only whitespace
			$self->generate_debugging_code;

			# escape § sign (which is the qouting delimiter)
			$$text =~ s/§/\\§/g;

			# truncate whitespace
			if ( $self->get_trunc_ws ) {
				$$text =~ s/^\s+//;
				if ( not $$text =~ s/\s*\n\s*$/\n/ ) {
					$$text =~ s/\s+$/ /;
				}
			}

			# generate print() command
			$self->write ("print qq§$$text§;\n");
		}

	} elsif ( $autoprint and $context eq 'html_exact' ) {
		$$text =~ s/§/\\§/g;
		$self->write ( "print qq§$$text§;\n");

	} elsif ( $context eq 'perl' ) {
		$self->write ($$text);

	} elsif ( $context eq 'var_quote' ) {
		$$text =~ s/\^/\\^/g;
		$self->write ($$text);

	} elsif ( $context eq 'var_noquote' ) {
		$self->write ($$text);
	}

	1;
}

#---------------------------------------------------------------------
# Process method for each CIPP command
#---------------------------------------------------------------------

sub cmd_perl {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_BLOCK_TAG;

	if ( $self->get_current_tag_closed ) {
		$self->pop_context;

		$self->check_options (
			mandatory => {},
			optional  => {},
		) || return $RC;

		$self->write (";}\n");

		return $RC;
	}

	$self->check_options (
		mandatory => {},
		optional  => { 'cond' => 1 },
	) || return $RC;

	my $options = $self->get_current_tag_options;

	$self->write ("if ($options->{cond}) ") if defined $options->{cond};
	$self->write ("{");

	$self->push_context('perl');

	return $RC;
}

sub cmd_expression {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_BLOCK_TAG;

	if ( $self->get_current_tag_closed ) {
		my $buffer = $self->get_last_text_block;
		$self->add_tag_message (
			message => "Expression must not have trailing semicolon"
		) if $buffer =~ /;\s*$/;

		$self->pop_context;

		$self->check_options (
			mandatory => {},
			optional  => {},
		) || return $RC;

		$self->write (");\n");

		return $RC;
	}

	$self->check_options (
		mandatory => {},
		optional  => {},
	) || return $RC;

	$self->write ("print (");

	$self->push_context('perl');

	return $RC;
}

sub cmd_html {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_BLOCK_TAG;

	if ( $self->get_current_tag_closed ) {
		$self->pop_context;

		$self->check_options (
			mandatory => {},
			optional  => {},
		);

		return $RC;
	}

	$self->check_options (
		mandatory => {},
		optional  => {},
	) || return $RC;

	$self->push_context('force_html');

	return $RC;
}

sub cmd_if {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_BLOCK_TAG;

	if ( $self->get_current_tag_closed ) {
		$self->check_options (
			mandatory => {},
			optional  => {},
		) || return $RC;
		$self->write ("}\n");
		return $RC;
	}

	$self->check_options (
		mandatory => { 'cond' => 1 },
		optional  => {},
	) || return $RC;

	my $options = $self->get_current_tag_options;

	$self->write ("if ($options->{cond}) {\n");

	return $RC;
}

sub cmd_while {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_BLOCK_TAG;

	if ( $self->get_current_tag_closed ) {
		$self->check_options (
			mandatory => {},
			optional  => {},
		) || return $RC;
		$self->write ("}\n");
		return $RC;
	}

	$self->check_options (
		mandatory => { 'cond' => 1 },
		optional  => {},
	) || return $RC;

	my $options = $self->get_current_tag_options;

	$self->write("while ($options->{cond}) {\n");

	return $RC;
}

sub cmd_do {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_BLOCK_TAG;

	if ( $self->get_current_tag_closed ) {
		$self->check_options (
			mandatory => { 'cond' => 1 },
			optional  => {},
		) || return $RC;

		my $options = $self->get_current_tag_options;

		$self->write ("} while ($options->{cond});\n");

		return $RC;
	}

	$self->check_options (
		mandatory => {},
		optional  => {},
	) || return $RC;

	$self->write ("do {\n");

	return $RC;
}

sub cmd_var {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_BLOCK_TAG;

	my $tag_data;

	if ( $tag_data = $self->get_current_tag_closed ) {
		$self->pop_context;

		$self->check_options (
			mandatory => {},
			optional  => {},
		) || return $RC;

		my $quote_char = $tag_data->{quote} ? '^' : '';

		$self->write($quote_char);

		if ( $tag_data->{default} ) {
			my ($open_quote, $close_quote);
			($open_quote, $close_quote) = ("qq^","^")
				if $tag_data->{quote};
			$self->write(
				qq{|| $open_quote$tag_data->{default}$close_quote}
			);
		}

		$self->write(";\n");
		return $RC;
	}

	my ($var_quote, $var_default);

	$self->check_options (
		mandatory => { 'name' => 1 },
		optional  => { 'default' => 1,
			       'type'    => 1,
			       'my'      => 1,
			       'noquote' => 1 },
	) || return $RC;

	my $options = $self->get_current_tag_options;

	my $name = $self->parse_variable_option (
		option => 'name'
	) || return $RC;

	if ( $name =~ /^[\@\%]/ ) {
		if ( defined $options->{default} ) {
			$self->add_tag_message (
				message => "DEFAULT is invalid for non scalar variables"
			);
			return $RC;
		}
		$var_quote = 0;
	} else {
        	$var_quote = 1;
	}

        if ( defined ($options->{type}) ) {
		$options->{type} =~ tr/A-Z/a-z/;
		if ( $options->{type} eq "num" ) {
			$self->{var_quote} = 0;
		} else {
			$self->add_tag_message (
				message => "Invalid TYPE."
			);
			return $RC;
		}
	}

	$var_quote = 0 if defined $options->{noquote};

	my $quote_char     = $var_quote ? 'qq^' : '';
	my $quote_end_char = $var_quote ? '^' : '';

	$self->write("my ") if defined $options->{'my'};

        if ( defined ($options->{default}) ) {
		$var_default = $options->{default};
	}

	$self->write("$name=".$quote_char);

	if ( $var_quote ) {
		$self->push_context('var_quote');
	} else {
		$self->push_context('var_noquote');
	}

	return $self->RC_BLOCK_TAG (
		quote   => $var_quote,
		default => $var_default
	);
}

sub cmd_else {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_SINGLE_TAG;

	$self->check_options (
		mandatory => {},
		optional  => {},
	) || return $RC;

	$self->write ("} else {\n");

	return $RC;
}

sub cmd_elsif {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_SINGLE_TAG;

	$self->check_options (
		mandatory => { 'cond' => 1 },
		optional  => {},
	) || return $RC;

	my $options = $self->get_current_tag_options;

	$self->write ("} elsif ($options->{cond}) {\n");

	return $RC;
}

sub cmd_try {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_BLOCK_TAG;

	$self->check_options (
		mandatory => {},
		optional  => {},
	) || return $RC;

	if ( $self->get_current_tag_closed ) {
		$self->write (
			"};\n".
			"(\$_cipp_exception, \$_cipp_exception_msg)=".
			"split(\"\\t\",\$\@,2);\n".
			'$_cipp_exception_msg=$_cipp_exception '.
			'if $@ and $_cipp_exception_msg eq "";'."\n".
			'die "_cipp_exit_command" if $_cipp_exception eq "_cipp_exit_command";'."\n"
		);
		return $RC;
	}

	$self->write (
		"my (\$_cipp_exception,\$_cipp_exception_msg)=(undef,undef);\n".
		"eval {\n"
	);

	return $RC;
}

sub cmd_catch {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_BLOCK_TAG;

	$self->check_options (
		mandatory => {},
		optional  => { 'throw' => 1,
			       'my' => 1,
			       'excvar' => 1,
			       'msgvar' => 1 },
	) || return $RC;

	if ( $self->get_current_tag_closed ) {
		$self->write ("}\n");
		return $RC;
	}

	my $options = $self->get_current_tag_options;

	my $my = '';
	$my = 'my ' if defined $options->{'my'};

	my $excvar = $self->parse_variable_option (
		option => 'excvar', types => [ 'scalar' ]
	);
	my $msgvar = $self->parse_variable_option (
		option => 'msgvar', types => [ 'scalar' ]
	);

	$self->write ("$my$excvar = \$_cipp_exception;\n")     if $excvar;
	$self->write ("$my$msgvar = \$_cipp_exception_msg;\n") if $msgvar;

	if ( defined $options->{throw} ) {
		$self->write (
			'if ( $_cipp_exception eq "'.$options->{throw}.'" ) {'."\n"
		);
	} else {
		$self->write (
			"if ( defined \$_cipp_exception ) {\n"
		);
	}

	return $RC;
}

sub cmd_log {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_SINGLE_TAG;

	$self->check_options (
		mandatory => { 'msg'  => 1 },
		optional  => { 'type' => 1, 'filename' => 1, 'throw' => 1 },
	) || return $RC;

	my $options = $self->get_current_tag_options;

	$options->{type}     ||= "APP";
	$options->{filename} ||= "";
	$options->{throw}    ||= "LOG";

	$self->writef (
		'$CIPP::request->log ('."\n".
		'   type     => "%s",'."\n".
		'   message  => "%s",'."\n".
		'   filename => "%s",'."\n".
		'   throw    => "%s",'."\n".
		');'."\n",

		$options->{type}, $options->{msg},
		$options->{filename}, $options->{throw}
	);

	return $RC;
}

sub cmd_throw {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_SINGLE_TAG;

	$self->check_options (
		mandatory => { 'throw' => 1 },
		optional  => { 'msg' => 1 },
	) || return $RC;

	my $options = $self->get_current_tag_options;

	if ( defined $options->{msg} ) {
		$self->write (
			qq{die "$options->{throw}\t$options->{msg}";\n}
		);
	} else {
		$self->write (
			qq{die "$options->{throw}\t";\n}
		);
	}

	return $RC;
}

sub cmd_dump {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_SINGLE_TAG;

	$self->check_options (
		mandatory => {},
		optional  => { '*' => 1 },
	) || return $RC;

	my $options_order = $self->get_current_tag_options_order;

	my $options = $self->get_current_tag_options;

	my $stderr = delete $options->{stderr};
	my $log    = delete $options->{log};

	$self->write ("use Data::Dumper;\n");

	my $dumper_code =
		"join('',Data::Dumper->Dump ([".
		join(', ', grep !/^stderr|log$/i, @{$options_order}).
		"], [qw(".
		join(' ', grep !/^stderr|log$/i, @{$options_order}).
		")]))";

	if ( $stderr ) {
		$self->writef (
			"print STDERR %s;\n",
			$dumper_code
		);
	}

	if ( $log ) {
		$self->writef (
			'$CIPP::request->log(type=>"dump",message=>"\n".%s);'."\n",
			$dumper_code
		);
	}

	if ( not $stderr and not $log ) {
		$self->writef (
			'print "".%s."\n";',
			$dumper_code
		);
	}

	return $RC;
}

sub cmd_block {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_BLOCK_TAG;

	$self->check_options (
		mandatory => {},
		optional  => {},
	) || return $RC;

	if ( $self->get_current_tag_closed ) {
		$self->write ("}\n");
		return $RC;
	}

	$self->write ("{\n");

	return $RC;
}

sub cmd_my {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_SINGLE_TAG;

	my $options      = $self->get_current_tag_options;
	my $options_case = $self->get_current_tag_options_case;
	my $options_list = $self->get_current_tag_options_order;

	if ( not scalar @{$options_list} ) {
		$self->add_tag_message (
			message => "No variables given."
		);
		return $RC;
	}

	# copy all options into the VAR option, so we
	# can use $self->parse_variable_option_hash
	delete $options_case->{var};
	$options->{var} .=
		( defined $options->{var} ? ',' : '' ).
		join (",", map { s/,$//; $_ } values %{$options_case});

	# now parse the 'var' option
	my $var = $self->parse_variable_option_hash (
		option => 'var'
	);

	# generate my statement
	my $varlist = join (",", keys %{$var});
	$self->write ("my ($varlist);\n");

	return $RC;
}

sub cmd_htmlquote {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_SINGLE_TAG;

	$self->check_options (
		mandatory => { 'var' => 1 },
		optional  => { 'htmlvar' => 1, 'my' => 1 },
	) || return $RC;

	my $options = $self->get_current_tag_options;

	my $var = $self->parse_variable_option (
		option => 'var', types => [ 'scalar' ]
	) || return $RC;

	my $htmlvar;
	if ( defined $options->{htmlvar} ) {
		$htmlvar = $self->parse_variable_option (
			option => 'htmlvar', types => [ 'scalar' ]
		) || return $RC;
	}

	($htmlvar = $var) =~ s/^\$(.*)$/\$html_$1/ if not $htmlvar;

	my $my_cmd = $options->{'my'} ? 'my ' : '';

	$self->write (
		"$my_cmd$htmlvar=\$CIPP::request->html_quote($var);\n"
	);

	return $RC;
}

sub cmd_urlencode {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_SINGLE_TAG;

	$self->check_options (
		mandatory => { 'var'    => 1 },
		optional  => { 'encvar' => 1, 'my' => 1 },
	) || return $RC;

	my $options = $self->get_current_tag_options;

	my $var = $self->parse_variable_option (
		option => 'var', types => [ 'scalar' ]
	) || return $RC;

	my $encvar;
	if ( defined $options->{encvar} ) {
		$encvar = $self->parse_variable_option (
			option => 'encvar', types => [ 'scalar' ]
		) || return $RC;
	}

	($encvar = $var) =~ s/^\$(.*)$/\$enc_$1/ if not $encvar;

	my $my_cmd = $options->{'my'} ? 'my ' : '';

	$self->write (
		"$my_cmd$encvar=\$CIPP::request->url_encode($var);\n"
	);

	return $RC;
}

sub cmd_foreach {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_BLOCK_TAG;

	if ( $self->get_current_tag_closed ) {
		$self->check_options (
			mandatory => {},
			optional  => {},
		) || return $RC;
		$self->write ("}\n");
		return $RC;
	}

	$self->check_options (
		mandatory => { 'var' => 1, 'list' => 1 },
		optional  => { 'my' => 1 },
	) || return $RC;

	my $options = $self->get_current_tag_options;

	my $var = $self->parse_variable_option (
		option => 'var', types => [ 'scalar' ]
	) || return $RC;

	$self->write ("my $var;\n") if $options->{'my'};
	$self->write ("foreach $var ($options->{list}) {\n");

	return $RC;
}

sub cmd_textarea {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_BLOCK_TAG;

	if ( $self->get_current_tag_closed ) {
		$self->pop_context;
		$self->check_options (
			mandatory => {},
			optional  => {},
		) || return $RC;
		$self->write ('}); print "\n";'."\n");
		return $RC;
	}

	my $options = $self->get_current_tag_options;

	my $options_text = '';
	my ($par, $val);
	while ( ($par,$val) = each %{$options} ) {
		$par =~ tr/A-Z/a-z/;
		$options_text .= qq[ $par="$val"];
	}

	$self->write (
		qq[print qq{},\$CIPP::request->html_quote (qq{]
	);

	$self->push_context('var_quote');

	return $RC;
}

sub cmd_sub {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_BLOCK_TAG;

	my $data;
	if ( $data = $self->get_current_tag_closed ) {
		$self->check_options (
			mandatory => {},
			optional  => {},
		) || return $RC;

		my $buffer_sref = $self->close_output_buffer;

		$self->write ( $buffer_sref );
		$self->write ("}\n");

		# now a Perl Syntax check for the subroutine
		my $var_decl;
		if ( $data->{import} and @{$data->{import}} ) {
			$var_decl = 'my (';
			$var_decl .= "$_, " for @{$data->{import}};
			$var_decl =~ s/, $//;
			$var_decl .= ");\n";
		}
		$$buffer_sref = "use strict; $var_decl$$buffer_sref";

		$self->perl_error_check ( perl_code_sref => $buffer_sref );

		return $RC;
	}

	$self->check_options (
		mandatory => { 'name'   => 1 },
		optional  => { 'import' => 1 },
	) || return $RC;

	my $options = $self->get_current_tag_options;

	my $name = $options->{name};
	$name = "main::$name" if $name !~ /:/ and
				 not $self->get_state->{module_name};

	if ( $options->{import} ) {
		my $import = $self->parse_variable_option_list (
			option => 'import',
		);
		$RC = $self->RC_BLOCK_TAG (
			import => $import
		);
	}

	$self->write (
		qq[sub $name {\n]
	);

	$self->open_output_buffer;

	return $RC;
}

sub cmd_hiddenfields {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_SINGLE_TAG;

	$self->check_options (
		mandatory => {},
		optional  => { '*' => 1 },
	) || return $RC;

	my $options      = $self->get_current_tag_options;
	my $options_case = $self->get_current_tag_options_case;

	my (@val_list, $par, $val);

	# first get variables from PARAMS option
	if ( defined $options->{params} ) {
		my $params = $self->parse_variable_option_hash (
			option => 'params',
			types  => [ 'scalar', 'array' ]
		) || return $RC;

		foreach $par ( keys %{$params} ) {
			$val = $par;
			$par =~ s/^[\$\@]//;
			push @val_list, "$val\t$par";
		}
	}

	# now add explicite options
	while ( ($par,$val) = each %{$options} ) {
		next if $par eq 'params';
		push @val_list, "$val\t".$options_case->{$par};
	}

	# now we have tab delimited entries in @val_list:
	#
	#	idx 0	assigned parameter:
	#		if begins with $ : scalar variable
	#		if begins with @ : array variable
	#		else:              literal string
	#
	# 	idx 1	name of the parameter for the hidden field

	# first generate constant hiddenfields for scalar parameters
	my $item;
	foreach $item (grep /^[^\@]/, @val_list) {
		($val, $par) = split ("\t", $item);
		$par=lc($par);
		$self->write (
		    qq[print qq{].
		    qq[
1050
		    qq[\$CIPP::request->html_field_quote(qq{$val}).qq{"\$CIPP::ee>\\n};\n] );
	}

	# generate dynamic hiddenfield code for arrays
	foreach $item (grep /^\@/, @val_list) {
		($val, $par) = split ("\t", $item);
		$par=lc($par);
		$self->write (
		    qq[{my \$cipp_tmp;\nforeach \$cipp_tmp ($val) {\n].
		    qq[print qq{
		    qq[value="}.\$CIPP::request->html_field_quote(qq{\$cipp_tmp}).].
		    qq[qq{"\$CIPP::ee>\\n};\n].
		    qq[}\n}\n] );
	}

	return $RC;
}

sub cmd_comment {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_BLOCK_TAG;

	if ( $self->get_current_tag_closed ) {
		$self->pop_context;
		$self->check_options (
			mandatory => {},
			optional  => {},
		) || return $RC;
		return $RC;
	}

	$self->check_options (
		mandatory => {},
		optional  => {},
	) || return $RC;

	$self->push_context('comment');

	return $RC;
}

sub cmd_input {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_SINGLE_TAG;

	$self->check_options (
		mandatory => {},
		optional  => { '*' => 1 },
	) || return $RC;

	my $code = qq[print qq{

	my $options      = $self->get_current_tag_options;
	my $options_case = $self->get_current_tag_options_case;

	my ($par, $val);
	while ( ($par,$val) = each %{$options} ) {
		if ( $par eq 'value' ) {
			# quote the VALUE option
			$code .= qq[ value="}.\$CIPP::request->html_quote ].
		   		 qq[(qq{$options->{value}}).qq{"];

		} elsif ( $par eq 'src' ) {
			# check whether this image exists and is of correct type
			# ()
			return $RC if not $self->check_object_type (
				name => $val,
				type => 'cipp-image',
			);

			my $object_url = $self->get_object_url ( name => $val );
			$code .= qq[ src="$object_url"];

		} elsif ( $par ne 'sticky' ) {
			# other parameters are taken as is
			$par =~ tr/A-Z/a-z/;
			$code .= qq[ $par="$val"];
		}
	}

	my $sticky_var = $options->{sticky};

	if ( $sticky_var ) {
		if ( $options->{type} =~ /^radio$/i and
		     $options->{name} !~ /\$/ and not $options->{checked} ) {
			# sticky feature for type="radio"
	     		if ( $sticky_var == 1 ) {
				$sticky_var = '$'.$options->{name};
			}
			$code .= qq[},($sticky_var eq qq{$options->{value}} ].
				 qq[? " checked\$CIPP::ee>\\n":"\$CIPP::ee>\\n");\n];

		} elsif ( $options->{type} =~ /^checkbox$/i and
		          $options->{name} !~ /\$/ and not $options->{checked} ) {
			# sticky feature for type="checkbox"
			$sticky_var = '@'.$options->{name} if $sticky_var == 1;
			$code .= qq[},(grep /^$options->{value}\$/,$sticky_var) ].
				 qq[? " checked\$CIPP::ee>\\n":"\$CIPP::ee>\\n";\n];
		}
	} else {
		$code .= "\$CIPP::ee>\\n};\n";
	}

	$self->write($code);

	return $RC;
}

sub cmd_savefile {			# deprecated. replaced by
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_SINGLE_TAG;

	$self->check_options (
		mandatory => { 'var' => 1, 'filename' => 1 },
		optional  => { 'throw' => 1, 'symbolic' => 1 }
	) || return $RC;

	my $options = $self->get_current_tag_options;

	$options->{var} =~ s/^\$//;

	$options->{throw} ||= "savefile";

	my $formvar;
	if ( ! defined $options->{symbolic} ) {
		$formvar = "'$options->{var}'";
	} else {
		$formvar = "\$$options->{var}";
	}

	my $code = "{\nno strict;\n";
	$code .= "my \$_cipp_filehandle = CGI::param($formvar);\n";
	$code .= "die '$options->{throw}\tFile upload variable not set.'\n ";
	$code .= "if not \$_cipp_filehandle;\n";
	$code .= "open (cipp_SAVE_FILE, \"> $options->{filename}\")\n";
	$code .= "or die \"$options->{throw}\tCan't open file '$options->{filename}' ".
		 "for writing\";\n";
	$code .= "binmode cipp_SAVE_FILE;\n";
	$code .= "binmode \$_cipp_filehandle;\n";
	$code .= "my (\$_cipp_filebuf, \$_cipp_read_result);\n";
	$code .= "while (\$_cipp_read_result = read \$_cipp_filehandle, ".
		 "\$_cipp_filebuf, 1024) {\n";
	$code .= "print cipp_SAVE_FILE \$_cipp_filebuf ";
	$code .= "or die \"$options->{throw}\tError writing to output file.\";\n";
	$code .= "}\n";
	$code .= "close cipp_SAVE_FILE;\n";
	$code .= "(!defined \$_cipp_read_result) and \n";
	$code .= "die \"$options->{throw}\tError reading the upload file. ".
	         "Did you set ENCTYPE=multipart/form-data?\";\n";
	$code .= "close \$_cipp_filehandle;\n";
	$code .= "}\n";

	$self->write ($code);

	return 1;
}

sub cmd_fetchupload {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_SINGLE_TAG;

	$self->check_options (
		mandatory => { 'var' => 1, 'filename' => 1 },
		optional  => { 'throw' => 1 }
	) || return $RC;

	my $options = $self->get_current_tag_options;
	$options->{throw} ||= "fetchupload";

	my $var = $self->parse_variable_option (
		option => 'var',
		types => [ 'scalar' ]
	) || return $RC;

	$self->writef (
		'$CIPP::request->fetch_upload ('."\n".
		'  filename => "%s",'."\n".
		'  fh       => %s,'."\n".
		'  throw    => "%s"'."\n".
		');'."\n",

		$options->{filename},
		$var,
		$options->{throw},
	);

	return $RC;
}

sub cmd_interface {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_SINGLE_TAG;

	if ( defined $self->get_state->{interface_occured} ) {
		$self->add_tag_message (
			message => 'Multiple instances of '.
				   ' are forbidden.'
		);
		return $RC;
	}

	if ( $self->get_object_type ne 'cipp' ) {
		$self->add_tag_message (
			message => "Illegal use of the  command. This is not a CIPP program."
		);
		return $RC;
	}

	$self->get_state->{interface_occured} = 1;

	$self->check_options (
		mandatory => {},
		optional  => { 'input' => 1, 'optional' => 1 },
	) || return $RC;

	my $mandatory = $self->parse_variable_option_hash (
		option => 'input'
	);

	my $optional  = $self->parse_variable_option_hash (
		option => 'optional'
	);

	return $RC if not keys %{$mandatory} and not keys %{$optional};

	$self->write (
		"my (".
		join (", ", keys %{$mandatory}, keys %{$optional}).
		");\n\n"
	);

	$self->write (
		'$CIPP::request->read_input_parameter ('."\n".
		"  mandatory => {\n"
	);

	my ($name, $var, @clash);
	while ( ($var, $name) = each %{$mandatory} ) {
		if ( defined $optional->{$var} ) {
			push @clash, $var;
			next;
		}
		$self->write (
			"    '$name' => \\$var,\n"
		);
	}

	$self->write (
		"  },\n".
		"  optional => {\n"
	);

	while ( ($var, $name) = each %{$optional} ) {
		$self->write (
			"    '$name' => \\$var,\n"
		);
	}
	$self->write (
		"  },\n".
		");\n\n"
	);

	$self->add_tag_message (
		message => "INPUT/OPTIONAL variable clash: ".
			    join(', ', @clash)
	) if @clash;


	return $RC;
}

sub cmd_use {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_SINGLE_TAG;

	$self->check_options (
		mandatory => { 'name' => 1 },
		optional  => {},
	) || return $RC;

	my $options = $self->get_current_tag_options;

	$self->writef(
		'use %s;'."\n",
		$options->{name}
	);

	$self->add_used_module (
		name => $options->{name},
	);

	return $RC;
}

sub cmd_require {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_SINGLE_TAG;

	$self->check_options (
		mandatory => { 'name' => 1 },
	) || return $RC;

	my $options = $self->get_current_tag_options;

	$self->write(
		qq[{ my \$_cipp_mod = "$options->{name}";\n].
		qq[\$_cipp_mod =~ s!::!/!og;\n].
		qq[\$_cipp_mod .= ".pm";\n].
		qq[require \$_cipp_mod;}\n]
	);

	if ( $options->{name} !~ /\$/ ) {
		$self->add_used_module (
			name => $options->{name},
		);
	}

	return $RC;
}

sub cmd_module {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_BLOCK_TAG;

	if ( $self->get_current_tag_closed ) {
		$self->check_options (
			mandatory => {},
			optional  => {},
		) || return $RC;
		return $RC;
	}

	$self->check_options (
		mandatory => { 'name' => 1 },
		optional  => { 'isa'  => 1 },
	) || return $RC;

	my $options = $self->get_current_tag_options;

	if ( $self->get_state->{module_name} ) {
		$self->add_tag_message (
			message => "Mulitiple module declaration: ".
				   $self->get_state->{module_name}
		);
		return $RC;
	}

	$self->get_state->{module_name} = $options->{name};

	$self->write("package $options->{name};\n\n");

	if ( $options->{isa} ) {
		my $isa = $options->{isa};
		$isa =~ s/,/ /g;
		$self->write (
			'@'.$options->{name}."::ISA = qw( $isa );\n"
		);
	}

	my @isa = split (/\s*,\s*/, $options->{isa});
	foreach my $isa ( @isa ) {
		$self->write(
			qq[\n{ my \$_cipp_mod = "$isa";\n].
			qq[\$_cipp_mod =~ s!::!/!og;\n].
			qq[\$_cipp_mod .= ".pm";\n].
			qq[require \$_cipp_mod;}\n\n]
		);
	}

	return $RC;
}

sub cmd_config {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_SINGLE_TAG;

	$self->check_options (
		mandatory => { 'name' => 1 },
		optional  => { 'nocache' => 1, 'runtime' => 1, 'throw' => 1 },
	) || return $RC;

	my $options = $self->get_current_tag_options;

	my $name = $options->{name};

	if ( not $options->{runtime} ) {
		return $RC if not $self->check_object_type (
			name => $name,
			type => 'cipp-config',
		);

		$self->add_used_object (
			name => $name,
			type => 'cipp-config'
		);
	}

	my $throw = $options->{throw};
	$throw ||= 'config';

	my $require;

	$self->writef (
		'$CIPP::request->read_config ('."\n".
		'    name  => "%s",'."\n".
		'    throw => "%s"'."\n".
		');'."\n",
		$name,
		$throw
	);

	return $RC;
}

sub cmd_form {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_BLOCK_TAG;

	if ( $self->get_current_tag_closed ) {
		$self->check_options (
			mandatory => {},
			optional  => {},
		) || return $RC;

		$self->write ('print "\n";'."\n");

		return $RC;
	}

	$self->check_options (
		mandatory => { 'action' => 1 },
		optional  => { '*' => 1 },
	) || return $RC;

	my $options = $self->get_current_tag_options;

	my $method;
	if ( defined $options->{method} ) {
		$method = $options->{method};
		delete $options->{method};
	} else {
		$method = "POST";
	}

	my $name = $options->{action};
	delete $options->{action};

	my $anchor;
	if ( $name =~ /#/ ) {
		($name, $anchor) = split ("#", $name, 2);
		$anchor = "#$anchor";
	}

	return $RC if not $self->check_object_type (
		name => $name,
		type => 'cipp',
	);

	my $object_url = $self->get_object_url ( name => $name );

	my $code = qq[print qq{
		   qq[method="$method"];

	my ($par, $val);
	while ( ($par,$val) = each %{$options} ) {
		$par =~ tr/a-z/A-Z/;
		$code .= qq[ $par="$val"];
	}

	$code .= ">\\n};\n";

	$self->write($code);

	return $RC;
}

sub cmd_a {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_BLOCK_TAG;

	if ( $self->get_current_tag_closed ) {
		$self->pop_context;
		$self->check_options (
			mandatory => {},
			optional  => {},
		) || return $RC;

		$self->write ('print qq[\n];'."\n");

		return $RC;
	}

	$self->check_options (
		mandatory => { 'href' => 1 },
		optional  => { '*' => 1 },
	) || return $RC;

	my $options = $self->get_current_tag_options;

	my $name = $options->{href};
	delete $options->{href};

	my $anchor;
	if ( $name =~ /#/ ) {
		($name, $anchor) = split ("#", $name, 2);
	}

	return $RC if not $self->object_exists (
		name => $name,
		add_message_if_not => 1
	);

	my $object_url = $self->get_object_url (
		name => $name,
		add_message_if_has_no => 1
	);

	return $RC if not defined $object_url;

	my $code;
	if ( defined $anchor ) {
		$code = qq[print qq{
	} else {
		$code = qq[print qq{
	}

	my ($par, $val);
	while ( ($par,$val) = each %{$options} ) {
		$par =~ tr/a-z/A-Z/;
		$code .= qq[ $par="$val"];
	}

	$code .= ">};\n";

	$self->write($code);

	$self->push_context ('html_exact');

	return $RC;
}

sub cmd_frame {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_SINGLE_TAG;

	if ( $self->get_current_tag_closed ) {
		$self->check_options (
			mandatory => {},
			optional  => {},
		) || return $RC;

		return $RC;
	}

	$self->check_options (
		mandatory => { 'src' => 1 },
		optional  => { '*' => 1 },
	) || return $RC;

	my $options = $self->get_current_tag_options;

	my $name = delete $options->{src};

	my $anchor;
	if ( $name =~ /#/ ) {
		($name, $anchor) = split ("#", $name, 2);
	}

	return $RC if not $self->object_exists (
		name => $name,
		add_message_if_not => 1
	);

	my $object_url = $self->get_object_url (
		name => $name,
		add_message_if_has_no => 1
	);

	return $RC if not defined $object_url;

	my $code;
	if ( defined $anchor ) {
		$code = qq[print qq{
	} else {
		$code = qq[print qq{
	}

	my ($par, $val);
	while ( ($par,$val) = each %{$options} ) {
		$par =~ tr/a-z/A-Z/;
		$code .= qq[ $par="$val"];
	}

	$code .= "\$CIPP::ee>};\n";

	$self->write($code);

	return $RC;
}

sub cmd_geturl {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_SINGLE_TAG;

	$self->check_options (
		mandatory => { 'name' => 1 },
		optional  => { '*'    => 1 },
	) || return $RC;

	my $options      = $self->get_current_tag_options;
	my $options_case = $self->get_current_tag_options_case;

	# mangle URLVAR and VAR options. URLVAR is depreciated.

	if ( $options->{urlvar} ) {
		if ( $options->{var} ) {
			$self->add_tag_message (
				message => "Using VAR and URLVAR option ".
					   "is forbidden. URLVAR is ".
					   "deprecated."
			);
			return $RC;
		}
		$options->{var} = $options->{urlvar};
		delete $options->{urlvar};
	}

	if ( not $options->{var} ) {
		$self->add_tag_message (
			message => "VAR option missing."
		);
		return $RC;
	}

	my $var = $self->parse_variable_option (
		option => 'var',
		types => [ 'scalar' ]
	);
	delete $options->{var};


	my $name      = delete $options->{name};
	my $runtime   = delete $options->{runtime};
	my $throw     = delete $options->{throw} || 'geturl';
	my $path_info = delete $options->{pathinfo};
	my $my_cmd    = delete $options->{my};
	$my_cmd = $my_cmd ? 'my ' : '';

	return $RC if not $runtime and not $self->object_exists (
		name => $name,
		add_message_if_not => 1
	);

	my $object_url;

	if ( not $runtime ) {
		$object_url = $self->get_object_url (
			name => $name,
			add_message_if_has_no => 1
		);
		return $RC if not defined $object_url;

		$self->write ("${my_cmd}$var=qq{$object_url}\n");

	} else {
		$self->write (
			qq{${my_cmd}$var=\$CIPP::request->get_object_url ( name => "$name", throw => "$throw")}
		);
	}

	# add PATHINFO, if requested
	$self->write (qq[.qq{/$path_info}]) if $path_info;

	# now add parameters to the url
	my @val_list;
	my ($par, $val);

	# get values from PARAMS

	if ( defined $options->{params} ) {
		my $params = $self->parse_variable_option_hash (
			option => 'params',
			types  => [ 'scalar', 'array' ]
		) || return $RC;

		foreach $par ( keys %{$params} ) {
			$val = $par;
			$par =~ s/^[\$\@]//;
			push @val_list, "$val\t$par";
		}
	}

	# now add explicite options
	while ( ($par,$val) = each %{$options} ) {
		next if $par eq 'params';
		push @val_list, "$val\t".$options_case->{$par};
	}

	# now we have tab delimited entries in @val_list:
	#
	#	idx 0	assigned parameter:
	#		if begins with $ : scalar variable
	#		if begins with @ : array variable
	#		else:              literal string
	#
	# 	idx 1	name of the parameter for the hidden field

	if ( @val_list ) {
		return $RC if not $runtime and not $self->check_object_type (
			name => $name,
			type => 'cipp',
			message => "Illegal attempt to add parameters ".
				   "to a non CGI URL."
		);

		# process scalar parameters first.
		my $delimiter = "?";
		my $item;

		foreach $item (grep /^[^\@]/, @val_list) {
			($val, $par) = split ("\t", $item);
			$par=lc($par);
			$self->write (
			    qq{.qq{${delimiter}$par=}.}.
			    qq{\$CIPP::request->url_encode("$val")} );

			$delimiter = $self->get_url_par_delimiter if $delimiter eq '?';
		}
		$self->write ( ";\n" );

		# now array parameters
		foreach $item (grep /^\@/, @val_list) {
			($val, $par) = split ("\t", $item);
			$par=lc($par);
			$self->write (
				qq[{my \$_cipp_tmp;\nforeach \$_cipp_tmp ($val) {\n].
				qq[$var.="${delimiter}$par=".].
				qq[\$CIPP::request->url_encode(\$_cipp_tmp);\n].
				qq[}\n}\n] );

			$delimiter = $self->get_url_par_delimiter if $delimiter eq '?';
		}
	}

	$self->write (";\n");

	return $RC;
}

sub cmd_img {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_SINGLE_TAG;

	$self->check_options (
		mandatory => { 'src' => 1 },
		optional  => { '*' => 1 },
	) || return $RC;

	my $options = $self->get_current_tag_options;

	my $name   = delete $options->{src};
	my $nosize = delete $options->{nosize};

	my $object_url = $self->get_object_url (
		name => $name,
		add_message_if_has_no => 1
	);

	return $RC if not defined $object_url;

	my $code = qq[print qq{

	if ( not defined $nosize and
	     not defined $options->{width} and
	     not defined $options->{height} ) {
		my $filename = $self->get_object_filename ( name => $name );
		last if not $filename;
		eval "use Image::Size qw()";
		last if $@;
		eval {
			($options->{width},
			 $options->{height})
			 	= Image::Size::imgsize ($filename);
		};
	}

	my ($par, $val);
	while ( ($par,$val) = each %{$options} ) {
		$code .= qq[ $par="$val"];
	}

	$code .= "\$CIPP::ee>};\n";

	$self->write($code);

	return $RC;
}

sub cmd_select {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_BLOCK_TAG;

	if ( $self->get_current_tag_closed ) {
		$self->get_state->{select_tag_options} = undef;
		$self->check_options (
			mandatory => {},
			optional  => {},
		) || return $RC;
		$self->write(
			qq{print "\\n";}
		);
		return $RC;
	}

	if ( $self->get_state->{select_tag_options} ) {
		$self->add_tag_message (
			message => "Nesting forbidden."
		);
		return $RC;
	}

	$self->check_options (
		mandatory => { 'name' => 1 },
		optional  => { '*' => 1 },
	) || return $RC;

	my $options = $self->get_current_tag_options;

	$self->get_state->{select_tag_options} = $options;

	my $code = qq[print qq{

	my ($par, $val);
	while ( ($par,$val) = each %{$options} ) {
		if ( $par ne 'sticky' ) {
			$code .= qq[ $par="$val"];
		}
	}
	$code .= ">\\n};\n";

	$self->write($code);

	return $self->RC_BLOCK_TAG (%{$options});
}

sub cmd_option {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_BLOCK_TAG;

	if ( $self->get_current_tag_closed ) {
		$self->check_options (
			mandatory => {},
			optional  => {},
		) || return $RC;
		$self->pop_context;
		$self->write(
			qq[^),"\\n";]
		);
		return $RC;
	}

	my $select_options = $self->get_state->{select_tag_options};

	if ( not $select_options ) {
		$self->add_tag_message (
			message => "Missing  tag."
		);
		return $RC;
	}

	$self->check_options (
		mandatory => {},
		optional  => { '*' => 1 },
	) || return $RC;

	my $options = $self->get_current_tag_options;

	my $code = qq[print qq{

	my ($par, $val);
	while ( ($par,$val) = each %{$options} ) {
		if ( $par eq 'value' ) {
			$code .= qq[ value="}.\$CIPP::request->html_field_quote].
		   		 qq[(qq{$options->{value}}).qq{"];
		} else {
			$par =~ tr/A-Z/a-z/;
			if ( $par ne 'sticky' ) {
				$code .= qq[ $par="$val"];
			}
		}
	}

	my $sticky_var = $select_options->{sticky} || $options->{sticky};

	if ( $sticky_var ) {
		if ( $options->{name} !~ /\$/ and not $options->{selected} and
		     $select_options->{multiple} ) {
			if ( $sticky_var == 1 ) {
				$sticky_var = '@'.$select_options->{name};
			}
			$code .= qq[},(grep /^$options->{value}\$/,$sticky_var) ? " selected>":">",\n];
		} elsif ( $options->{name} !~ /\$/ and not $options->{selected} ) {
			if ( $sticky_var == 1 ) {
				$sticky_var = '$'.$select_options->{name};
			}
			$code .= qq[},($sticky_var eq qq{$options->{value}}) ? " selected>":">",\n];
		}
	} else {
		$code .= ">},\n";
	}

	$self->write($code);
	$self->write (
		qq[\$CIPP::request->html_quote (qq^]
	);

	$self->push_context('var_quote');

	return $RC;
}

sub cmd_lib {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_SINGLE_TAG;

	$self->check_options (
		mandatory => { 'name' => 1 },
		optional  => {},
	) || return $RC;

	my $options = $self->get_current_tag_options;

	$self->write("use $options->{name};\n");

	return $RC;
}

sub cmd_getparam {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_SINGLE_TAG;

	$self->check_options (
		mandatory => { 'name' => 1 },
		optional  => { 'my' => 1, 'var' => 1 },
	) || return $RC;

	my $options = $self->get_current_tag_options;

	my $var;
	if ( not defined $options->{var} ) {
		$var = '$'.$options->{name};
		$options->{'my'} = 1;
	} else {
		$var = $self->parse_variable_option (
			option => "var"
		);
	}

	my $my = $options->{'my'} ? 'my' : '';

	$self->write("$my $var = \$CIPP::request->param(\"$options->{name}\");\n");

	return $RC;
}

sub cmd_getparamlist {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_SINGLE_TAG;

	$self->check_options (
		mandatory => { 'var' => 1 },
		optional  => { 'my' => 1 },
	) || return $RC;

	my $var = $self->parse_variable_option (
			option => "var",
			types => [ 'array' ]
	) || return $RC;

	my $options = $self->get_current_tag_options;

	my $my = $options->{'my'} ? 'my' : '';

	$self->write("$my $var = \$CIPP::request->param();\n");

	return $RC;
}

sub cmd_autoprint {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_SINGLE_TAG;

	$self->check_options (
		mandatory => {},
		optional  => { 'off' => 1, 'on' => 1 },
	) || return $RC;

	my $options = $self->get_current_tag_options;

	if ( $options->{on} and $options->{off} ) {
		$self->add_tag_message (
			message => 'Illegal combination of ON and OFF.'
		);
		return $RC;
	}

	if ( not $options->{on} and not $options->{off} ) {
		$self->add_tag_message (
			message => 'Neither ON nor OFF specified.'
		);
		return $RC;
	}

	$self->get_state->{autoprint} = 0 if $options->{off};
	$self->get_state->{autoprint} = 1 if $options->{on};

	return $RC;
}

sub cmd_exit {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_SINGLE_TAG;

	$self->check_options (
		mandatory => {},
		optional  => {},
	) || return $RC;

	$self->write(
		"die '_cipp_exit_command';\n"
	);

	return $RC;
}

sub cmd_profile {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_BLOCK_TAG;

	if ( $self->get_current_tag_closed ) {
		$self->check_options (
			mandatory => {},
			optional  => {},
		) || return $RC;

		$self->write (
			'$CIPP::request->stop_profiling;'."\n"
		);

		return $RC;
	}

	$self->check_options (
		mandatory => {},
		optional  => {
			'deep'       => 1, 'name'      => 1,
			'filename'   => 1, 'filter'    => 1,
			'scaleunit'  => 1,
		},
	) || return $RC;

	my $options = $self->get_current_tag_options;

	my $deep        = $options->{deep} ? 1 : 0;
	my $name        = $options->{name} || 'unnamed';
	my $filename    = $options->{filename};

	my $filter      = $options->{filter}    || 0;
	my $scale_unit  = $options->{scaleunit} || 0.2;

	$self->write (
		'$CIPP::request->start_profiling ('."\n".
		"    deep        => $deep,\n".
		"    name        => qq{$name},\n".
		"    filename    => qq{$filename},\n".
		"    filter      => $filter,\n".
		"    scale_unit  => $scale_unit\n".
		");\n"
	);

	return $RC;
}

sub cmd_profile_old {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_SINGLE_TAG;

	$self->check_options (
		mandatory => {},
		optional  => { 'on' => 1, 'off' => 1, 'deep' => 1 },
	) || return $RC;

	my $options = $self->get_current_tag_options;

	my $deep = '';
	if ( $options->{on} ) {
		if ( $options->{deep} ) {
			$self->get_state->{profile} = "deep";
			$deep = " DEEP";
		} else {
			$self->get_state->{profile} = "on";
		}
	}

	if ( $options->{off} ) {
		$self->get_state->{profile} = undef;
		$self->write(
			'printf STDERR "PROFILE %5d STOP'.$deep.'\n",$$;'
		);
	} else {
		$self->write(
			"require 'Time/HiRes.pm';\n",
			'printf STDERR "\nPROFILE %5d START'.$deep.'\n",$$;'
		);
	}

	return $RC;
}

sub get_profile_start_code {
	my $self = shift; $self->trace_in;

	return	'my ($_cipp_t1, $_cipp_t2);'."\n".
		'$_cipp_t1 = Time::HiRes::time();'."\n";
}

sub get_profile_end_code {
	my $self = shift; $self->trace_in;

	my ($what, $detail) = @_;

	$what   = "q[$what]";
	$detail = "q[$detail]";

	return	'$_cipp_t2 = Time::HiRes::time();'."\n".
		'printf STDERR "PROFILE %5d %-10s %-40s %2.4f\n", '.
		'$$, '.$what.','.$detail.', $_cipp_t2-$_cipp_t1;'."\n";
}

sub get_dbh_code {
	my $self = shift; $self->trace_in;

	my $options = $self->get_current_tag_options;

	if ( $options->{dbh} and $options->{db} ) {
		$self->add_tag_message (
			message => "Illegal combination of DB and DBH."
		);
		return;
	}

	if ( $options->{dbh} ) {
                #-- trivial, if DBH option was set
		my $var = $self->parse_variable_option (
			option => 'dbh',
			types => [ 'scalar' ]
		) || return;
		return $var;

	}
        elsif ( $options->{db} =~ /\$/ ) {
                #-- Obviously a variable database name, then this is
                #-- resolved at runtime (need to normalize the name
                #-- on-the-fly i.e. remove the PROJECT DOT from the
                #-- variable's content).
                return   '$CIPP::request->dbh(do{my $__db='
                       . $options->{db}
                       . ';$__db=~s/^[^.]+\.//;$__db})';

        }
        else {
                #-- otherwise it's a static new.spirit dotted object name
		my $db = $options->{db};
		if ( $db ) {
			$self->check_object_type (
				name    => $db,
				type    => 'cipp-db',
				message => "$db is not a database configuration object"
			) || return;

			# we normalize here, because the identifier for
			# the default db __default must not be normalized
			# by the ->add_used_object method call beyond.
			# so we can call it with normalized => 1.
			$db =~ s/^[^.]+\.//;
#			$db = $self->get_normalized_object_name ( name => $options->{db} );
		} else {
			$db = "default";
		}

		$self->add_used_object (
			name => ($db eq 'default' ? '__default' : $db),
			type => 'cipp-db',
			normalized => 1
		);

		return '$CIPP::request->dbh("'.$db.'")';
	}
}

sub cmd_getdbhandle {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_SINGLE_TAG;

	$self->check_options (
		mandatory => { 'var' => 1 },
		optional  => { 'my'  => 1, 'db' => 1 },
	) || return $RC;

	my $options = $self->get_current_tag_options;

	my $var = $self->parse_variable_option (
		option => 'var',
		types  => [ 'scalar' ]
	) || return $RC;

	my $dbh_code = $self->get_dbh_code;

	my $my_cmd = $options->{'my'} ? 'my ' : '';

	if ( $self->get_state->{profile} ) {
		$self->write ( $self->get_profile_start_code );
	}

	$self->write (
		qq{${my_cmd}$var = $dbh_code;\n}
	);

	if ( $self->get_state->{profile} ) {
		$self->write (
			$self->get_profile_end_code (
				"CONNECT", "Database: ".($options->{db}||'default')
			)
		);
	}

	return $RC;
}

sub cmd_switchdb {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_BLOCK_TAG;

	if ( $self->get_current_tag_closed ) {
		$self->check_options (
			mandatory => {},
			optional  => {},
		) || return $RC;

		$self->writef (
			'};'."\n".
			'$CIPP::request->unswitch_db;'."\n".
			'die $@ if $@;'."\n"
		);

		return $RC;
	}

	$self->check_options (
		optional  => { 'dbh' => 1, 'db' => 1 },
	) || return $RC;

	my $options = $self->get_current_tag_options;

	my $dbh_code = $self->get_dbh_code;

	$self->write (
		qq[eval {\n].
		qq[\$CIPP::request->switch_db ( dbh => $dbh_code );\n]
	);

	return $RC;
}

sub cmd_autocommit {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_SINGLE_TAG;

	$self->check_options (
		mandatory => {},
		optional  => { 'on' => 1, 'off' => 1, 'db' => 1,
			       'dbh' => 1, 'throw' => 1 },
	) || return $RC;

	my $options = $self->get_current_tag_options;

	my $dbh_code = $self->get_dbh_code;

	if ( not defined $options->{on} and not defined $options->{off} ) {
		$self->add_tag_message (
			message => "Neither ON nor OFF option set."
		);
		return $RC;
	}

	if ( defined $options->{on} and defined $options->{off} ) {
		$self->add_tag_message (
			message => "Illegal combination of ON and OFF options."
		);
		return $RC;
	}

	my $status = defined $options->{on} ? 1 : 0;
	my $throw  = $options->{throw} || 'autocommit';

	$self->writef (
		'$CIPP::request->set_throw (qq{%s});'."\n",
		$throw
	);

	if ( $status ) {
		$self->writef (
			'die qq{%s\tAutoCommit already on} if %s->{AutoCommit};'."\n",
			$throw,
			$dbh_code
		);
	} else {
		$self->writef (
			'die qq{%s\tAutoCommit already off} if not %s->{AutoCommit};'."\n",
			$throw,
			$dbh_code
		);
	}

	$self->write ("$dbh_code\->{AutoCommit} = $status;\n");


	return $RC;
}

sub cmd_commit {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_SINGLE_TAG;

	$self->check_options (
		mandatory => {},
		optional  => { 'db' => 1, 'dbh' => 1, 'throw' => 1 },
	) || return $RC;

	my $options = $self->get_current_tag_options;

	my $dbh_code = $self->get_dbh_code;
	my $throw  = $options->{throw} || 'commit';

	$self->writef (
		'$CIPP::request->set_throw (qq{%s});'."\n",
		$throw
	);

	$self->writef (
		'die qq{%s\tCommit used, but AutoCommit is on} if %s->{AutoCommit};'."\n",
		$throw,
		$dbh_code
	);

	$self->write (
		"$dbh_code\->commit;\n"
	);

	return $RC;
}

sub cmd_rollback {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_SINGLE_TAG;

	$self->check_options (
		mandatory => {},
		optional  => { 'db' => 1, 'dbh' => 1, 'throw' => 1 },
	) || return $RC;

	my $options = $self->get_current_tag_options;

	my $dbh_code = $self->get_dbh_code;
	my $throw  = $options->{throw} || 'rollback';

	$self->writef (
		'$CIPP::request->set_throw (qq{%s});'."\n",
		$throw
	);

	$self->writef (
		'die qq{%s\tRollback used, but AutoCommit is on} if %s->{AutoCommit};'."\n",
		$throw,
		$dbh_code
	);

	$self->write (
		"$dbh_code\->rollback;\n"
	);

	return $RC;
}

sub cmd_dbquote {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_SINGLE_TAG;

	$self->check_options (
		mandatory => { 'var' => 1 },
		optional  => { 'dbvar' => 1, 'dbh' => 1, 'db' => 1, 'my' => 1 },
	) || return $RC;

	my $options = $self->get_current_tag_options;

	my $my_cmd = $options->{'my'} ? 'my ' : '';
	my $dbh_code = $self->get_dbh_code;

	my $var = $self->parse_variable_option (
		option => 'var',
		types  => [ 'scalar' ]
	) || return $RC;

	my $dbvar = $self->parse_variable_option (
		option => 'dbvar',
		types  => [ 'scalar' ]
	);

	($dbvar = $var) =~ s/^\$/\$db_/ if not $dbvar;

	$self->writef (
		'%s%s = %s->quote(%s);'."\n",
		$my_cmd,
		$dbvar,
		$dbh_code,
		$var
	);

	return $RC;
}

sub cmd_sql {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_BLOCK_TAG;

	my $data;
	if ( $data = $self->get_current_tag_closed ) {
		$self->check_options (
			mandatory => {},
			optional  => {},
		) || return $RC;

		return $RC if $data->{type} eq 'do';

		$self->writef (
			"    }\n".
			'    $_cipp_sth->finish;'."\n".
			'    $CIPP::request->sql_select_finished;'."\n".
			'}'."\n"
		);

		return $RC;
	}

	$self->check_options (
		mandatory => {
			sql => 1
		},
		optional => {
			db 	 => 1,  dbh => 1,     cond => 1,
			var	 => 1,  params => 1,  result => 1,
			throw	 => 1,  maxrows => 1, winstart => 1,
			winsize	 => 1,  my => 1,      profile => 1,
		}
	) || return $RC;

	my $options = $self->get_current_tag_options;

	if ( defined $options->{winstart} ^ defined $options->{winsize} ) {
		$self->add_tag_message (
			message => 'WINSTART without WINSIZE or vice versa.'
		);
		return $RC;
	}

	if ( defined $options->{winstart} and defined $options->{maxrows} ) {
		$self->add_tag_message (
			message => 'Illegal combination of WINSTART and MAXROWS.'
		);
		return $RC;
	}

	my $dbh_code = $self->get_dbh_code;

	my $var_lref = $self->parse_variable_option_list (
		option => 'var',
		types => [ 'scalar' ]
	);

	my $result_var = $self->parse_variable_option (
		option => 'result',
		types => [ 'scalar' ]
	);

	my $sql      = $options->{sql};
	my $throw    = $options->{throw} || "sql";

	my $maxrows  = $options->{maxrows};
	my $winstart = $options->{winstart};
	my $winsize  = $options->{winsize};
	my $my_cmd   = $options->{'my'} ? 'my ' : '';

	$sql =~ s/;\s*$//;
	$sql =~ s/^\s+//;
	$sql =~ s/\s+$//;

	my $params_code = "";
	$params_code = "$options->{params}" if $options->{params};

	my $profile = $options->{profile} || "sql";

	if ( $options->{var} ) {
		# we assume a SELECT statement which is fetching data
		my $var_list = join(",",@{$var_lref});

		# declare variables, if neccessary
		$self->write ( "my ($var_list);\n" ) if $my_cmd;

                # prepare statement
                $self->writef (
                        '{'."\n".
                        '    my $_cipp_sth = $CIPP::request->sql_select ('."\n".
			'        %s, qq{%s}, [%s], qq{%s}, qq{%s}'."\n".
			'    );'."\n".
                        '    $_cipp_sth->execute(%s);'."\n",
                        $dbh_code,
                        $sql,
                        $params_code,
			$throw,
			$profile
                );

                # build list of references for binding fetch data
                # (dynamically extend or shrink list if column count
                #  of the result set doesn't match - for backward
                #  compatability)
                $self->writef (
                        '    my $_cipp_col_cnt  = $_cipp_sth->{NUM_OF_FIELDS};'."\n".
                        '    my @_cipp_col_refs = \(%s);'."\n".
                        '    while ( @_cipp_col_refs < $_cipp_col_cnt ) {'."\n".
                        '        my $_cipp_dummy;'."\n".
                        '        push @_cipp_col_refs, \$_cipp_dummy;'."\n".
                        '    }'."\n".
                        '    splice (@_cipp_col_refs, $_cipp_col_cnt) if @_cipp_col_refs > $_cipp_col_cnt;'."\n",
                        $var_list
                );

                $self->writef (
                        '    $_cipp_sth->bind_columns (undef, @_cipp_col_refs);'."\n".
                        '    my $_cipp_maxrows;'."\n",
                        $throw
                );

		# code for MAXROWS/WINSTART/WINSIZE stuff

		my $maxrows_cond;

		if ( defined $maxrows ) {
			$self->writef (
				'    $_cipp_maxrows = %s;'."\n",
				$maxrows
			);
			$maxrows_cond = '$_cipp_maxrows-- > 0 and';
		}

		my $winstart_cmd;

		if ( defined $winstart ) {
			$self->writef (
				'    $_cipp_maxrows = %s+%s;'."\n".
				'    my $_cipp_winstart = %s;'."\n",
				$winstart,
				$winsize,
				$winstart
			);
			$winstart_cmd = 'next if --$_cipp_winstart > 0;'."\n";
			$maxrows_cond = '--$_cipp_maxrows > 0 and';
		}

		if ( $options->{cond} ) {
			$maxrows_cond .= " ($options->{cond}) and";
		}

		# fetch loop

		$self->writef (
		        '    my $_cipp_utf8 = $CIPP::request->get_utf8;'."\n".
			'    SQL: while ( %s $_cipp_sth->fetch ) {'."\n".
			'        if ( $_cipp_utf8 ) {'."\n".
			'            Encode::_utf8_on($_) for (%s);'."\n".
			'        }'."\n",
			$maxrows_cond,
			$var_list
		);

		$self->write ($winstart_cmd) if $winstart_cmd;

		return $self->RC_BLOCK_TAG (
			type => 'select',
			throw => $throw,
			profile => $profile,
		);

	} else {
		# we assume a do statement without a result set
		my $result_code = "";
		$result_code = "${my_cmd}$result_var = " if $options->{result};

                $self->writef (
                        '%s$CIPP::request->sql_do ('."\n".
			'    %s, qq{%s}, [%s], qq{%s}, qq{%s}'."\n".
			');'."\n",
			$result_code,
                        $dbh_code,
                        $sql,
                        $params_code,
			$throw,
			$profile
                );

		return $self->RC_BLOCK_TAG (
			type  => 'do',
		);
	}
}

sub cmd_incinterface {
	my $self = shift; $self->trace_in;
	my %par = @_;
	my  ($tag, $options, $options_case, $closed) =
	@par{'tag','options','options_case','closed'};

	my $RC = $self->RC_SINGLE_TAG;

	if ( $self->get_object_type ne 'cipp-inc' ) {
		$self->add_tag_message (
			message =>
				"Illegal use of the  ".
				"command. This is not a CIPP Include."
		);
		return $RC;
	}

	if ( $self->get_state->{incinterface}->{input} ) {
		$self->add_tag_message (
			message =>
				"Multiple occurence of ."
		);
		return $RC;
	}

	$self->check_options (
		optional => {
			input		=> 1,
			optional	=> 1,
			output		=> 1,
			noquote		=> 1,
		}
	) or return $RC;

	if ( not defined $options->{input} and
	     not defined $options->{optional} ) {
		$self->get_state->{include_noinput} = 1;
	}

	if ( not defined $options->{output} ) {
		$self->get_state->{include_nooutput} = 1;
	}

	my $input = $self->parse_variable_option_hash (
		option => 'input',
		name2var => 1,
	);
	my $optional = $self->parse_variable_option_hash (
		option => 'optional',
		name2var => 1,
	);
	my $noquote = $self->parse_variable_option_hash (
		option => 'noquote',
		name2var => 1,
	);
	my $output = $self->parse_variable_option_hash (
		option => 'output',
		name2var => 1,
	);

	$self->get_state->{incinterface}->{input}    = $input;
	$self->get_state->{incinterface}->{optional} = $optional;
	$self->get_state->{incinterface}->{noquote}  = $noquote;
	$self->get_state->{incinterface}->{output}   = $output;

	my @unknown;
	foreach my $var ( keys %{$noquote} ) {
		push @unknown, $var if not defined $input->{$var} and
				       not defined $optional->{$var};
	}
	if ( @unknown ) {
		$self->add_tag_message (
			message => "Unknown NOQUOTE variable(s): ".
				   join (", ", @unknown)
		);
	}

	my %double;
	foreach my $var ( keys %{$input}, keys %{$optional} ) {
		$double{$var} = 1 if defined $input->{$var} and
				     defined $optional->{$var};
	}
	if ( %double ) {
		$self->add_tag_message (
			message => "Illegal INPUT and OPTIONAL declared variable(s): ".
				   join (", ", sort keys %double)
		);
	}

	return $RC;
}

sub cmd_include {
	my $self = shift; $self->trace_in;
	my %par = @_;
	my  ($tag, $options, $options_case, $closed) =
	@par{'tag','options','options_case','closed'};

	my $RC = $self->RC_SINGLE_TAG;

	$self->check_options (
		mandatory => { 'name' => 1 },
		optional  => { '*' => 1 },
	) || return $RC;

	my $options = $self->get_current_tag_options;

	my $name = delete $options->{name};
	my $my   = delete $options->{'my'};

	# filter output parameters from $options
	my ($var_output, $var);
	foreach $var ( keys %{$options} ) {
		if ( $var =~ /^[\$\@\%]/ ) {
			# output parameters begin with $, @, % an
			my $var_name = $options->{$var};
			$var_name =~ tr/A-Z/a-z/;
			$var_output->{$var_name} = $var;
			delete $options->{$var};
		}
	}

	# memorize that we use this Include
	$self->add_used_object (
		name => $name,
		type => 'cipp-inc'
	);

	# check filename of Include
	my $filename = $self->get_object_filename ( name => $name );

	if ( not defined $filename ) {
		$self->add_tag_message (
			message => "Include $name not found."
		);
		return $RC;
	}

	if ( not -r $filename ) {
		$self->add_tag_message (
			message =>
				"Include file '$filename' ($name) ".
				"not readable."
		);
		return $RC;
	}

	# first process this Include (cached)
	my $include_parser = $self->create_new_parser (
		object_type    => 'cipp-inc',
		program_name   => $name,
	);

	# check recursive inclusion
	my $norm_name = $include_parser->get_norm_name;
# print "trace=".$self->get_inc_trace." norm_name=$norm_name\n";

	if ( $self->get_inc_trace =~ /:$norm_name:/ ) {
		$self->add_tag_message (
			message =>
				"Illegal recursive inclusion of ".
				"Include '$name' (trace is '".
				$self->get_inc_trace."')",
		);
		return $RC;
	}

	$include_parser->process;

	# copy error messages of this Include into $self
	foreach my $msg ( @{$include_parser->get_messages} ) {
		$self->add_message_object (
			object => $msg
		);
	}

	# check if the actual parameters match the Includes interface
	return $RC if not $self->interface_is_correct (
		include_parser => $include_parser,
		input 	       => $options,
		output	       => $var_output
	);

	# now generate Include subroutine call code
	my $code = '';
	my $interface = $include_parser->read_include_interface_file;

	# get output parameters
	my $output = $var_output;
	if ( $my ) {
		if ( keys %{$output} ) {
			$code .= "my (";
			foreach my $var_name ( values %{$output} ) {
				$code .= "$var_name,";
			}
			$code =~ s/,$//;
			$code .= ");\n";
		}
	}

	# these three files are neccessary for include processing
	my $sub_filename = $self->get_relative_inc_path (
		filename => $include_parser->get_prod_filename
	);

	# call subroutine
	$code .= '$CIPP::request->call_include_subroutine ('."\n";
	$code .= "\tfile         => '$sub_filename',\n";
	$code .= "\tinput        => {\n";

	# input parameters
	my $input = $options;
	my $quote_start;
	my $quote_end;
	my $val;

	foreach my $name ( keys %{$input} ) {
		my $var = $interface->{input}->{$name} ||
		          $interface->{optional}->{$name};
		$var =~ /^(.)/;
		my $type = $1;

		if ( $type eq '$' ) {
		     	# scalar parameter
			$quote_start = defined $interface->{noquote}->{$name}
				? '' : 'qq{';
			$quote_end   = defined $interface->{noquote}->{$name}
				? '' : '}';
			$val = $input->{$name};
			$code .= "\t\t$name => $quote_start$val$quote_end,\n";

		} elsif ( $type eq '@' ) {
			# list parameter
			$code .= "\t\t$name => [ $input->{$name} ],\n";

		} elsif ( $type eq '%' ) {
			# hash parameter
			$code .= "\t\t$name => { $input->{$name} },\n";
		}
	}

	$code .= "\t},\n";

	# tell which output parameters we want
	if ( keys %{$output} ) {
		$code .= "\toutput => {\n";
		my $type;
		foreach my $name ( keys %{$output} ) {
			my $var = $output->{$name};
			$code .= "\t\t\t'$name' => \\$var,\n";
		}
		$code .= "\t\t},\n";
	}

	$code .= ");\n";

	$self->write ( $code );

	return $RC;
}

sub cmd_httpheader {
	my $self = shift; $self->trace_in;
	my %par = @_;
	my  ($tag, $options, $options_case, $closed) =
	@par{'tag','options','options_case','closed'};

	my $RC = $self->RC_BLOCK_TAG;

	if ( $self->get_current_tag_closed ) {
		$self->pop_context;
		$self->writef (
			"\n".
			"  }; # end of generic exception handler eval\n\n".
			'  # check for an exception (filters  exception)'."\n".
			'  if ( $@ and $@ !~ /_cipp_exit_command/ ) {'."\n".
			'      $CIPP::request->error ('."\n".
			'          message    => $@,'."\n".
			'          httpheader => "%s"'."\n".
			'      );'."\n".
			'      die "_cipp_exit_command";'."\n".
			'  } elsif ( $@ ) {'."\n".
			'      die $@;'."\n".
			'  }'."\n\n",
			$self->get_program_name
		);

		$self->write (
			q[  1;]."\n",
			q[};]."\n",
		);

		my $buffer_sref = $self->close_output_buffer;

		$self->check_options (
			mandatory => {},
			optional  => {},
		) || return $RC;

		my $http_filename = $self->get_http_filename;

		return $RC if not $http_filename;

		my $fh = FileHandle->new;
		if ( open ($fh, ">$http_filename") ) {
			print $fh $$buffer_sref;
			close $fh;
		} else {
			$self->add_tag_message (
				message => "Can't write '$http_filename'"
			);
		}

		return $RC;
	}

	# We open the output buffer before error checking,
	# because the closed_tag code above assumes it.
	$self->open_output_buffer;
	$self->push_context('perl');

	# now check for errors
	$self->check_options (
		mandatory => { 'var' => 1 },
		optional  => { 'my'  => 1 },
	) || return $RC;

	my $var = $self->parse_variable_option (
		option => 'var', types => [ 'scalar' ]
	) || return $RC;

	# prevent multiple  instances
	if ( $self->get_state->{http_header_occured} ) {
		$self->add_tag_message (
			message => "Only one  per program allowed.",
		);
		return $RC;
	}

	# only allowed in CGIs and Includes
	if ( $self->get_object_type ne 'cipp' and $self->get_object_type ne 'cipp-inc' ) {
		$self->add_tag_message (
			message => " only allowed inside Programs or Includes",
		);
		return $RC;
	}

	$self->get_state->{http_header_occured} = 1;

	# generate HTTP header code, like an Include subroutine
	$self->writef (
		q[sub {]."\n".
		q[  use strict;]."\n".
		q[  shift;]."\n".
#		q[  my $_cipp_line_nr;]."\n".
		q[  my %s = $CIPP::request->get_http_header;]."\n".
		q[  eval {]."\n",
		$var
	);

	return $RC;
}

sub cmd_lang {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_BLOCK_TAG;

        if ( $self->get_current_tag_closed ) {
            $self->pop_context;
            $self->write("^)");
            $self->write(";\n") if $self->context eq 'perl';
            return $RC;
        }

	$self->check_options (
		mandatory => {},
		optional  => {},
	) || return $RC;

        $self->push_context('var_noquote');

        $self->write("CIPP->request->set_locale_messages_lang(qq^");

        return $RC;
}

sub cmd_l {
	my $self = shift; $self->trace_in;

	my $RC = $self->RC_BLOCK_TAG;

	if ( $self->get_current_tag_closed ) {
		$self->check_options (
			mandatory => {},
			optional  => {},
		) || return $RC;

		my $buffer_sref      = $self->close_output_buffer;
		my (undef, $options) = $self->pop_context;
		my $context          = $self->context;

                ${$buffer_sref} =~ s/^\s+//gm;
                ${$buffer_sref} =~ s/\s*$/ /gm;
                ${$buffer_sref} =~ s/\s+$//s;
		${$buffer_sref} =~ s/\^/\\^/g;
                ${$buffer_sref} =~ s/\s+/ /gs;

		$options ||= {};

		$self->write("print ") if $context ne 'perl' &&
				          $context !~ /^var/;
		$self->write("^.")     if $context eq 'var_quote';

                my $domain = $self->get_text_domain;

		if ( $options and keys %{$options} ) {
			my $options_hash = "{ ";
			while ( my ($k,$v) = each %{$options} ) {
				$v =~ s/\^/\\^/g;
				$options_hash .= "'$k' => qq^$v^, ";
			}
			$options_hash .= "}";
			$self->writef (
				qq[\$CIPP::request->dgettext("$domain",qq^%s^, $options_hash)],
				${$buffer_sref}
			);
		} else {
			$self->writef (
				qq[\$CIPP::request->dgettext("$domain",qq^%s^)],
				${$buffer_sref}
			);
		}

		$self->write(";\n") if $context ne 'perl' &&
				       $context !~ /^var/;
		$self->write(".qq^") if $context eq 'var_quote';

		return $RC;
	}

	$self->open_output_buffer;

	my %data;
	my $options_case = $self->get_current_tag_options_case;
	my $options      = $self->get_current_tag_options;

	foreach my $opt ( keys %{$options_case} ) {
		$data{$options_case->{$opt}} = $options->{$opt};
	}

	$self->push_context('var_noquote', \%data);

	return $RC;

}

1;