#!/usr/local/bin/perl
#
# (c) 1998, 1999 das buero am draht (mfx@dasburo.com)
#
# version 1.13
#

# file i/o
#
# write_file(string, "filename") -> bool_ok
# copy_file("filename_in", "filename_out", substitutions) -> bool_ok
# read_file("filename") -> string / "" (==false)
#
#---------------------------------------------------------------------------
# string substitution
#
# substitute(string, substitutions) -> string 
# remove_end_spaces (string) -> string --- removes initial and trailing spaces
# dequote(string) -> string            --- removes initial and trailing quotes ("')
# tolower(string) -> string            --- 7bit-tolower
# toupper(string) -> string            --- 7bit-toupper
# tohtml (string) -> string            --- 8bit -> 7bit-Ü    (both iso and mac)
# toplain(string) -> string            --- 8ibt -> 7bit-Ue        (both iso and mac)
# quotehtml(string)->string            --- quote html < > & tags
#
#---------------------------------------------------------------------------
#
# set_default_selection: formname string -> string
#    benoetigt CGI.pm, bz.w die funktion param(formname)->value
#    ersetzt SELECTED_formname_value durch SELECTED formname_value
#
#---------------------------------------------------------------------------
#
# parse_params: string -> hashref
#
#---------------------------------------------------------------------------
# 
# 0.95: browser detection
#
# searchBrowserDB ( user_agent()) -> list of "standard" names
# mightBeBot( user_agent()) ) -> bool
# getVersion( user_agent()) ) -> version/0
# hasFrames( user_agent()) ) -> bool
# 
# isNetscape( user_agent()) , version ) -> is netscape of at least that version
# isMSIE( user_agent()) , version ) -> is internet explorer of at least that version
# (+ convenience functions of that name for most other browsers)
# 
#---------------------------------------------------------------------------
# 0.96:
#
# parse_html_file: filename -> html_parse_tree
# print_html_tree: html_parse_tree -> () --- prints the tree as a nested structure
# exec_html_tree: html_parse_tree -> ()  --- executes the tree
#
# 0.97: rolling your own tags
#
# add_html_tag: tag, handle-to-sub -> () --- adds a method to handle a new tag
#
# env_get: env, name -> val
# env_set: env, name, val -> ()
# env_new_scope: env -> env
# env_print: env -> () 
#
# eval_expr: expr, env -> val
# eval_arg: expr, env, default -> val
# get_params: html_parse_tree -> bag-of-params
# get_param: name, body, env -> html_parse_tree
#
# action_nop
# action_kill
# action_if
# action_proto
# action_use
# action_loop
# action_substitute
# action_include
# action_print_self
#
# 0.98
#
# add_html_tag_no_body: tag, handle-to-sub -> () --- adds a method to handle a new tag
# apply_html_tree: tree, fn -> ()
#
# 0.99
#
# read_config_file: filename -> (ref-to-root-hash, ref-to-hash)
#       reads a config file with # comments, a=b syntax, [sections]
#
# 1.0
#
# is_singleton_tag
#
# 1.01
# 
# compile_expr
# disable_all_tags
# 
# 1.02
#
# add_standard_tags
# kommentare und sgml-kommandos jetzt hoffentlich richtig
#
# 1.03
# 
# set_print_callback -- print-cb fuer exec_html_tree
#
# 1.04
#
# read_config: filename... -> ok
#       reads a config file with, cashes the values. reads the first it finds
# get_config : key, section -> value/undef
#       accesses the values from the last read_config
#       (get_config key == get_config key '' == read from main section)
#
# parse_html_file_from_string: string, filename -> tree
#
# 1.05 bugfix-release
#
# - set_print_callback liefert jetzt den alten wert zurueck
# - write_file schliesst jetzt den file descriptor
#
# 1.06
# 
# - std_print prints via std_print_callback
# - read_config_file1: filename --> (ref-to-hash)
#
# 1.10
#
# - Timer::new(), Timer::reset(), Timer::get()
# - concat_paths: string.... -> string
# - concat_hash: ref-to-hash-1 ref-to-hash-2 -> ref-to-hash-1
#      and adds hash-2 to hash-1
#
# 1.11
#
# - action_include_http
#   auf speziellen wunsch von henry
# 
# 1.12
#
# - refkeys
#   weil das arbeiten mit "%" in templates so nervt
#
# 1.13
#
# - quotehtml_counted (text, [farbe der zeilennummern=green], [breite der zeilennummern=3]
#   erzeugt einen <pre>-block, der zeilennummern enthält
#
# - dbad_style
#   (fabian zuliebe) damit man endlich ohne grossen aufwand DBAD-konforme seiten bauen kann
#
#
#
#---------------------------------------------------------------------------

# perl package magic -- currently not needed
#
package DBAD;
use Exporter();

@ISA = qw(Exporter);
@EXPORT = 
	qw( 
	   needs_bad_version do_show_errors
	   write_file copy_file read_file 
	   substitute remove_end_spaces tolower toupper
	   quotehtml dequote tohtml toplain tolatin1
	   parse_html_file print_html_tree exec_html_tree
	   env_get env_set env_new_scope env_print
	   eval_expr eval_arg
	   action_nop action_kill 
	   action_proto action_use 
	   action_if action_loop action_substitute 
	   action_include
	   action_print_self
	   action_print_self_no_body
	   add_html_tag
	   add_html_tag_no_body
	   read_config_file
	   is_singleton_tag
	   compile_expr
	   disable_all_tags
	   set_print_callback
	   read_config
	   get_config
	   parse_html_file_from_string
	   std_print
	   read_config_file1
	   concat_paths
	   concat_hash
	   refkeys
	   quotehtml_counted
	   dbad_style
	   );
@EXPORT_OK = qw ( );

my $VERSION = 1.13;
my $show_errors = 1;

sub needs_bad_version {
	my ($required_version) = @_;
	if($required_version > $VERSION){
		print "\n<b><font color=red>";
		print "B&uuml;ro-am-Draht Perl library (<tt>bad.pm</tt>) version $required_version required -- version $VERSION present";
		print "</font></b>\n"; 
		die "library too old";
	}
}

sub do_show_errors {
	($show_errors) = @_;		# enable/disable errors
}

sub prot_error {
	if($show_errors){
		# print "Content-type: text/html\n\n";
		print "<br><b><font color=red>";
		print @_;
		print "</font></b><br>\n";
	}
	return "";
}

#
#
#

sub substitute {
	my ($data, $substitutions) = @_;
	if($substitutions){
		%subst = %{$substitutions};
		foreach $key (keys %subst) {
			$value = $subst{$key};
			$data =~ s/$key/$value/g;	# was: s/\$$key/$value/g;
		}
	}
	return $data;
}

sub copy_file {
	my ($infile, $outfile, $substitutions) = @_;
	my $data = read_file($infile) || return 0;
	if($substitutions){
		$data = substitute($data, $substitutions);
	}
	return write_file($data, $outfile);
}

sub read_file {
	my ($filename) = @_;
	my $data;
	$_read_file_count ++;
	if(open(DATEN, "<$filename")){
		undef $/;
		$data = <DATEN>;				# snarf in the whole file
		$/ = "\n";
		close(DATEN);
		return $data;
	} else {
		prot_error ("Konnte Datei $filename nicht einlesen: $!\n");
		return 0;
	}
}

sub write_file {
	my ($data, $filename) = @_;
	$_write_file_count ++;
	if(open(DATEN, ">$filename")){
		print DATEN $data;
		close DATEN;
		return 1;
	} else {
		prot_error ("Konnte Datei $filename nicht schreiben: $!\n");
		return 0;
	}
}

sub remove_end_spaces {
	my ($x) = @_;
	if(!defined $x){
		return $x;
	}
	if($x =~ /\A\s+(.*)\Z/){ $x = $1; }
	if($x =~ /\A(.*\S)\s+\Z/){ $x = $1; }
	return $x;
}

