#!/usr/local/bin/perl
#
# (c) 1998 das buero am draht
#

# 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
# 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
#
# replace_tags: (string, hashref) -> string
#                                      --- complex nested tag-substitution
# currently implemented:
#    <LOOP VAR=i BEGIN=1 END=11 INC=1>...</LOOP>
#    <REPLACE VAR=xxx>default</REPLACE>
# internal:
#    <KILL>....</KILL>

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

@ISA = qw(Exporter);
@EXPORT = 
	qw( 
	   needs_bad_version do_show_errors replace_tags
	   write_file copy_file read_file 
	   substitute remove_end_spaces tolower
	   quotehtml dequote tohtml toplain
	   );
@EXPORT_OK = qw ( );

my $VERSION = 0.93;
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 "<br><b><font color=red>";
		print @_;
		print "</font></b><br>\n";
	}
}

#
#
#

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;
	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) = @_;
	if(open(DATEN, ">$filename")){
		print DATEN $data;
		return 1;
	} else {
		prot_error ("Konnte Datei $filename nicht schreiben: $!\n");
		return 0;
	}
}

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

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

sub tohtml {
	my ($x) = @_;	
	if($x){
		# 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) = @_;
	$x =~ s/&/&amp;/g;
	$x =~ s/</&lt;/g;
	$x =~ s/>/&gt;/g;
	return $x;
}

# debug-ausgabe fuer replace_tags

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

# replace_tags: (data, endtag) -> (before, after)
# sucht </endtag> und liefert alles davor/danach (das endtag selbst nicht!)
# der "before"-bereich ist fertig expandiert

my $tags = "loop|replace|kill";	# change this iff a new tag is introduced!!!

my $params = "[^>]*";
my $begin= "<(\/*)($tags)($params)>";
my $start_kill = "<kill>";
my $end_kill = "</kill>";

sub replace_tags {
	my ($data, $env, $endtag) = @_;
	my $done = "";

	while($data =~ /$begin/i){
		my $end    = $1;		# is this a begin- or end-tag?
		my $tag    = tolower($2); # which tag was matched?
		my $params = $3;		# the param string, iff there is any
		my $before = $`;		# everything preceding the tag
		my $after  = $';		# everything following the tag
		my $all    = $&;		# the whole matched string
		if($end){
			if($tag eq $endtag){
				return ($done . $before, $after);
			} 
			# unerwartetes end-tag!
			debug "unerwartetes end-tag $tag";

			return ("", $done . $data);
		} else {
			# begin tag starts sub-task
			debug "begin $tag"; $debuglevel++;

			my ($idem, $subs, $cont) = handle_tag($tag, $params, $after, $env);

			$debuglevel--; debug "end $tag";

			$done .= $before;
			if($idem){
				$done .= $all;
			}
			$done .= $subs;
			if($idem){
				$done .= "</$tag>";
			}
			$data = $cont;
		}
	}
	return ("" , $done . $data);
}

sub handle_tag {
	my ($tag, $params, $after, $env) = @_;

    my @params = split ' ', $params;
	my %params;
	for (@params) {
		if(/(.+)=(.*)/){
			$params{tolower($1)} = $2;
		}
	}
	if($tag eq "loop"){
		debug "handle loop";
		my $var = $params{"var"}   || "i";
		my $beg = $params{"begin"} ||  1;
		my $end = $params{"end"}   || $beg + 10;
		my $inc = $params{"inc"}   || ($beg < $end ? 1 : -1);
		my $i;
		my $acc = "";
		my $body;
		my $cont;
		for($i = $beg; $i <= $end; $i+= $inc){
			$$env{$var} = $i;
			($body, $cont) = replace_tags($after, $env, $tag);
			if($i == $beg + $inc){
				$acc .= $start_kill; # second loop
			}
			$acc .= $body;
			if($i + $inc > $end){
				$acc .= $end_kill;   # last loop
			}
		}
		return (1,$acc, $cont);
	}
	if($tag eq "replace"){
		my ($body, $cont) = replace_tags($after, $env, $tag);
		my $key = $params{"var"};
		my $def = $params{"default"};
		my $val = $$env{$key};
		
		debug "handle substitution key=$key def=$def val=$val";

		if($val){ 
			return (1,$val,$cont);  # match!
		}
		if($def){ 
			return (1,$def,$cont);  # no match, but explicit default value
		}
		return (1,$body, $cont);	  # no match, no default: stay as is		
	}
	if($tag eq "kill"){			# generierter code, remove
		my ($body, $cont) = replace_tags($after, $env, $tag);
		return (0, "", $cont);
	}
	debug "unknown tag: $tag";
	my ($body, $cont) = replace_tags($after, $env, $tag);
	return (1, $body, $cont);
}

return 1;