##
##  wml::des::navbar -- Navigation Bar
##  Copyright (c) 1997-2001 Ralf S. Engelschall, All Rights Reserved. 
##  Copyright (c) 1999-2001 Denis Barbier
##

#  The <preserve>/<restore> tags with multiple arguments require WML 2.0.3
#use wml::mod::version
<require 2.0.3 />

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

<set-var __nbcount=0 />

#
#   navbar definition
#
<define-tag navbar:define endtag=required>
<preserve name imgstar imgbase urlbase target txtcol_normal txtcol_select />
<set-var %attributes />
<defvar name "unknown-navbar" />
<defvar imgstar "n:s:o" />
<set-var __countbuttons=1 />
<perl> 
  #   The $name variable is used in other <navbar:*> tags and
  #   so is global
  $name = '<get-var name />';
  {
    my ($p, $i);

    #   initialise the data structure for this particular navbar
    #   and fill it with some already known information
    my $CFG = {};
    $NAVBAR{$name} = $CFG;

    $CFG->{NAME} = $name;

    $CFG->{IMGSTAR}  = '<get-var imgstar />';
    $CFG->{IMGBASE}  = '<get-var imgbase />';
    $CFG->{URLBASE}  = '<get-var urlbase />';
    $CFG->{TARGET}   = '<get-var target />';
    $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->{EPILOG} = {};
    $CFG->{EPILOG}->{N}  = {};
    $CFG->{EPILOG}->{S}  = {};
    $CFG->{EPILOG}->{SS} = {};
    $CFG->{EPILOG}->{N}->{'any'} = "\n";

    $CFG->{BUTTON} = [];

    $CFG->{OPEN}  = 0;
    $CFG->{INDEX} = 0;

    $CFG->{PREV}   = '';
    $CFG->{NEXT}   = '';
    $CFG->{UP}     = '';

    $CFG->{FILTER} = '';

    #   here the other tags now fill in more information...
</perl>
%body
<perl>
    #   ...and finally we do some cleanups

    $last = $#{$NAVBAR{$name}->{BUTTON}}+1;
    foreach $what (qw(PROLOG EPILOG)) {
        foreach $type (qw(N S SS)) {
            foreach $pos (keys(%{$NAVBAR{$name}->{$what}->{$type}})) {
                if ($pos eq 'first') {
                    $NAVBAR{$name}->{$what}->{$type}->{1} =
                        $NAVBAR{$name}->{$what}->{$type}->{$pos};
                    delete $NAVBAR{$name}->{$what}->{$type}->{$pos};
                }
                elsif ($pos eq 'last') {
                    $NAVBAR{$name}->{$what}->{$type}->{$last} =
                        $NAVBAR{$name}->{$what}->{$type}->{$pos};
                    delete $NAVBAR{$name}->{$what}->{$type}->{$pos};
                }
                elsif ($pos !~ m;^(any|\d+)$;) {
                    foreach $p (split(',', $pos)) {
                        my $pfirst = 1;
                        my $plast  = $last;
                        my $pstep  = 1;
                        if ($p =~ m|:(\d+)$|) {
                            $pstep = $1;
                            $p     = $`;
                        }
                        if ($p =~ m|^(\d+)|) {
                            $pfirst = $1;
                        }
                        if ($p =~ m|(\d+)$|) {
                            $plast = $1;
                        }
                        for ($i = $pfirst; $i <= $plast; $i+=$pstep) {
                            $NAVBAR{$name}->{$what}->{$type}->{$i} =
                                $NAVBAR{$name}->{$what}->{$type}->{$pos};
                        }
                    }
                    delete $NAVBAR{$name}->{$what}->{$type}->{$pos};
                }
            }
        }
    }
  }
</perl>
<restore  name imgstar imgbase urlbase target txtcol_normal txtcol_select />
</define-tag>

<define-tag navbar:header endtag=required>
<perl>
    <perl:assign $_navvar>%body</perl:assign>
    $NAVBAR{$name}->{HEADER} = $_navvar;
</perl>
</define-tag>

<define-tag navbar:footer endtag=required>
<perl>
    <perl:assign $_navvar>%body</perl:assign>
    $NAVBAR{$name}->{FOOTER} = $_navvar;
</perl>
</define-tag>

<define-tag navbar:prolog endtag=required>
<preserve type pos />
<set-var %attributes />
<defvar type "N" />
<defvar pos "any" />
<subst-in-var pos "next" <get-var __countbuttons /> />
<perl>
    <perl:assign $_navvar>%body</perl:assign>
    $NAVBAR{$name}
        ->{PROLOG}
        ->{'<get-var type />'}
        ->{'<get-var pos />'} = $_navvar;
</perl>
<restore  type pos />
</define-tag>

<define-tag navbar:epilog endtag=required>
<preserve type pos />
<set-var %attributes />
<defvar type "N" />
<defvar pos "any" />
<subst-in-var pos "next" <get-var __countbuttons /> />
<perl>
    <perl:assign $_navvar>%body</perl:assign>
    $NAVBAR{$name}
        ->{EPILOG}
        ->{'<get-var type />'}
        ->{'<get-var pos />'} = $_navvar;
</perl>
<restore  type pos />
</define-tag>

<define-tag navbar:open endtag=required>
<preserve name />
<set-var %attributes />
<defvar name "unknown-navbar" />
<perl>
    $NAVBAR{'<get-var name />'}->{OPEN} = 1;
</perl>
<restore name />
</define-tag>

#
#   buttons definition
#
<set-var __buttoncnt=1 />
<define-tag navbar:button>
<preserve id alias txt alt img hint url target menu />
<set-var %attributes />
<increment __countbuttons />
<if <get-var alias /> <set-var id= /> />
<if <get-var id /> "" <group
    <set-var id=button<get-var __buttoncnt /> />
    <increment __buttoncnt />
/>/>
#    Skip the navigation buttons
<if <match <get-var url /> "^#[a-zA-Z]+#$" />
    <set-var alias="_nav_" /> />
<subst-in-var id "[^a-zA-Z0-9]" "_" />
<subst-in-var alias "[^a-zA-Z0-9]" "_" />

<perl>
{
    my $B = {};
    push(@{$NAVBAR{$name}->{BUTTON}}, $B);

    $B->{ID}     = '<get-var id />';
    $B->{ALIAS}  = '<get-var alias />';
    $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 />';
    $B->{MENU}   = '<get-var menu />';

    my %tag_attr<get-var id /> = ();
<set-var __list_tags="a\nimg" />
<set-var __list_sel="N\nS\nSS" />
<foreach __tag __list_tags>
  <set-var __nb_attr=<attributes-quote <attributes-extract
        :<get-var __tag />:(.*) %attributes /> /> />
  <foreach __sel __list_sel>
    $tag_attr<get-var id />{'<get-var __tag /><get-var __sel />'} =  qq(<or
      <attributes-quote <attributes-extract
          :<get-var __tag />\\.<get-var __sel />:(.*) %attributes /> />
      <get-var __nb_attr /> />);
  </foreach>
</foreach>
    #   Perform some clean ups
    foreach my $key (keys %tag_attr<get-var id />) {
        $tag_attr<get-var id />{$key} =~ s/^\s*/ /;
        delete $tag_attr<get-var id />{$key} if $tag_attr<get-var id />{$key} =~ m/^\s*$/;
    }
    $B->{TAG_ATTR}= \%tag_attr<get-var id />;
}
</perl>
<restore  id alias txt alt img hint url target menu />
</define-tag>

#   this is a special case since its body can contain any Perl
#   statements, so we use the <<'HERE' syntax.
<define-tag navbar:filter endtag=required>
<perl>
    <perl:assign:sq $_navvar>%body</perl:assign:sq>
    $NAVBAR{$name}->{FILTER} = $_navvar;
</perl>
</define-tag>

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

#
#   navbar indexing
#      * compute automatic links (UP/PREV/NEXT)
#      * determine which menus are open/closed
#
<define-tag navbar:index>
<preserve name select subselected />
<set-var %attributes />
<subst-in-var select "[^a-zA-Z0-9]" "_" />
<defvar name "unknown-navbar" />
<perl>
{
    my $name = '<get-var name />';
    my $subselected = (qq|<get-var subselected />| eq '' ? 1 : 0);

    &navbar_index($NAVBAR{$name}, $name, '<get-var select />', $subselected, '', '', 0);
    $NAVBAR{$name}->{OPEN} = 1;
}
</perl>
<restore  name select subselected />
</define-tag>

#    This does the job.
<protect pass=2>
<:
sub navbar_index {
    my ($CFG, $name, $select, $subselected, $up, $prev, $next) = @_;
    my ($id, $alias);

    #     Stop if this navbar has already been processed
    return if $CFG->{INDEX};
    $CFG->{INDEX} = 1;

    foreach my $B (@{$CFG->{BUTTON}}) {
        $alias = $B->{ALIAS};
        $id    = $B->{ID};
        if ($alias ne '') {
            #     This button is an alias, so it must not be a target
            #     for UP/PREV/NEXT.
            #     If it is a menu, look after, otherwise skip it
            next if $B->{MENU} eq '';

            if ($select eq $id or $select eq $alias) {
                $NAVBAR{$B->{MENU}}->{OPEN} = 1
            }
            ($prev, $next) = &navbar_index($NAVBAR{$B->{MENU}}, $name,
                $select, $subselected, $B->{URL}, $prev, $next);
            $CFG->{OPEN} = 1 if $NAVBAR{$B->{MENU}}->{OPEN};
        }
        else {
            #     Regular button
            if ($next) {
                $NAVBAR{$name}->{NEXT} = $B->{URL};
                $next = 0;
                last;
            }
            if ($select eq $id) {
                $NAVBAR{$name}->{UP}   = $up;
                $NAVBAR{$name}->{PREV} = $prev;
                $CFG->{OPEN} = 1;
                $next = 1;
            }
            if ($B->{MENU} ne '') {
                #     This button opens a menu
                $NAVBAR{$B->{MENU}}->{OPEN} = 1 if ($select eq $id);
                $prev = $B->{URL};
                ($prev, $next) = &navbar_index($NAVBAR{$B->{MENU}}, $name,
                    $select, $subselected, $B->{URL}, $prev, $next);
                $CFG->{OPEN} = 1 if $NAVBAR{$B->{MENU}}->{OPEN};
            }
            else {
                $prev = $B->{URL};
            }
        }
    }
    return ($prev, $next);
}
:>
</protect>

#   This macro must be defined.
<provide-tag lang:current></provide-tag>

#
#   navbar rendering
#
<define-tag navbar:render>
<preserve name select subselected menumode txtonly nohints txtcol_normal txtcol_select />
<set-var subselected=* />
<set-var menumode=inner />
<set-var txtonly=* />
<set-var nohints=* />
<navbar:index %attributes />
<set-var %attributes />
<subst-in-var select "[^a-zA-Z0-9]" "_" />
<increment __nbcount />
<defvar name "unknown-navbar" />
<perl>
sub navbar_render_<get-var __nbcount /><lang:current /> {
    my($name, $select, $subselected, $txtcol_n, $txtcol_s,
       $menumode, $txtonly, $nohints, $nbcount) = @_;

    #   select the correct navigation bar configuration
    my $CFG = $NAVBAR{$name};

    #   retrieve parts of config
    my @imgstar  = split(':', $CFG->{IMGSTAR});
    my $imgbase  = $CFG->{IMGBASE};
    my $urlbase  = $CFG->{URLBASE};
    $txtcol_n    = $CFG->{TXTCOL_N} if $txtcol_n eq '';
    $txtcol_s    = $CFG->{TXTCOL_S} if $txtcol_s eq '';
    my $filter   = $CFG->{FILTER};

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

    my $tag_attr = {};
    #   Initialize extra attributes
    #   This must be done in pass 2
<set-var __list_tags="a\nimg" />
<set-var __list_sel="N\nS\nSS" />
<foreach __tag __list_tags>
  <set-var __nb_attr=<attributes-quote <attributes-extract
        :<get-var __tag />:(.*) %attributes /> /> />
  <foreach __sel __list_sel>
    $tag_attr{'<get-var __tag /><get-var __sel />'} =  qq(<or
      <attributes-quote <attributes-extract
          :<get-var __tag />\\.<get-var __sel />:(.*) %attributes /> />
      <get-var __nb_attr /> />);
  </foreach>
</foreach>

    #   Perform some clean ups
    foreach my $key (keys %tag_attr) {
        $tag_attr{$key} =~ s/^\s*/ /;
        delete $tag_attr{$key} if $tag_attr{$key} =~ m/^\s*$/;
    }

    #   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};
        my $alias  = $B->{ALIAS};
        my $txt    = $B->{TXT};
        my $alt    = $B->{ALT};
        my @img    = split(':', $B->{IMG});
        my $url    = $B->{URL};
        my $target = ($B->{TARGET} eq '' ? $CFG->{TARGET} : $B->{TARGET});
        my $hint   = $B->{HINT};
        my $menu   = $B->{MENU};

        my $idselect = ($select eq $id or ($select eq $alias and $alias ne '') ? 1 : 0);
        my $buttontype = 'N';
        $buttontype = ($subselected ? 'SS' : 'S') if $idselect;
        my %extra_attr = (
                a       => (${$B->{TAG_ATTR}}{'a'.$buttontype} || $tag_attr{'a'.$buttontype}),
                img     => (${$B->{TAG_ATTR}}{'img'.$buttontype} || $tag_attr{'img'.$buttontype}),
        );

        #
        #   PROLOG
        #

        #   determine list of prolog/epilog types to search
        my @Ltype = ($buttontype, 'N');

        #   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;
                }
            }
        }

        #
        #   THE BUTTON ITSELF
        #

        #   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++) {
            $img[$i] = "$imgbase/$img[$i]" if ($imgbase ne '' and 
                                               $img[$i] !~ m;^([.+\-\w]+:)?/;);
            $img[$i] = &canonpath($img[$i]) if ($img[$i] !~ m;^[.+\-\w]+:/;);
        }

        #   cleanup url information
        if ($url =~ m|#([a-zA-Z]+)#|) {
            $url = $NAVBAR{$name}->{uc($1)};
        }
        if ($url ne '') {
            $url  = "$urlbase/$url" if ($urlbase ne '' and $url !~ m;^([.+\-\w]+:)?/;);
            $url  = &canonpath($url) if ($url !~ m;^[.+\-\w]+:/;);
        }

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

        #   alt attribute defaults to txt attribute if missing
        if ($alt eq '') {
            $alt = $txt;
        }

        #   output the button markup code
        if ($#img < 0 or $txtonly) {
            #   cleanup txt information:
            #   special feature for supporting colorized hyperlinks
            if ($idselect and $txtcol_s) {
                $txt = '<*font color="'.$txtcol_s.'">'.$txt.'<*/font>';
            }
            elsif ($txtcol_n) {
                $txt = '<*font color="'.$txtcol_n.'">'.$txt.'<*/font>';
            }
            #
            #   for a button without images
            #
            $hint = $url if ($hint eq '');
            $hint = '' if $nohints;
            if (($idselect and not $subselected) or $url eq '') {
                $O .= $txt;
            }
            else {
                $js = '';
                if ($hint ne '') {
                    $js = qq# onmouseover="self.status = '$hint'; return true"# .
                          qq# onmouseout="self.status = ''; return true"# .
                          qq# onfocus="self.status = '$hint'; return true"# .
                          qq# onblur="self.status = ''; return true"#;
                }
                $O .= '<*a href="'.$url.'"'.$target.$js.$extra_attr{'a'}.'>'.$txt.'<*/a>';
            }
        }
        else {
            #
            #   for a button with images
            #
            $hint = $txt if ($hint eq '');
            $hint = '' if $nohints;
            if (($idselect and not $subselected) or $url eq '') {
                $O .= '<img src="'.$img[1].'" alt="'.$alt.'"'.$extra_attr{'img'}.' />';
            }
            elsif ($idselect and $subselected) {
                $js = '';
                if ($#img == 2) {
                    $js = qq# onmouseover="nb_imgOver('${nb}_$id', $nohints, '$hint'); return true"# .
                          qq# onmouseout="nb_imgSelect('${nb}_$id'); return true"# .
                          qq# onfocus="nb_imgOver('${nb}_$id', $nohints, '$hint'); return true"# .
                          qq# onblur="nb_imgSelect('${nb}_$id'); return true"#;
                    push(@preload, [ $id, "s:$img[1]", "o:$img[2]" ]);
                }
                elsif ($hint ne '') {
                    $js = qq# onmouseover="self.status = '$hint'; return true"# .
                          qq# onmouseout="self.status = ''; return true"# .
                          qq# onfocus="self.status = '$hint'; return true"# .
                          qq# onblur="self.status = ''; return true"#;
                }
                $O .= '<*a href="'.$url.'"'.$target.$js.$extra_attr{'a'}.'>' .
                      '<img name="'.$nb.'_'.$id.'" src="'.$img[1].'" alt="'.$alt.'" border=0'.$extra_attr{'img'}.' />' .
                      '<*/a>';
            }
            else { # not selected 
                $js = '';
                if ($#img == 2) {
                    $js = qq# onmouseover="nb_imgOver('${nb}_$id', $nohints, '$hint'); return true"# .
                          qq# onmouseout="nb_imgNormal('${nb}_$id'); return true"# .
                          qq# onfocus="nb_imgOver('${nb}_$id', $nohints, '$hint'); return true"# .
                          qq# onblur="nb_imgNormal('${nb}_$id'); return true"#;
                    push(@preload, [ $id, "n:$img[0]", "o:$img[2]" ]);
                }
                elsif ($hint ne '') {
                    $js = qq# onmouseover="self.status = '$hint'; return true"# .
                          qq# onmouseout="self.status = ''; return true"# .
                          qq# onfocus="self.status = '$hint'; return true"# .
                          qq# onblur="self.status = ''; return true"#;
                }
                $O .= '<*a href="'.$url.'"'.$target.$js.$extra_attr{'a'}.'>' .
                      '<img name="'.$nb.'_'.$id.'" src="'.$img[0].'" alt="'.$alt.'" border=0'.$extra_attr{'img'}.' />' .
                      '<*/a>';
            }
        }

        if ($menumode eq 'inner' and $menu ne '' and $NAVBAR{"$menu"}->{OPEN}) {
            $O .= &navbar_render_<get-var __nbcount /><lang:current />($menu,
                $select, $subselected, $txtcol_n, $txtcol_s,
                $menumode, $txtonly, $nohints, $nbcount);
        }
        
        #
        #   EPILOG
        #

        #   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|[ \t]+$||;
                    $O .= $mcode;
                    last L2;
                }
            }
        }

        if ($menumode ne 'inner' and $menu ne '' and $NAVBAR{"$menu"}->{OPEN}) {
            $O .= &navbar_render_<get-var __nbcount /><lang:current />($menu,
                $select, $subselected, $txtcol_n, $txtcol_s,
                $menumode, $txtonly, $nohints, $nbcount);
        }
        

    }

    #   output the global footer
    $mcode = $CFG->{FOOTER};
    $mcode =~ s|^\s+||;
    $mcode =~ s|\s+$||;
    $O .= $mcode."\n";
    $P = <<'EOT';
<navbar:jsfuncs />
EOT

    #   prefix the output with some JavaScript
    #   aux functions and the preloading of used images
    if ($#preload >= 0) {
        $P .= <<'EOT';
<javascript>
if (document.images) {
EOT
        foreach $p (@preload) {
            my $name = $p->[0];
            my ($normtag, $normpath) = ($p->[1] =~ m|^([nso]):(.+)$|);
            my ($overtag, $overpath) = ($p->[2] =~ m|^([nso]):(.+)$|);
            $P .= "    ${nb}_${name}_${normtag} = new Image();\n";
            $P .= "    ${nb}_${name}_${normtag}.src = '$normpath';\n";
            $P .= "    ${nb}_${name}_${overtag} = new Image();\n";
            $P .= "    ${nb}_${name}_${overtag}.src = '$overpath';\n";
        }
        $P .= <<'EOT';
}
</javascript>
EOT
        $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
    return $O;
}
{
    #   import attributes to ePerl
    my $select      =  qq|<get-var select />|;
    my $subselected = (qq|<get-var subselected />| eq '' ? 1 : 0);
    my $menumode    =  qq|<get-var menumode />|;
    my $txtonly     = (qq|<get-var txtonly />|     eq '' ? 1 : 0);
    my $nohints     = (qq|<get-var nohints />|     eq '' ? 1 : 0);

    <perl:print: \
       "&navbar_render_<get-var __nbcount /><lang:current />('<get-var name />',
             $select, $subselected,
             '<get-var txtcol_normal />', '<get-var txtcol_select />', 
             $menumode, $txtonly, $nohints, <get-var __nbcount />)" />
}
</perl>
<restore  name select subselected menumode txtonly nohints txtcol_normal txtcol_select />
</define-tag>

<define-tag navbar:jsfuncs>
<javascript>
function nb_imgNormal(imgName) {
    if (document.images) {
        document[imgName].src = eval(imgName + '_n.src');
        self.status = '';
    }
}
function nb_imgSelect(imgName) {
    if (document.images) {
        document[imgName].src = eval(imgName + '_s.src');
        self.status = '';
    }
}
function nb_imgOver(imgName, nohints, descript) {
    if (document.images) {
        document[imgName].src = eval(imgName + '_o.src');
        if (! nohints) self.status = descript;
    }
}
</javascript>
<define-tag navbar:jsfuncs></define-tag>
</define-tag>

##EOF##