sub dequote {
	my ($x) = @_;
	$x =~ s/(^\")(.*)(\"$)/$2/;
	$x =~ s/(^\')(.*)(\'$)/$2/;
	return $x;
}
	
sub tolower {
	my ($x) = @_;
	if(defined $x){
		$x =~ tr/A-Z/a-z/;
	}
	return $x;
}

sub toupper {
	my ($x) = @_;
	if(defined $x){
		$x =~ tr/a-z/A-Z/;
	}
	return $x;
}

sub tolatin1 {
	my ($x, $iso_ok) = @_;
	if($x){
		# mac
		$x =~ s/\x8a/\xe4/g;
		$x =~ s/\x9a/\xf6/g;
		$x =~ s/\x9f/\xfc/g;
		$x =~ s/\x80/\xc4/g;
		$x =~ s/\x85/\xd6/g;
		$x =~ s/\x86/\xdc/g;
		$x =~ s/\xd0/&#151;/g;	# langer strich??
		$x =~ s/\xd1/&#150;/g;	# langer strich?? ja !!
		$x =~ s/\xca/&nbsp;/g;
		$x =~ s/\xa7/&szlig;/g;	
		$x =~ s/\xd0/-/g;	# langer strich??
		$x =~ s/\xa8/&reg;/g;
	}
	return $x;
}

sub tohtml {
	my ($x, $iso_ok) = @_;
	if($x){
		if(! $iso_ok){
			# iso-latin-1
			$x =~ s/\xe4/&auml;/g;
			$x =~ s/\xf6/&ouml;/g;
			$x =~ s/\xfc/&uuml;/g;
			$x =~ s/\xc4/&Auml;/g;
			$x =~ s/\xd6/&Ouml;/g;
			$x =~ s/\xdc/&Uuml;/g;
			$x =~ s/\xdf/&szlig;/g;
			$x =~ s/\xa9/&copy;/g; #same as mac
			$x =~ s/\xae/&reg;/g;
		}
		# mac
		$x =~ s/\x8a/&auml;/g;
		$x =~ s/\x9a/&ouml;/g;
		$x =~ s/\x9f/&uuml;/g;
		$x =~ s/\x80/&Auml;/g;
		$x =~ s/\x85/&Ouml;/g;
		$x =~ s/\x86/&Uuml;/g;
		$x =~ s/\xd0/&#151;/g;	# langer strich??
		$x =~ s/\xd1/&#150;/g;	# langer strich?? ja !!
		$x =~ s/\xca/&nbsp;/g;
		$x =~ s/\xa7/&szlig;/g;	
		$x =~ s/\xd0/-/g;	# langer strich??
		$x =~ s/\xa8/&reg;/g;
	}
	return $x;
}

sub toplain {
	my ($x) = @_;
	if($x){
		$x =~ s/ /_/g;

		# iso-latin-1
		$x =~ s/\xe4/ae/g;
		$x =~ s/\xf6/oe/g;
		$x =~ s/\xfc/ue/g;
		$x =~ s/\xc4/Ae/g;
		$x =~ s/\xd6/Oe/g;
		$x =~ s/\xdc/Ue/g;
		$x =~ s/\xdf/ss/g;
		$x =~ s/\xa9/(C)/g; #same as mac
		$x =~ s/\xae/(R)/g;
		
		# html
		$x =~ s/&szlig;/ss/g;
		$x =~ s/&auml;/ae/g;
		$x =~ s/&ouml;/oe/g;
		$x =~ s/&uuml;/ue/g;
		$x =~ s/&Auml;/Ae/g;
		$x =~ s/&Ouml;/Oe/g;
		$x =~ s/&Uuml;/Ue/g;
		$x =~ s/&copy;/(C)/g;
		$x =~ s/&reg;/(R)/g;

		# mac
		$x =~ s/\x8a/ae/g;
		$x =~ s/\x9a/oe/g;
		$x =~ s/\x9f/ue/g;
		$x =~ s/\x80/Ae/g;
		$x =~ s/\x85/Oe/g;
		$x =~ s/\x86/Ue/g;
		$x =~ s/\xa7/sz/g;	
		$x =~ s/\xa8/(R)/g;	
		$x =~ s/d0/_/g;	# langer strich??
	}
	return $x;
}

sub quotehtml {
	my ($x) = @_;
	if(defined $x){
		$x =~ s/&/&amp;/g;
		$x =~ s/</&lt;/g;
		$x =~ s/>/&gt;/g;
	}
	return $x;
}

sub quotehtml_counted {
	my ($data, $color, $width) = @_;
	$color ||= "green";
	$width ||= 3;
	my $acc = "<pre>";
	my $cnt=1;
	foreach $line (split(/\n/,quotehtml($data))){
		$acc .= "<font color=$color>". sprintf("%$width"."d", $cnt). "</font> $line\n";
		$cnt++;
	}
	$acc .= "</pre>";
	return $acc;
}


# debug-ausgabe fuer replace_tags

my $debuglevel = 0;
sub debug {
#	print ' ' x $debuglevel, @_, "\n";
}

# parse_params: string -> (hashref, string')
# string: eine html-tag-paramlist foo="bar" lala=lolo lolo='7+3'
# hashref: { "foo" => "bar","lala"=>"lolo" ,.... }
# string': alles nach dem schliessenden >

sub parse_params {
	my ($params) = @_;
	my %params = ();
  LOOP:
	while($params){
		if($params =~ /\A\s*>(.*)/s){
			#debug_print "\n<!-- params finished with rest $1 -->";
			return (\%params, $1);
		}
		if($params =~ /([^>=\s]+)\s*(.*)/s){
			my $key = "\L$1";
			$params = $2;
			if($params =~ /\A=\s*(.*)/s){
				# param = value
				$params = $1;
				if($params =~ /\A'([^']*)'(.*)/s){
			       #debug_print "\n<!-- single quote param: $key = $1 -->";
    			   $params{$key} = $1;
                   $params = $2;
                   next LOOP;
                }
				if($params =~ /\A"([^"]*)"(.*)/s){
			       #debug_print "\n<!-- double quote param: $key = $1 -->";
    			   $params{$key} = $1;
                   $params = $2;
                   next LOOP;
                }
				if($params =~ /([^>\s]+)(.*)/s){
			       #debug_print "\n<!-- unquoted param: $key = $1 -->";
    			   $params{$key} = $1;
                   $params = $2;
                   next LOOP;
                }
			} else {
				# param as keyword
				#debug_print "\n<!-- keyword param: $key -->";
				$params{$key} = $key;
			}
		} else {
		    #debug_print "\n<!-- params unparsed: $params -->";
			return (\%params, $params);
		}
	}
    #debug_print "\n<!-- params dropped off -->";
	return (\%params, $params);
}


sub set_default_selection {
	my ($form, $string) = @_;
	my $last = param($form);
	return substitute($string, {
		"SELECTED $form" => "SELECTED_$form",
		"SELECTED_$form" . "_$last" => "SELECTED $form" . "_$last",		
	});
}

#
# browser version support
#

my %knownBrowsers = 
	(
	 "MSIE" => "MSIE",
	 "Lynx" => "Lynx",
	 "AOL"  => "AOL",
	 "MSN"  => "MSN",
	 "Cyberdog" => "Cyberdog",
	 "HotJava"  => "HotJava",
	 "FrontPage"=> "FrontPage",
	 "OmniWeb"  => "OmniWeb",
	 "Mosaic"   => "Mosaic",
	 "Netscape" => "Mozilla"
	 );

sub searchBrowserDB {
	my $v = shift @_ || user_agent();

	my @results;
	foreach $key (keys %knownBrowsers){
		my $pat = $knownBrowsers{$key};
		if($v =~ $pat){
			push @results, $key;
			push @versions, $1;
			$n ++;
		}
	}
	return @results;
}

