##
##  wml::des::navbar -- Navigation Bar
##  Copyright (c) 1997 Ralf S. Engelschall, All Rights Reserved. 
##
##     Modified by Florian Hars, 1998--1999 <florian@hars.de>
##     Added support for nested and multi-lingual navbars
##     Last version of this file is available at
##        http://www.hars.de/www/navbar-FH.wml
##     Further information is available at
##        http://www.hars.de/www/wml_navbars.html	  
##
##     $Log: navbar-FH.wml,v $
##     Revision 1.4  2007-10-14 15:25:26  hars
##     Version wie nach vielen Jahren vorgefunden
##
##     Revision 1.3  1999/04/18 13:04:44  hars
##     Moved rendering specific attributes to navbar:render
##
##     Revision 1.2  1999/03/28 19:55:47  hars
##     Added automatic button creation
##
##     Revision 1.1  1999/03/28 15:35:46  hars
##     First public release
##
##

#use wml::std::tags
#use wml::sup::path

#
#   navbar definition
#
<define-container navbar:define>
<preserve name>
<preserve imgstar>
<preserve imgbase>
<preserve subprolog>
<preserve subepilog>
<preserve urlbase>
<preserve target>
<preserve defaultlanguage>
<preserve txtcol_normal>
<preserve txtcol_select>
<set-var %attributes>
<if <get-var name>    "" <set-var name="unknown-navbar">>
<if <get-var imgstar> "" <set-var imgstar="n:s:o">>
<: 
{
    #   initialise the data structure for this particular navbar
    #   and fill it with some already known information
    my $CFG = {};
    $NAVBAR{'<get-var name>'} = $CFG;

    $CFG->{NAME} = '<get-var name>';

    $CFG->{IMGSTAR}  = '<get-var imgstar>';
    $CFG->{IMGBASE}  = '<get-var imgbase>';
    $CFG->{URLBASE}  = '<get-var urlbase>';
    $CFG->{TARGET}   = '<get-var target>';
    $CFG->{DEFLANG}  = uc '<get-var defaultlanguage>';
    chomp $CFG->{DEFLANG};
    $CFG->{TXTCOL_N} = '<get-var txtcol_normal>';
    $CFG->{TXTCOL_S} = '<get-var txtcol_select>';

    $CFG->{HEADER} = '';
    $CFG->{FOOTER} = '';

    $CFG->{PROLOG} = {};
    $CFG->{PROLOG}->{N}  = {};
    $CFG->{PROLOG}->{S}  = {};
    $CFG->{PROLOG}->{SS} = {};
    $CFG->{PROLOG}->{N}->{'any'} = '';

    $CFG->{SUBPROLOG} = [ split(':', '<get-var subprolog>') ];
    $CFG->{SUBEPILOG} = [ split(':', '<get-var subepilog>') ];

    $CFG->{EPILOG} = {};
    $CFG->{EPILOG}->{N}  = {};
    $CFG->{EPILOG}->{S}  = {};
    $CFG->{EPILOG}->{SS} = {};
    $CFG->{EPILOG}->{N}->{'any'} = '';

    $CFG->{BUTTON} = [];

    $CFG->{FILTER} = '';

    #   here the other tags now fill in more information...
:>
%body
<:
    #   ...and finally we do some cleanups
    $last = $#{$NAVBAR{'<get-var name>'}->{BUTTON}}+1;
    foreach $what (qw(PROLOG EPILOG)) {
        foreach $type (qw(N S SS)) {
            foreach $pos (keys(%{$NAVBAR{'<get-var name>'}->{$what}->{$type}})) {
                if ($pos eq 'first') {
                    $NAVBAR{'<get-var name>'}->{$what}->{$type}->{1} =
                        $NAVBAR{'<get-var name>'}->{$what}->{$type}->{$pos};
                    delete $NAVBAR{'<get-var name>'}->{$what}->{$type}->{$pos};
                }
                elsif ($pos eq 'last') {
                    $NAVBAR{'<get-var name>'}->{$what}->{$type}->{$last} =
                        $NAVBAR{'<get-var name>'}->{$what}->{$type}->{$pos};
                    delete $NAVBAR{'<get-var name>'}->{$what}->{$type}->{$pos};
                }
            }
        }
    }
}
:>
<restore txtcol_select>
<restore txtcol_normal>
<restore defaultlanguage>
<restore target>
<restore urlbase>
<restore subepilog>
<restore subprolog>
<restore imgbase>
<restore imgstar>
<restore name>
</define-container>