sub getVersion {
	my $v = shift @_;
	my $fullname = shift @_ || user_agent();
	
	my $pat = $knownBrowsers{$v};
	if($fullname =~ /$pat[\/]([\d.]*)/){
		return $1;
	}
	return 0;
}

my %hasFramesTable =
	(
	 "Netscape" => 2.0,
	 "MSIE" => 3.0
	 );

sub hasFrames {
	my $v = shift @_;

	my @names = searchBrowserDB($v);
	
	while(@names){
		my $r = shift @names;
		my $v = getVersion($r);
		my $fb = $hasFramesTable{$r};
		if($fb){
			if($v >= $fb) {
				return 1;
			}
		}
	}
	return 0;
}

sub mightBeBot {
	my $v = shift @_ || user_agent();
	if($v =~ /bot/i || 
	   $v =~ /crawl/i || 
	   $v =~ /checker/i || 
	   $v =~ /fetcher/i || 
	   $v =~ /ferret/i || 
	   $v =~ /squid/i || 
	   $v =~ /sucker/i || 
	   $v =~ /wget/i || 
	   $v =~ /libww-perl/i || 
	   $v =~ /arachnl/i || 
	   $v =~ /spider/i){
		return 1;
	}
	return 0;
}

#
# "old" convenience functions
#

sub isNetscape {
	my $v = shift @_ || user_agent();
	my $n = shift @_ || 0;
	if($v =~ /Mozilla\/([\d.]*)/){
		# gesehene formen:
		# 3.0.1
		# 3.01
		# 4.0p1
		if($1 >= $n) { return $1; }
	}
	return 0;
}

sub isMSIE {
	my $v = shift @_ || user_agent();
	my $n = shift @_ || 0;
	if($v =~ /MSIE ([\d.]*)/){
		if($1 >= $n) { return $1; }
	}
	return 0;
}

sub isLynx {
	my $v = shift @_ || user_agent();
	my $n = shift @_ || 0;
	if($v =~ /Lynx\/([\d.]*)/){
		if($1 >= $n) { return $1; }
	}
	return 0;
}

sub isAOL {
	my $v = shift @_ || user_agent();
	my $n = shift @_ || 0;
	if($v =~ /AOL ([\d.]*)/){
		if($1 >= $n) { return $1; }
	}
	return 0;
}

sub isMSN {
	my $v = shift @_ || user_agent();
	my $n = shift @_ || 0;
	if($v =~ /MSN ([\d.]*)/){
		if($1 >= $n) { return $1; }
	}
	return 0;
}

sub isCyberdog {
	my $v = shift @_ || user_agent();
	my $n = shift @_ || 0;
	if($v =~ /Cyberdog\/([\d.]*)/){
		if($1 >= $n) { return $1; }
	}
	return 0;
}

sub isHotJava {
	my $v = shift @_ || user_agent();
	my $n = shift @_ || 0;
	if($v =~ /HotJava\/([\d.]*)/){
		if($1 >= $n) { return $1; }
	}
	return 0;
}

sub isFrontPage {
	my $v = shift @_ || user_agent();
	my $n = shift @_ || 0;
	if($v =~ /MSFrontPage\/([\d.]*)/){
		if($1 >= $n) { return $1; }
	}
	return 0;
}

sub isOmniWeb {
	my $v = shift @_ || user_agent();
	my $n = shift @_ || 0;
	if($v =~ /OmniWeb\/([\d.]*)/){
		# OmniWeb/2.7-beta-3 OWF/1.0
		if($1 >= $n) { return $1; }
	}
	return 0;
}

sub isMosaic {
	my $v = shift @_ || user_agent();
	my $n = shift @_ || 0;
	if($v =~ /Mosaic\/[v]([\d.]*)/){
		# SPRY_Mosaic/v8.32 (Windows 16-bit) SPRY_package/v4.00
		if($1 >= $n) { return $1; }
	}
	return 0;
}

sub isMac {
	my $v = shift @_ || user_agent();
	return ($v =~ /macintosh/i);
}

sub isWin95 {
	my $v = shift @_ || user_agent();
	return ($v =~ /Win95/i);
}

sub isWin16 {
	my $v = shift @_ || user_agent();
	return ($v =~ /Win16/i);
}

sub isWin32 {
	my $v = shift @_ || user_agent();
	return ($v =~ /Win16/i);
}

sub isWinNT {
	my $v = shift @_ || user_agent();
	return ($v =~ /WinNT/i);
}

sub isWindows {
	my $v = shift @_ || user_agent();
	return isWin16($v) || isWin32($v) || isWin95($v) || isWinNT($v);
}

sub isX11 {
	my $v = shift @_ || user_agent();
	return ($v =~ /X11/i);
}

sub isLinux {
	my $v = shift @_ || user_agent();
	return ($v =~ /Linux/i);
}

sub isSunOS {
	my $v = shift @_ || user_agent();
	return ($v =~ /SunOS/i);
}

sub isIRIX {
	my $v = shift @_ || user_agent();
	return ($v =~ /IRIX/i);
}

sub isStandardBrowser {
	my $v = shift @_ || user_agent();
	return ( isNetscape($v) || isMSIE($v) );
}

#
# new, expanded html tag tree parsing
#

my %parse_elements = 
	(
	 'proto'   => \&action_proto,
	 'use'     => \&action_use,
	 'param'   => \&action_kill,
	 'kill'    => \&action_kill,
	 'loop'    => \&action_loop,
	 'ins'     => \&action_substitute,
	 'include' => \&action_include,
	 'include_http' => \&action_include_http,
	 'if'      => \&action_if,
	 'switch'  => \&action_switch,
	 'for'     => \&action_for,
	 'foreach' => \&action_foreach,
	 'perl'    => \&action_eval_body,
	 );

my %parse_elements_verbatim = 
	(
	 'perl'    => \&action_eval_body,
	 );

my %parse_elements_no_body = 
	(
	 'eval'    => \&action_eval,
	 );

my $generate_debug_output =0;
my $generate_idempotencies=0;

sub disable_all_tags {
	%parse_elements = ();
	%parse_elements_verbatim = ();
	%parse_elements_no_body = ();
}

sub is_singleton_tag {
	my ($x) = @_;
	return defined($parse_elements_no_body{$x});
}
sub add_html_tag {
	my $name = shift @_;
	my $handler = shift @_ || \&action_print_self;
	$parse_elements{tolower($name)} = $handler;
}

sub add_html_tag_no_body {
	my $name = shift @_;
	my $handler = shift @_ || \&action_print_self_no_body;
	if($handler eq \&action_print_self){
		$handler = \&action_print_self_no_body
	}
	$parse_elements_no_body{tolower($name)} = $handler;
}

sub add_standard_html_tags { 
	my @standard_tags = 
		(
		 'head','body', 'html', 
		 'script', 'noscript', 
		 'div', 'center', 'font', 'applet', 'map', 'span', 'layer',
		 'h1', 'h2', 'h3', 'h4', 'h5', 'h6', 
		 'form', 'select', 'textarea', 
		 'ul', 'ol', 'dl', 
		 'pre',  'blockquote', 'dir', 'menu', 'xmp', 'listing', 'plaintext', 
		 'table',
		 'caption', 
		 'b', 'i', 'tt', 'u', 'strike', 'em', 'strong', 
		 'dfn', 'code', 'samp', 'kbd', 'var', 'cite', 
		 'big', 'small', 'sub', 'sup', 
		 'a',
		 );

	foreach $x (@standard_tags){
		add_html_tag($x, \&action_print_self);
	}

	my @nobody_tags = ('input','option','img','basefont','br','li','dl','dd','dt');

	foreach $x (@nobody_tags){
		add_html_tag_no_body($x, \&action_print_self);
	}
}

sub debug_print {
	if($generate_debug_output){
		print @_;
	}
}
sub idem_print {
	if($generate_idempotencies){
		print @_;
	}
}

my $current_line_number;

sub count_newlines {
	my ($head) = @_;
	my $n=0;
	while ($head =~ m/[\r\n]|\r|\n/g){
		$n++;
	}
	return $n;
}

my $print_self_tag = 'P';
my $current_file ;

sub parse_html_file_from_string {
	my ($file, $filename) = @_;
	
	$current_file = ($filename || '');

	# $file =~ s/\s+/ /g;	
	# $file =~ s/\n/ /g;	
#	if(! $leave_comments){
#		$file =~ s/<!--.*?-->//gs;
#	}
	my @raw = split '<', $file;
	my $head= shift @raw;

#	$current_line_number = count_newlines ($head);
	my @actions = ( [$print_self_tag, $head ] );
	my ($end, $actions, $inputs) = parse_tree ('', \@actions, \@raw);
	return $actions;
}

sub parse_html_file {
	my ($filename,$leave_comments) = @_;
	my $file = read_file($filename) || return undef;

	return parse_html_file_from_string ($file, $filename);
}

sub parse_tree {			# endtag, acc-list, input-list -> parsed-endtag, modified-acc, modified-input
	my ($endtag, $acc, $input) = @_;	

  TAG:
	while (@$input) {
		my $start_line = $current_line_number;
		my $x = shift @$input;
		
		while(@$input && $input->[0] =~ /\A[^\/a-zA-Z]/){
			$x .= '<' . shift @$input;
		}

		if($x =~ /\A!(.*)/s){	# --------------- COMMENT HANDLING -----------------
			# <! starts an sgml declaration, usually a comment, with its very own rules
			my $text = '<!';
			$x = $1;
		  LOOP:
			if($x =~ /\A([^>]*?--)(.*)\E/s){
				# eat comment
				$text .= $1;
				$x = $2;
			  ENDCOMMENT:
			    if($x =~ /\A(.*?--)(>.*)\E/s){
					$text .= $1;
					$x = $2;
					goto LOOP;
				} else {
					if(@$input == 0){
						warn "end of input in parse comment/1 (file $current_file, text=$text, x=$x)\n";
						return (undef, $acc, []);
					}
					$x .= '<' . shift @$input;
					goto ENDCOMMENT;
				}
			}
			if($x =~ /([^>]*)>(.*)/s){
				$text .= $1 . ">" . $2;
#				$current_line_number += count_newlines ($text);
				push @$acc, ( [$print_self_tag, $text ] );
				next TAG;
			}
			if(@$input == 0){
				warn "end of input in parse comment/2 (file $current_file)\n";
				return (undef, $acc, []);
			}
			$x .= '<' . shift @$input;
			next LOOP;
		}						# --------------- END COMMENT HANDLING -----------------

#		$current_line_number += count_newlines ($x);

		if($x =~ /\A(\s*[^\s>=]+)(.*)/s){
			my $tag = "\L$1"; # schneller als tolower($1);
			my ($params, $rest) = parse_params($2);
#			$params->{'_line'} = $current_line_number;

			if ($tag eq $endtag){       #--------------------------- end-recursion tag
				# finished!
				return ($x, $acc, $input);
			}			
			if (defined $parse_elements{$tag}) {#--------------------------- matched tags
				# recurse!
				my $body = [];
				if($rest ne ''){
					push @$body, [$print_self_tag, $rest, undef];
				}
				my ($end2, $acc2, $input2) = parse_tree ( "/$tag", $body, $input);
				if(defined $end2){
					# ok, there was a matching end tag
					push @$acc, [ $tag, $acc2, $params ];
					if($end2 =~ /[^>]>(.*)/s){
						if($1 ne ''){
							push @$acc, [ $print_self_tag, $1];
						}
					}
				} else {
					# end-tag not found!
					prot_error ("(File $current_file) End-Tag $tag nicht gefunden!");
					push @$acc, [ $tag, [], $params ];
					# we have parsed everything up to the end of the file - append it to the acc
					push @$acc, @$acc2;
				}
				$input = $input2;
				next TAG;
			}			
			if (defined $parse_elements_no_body{$tag}) {#--------------------------- unmatched tags
				push @$acc, [$tag, [], $params];
				push @$acc, [$print_self_tag, $rest];
				next TAG;
			}
			#--------------------------- ordinary text
			my $last = scalar(@$acc);
			# $x =~ s/> />\n/;
			if($last>0 && $acc->[$last-1]->[0] eq $print_self_tag){
				$acc->[$last-1]->[1] .= '<' . $x;
			} else {
				push @$acc, [ $print_self_tag, '<' . $x ];
			}
		} else {
			print "ERROR: DID NOT MATCH >>>$x<<<\n";
		}
	}
	return (undef, $acc, []);
}


sub print_html_tree {
	my ($actions, $indent, $quote) = @_;
	$indent ||= 0;
	$quote ||= 0;

	foreach $action (@$actions) {
		my ($tag, $body, $params) = @$action;
		print ' ' x $indent;
		$body =~ s/\n/\\n/g;
		$body =~ s/\r/\\r/g;
		$body =~ s/\t/\\t/g;
		if( $tag eq $print_self_tag){
			if($body =~ /\A\s*\Z/){
				print "PRINT '";
				if($quote){ 
					print quotehtml($body);
				} else {
					print $body;
				}
				print "'\n";
			} else {
				print "PRINT ";
				if($quote){ 
					print quotehtml($body);
				} else {
					print $body;
				}
				print "\n";
			}
		} else {
			print 'TAG= ';
			if($quote){
				print "<b>",toupper($tag),"</b>";
			} else {
				print toupper($tag);
			}
			print ' ' x $indent;
			if(keys %$params){
				print "\n", ' ' x $indent, "PARAMS= \n";
			}
			foreach $k (keys %$params){
				my $v = $params->{$k};
				if(!defined $v){
					$v = '';
				}
				print ' ' x $indent;
				print "  $k='";  
				if($quote){ 
					print quotehtml($v);
				} else {
					print $v;
				}

			};
			print "'\n";
			print_html_tree($body, $indent + 4,$quote);
		}
	}
}

#
# scoped environment
#

sub env_get {
	my ($env, $var) = @_;
	foreach $e (@$env) {
		if(defined $e->{$var}){
			return $e->{$var};
		}
	}
	return undef;
}

sub env_set {
	my ($env, $var, $val, $anyscope) = @_;
	if($anyscope){
		foreach $e (@$env) {
			if(defined $e->{$var}){
				$e->{$var} = $val;
			}
		}
	} else {
		$env->[0]->{$var} = $val;
	}
}

sub env_new_scope {
	my ($env) = @_;
	return [ {}, @$env];
}

sub env_print {
	my ($env) = @_;
	foreach $e (@$env) {
		print "{";
		foreach $k (keys %$e) {
			print $k, '=>', %$e->{$k}, ' ';
		}
		print "}";
	}
}

#
# html action machinery
#


sub std_print_callback {
	print @_;
}
my $print_cb = \&std_print_callback;

sub set_print_callback {
	my ($cb) = @_;
	my $old = $print_cb;
	$print_cb = $cb;
	return $old;
}

sub std_print{
	&$print_cb;
}

sub eval_expr {
	my ($expr, $env, $writeback) = @_;
	my $r = undef;
	my %locals;

	if(!($expr =~ /\W/)){
								# praktische abkuerzung, die das quoten um einfache woerter sparen soll
		return $expr;
	}

	while( $expr =~ /%(\w+)/){
		my $key = $1;
		my $val = env_get($env, $key);
		$locals{$key} = $val;
		$expr =~ s/%$key/\$locals{'$key'}/g;
	}
	$expr =~ s/%#(\w+)/%$1/g;
	# print "\n<!-- evaluating $expr -->";
	{
		$r = eval($expr);
	}
	if($@ ne ''){
		prot_error ("Error in eval('<font color=black><tt>$expr</tt></font>'): $@");
	}
	if($writeback){
		foreach $key (keys %locals){
			env_set($env, $key, $locals{$key}, 1);
		}
	}
	return $r;
}