<define-container navbar:header>
<: 
    $NAVBAR{'<get-var name>'}->{HEADER} = <<'EOT';
%body
EOT
_:>
</define-container>

<define-container navbar:footer>
<: 
    $NAVBAR{'<get-var name>'}->{FOOTER} = <<'EOT';
%body
EOT
_:>
</define-container>

<define-container navbar:prolog>
<preserve type>
<preserve pos>
<set-var %attributes>
<if <get-var type> "" <set-var type="N">>
<if <get-var pos>  "" <set-var pos="any">>
<: 
    $NAVBAR{'<get-var name>'}
        ->{PROLOG}
        ->{'<get-var type>'}
        ->{'<get-var pos>'} = <<'EOT';
%body
EOT
_:>
<restore pos>
<restore type>
</define-container>

<define-container navbar:epilog>
<preserve type>
<preserve pos>
<set-var %attributes>
<if <get-var type> "" <set-var type="N">>
<if <get-var pos>  "" <set-var pos="any">>
<: 
    $NAVBAR{'<get-var name>'}
        ->{EPILOG}
        ->{'<get-var type>'}
        ->{'<get-var pos>'} = <<'EOT';
%body
EOT
_:>
<restore pos>
<restore type>
</define-container>

<define-container navbar:subprolog>
<preserve level>
<set-var %attributes>
<if <get-var level> "" <set-var level="0">>
<: 
    $NAVBAR{'<get-var name>'}
        ->{SUBPROLOG}
        ->['<get-var level>'] = <<'EOT';
%body
EOT
_:>
<restore level>
</define-container>

<define-container navbar:subepilog>
<preserve level>
<set-var %attributes>
<if <get-var level> "" <set-var level="0">>
<: 
    $NAVBAR{'<get-var name>'}
        ->{SUBEPILOG}
        ->['<get-var level>'] = <<'EOT';
%body
EOT
_:>
<restore level>
</define-container>

<set-var __buttoncnt=1>
<define-tag navbar:button>
<preserve id>
<preserve txt>
<preserve alt>
<preserve img>
<preserve hint>
<preserve url>
<preserve target>
<set-var %attributes>
<if "<get-var id>" "" <prog
    <set-var id=button<get-var __buttoncnt>>
    <increment __buttoncnt>
>>
<:{
    my $B = {};
    push(@{$NAVBAR{'<get-var name>'}->{BUTTON}}, $B);

    $B->{ID}     = '<get-var id>';
    chomp($B->{ID});
    $B->{TXT}    = qq<<get-var txt>>;
    $B->{ALT}    = qq<<get-var alt>>;
    $B->{IMG}    = '<get-var img>';
    $B->{HINT}   = qq<<get-var hint>>;
    $B->{URL}    = '<get-var url>';
    $B->{TARGET} = '<get-var target>';
}:>
<restore target>
<restore url>
<restore hint>
<restore img>
<restore alt>
<restore txt>
<restore id>
</define-tag>

<define-container navbar:filter>
<: 
    $NAVBAR{'<get-var name>'}->{FILTER} = <<'EOT';
%body
EOT
_:>
</define-container>


#
#   navbar debugging
#
<define-tag navbar:debug>
<preserve name>
<set-var %attributes>
<if <get-var name> "" <set-var name="unknown-navbar">>
<:
    use Data::Dumper;
    print Data::Dumper::Dumper($NAVBAR{'<get-var name>'});
:>
<restore name>
</define-tag>

<:

sub parse_langtxt {
    my $txt = shift;
    my $deflang = shift;
    my $def = "";
    my %result;

    if ($txt =~ m/(.*)\|[\s\n]*(.*)[\s\n]*/) {
	$txt = $1;
	$result{default}=$2;
    }
    while ($txt =~ s/^[\s\n]*(?:<|\[LANG_)(\w+):[\s\n]*([^>\]]*?)[\s\n]*(?:\>|\:\])[\s\n]*//s) {
	$def = $2 unless $def ne "";
	if (uc($1) eq uc($deflang) && !exists($result{default})) {
	    $result{default}=$2;
	}
	$result{uc $1} = $2;
    }

    $result{default}=$def unless exists($result{default}) || $def eq "";
    $result{default}=$txt unless exists($result{default});

    return %result;
}