sub compile_expr {
	my ($expr) = @_;
	# print "<!-- compiling expr '$expr' -->\n";
	my $sub = q {
		my ($env, $writeback) = @_;
		my $r = undef;
		my %locals;
	};
	my %locals;
	while( $expr =~ /%([a-zA-Z_]\w*)/){
		my $key = $1;
		$locals{$key} = 1;

		$sub .= "\$locals{'$key'} = env_get(\$env, '$key');\n";
	    $expr =~ s/%$key/\$locals{'$key'}/g;
	}
	$expr =~ s/%#(\w+)/%$1/g;
    $sub .= "\$ret = $expr;\n";
	$sub .= "if(\$writeback){";	

	foreach $key (keys %locals){
		$sub .= "env_set(\$env, '$key', \$locals{'$key'}, 1);\n";
	}
	$sub .= "} return \$ret;";
	# print "<!-- compiled function: sub { $sub\n} -->\n";
	my $x = eval "sub { $sub }";
	if($@ ne ''){
		prot_error ("Error in eval('<font color=black><tt>$expr</tt></font>'): $@");
		return sub { return ''};
	}
	return $x;
}

sub eval_arg {
	my ($expr, $env, $default) = @_;
	if(! defined $expr){
		return $default;
	}
								# shortcut: simple number
	if($expr =~ /\A\d+\Z/){
		return $expr;
	}
								# shortcut: simple variable
	if($expr =~ /\A%(\w+)\Z/){
		return env_get($env, $1);		
	}

	return eval_expr($expr, $env);
}

sub get_params {
	my ($body) = @_;
	my %params;
	foreach $action (@$body){
		my ($tag, $body, $args) = @$action;
		if($tag eq 'param'){
			my $name = $args->{'name'};
			if(defined $name){
				$params{$name} = $body;
			}
		}
	}
	return \%params;
}

sub get_param {
	my ($name, $body, $env) = @_;
    my $params = get_params($body);
	my $p = $params->{$name};
	if(! defined $p){
		$p = env_get($env, "param:$name");
	}
	return $p;
}

sub action_nop {
	my ($action, $env) = @_;
	my ($tag, $body, $args) = @$action;

	exec_html_tree($body, $env);
}

sub tag_and_params_to_string {
	my ($tag, $args) = @_;
	
	my $s = "<$tag";
  PARAM:
	while(my ($key, $val) = each %$args){
		if($key =~ /^_/){ 
			next PARAM;  # intern generierter key
		}
		if($val =~ /[^a-zA-Z0-9]/ || $val eq '' ){		# contains things that might need quoting
			if($val =~ /"/){ # "
			   $s .= (" $key" . "='" . $val . "'");
		   } else {
			   $s .= (" $key" . '="' . $val . '"');
		   }
			next PARAM;
		}
		if($key eq $val){
			$s .= " $key";
			next PARAM;
		}
		$s .= " ".$key."=".$val;
	}
	$s .= ">";
	return $s;
}

sub compute_args {
	my ($args, $env) = @_;
	my %args;
LOOP:	
	while (my ($arg, $expr) = each %$args) {
		if(!defined $expr){
			next LOOP;
		}
		if($arg !~ /\?/){	# shortcut
			$args{$arg} = $expr;
			next LOOP;
		}
		if ($arg =~ /\A\?(.*)\Z/){
			my $key = $1;
#---------------------------------------------------------------------------
# compilation bringt sichtbare ergebnisse; nur beim profilen stoerts etwas
			if(0){ # no compilation
				my $x = eval_expr($expr, $env);
				$args{$key} = $x;
				next LOOP;
			}
#---------------------------------------------------------------------------
			
			if ($arg =~ /\A\?\?(.*)\Z/){
				my $key = $1;
				
				my $val = &$expr($env);
				# print "<!-- computed arg '$key' value '$val' -->\n";
				if(defined ($val) && $val ne ''){
					$args{$key} = $val;
				}
				next LOOP;
			}

			my $cexpr = compile_expr($expr);
			my $val = &$cexpr($env);

			# print "<!-- computed arg '$key' value '$val' -->\n";
			# print "<!-- storing arg '$key' -->\n";
			# $args->{$arg} = undef;
			delete $args->{$arg};
			$args->{"?$arg"} = $cexpr;

			# my $val = eval_expr($expr, $env);			
			if(defined ($val) && $val ne ''){
				$args{$key} = $val;
			}
			next LOOP;
		}
		$args{$arg} = $expr;
	}
	return \%args;
}

sub action_print_self {
	my ($action, $env) = @_;
	my ($tag, $body, $args) = @$action;
	if(%$args){
		my $args2 = compute_args($args, $env);
		&$print_cb( tag_and_params_to_string($tag, $args2) );
	} else {
		&$print_cb( "<$tag>" );
	}
	exec_html_tree($body, $env);
	&$print_cb( "</$tag>" );
}

sub action_print_self_no_body {
	my ($action, $env) = @_;
	my ($tag, $body, $args) = @$action;

	if(%$args){
		my $args2 = compute_args($args, $env);
		&$print_cb( tag_and_params_to_string($tag, $args2) );
	} else {
		print "<$tag>";
	}
}

sub action_kill {
	# don't print the content
}

sub action_include {
	my ($action, $env) = @_;
	my ($tag, $body, $args) = @$action;
	my $filename = $args->{'file'};
	my $expr = $args->{'file_expr'};
	if(!defined($filename)){
		if($expr){
			$filename = eval_expr($expr, $env);
		} else {
			$filename = "";
		}
	}
	my $as_text  = $args->{'as_text'} || 0;

	if((! defined $filename) || !(-f $filename)){ # no name given, or file not found
		exec_html_tree ($body, $env);
		return;
	}
	if($as_text){
		my $data = read_file($filename);
		&$print_cb($data);
		return;
	} else {
		my $actions = parse_html_file($filename);
		if(! defined $actions){		# some kind of parse error
			exec_html_tree ($body, $env);
			return;
		}
		exec_html_tree ($actions, $env);	
	}
}

sub action_include_http {
	my ($action, $env) = @_;
	my ($tag, $body, $args) = @$action;

	my $href      = $args->{'href'};
	my $href_expr = $args->{'href_expr'};
	my $writeback = $args->{'writeback'};
	my $proxy     = $args->{'proxy'};
	my $method    = $args->{'method'} || 'get';  # "get" oder "post"
	my $arguments = $args->{'args'} || {}; 		 # hash, der key/value-paare enthaelt
	my $args_expr = $args->{'args_expr'};     	 # hash, der key/value-paare enthaelt

	my $strip_body = $args->{'strip_body'} ||0;

	if(!defined($href)){
		if($href_expr){
			$href = eval_expr($href_expr, $env);
		} else {
			$href = "";
		}
	}

	if($args_expr){
		$arguments = eval_expr($args_expr, $env);
	}

	if((! $href)){ # no name given
		exec_html_tree ($body, $env);
		return;
	}

	use LWP::UserAgent;
	use HTTP::Request::Common;
	my $ua = LWP::UserAgent->new();
	if($proxy){
		$ua->proxy('http', $proxy);
	}	
	my $response;
	if($method =~ /get/i){
		$response = $ua->request(GET $href);
	} else {					# feature: im augenblick ist alles, was nicht "get" ist, "post"
		$response = $ua->request(POST $href, [%$arguments]);
	}
	if($response->is_success()){
		my $data = $response->content();
		if($strip_body){		# entferne alles bis auf den body
			$data =~ s/.*<body.*?>(.*)/$1/sgi;
			$data =~ s/(.*)<\/body>.*/$1/sgi;
		}
		if($writeback){
			env_set($env, $writeback, $data, 0);
			# &$print_cb("<!-- output from $href to $writeback: $data -->");
		} else {
			if($data eq ''){
				$data = "<!-- no data from include $href ! -->";
			}
			&$print_cb($data);
		}
		return;
	} else {
		&$print_cb("<!-- konnte href=\"$href\" nicht includen: ". $response->error_as_HTML() ." -->");
		exec_html_tree ($body, $env);
	}
}

sub action_if {
	my ($action, $env) = @_;
	my ($tag, $body, $args) = @$action;

	if(defined $args->{'cond'}) {
		my $expr = $args->{'cond'};
		# debug_print "\n<!-- evaluating $expr -->";
		$ok = eval_expr($expr, $env);
	} else {
		debug_print "\n<!-- COND missing -->";
	}
	if($ok){
		# debug_print "<!-- IF was TRUE --->";
		exec_html_tree($body, $env);
	} else {
		# debug_print "<!-- IF was FALSE --->";		
		my $p = get_param('else', $body, $env);
		if($p){
			exec_html_tree($p, $env);
		}
	}
}

sub action_switch {
	my ($action, $env) = @_;
	my ($tag, $body, $args) = @$action;
	my $value=undef;
	if(defined $args->{'expr'}) {
		my $expr = $args->{'expr'};
		$value = eval_expr($expr, $env);
	} else {
		debug_print "\n<!-- Switch: EXPR missing -->";
	}
	my $params = get_params($body);
	foreach $p (keys %$params){
		if($p ne 'default'){
			my $x = eval_expr($p, $env);
			if($x eq $value){
				exec_html_tree($params->{$p}, $env);
				return;
			}
		}
	}
	my $p = get_param('default', $body, $env);
	if(defined $p){
		exec_html_tree($p, $env);
		return;
	} else {
		exec_html_tree($body, $env); # nothing matches: print self
	}
}

sub action_eval {
	my ($action, $env) = @_;
	my ($tag, $body, $args) = @$action;
	my $value=undef;
	if(defined $args->{'expr'}) {
		my $expr = $args->{'expr'};
		$value = eval_expr($expr, $env);
	} else {
		debug_print "\n<!-- Eval: EXPR missing -->";
	}
}

sub action_eval_body {
	my ($action, $env) = @_;
	my ($tag, $body, $args) = @$action;
	my $text = "";
	foreach $p (@$body){
		my ($t, $b, $a) = @$p;
		if($t eq $print_self_tag){
#			print "<!-- add text $b -->";
			$text .= $b;
		}
	}
#	print "<!-- going to eval $text -->";
	$value = eval_expr($text, $env);
}

sub action_proto {
	my ($action, $env) = @_;
	my ($tag, $body, $args) = @$action;
	my $name = $args->{'name'};
	if(!defined $name){
		debug_print "\n<!-- NAME not set! --->";
		return;
	}
	env_set($env, $name, $action);
}

sub action_use {
	my ($action, $env) = @_;
	my ($tag, $body, $args) = @$action;

	my $proto_name = $args->{'proto'};
	if(!defined $proto_name){
		debug_print "\n<!-- PROTO not set! --->";
		return;
	}
	my $proto = env_get($env, $proto_name);	
	if(!defined $proto){
		debug_print "\n<!-- proto $proto_name not defined! --->";
		return;
	}
	my ($proto_tag, $proto_body, $proto_args) = @$proto;
	my $local_env = env_new_scope($env);
	foreach $key (keys %$args) {
		if($key ne 'proto'){
			env_set($local_env, $key, eval_expr($args->{$key}, $env));
		}
	}
	my $params = get_params($body);
	foreach $key (keys %$params) {
		env_set($local_env, "param:$key", $params->{$key});
	}
	
	exec_html_tree($proto_body, $local_env);
}

sub action_loop {
	my ($action, $env) = @_;
	my ($tag, $body, $args) = @$action;
	
	my $var = $args->{'var'}   || 'i';
	my $beg = eval_arg($args->{'begin'}, $env, 1);
	my $end = eval_arg($args->{'end'}, $env, $beg + 3);
	my $inc = eval_arg($args->{'inc'}, $env, ($beg < $end ? 1 : -1));
	
	my $i;
	for($i = $beg; 
		($inc > 0 && $i <= $end) || ($inc < 0 && $i >= $end); 
		$i += $inc)
	{
		# debug_print "<!-- loop $var=$i -->";
		my $local_env = env_new_scope($env);
		env_set($local_env, $var, $i);
		exec_html_tree($body, $local_env);
		# debug_print "<!-- /loop $var=$i -->";
	}
}

sub action_foreach {
	my ($action, $env) = @_;
	my ($tag, $body, $args) = @$action;
	
	my $var = $args->{'var'};
	my $count= $args->{'count'};
	my $data = eval_arg($args->{'list'}, $env);
	
	my $i=0;
	foreach $elem (@$data) {
		# debug_print "<!-- foreach $var=$i -->";
		my $local_env = env_new_scope($env);
		if(defined $var){
			env_set($local_env, $var, $elem);
		}
		if(defined $count){
			env_set($local_env, $count, $i);
		}
		exec_html_tree($body, $local_env);
		# debug_print "<!-- /foreach $var=$i -->";
		$i++;
	}
}

sub action_for {
	my ($action, $env) = @_;
	my ($tag, $body, $args) = @$action;
	my $vars= $args->{'vars'};
	my $init= $args->{'init'};
	my $step= $args->{'step'};
	my $cond= $args->{'cond'};
	my $max = $args->{'max'} || "100";

	if(!(defined($vars) && defined($init) && defined($step) && defined($cond))){
		# da fehlt was
		exec_html_tree ($body);
		return;
	}

	my $local_env = env_new_scope($env);
	foreach $v (split ',',$vars){
		env_set($local_env, $v, 0);
	}

	eval_expr($init, $local_env, 1); # do it for the side effect!
	my $maxloop = eval_expr($max, $env);
	while(eval_expr($cond, $local_env)){
		exec_html_tree($body, $local_env);
		eval_expr($step, $local_env, 1); # 1 - writeback
		if(--$maxloop <0){
			return;
		}
	}
}

sub action_substitute {
	my ($action, $env) = @_;
	my ($tag, $body, $args) = @$action;
	my $val = undef;
	my $found=0;

	my $expr = $args->{'expr'};
	if(defined $expr){
		$cexpr = compile_expr($expr);
		$args->{'cexpr'} = $cexpr;
		$args->{'expr'} = undef;
	}

	my $cexpr = $args->{'cexpr'};
	if(defined $cexpr){
		$found ++;
		$val = &$cexpr($env);
		if(defined $val){
			&$print_cb($val);
			return;
		}
	}

	my $var = $args->{'var'};
	if(defined $var){
		$found++;
		$val = env_get($env, $var);
		if(defined $val){
			&$print_cb($val);
			return;
		}
		debug_print "<!-- INS: VAR $var not found, printing default -->";
	}


	my $param = $args->{'param'};
	if(defined $param){
		$found++;
		my $p = get_param($param, $body, $env);
		if(defined $p){
			exec_html_tree($p, $env);
			return;
		} else {
			debug_print "<!-- INS: PARAM $param not found, printing default -->";
		}
	}
	if($found == 0){
		debug_print "<!-- INS: neither EXPR nor VAR nor PARAM found, printing default -->";
	}
	
	exec_html_tree($body, $env);
}

sub exec_html_tree {
	my $actions = shift @_;
	my $env = shift @_ || [{}];
  LOOP:
	foreach $action (@$actions) {
		my ($tag, $body) = @$action;
		if( $tag eq 'P'){ # $print_self_tag
			&$print_cb ($body);
		} else {
			my $h = $parse_elements{$tag} || $parse_elements_no_body{$tag};
			&$h($action, $env);
		}
	}
}