:>
#
#   navbar rendering
#
<define-tag navbar:render>
<preserve name>
<preserve select>
<preserve subselected>
<preserve txtonly>
<preserve nohints>
<preserve nopreload>
<preserve languages>
<preserve imgstyle>
<set-var subselected=*>
<set-var txtonly=*>
<set-var nohints=*>
<set-var nopreload=*>
<set-var languages="">
<set-var %attributes>
<if <get-var name> "" <set-var name="unknown-navbar">>
<if <get-var languages> "" 
   <prog <set-var __i=0>\
     <while <get-var __languages[__i]>>\
       <set-var languages=<get-var languages>:<get-var __languages[__i]>>\
       <increment __i>\
     </while>\
   >\
>\
<:{
    #   import attributes to ePerl
    my $select      = qq|<get-var select>|;
    chomp($select);
    my $subselected = (qq|<get-var subselected>| eq '' ? 1 : 0);
    my $txtonly     = (qq|<get-var txtonly>|     eq '' ? 1 : 0);
    my $nopreload   = (qq|<get-var nopreload>|   eq '' ? 1 : 0);
    my @langs = split(":", '<get-var languages>');	
    my @languages = ();
    foreach my $lang (@langs) {	
        if ($lang ne "") {
            push @languages, $lang;
        }
    }
    my $imgstyle = '<get-var imgstyle>';
    my @sel;
    my $sublevels = 0;	

    if ($select =~ m/^[^.]+$/) {
        $sel[0] = $select;
    } else {
        my $seltmp = $select;
        while ($seltmp =~ m/(^[^.]+)\.(.+)/) {
            if ($sublevels == 0) {
                $sel[$sublevels]=$1;
            } else {
                $sel[$sublevels] = $sel[$sublevels-1] . "." . $1;
            }
            $sublevels++;
            $seltmp = $2;
	}
        $sel[$sublevels] = $sel[$sublevels-1] . "." . $seltmp;
    }



    #   select the correct navigation bar configuration
    my $CFG = $NAVBAR{'<get-var name>'};

    #   retrieve parts of config
    my @imgstar  = split(':', $CFG->{IMGSTAR});
    my $imgbase  = $CFG->{IMGBASE};
    my $urlbase  = $CFG->{URLBASE};
    my $target   = $CFG->{TARGET};
    my $deflang  = $CFG->{DEFLANG};
    my $nohints  = (qq|<get-var nohints>| eq '' ? 1 : 0);
    my $txtcol_n = $CFG->{TXTCOL_N};
    my $txtcol_s = $CFG->{TXTCOL_S};
    my $filter   = $CFG->{FILTER};

    #   initialise output creation
    my $O = '';
    my $n = 0;
    my @preload = ();

    #   output the global header
    $mcode = $CFG->{HEADER};
    $mcode =~ s|^\s+||;
    $mcode =~ s|\s+$||;
    $O .= $mcode."\n";

    #   now iterate over every defined button
    foreach $B (@{$CFG->{BUTTON}}) {
        #   count the buttons
        $n++;

        #   retrieve information about button
        my $id     = $B->{ID};

        # see if we have to show this button
        my $renderbutton = 0;
        my $sublevnr;

	$renderbutton = 1 unless $id =~ m/\./;
            for ($sublevnr = 0; $sublevnr <= $sublevels; $sublevnr++) {
            $renderbutton = 1 if $id =~ m/^$sel[$sublevnr]\.[^.]+$/; 
        }	

        if ($renderbutton) {
	    my %txt    = parse_langtxt($B->{TXT}, $deflang);
	    my $txt;
	    my %alt    = parse_langtxt($B->{ALT}, $deflang);
	    my $alt;
	    my @img    = split(':', $B->{IMG});
	    my $langimg, $defimg;
	    my $url    = $B->{URL};
	    my $langurl, $defurl;
	    my $target = $B->{TARGET};
	    my %hint   = parse_langtxt($B->{HINT}, $deflang);
	    my $hint;

	    my $idlevel = scalar split('\.', $id) -1;

	    #
	    #   PROLOG
	    #

	    #   determine list of prolog/epilog types to search
	    my @Ltype;
	    @Ltype = qw(N);
	    @Ltype = qw(S N)  if ($select eq $id and not $subselected);
	    @Ltype = qw(SS N) if ($select eq $id and $subselected);


	    #   output corresponding prolog for this type of button
	  L1: foreach $type (@Ltype) {
	      foreach $pos (($n, 'any')) {
		  if ($CFG->{PROLOG}->{$type}->{$pos}) {
		      $mcode = $CFG->{PROLOG}->{$type}->{$pos};
		      $mcode =~ s|^\s+||;
		      $mcode =~ s|\s+$||;
		      $O .= $mcode;
		      last L1;
		  }
	      }
	  }

	    $O .= $CFG->{SUBPROLOG}->[$idlevel];

	    #
	    #   THE BUTTON ITSELF
	    #

	    #   cleanup url information
	    if ($url =~ m/(.*)\|(.*)/) {
		$langurl=$1;
		$defurl=$2;
	    } else {
		$langurl = $defurl = $url;
		$defurl =~ s/\#//g;
	    }
	    if ($#languages >= 0 && $langurl =~ m/\#/) {
		$url="";
		foreach my $lang (@languages) {
		    my $tmpurl=$langurl;
		    $tmpurl =~ s/\#/lc($lang)/ge;
		    $tmpurl= "$urlbase/$tmpurl" if ($urlbase ne '' and $tmpurl !~ m;^(http://|/););
		    if (($tmpurl !~ m;^(http://|/); && ! -f $tmpurl) || uc($lang) eq $deflang) {
			$tmpurl = $defurl;
			$tmpurl  = "$urlbase/$tmpurl" if ($urlbase ne '' and $tmpurl !~ m;^(http://|/););
		    }
		    $tmpurl  = &canonpath($tmpurl) if ($tmpurl !~ m;^http://;);
		    $url .= "[LANG_".uc($lang).":".$tmpurl.":]";
		}
	    } else {
		$url = $defurl;
		$url  = "$urlbase/$url" if ($urlbase ne '' and $url !~ m;^(http://|/););
		$url  = &canonpath($url) if ($url !~ m;^http://;);
  	    }

	    #   cleanup target information
	    $target = " target=\"$target\"" if ($target ne '');

	    #   cleanup txt information:
	    $txt="";
	    if ($#languages >= 0) {
		foreach my $lang (@languages) {
		    $txt .= '[LANG_'.uc($lang).':';
		    if (exists($txt{uc($lang)})) {
			$txt .= $txt{uc($lang)};
		    } else {
			$txt .= $txt{default};
		    }
		    $txt .= ':]';
		}
	    } else {
		$txt = $txt{default};
	    }

	    #   cleanup hint information:
	    $hint="";
	    if ($#languages >= 0) {
		foreach my $lang (@languages) {
		    if (exists($hint{uc($lang)})) {
			$hint .= '[LANG_'.uc($lang).':'.$hint{uc($lang)}.':]';
		    } elsif (exists($hint{default}) && $hint{default} ne '') {
			$hint .= '[LANG_'.uc($lang).':'.$hint{default}.':]';
		    } 
		}
	    } elsif (exists($hint{default}) && $hint{default} ne '') {
		$hint = $hint{default};
	    }

	    #   output the button markup code
	    if ($#img < 0 || $txtonly) {
		#
		#   for a button without images
		#

		#   special feature for supporting colorized hyperlinks
		if ($select eq $id and $txtcol_s) {
		    $txt = '<font color="'.$txtcol_s.'">'.$txt.'</font>';
		}
		elsif ($txtcol_n) {
		    $txt = '<font color="'.$txtcol_n.'">'.$txt.'</font>';
		}

		$hint = $url if ($hint eq '');
		if ($select eq $id and not $subselected) {
		    $O .= $txt;
		}
		elsif ($select eq $id and $subselected) {
		    $js = '';
		    if ($hint ne '' && ! $nohints) {
			$js = qq# onMouseOver="self.status = '$hint'; return true"# .
			    qq# onMouseOut="self.status = ''; return true"#;
		    }
		    $O .= '<a href="'.$url.'"'.$target.$js.'>'.$txt.'</a>';
		}
		else {  # not selected 
		    $js = '';
		    if ($hint ne '' && ! $nohints) {
			$js = qq# onMouseOver="self.status = '$hint'; return true"# .
			    qq# onMouseOut="self.status = ''; return true"#;
		    }
		    $O .= '<a href="'.$url.'"'.$target.$js.'>'.$txt.'</a>';
		}
	    }
	    else {
		#
		#   for a button with images
		#
		my @imgs;
		my $jsid=$id;
		$jsid =~ s/\./__/g;

                $hint = $txt if ($hint eq '');
		$hint = '' if $nohints;
		
		#   alt attribute defaults to txt attribute if missing
		if ($alt{default} eq '') {
		    %alt = %txt;
		}
		
		#   cleanup image information
		if ($#img == 0 and $img[0] =~ m|\*|) {
		    ($img[2] = $img[0]) =~ s|\*|$imgstar[2]|g;
		    ($img[1] = $img[0]) =~ s|\*|$imgstar[1]|g;
		    $img[0] =~ s|\*|$imgstar[0]|g;
		}
		if ($#img == 0) {
		    $img[1] = $img[0] 
		    }
		for ($i = 0; $i <= $#img; $i++) {
		    if ($img[$i] =~ m/(.*)\|(.*)/) {
			$langimg=$1;
			$defimg=$2;
		    } else {
			$langimg = $defimg = $img[$i];
			$defimg =~ s/\#//g;
		    }
		    if ($#languages >= 0 && $langimg =~ m/\#/) {
			$img[$i]="";
			$imgs[$i]="";
			foreach my $lang (@languages) {
			    my $tmpimg;
			    if (uc($lang) eq uc($deflang)) {
				$tmpimg  = $defimg;
			    } else {
				$tmpimg=$langimg;
				$tmpimg =~ s/\#/$lang/ge;
			    }
			    if ($imgbase ne '' and $tmpimg !~ m;^(http://|/);) {
				$tmpimg= "$imgbase/$tmpimg";
			    }
			    if ($tmpimg !~ m;^http://;) {
				$tmpimg  = &canonpath($tmpimg);
                                &{$imgstyle{$imgstyle}}($tmpimg, 
							 $txt{uc($lang)}||$txt{default},
							 $i,
							 $idlevel,
							 $lang,
							 $id)
				    unless -e $tmpimg || 
					!exists($imgstyle{$imgstyle});
			    }
			    $img[$i] .= "[LANG_".uc($lang).":".$tmpimg.":]";
			    $imgs[$i] .= '[LANG_'.uc($lang).':' .
				'<img name="nb_img_'.$jsid.'" src="'.$tmpimg .
				    '" alt="';
			    if (exists($alt{uc($lang)})) {
				$imgs[$i] .= $alt{uc($lang)};
			    } else {
				$imgs[$i] .= $alt{default};
			    }
			    $imgs[$i] .='" border=0>:]';
			}
		    } else {
			$img[$i] = $defimg;
			$img[$i]  = "$imgbase/$img[$i]" if ($imgbase ne '' and $img[$i] !~ m;^(http://|/););
			    if ($img[$i] !~ m;^http://;) {
				$img[$i]  = &canonpath($img[$i]);
                                &{$imgstyle{$imgstyle}}($img[$i], 
							 $txt{default},
							 $i,
							 $idlevel,
							 "",
							 $id) 
				    unless -e $img[$i] || 
					!exists($imgstyle{$imgstyle});
			    }
			$imgs[$i] = '<img name="nb_img_'.$jsid.'" src="'.$img[$i].'" alt="'.$alt{default}.'" border=0>'
		    }
		}
		
		if ($select eq $id and not $subselected) {
		    $O .= $imgs[1];
		}
		elsif ($select eq $id and $subselected) {
		    $js = '';
		    if ($#img == 2) {
			$js = qq# onMouseOver="nb_imgOver('nb_img_$jsid', '$hint'); return true"# .
			    qq# onMouseOut="nb_imgSelect('nb_img_$jsid'); return true"#;
			push(@preload, [ $jsid, "s:$img[1]", "o:$img[2]" ]);
		    }
		    elsif ($hint ne '') {
			$js = qq# onMouseOver="self.status = '$hint'; return true"# .
			    qq# onMouseOut="self.status = ''; return true"#;
		    }
		    $O .= '<a href="'.$url.'"'.$target.$js.'>' .
			$imgs[1] .
			    '</a>';
		}
		else { # not selected 
		    $js = '';
		    if ($#img == 2) {
			$js = qq# onMouseOver="nb_imgOver('nb_img_$jsid', '$hint'); return true"# .
			    qq# onMouseOut="nb_imgNormal('nb_img_$jsid'); return true"#;
			push(@preload, [ $jsid, "n:$img[0]", "o:$img[2]" ]);
		    }
		    elsif ($hint ne '') {
			$js = qq# onMouseOver="self.status = '$hint'; return true"# .
			    qq# onMouseOut="self.status = ''; return true"#;
		    }
		    $O .= '<a href="'.$url.'"'.$target.$js.'>' .
			$imgs[0] .
			    '</a>';
		}
	    }

	    #
	    #   EPILOG
	    #


	    $O .= $CFG->{SUBEPILOG}->[$idlevel];

	    #   output corresponding epilog for this type of button
	  L2: foreach $type (@Ltype) {
	      foreach $pos (($n, 'any')) {
		  if ($CFG->{EPILOG}->{$type}->{$pos}) {
		      $mcode = $CFG->{EPILOG}->{$type}->{$pos};
		      $mcode =~ s|^\s+||;
		      $mcode =~ s|\s+$||;
		      $O .= $mcode."\n";
		      last L2;
		  }
	      }
	  }
        }

    }

    #   output the global footer
    $mcode = $CFG->{FOOTER};
    $mcode =~ s|^\s+||;
    $mcode =~ s|\s+$||;
    $O .= $mcode."\n";

    #   prefix the output with some JavaScript
    #   aux functions and the preloading of used images
    if ($#preload >= 0 && ! $nopreload) {
        $P = '';
        $P .= q(<javascript>);
        $P .= "function nb_imgNormal(imgName) {\n";
        $P .= "    if (document.images) {\n";
        $P .= "        document[imgName].src = eval(imgName + \"_n.src\");\n";
        $P .= "        self.status = '';\n" unless $nohints;
        $P .= "    }\n";
        $P .= "}\n";
        $P .= "function nb_imgSelect(imgName) {\n";
        $P .= "    if (document.images) {\n";
        $P .= "        document[imgName].src = eval(imgName + \"_s.src\");\n";
        $P .= "        self.status = '';\n" unless $nohints;
        $P .= "    }\n";
        $P .= "}\n";
        $P .= "function nb_imgOver(imgName, descript) {\n";
        $P .= "    if (document.images) {\n";
        $P .= "        document[imgName].src = eval(imgName + \"_o.src\");\n";
        $P .= "        self.status = descript;\n" unless $nohints;
        $P .= "    }\n";
        $P .= "}\n";
        $P .= "if (document.images) {\n";
        foreach $p (@preload) {
            my $name = $p->[0];
            my ($normtag, $normpath) = ($p->[1] =~ m|^([nso]):(.+)$|);
            my ($overtag, $overpath) = ($p->[2] =~ m|^([nso]):(.+)$|);
            $P .= "    nb_img_${name}_${normtag} = new Image();\n";
            $P .= "    nb_img_${name}_${normtag}.src = \"$normpath\";\n";
            $P .= "    nb_img_${name}_${overtag} = new Image();\n";
            $P .= "    nb_img_${name}_${overtag}.src = \"$overpath\";\n";
        }
        $P .= "}\n";
        $P .= q(</javascript>);
        $O = $P.$O;
    }

    #   additionally apply an existing Perl filter
    if ($filter ne '') {
        eval("\$filter_func = sub {" . $filter . "};");
        $O = &{$filter_func}($O, $CFG, $select);
    }

    #   finally produce the HTML markup code
    print $O;
}:>
<restore imgstyle>
<restore languages>
<restore nopreload>
<restore nohints>
<restore txtonly>
<restore subselected>
<restore select>
<restore name>
</define-tag>

##EOF##