sub apply_html_tree {
	my ($actions, $fn) = @_;
	foreach $action (@$actions) {
		&$fn($action);		
		my ($tag, $body) = @$action;
		if($tag ne $print_self_tag){
			apply_html_tree($body, $fn);
		}
	}
}

############################################################################
#
# config files
#

sub read_config_file {
	my ($filename,$preserve_case) = @_;
	my $root={};
	my $sections={};

	my $current_section = undef;
	my $current_hash = {};

	$_read_file_count ++;

	open FILE, "<$filename" || die "could not open config file $filename: $!";
  LOOP:
	while(<FILE>){
		s/^\s*#.*//g;
		s/\s+#.*//g;
		if(/\[(.*)\]/){
			my $val=$1 ;
			$val = tolower($val) unless $preserve_case;
			$val =~ s/^\s+//;
			$val =~ s/\s+$//;
			# new secion, ends last one
			if(defined $current_section){
				if(defined ($sections->{$current_section})){
					debug_print "$filename: section $current_section mehrmals definiert\n";
				}
				$sections->{$current_section} = $current_hash;
			} else {
				$root = $current_hash;
			}
			$current_hash = {};
			$current_section = $val;
		}
		if(/(.*?)=(.*)/){
			my $key = $1;
			$key = tolower($key) unless $preserve_case;
			my $val = $2;
			if(defined ($current_hash->{$key})){
				debug_print "$filename: ";
				if(defined $current_section){
					debug_print "($current_section) ";
				}
				debug_print "$key mehrmals definiert\n";
			}
			$val =~ s/^\s+//;
			$val =~ s/\s+$//;
			$key =~ s/^\s+//;
			$key =~ s/\s+$//;
			$current_hash->{$key} = $val;
		}
	}
	close FILE;
	if(defined $current_section){
		$sections->{$current_section} = $current_hash;
	} else {
		$root = $current_hash;
	}
	return ($root, $sections);
}

my $the_config_file;

sub read_config {
	foreach $x (@_){
		if(-e $x){
			my ($a, $b) = read_config_file $x;
			$b->{''} = $a;
			$the_config_file = $b;
			return 1;
		}
	}
	return 0;
}

sub read_config_file1 {
	my ($name) = @_;
	my ($h1, $h2) = read_config_file($name);
	$h2->{''} = $h1;
	return $h2;
}

sub get_config {
	my ($key, $section) = @_;
	if(!defined $section){ $section = '';}
	my $s = $the_config_file->{$section};
	if($s){
		return $s->{$key};
	}
	return undef;
}

#
# ex. Array.pm
#

package Array;

# new
# x/columns  () -> int
# y/rows     () -> int
# get        x,y -> int
# put        x,y,v -> ()
# get_row    n -> vector
# get_column n -> vector
# insert_row n data -> ()
# insert_column n data -> ()
# delete_row n -> ()
# delete_column n -> ()
# replace_row n data -> ()
# replace_column n data -> ()
# read_file  filename [separator=\t] [protocol=0]
# html_table_content [indexed=0] -> string

sub new {
	my $proto = shift;
	my $class = ref($proto) || $proto;
	my $self  = {};

	$self->{X}   = 0;
	$self->{Y}   = 0;
	$self->{DATA}= undef;

	bless($self, $class);
	return $self;
}

# clone

sub clone {
	my $self = shift;
	my $new = $self->new();

	$new->{X} = $self->{X};
	$new->{Y} = $self->{Y};

	my $orig = $self->{DATA};
	my @copy;

	foreach $line (@$orig) {
		my @line = @$line; # copy
		push @copy, \@line;
	}
	$new->{DATA} = \@copy;
	return $new;
}

# init

sub init {
	my $self = shift;
	my $x = shift;
	my $y = shift;
	my $v = shift || '';

	$self->{X} = $x;
	$self->{Y} = $y;

	my @arr;

	for(my $i=0; $i < $y; $i++) {
		my @line = ();
		for(my $j=0; $j < $x; $j++) {
			push @line, $v;
		}
		push @arr, \@line;
	}
	$self->{DATA} = \@arr;
	return $self;
}

# query size

sub x {
	my $self = shift;
	return $self->{X};
}

sub y {
	my $self = shift;
	return $self->{Y};
}

sub rows {
	my $self = shift;
	return $self->{Y};
}

sub columns {
	my $self = shift;
	return $self->{X};
}

# access element

sub get {
	my $self = shift;
	my ($x, $y) = @_;
	my $a = $self->{DATA}; 
	return $a->[$y][$x];
}

sub put {
	my $self = shift;
	my ($x, $y, $v) = @_;
	my $a = $self->{DATA}; 
	$a->[$y][$x] = $v;
}

# access rows and columns

sub get_row {
	my $self = shift;
	my $n = shift || 0;
	my $a = $self->{DATA}; 
	return $a->[$n];
}

sub get_column {
	my $self = shift;
	my $n = shift || 0;
	my $a = $self->{DATA}; 
	my @buf;
	foreach $line (@{$self->{DATA}}) {
		push @buf, $line->[$n];
	}
	return \@buf;
}

# replace row/column. undef elements are taken as they are

sub replace_row {
	my $self = shift;
	my $n    = shift;
	my $data = shift;

	my $a = $self->{DATA}; 
	my @acc;
	foreach $v (@{$a->[$n]}) {
		my $r = shift @$data;
		if(defined($r)){
			push @acc, $r;
		} else {
			push @acc, $v;
		}
	}
	$a->[$n] = \@acc;
}

sub replace_column {
	my $self = shift;
	my $n    = shift;
	my $data = shift;

	my $a = $self->{DATA}; 
	foreach $v (@$a) {
		my $r = shift @$data;
		if(defined($r)){
			$v->[$n] = $r;
		}
	}
}

# delete row/column

sub delete_row {
	my $self = shift;
	my $n    = shift;
	my $y    = $self->{Y};

	my $a = $self->{DATA}; 
	my @buf = ();
	for(my $i=0;$i<$y;$i++){
		if($i != $n){
			push @buf, $a->[$i];
		}
	}
	$self->{DATA} = \@buf;
	$self->{Y} --;
}

sub delete_column {
	my $self = shift;
	my $n    = shift;
	my $x    = $self->{X};

	my $a = $self->{DATA}; 
	my @a;

	foreach $v (@$a){
		my @buf = ();
		for(my $i=0;$i<$x;$i++){
			if($i != $n){
				push @buf, $v->[$i];
			}
		}
		push @a, \@buf;
	}

	$self->{DATA} = \@a;
	$self->{X} --;
}

#insert row/column

sub insert_row {
	my $self = shift;
	my $n    = shift;
	my $data = shift;
	my $y    = $self->{Y};

	my $a = $self->{DATA}; 
	my @buf = ();
	my $i;
	for($i=0;$i<$y;$i++){
		if($i == $n){
			push @buf, $data;
		}
		push @buf, $a->[$i];
	}
	if($n >= $i){
		push @buf, $data;
	}
	$self->{DATA} = \@buf;
	$self->{Y} ++;
}

sub insert_column {
	my $self = shift;
	my $n    = shift;
	my $data = shift;
	my $x    = $self->{X};

	my $a = $self->{DATA}; 
	my @a = ();

	foreach $v (@$a){
		my $i;
		my @buf = ();
		my $r = shift @$data;
		for($i=0;$i<$x;$i++){
			if($i == $n){
				push @buf, $r;
			}
			push @buf, $v->[$i];
		}
		if($n >= $i){
			push @buf, $r;
		}
		push @a, \@buf;
	}
	$self->{DATA} = \@a;
	$self->{X} ++;
}


# print with prefix/suffix to all elements

# read a file

sub read_file {
	my $self = shift;
	my $filename = shift;
	my $sep = shift || "\t";
	my $show = shift || 0;

	my $raw = ::read_file($filename);
	my @lines;
	if($raw =~ /\r\n/){
		@lines = split /\r\n/, $raw;
	} else {
		if($raw =~ /\n/){
			@lines = split /\n/, $raw;
		} else {
			@lines = split /\r/, $raw;			
		}		
	}
	
	my @arr = ();
	
#	open FILE,"<$filename" or 
#	  main::prot_error ("could not open file '$filename' for reading: $!") and return;
#	if($show){
#		print "<pre>\nopened file $filename\n";
#	}
#	while(<FILE>){
	
	while($_ = shift @lines){
		s/[\n\r]*//g;			# remove trailing newline chars
		my @line = split /$sep/,$_,10000; # LIMIT muss angegeben werden, damit trailing null fields nicht entfernt werden
		my $size = scalar @line;
		if(defined $self->{X} && $self->{X} < $size){
			$self->{X} = $size;
		}
		push @arr, \@line;
		if($show){
			print join(' ; ', @line), "\n";
		}
	}
	if($show){
		print "</pre>\n";
	}
#	close FILE;

	$self->{DATA} = \@arr;
	$self->{Y} = scalar @arr;
}

sub write_file {
	my $self = shift;
	my $filename = shift;
	my $sep = shift || "\t";
	my $lsep = shift || "\n";
	my $show = shift || 0;
	my $a = $self->{DATA};

	open FILE, ">$filename" or  
	  main::prot_error ("could not open file '$filename' for writing: $!") and return;
	if($show){
		print "<pre>\nopened file $filename ($!)\n";
	}
	foreach $line (@$a){
		if(defined $line){
			print FILE join($sep, @$line), $lsep;
			if($show){
				print join($sep,@$line), $lsep;
			}
		} else {
			if($show){
				print "undefined line", $lsep;
			}
		}
	}
	if($show){
		print "</pre>\n";
	}
	close FILE;
}

# build a table

sub html_table_content {
	my $self = shift;
	my $indexed = shift;
	my $acc = '';
	my $arr = $self->{DATA};
	if($indexed){
		for(my $y = 0; $y < $self->{Y}; $y++){
			$acc .= "<tr>\n";
			for(my $x = 0;$x < $self->{X}; $x++){
				my $v = $self->get($x, $y) || '';
				$acc .= "<td><i>($x, $y)</i><b> " . $v . "</b><td>";
			}
			$acc .= "</tr>\n";
		}
	} else {
		foreach $line (@$arr) {
			$acc .= "<tr>\n";
			foreach $v (@$line) {
				$acc .= "<td><b> " . $v . "</b></td>";
			}
			$acc .= "</tr>\n";
		}
	}
	return $acc;
}

# apply a function

sub apply {
	my $self = shift;
	my $fn = shift;
	my $acc = shift || {};

	my $arr = $self->{DATA};

	my $y = 0;
	foreach $line (@$arr) {
		my $x=0;
		foreach $v (@$line) {
			$acc = &$fn($v, $x, $y, $acc);
			$x ++;
		}
		$y++;
	}
	return $acc;
}


#
#
#

package Timer;

sub new {
	my @time = (0,0,0,0);
	my $t = \@time;
	bless $t;
	return $t;
}

sub reset(){
	my ($self) = @_;
	@$self = times();
}
sub get(){
	my ($self) = @_;
	my @now= times();
	my $diff = ($now[0] - $self->[0] +
				$now[1] - $self->[1] +
				$now[2] - $self->[2] +
				$now[3] - $self->[3]);
	@$self = @now;
	return $diff;
}


#
#
#

package DBAD;

sub concat_paths {
	my $acc = "";
	my @list = @_;			  

	foreach $x (@list){
		$x ||= "";
		if($x && $acc && !($acc =~ m|/$|)){
			$acc .= "/";
		}
		$acc .= "$x";
	}
	$acc =~ s|[^/]*/\.\./||g;
	return $acc;
}

sub concat_hash {				# (h1,h2) h1 += h2
	my ($h1, $h2) = @_;

	while(($k,$v) = each %$h2){
		$h1->{$k} = $v;
	}
	return $h1;
}

sub refkeys {
	my ($x) = @_;
	my @keys= keys %$x;
	return \@keys;
}

sub dbad_style {
	# warum die vielen wiederholungen? weil es nicht anders funktioniert. netscape 4 hat eine
	# derart kaputte stylesheet-engine, dass man alles explizit wiederholen muss
	return <<EOF;
<style type="text/css">
<!--
body {
	font-family: Zyntax,Arial,Geneva,Helvetica,sans-serif;	
}
a:link {
	text-decoration:none;
	color:#006699;
}
a:visited {
	text-decoration:none;
}
a:active {
	text-decoration:none;
}
tt {
	font-family: OCR A Extended, Courier New, Courier, Arial Terminal;
}
pre {
	font-family: OCR A Extended, Courier New, Courier, Arial Terminal;
}
td {
	font-family: Zyntax,Arial,Geneva,Helvetica,sans-serif;	
}
p {
	font-family: Zyntax,Arial,Geneva,Helvetica,sans-serif;	
}
//-->
</style>
EOF
}

package Patcher;

# die alternative zur grossen DBAD - der kleine patcher

sub patch_lang {
	my ($data, $lang) = @_;
	return patch($data, 
				 {
					 'lang' => $lang,
				 }, 
				 {
					 'de' => $lang eq 'de',
					 'en' => $lang eq 'en',
				 }
				 );
}

sub patch {
	my ($data, $r, $s) = @_;	# r=replacement-init, s=switch-init

	#------------ substitution ---------
	
	my %replacements;
	while (($k, $v) = each %$r){
		$replacements{'$k'} = $v;
	}

	#---------------------------------------- replacement engine
	# <replace name=value>
	# <replace name></replace>
	# => <name>

	$data =~ s/<replace ([^>=]*?)=([^>=]*?)>/
		$replacements{$1} = $2; $_ = '';
	/eisg;
	
	$data =~ s/<replace ([^>=]*?)>(.*?)<\/replace>/
		$replacements{$1} = $2; $_ = '';
	/eisg;
	
	my $again = 1;
	my $loops = 0;
	while($again){
		$again = 0;
		while (($k, $v) = each %replacements) {
			$data =~ s/<$k>/$again++; $v/isge;
		}
		if(++$loops > 42){		# magic fuzzy parameter
			$again = 0;
			die ("replacement engine replaced $loops times");
		}
	}
	
	#------------ switches -----------
	# <switch name=value>

	my %switches;
	$data =~ s/<switch (.*?)=(.*?)>/
		$switches{$1} = $2; $_ = '';
	/eisg;
	
	while (($k, $v) = each %$s){
		$switches{$k} = $v;
	}
	
	while (($k, $v) = each %switches) {
		if($v){
			$data =~ s/<$k>(.*?)<\/$k>/$1/isg;
		} else {
			$data =~ s/<$k>(.*?)<\/$k>//isg;
		}
	}
	
	return $data;
}

sub compact  {
	my ($data) = @_;

	# diese funktion ist gefährlich; sie kann nicht auf allen daten ausgeführt werden

	#----------- remove unneeded quotes
	# zerstört content der form a="b"

	$data =~ s/="\w+"/=$1/g;
	$data =~ s/='\w+'/=$1/g;
	$data =~ s/="\w+"/=$1/g;
	$data =~ s/='\w+'/=$1/g;

	#----------- remove single-line comments

	$data =~ s/<!--.*?-->//g;
	
	#---------- remove multiple spaces
	# zerstört verbatim-content

	$data =~ s/\s+/ /g;

	#----------- compact leading and trailing spaces away

	$data =~ s/^\s+//g;
	$data =~ s/\s+$//g;

	return $data;
}
return 1;