use Tie::OrderedHash;

package HTML::Tree;

sub treetrunk {    # where and what your control images are
  return {
    next => {
      collapsed   => "tree_next_collapsed.gif", 
      expanded   => "tree_next_expanded.gif", 
      spacer   => "tree_next_spacer.gif", 
      leaf     => "tree_next.gif", 
    }, 
    last => {
      collapsed   => "tree_last_collapsed.gif", 
      expanded   => "tree_last_expanded.gif", 
      spacer   => "tree_last_spacer.gif", 
      leaf     => "tree_last.gif", 
    }, 
  };
);

sub control_img_tribs {
  return {
    width =>  19, 
    height =>  16, 
    border =>  0, 
    align =>  'absmiddle', 
    vspace =>  0, 
    hspace =>   0, 
    alt =>  '', 
  };
);

sub icon_img_tribs {
  return {
    width =>  16, 
    height =>  16, 
    border =>  0, 
    align =>  'absmiddle', 
    vspace =>  0, 
    hspace =>   0, 
    alt =>  '', 
  };
);

sub link_tribs {
  return {
    #  target=>"right_panel", # or wherever you want
  };
);

sub control_link_tribs {
  return {
    #  target => "_self",     # normally skipped or set to _self
  };
};

%label_style = (
  "color"            => "#000000", # black
  "background-color" => "#ffffff", # on white
  "text-decoration"  => "none",    # no underlined links
);

%selected_label_style = (          # selections are
  "color"            => "#ffffff", # white
  "background-color" => "#0000ff", # on blue
  "text-decoration"  => "none",     
);

# these are illegal characters in a label:
$path_specifier="/"; # used to separate labels in a path string
$path_delimiter=";"; # used to separate paths in a path list string





package HTML::Tree::Node;

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

  # root name/value pairs
  die "odd parms for new item [called from $caller]" if @_%2;

  my %parms=@_;

  # pull out subs
  my $subs= delete $parms{subs} if exists $parms{subs};

  my (%selfhash, %subs);
  tie %selfhash, 'Tie::OrderedHash';
  tie %subs,     'Tie::OrderedHash';

  %selfhash=(%parms, subs =>\%subs );
  
  my @valid_tribs=qw(
    show
    label
    selected
    icon
    link
    expanded
  );

  for (keys %selfhash) {
    die "unknown new item attribute '$_' [called from $caller]" 
      unless grep /^$_$/, @valid_tribs;
  }
  for $char ($path_specifier, $path_delimiter) {
    die "illegal character '$char' in new label '$selfhash{label}' [called from $caller]" 
      if $char and exists($selfhash{label}) and $selfhash{label} =~/$char/;
  }

  my $self = \%selfhash; 
  bless $self, $class;    

  if (defined $subs) {
    die "new subs attribute not an object or (hash) reference [called from $caller]" 
      unless ref($subs);
    if (ref($subs) =~/^ARRAY/) {
      die "odd length arrayref for new subs [called from $caller]"
        if scalar(@{$subs}) %2;
      $self->add_subs(@{$subs});
    }
    elsif (ref($subs) =~/^HASH/) { # no order - sort by key names
      $self->add_subs(map {$_, $subs->{$_}} sort keys %{$subs});
    }
    elsif (ref($subs)) { # some other reference passed - might already be a Tree:Item
       # or a subclass, so we'll just re-assign it and trust the caller
       # that it acts like a subs hash reference 
      $self->{subs}=$subs;
    }
    else {
      die "new subs trib not a hashref, arrayref or other ref (object)";
    }
  }
  return $self;
}

sub add_sub {
  my ($caller_pkg, $caller_file, $caller_line) = caller;
  my $caller = "$caller_pkg::$caller_file line $caller_line";
  my $self=shift;
  my $class=ref($self) || die "$self is not an object [called from $caller]";

  die "odd parms for new sub [called from $caller]" if @_%2;
  my %newsub=@_;

  die "new sub needs a label" unless $newsub{label};

  for $char ($path_specifier, $path_delimiter) {
    die "illegal character '$char' in label '$newsub{label}' [called from $caller]" 
      if $char and exists($newsub{label}) and $newsub{label} =~/$char/;
  }

  $self->{subs}->{$newsub{label}}=new HTML::Tree (%newsub);
}

sub add_subs { # add multiple subs, specified as a list of label/hashref pairs
  my ($caller_pkg, $caller_file, $caller_line) = caller;
  my $caller = "$caller_pkg::$caller_file line $caller_line";
  my $self=shift;
  my $class=ref($self) || die "$self is not an object [called from $caller]";

  die "odd parms for new subs list [called from $caller]" if @_%2;
  my %newsubs;
  tie %newsubs, 'Tie::OrderedHoH';
  %newsubs=@_;

  my $subcount;
  for $label (keys %newsubs) {
    $subcount++;
    die "new sub $subcount ('$label') not a hashref"
      unless ref($newsubs{$label}) =~ /^HASH/;
    $self->add_sub(%{$newsubs{$label}}, label=> $label);
  }
  return $subcount;
}

sub select {
  my ($caller_pkg, $caller_file, $caller_line) = caller;
  my $caller = "$caller_pkg::$caller_file line $caller_line";
  my $self=shift;
  my $class=ref($self) || die "$self is not an object [called from $caller]";

  my $path=shift;
  my @path=split /$path_specifier/, $path;
  my $item = $self;
  my $foundpath;

  if ($path eq $path_specifier) { # root
    $self->{selected}=1;
    return;    
  }
  for $label (@path) {
    die "path '$foundpath$label' not found" unless exists $item->{subs}->{$label};
    $item = $item->{subs}->{$label};
    $foundpath .= $label.$path_specifier;
  }
  $item->{selected}=1;
}

sub unselect {
  my ($caller_pkg, $caller_file, $caller_line) = caller;
  my $caller = "$caller_pkg::$caller_file line $caller_line";
  my $self=shift;
  my $class=ref($self) || die "$self is not an object [called from $caller]";

  my $path=shift;
  my @path=split /$path_specifier/, $path;
  my $item = $self;
  my $foundpath;

  if ($path eq $path_specifier) { # root
    $self->{selected}=0;
    return;    
  }
  for $label (@path) {
    die "path '$foundpath$label' not found" unless exists $item->{subs}->{$label};
    $item = $item->{subs}->{$label};
    $foundpath .= $label.$path_specifier;
  }
  $item->{selected}=0;
}

sub expand {
  my ($caller_pkg, $caller_file, $caller_line) = caller;
  my $caller = "$caller_pkg::$caller_file line $caller_line";
  my $self=shift;
  my $class=ref($self) || die "$self is not an object [called from $caller]";

  my $path=shift;
  my @path=split /$path_specifier/, $path;
  my $item = $self;
  my $foundpath;

  if ($path eq $path_specifier) { # root
    $self->{expanded}=1;
    return;    
  }
  for $label (@path) {
    die "path '$foundpath$label' not found" unless exists $item->{subs}->{$label};
    $item = $item->{subs}->{$label};
    $foundpath .= $label.$path_specifier;
  }
  $item->{expanded}=1;
}

sub expand_to {
  my ($caller_pkg, $caller_file, $caller_line) = caller;
  my $caller = "$caller_pkg::$caller_file line $caller_line";
  my $self=shift;
  my $class=ref($self) || die "$self is not an object [called from $caller]";

  my $path=shift;
  my @path=split /$path_specifier/, $path;
  pop @path; # we only want to expand *to* it, not expand *it*
  my $item = $self;
  $item->{expanded}=1;
  my $foundpath;

  if ($path eq $path_specifier) { # root
    return;    
  }
  for $label (@path) {
    die "path '$foundpath$label' not found" unless exists $item->{subs}->{$label};
    $item = $item->{subs}->{$label};
    $foundpath .= $label.$path_specifier;
    $item->{expanded}=1;
  }
}

sub collapse {
  my ($caller_pkg, $caller_file, $caller_line) = caller;
  my $caller = "$caller_pkg::$caller_file line $caller_line";
  my $self=shift;
  my $class=ref($self) || die "$self is not an object [called from $caller]";

  my $path=shift;
  my @path=split /$path_specifier/, $path;
  my $item = $self;
  my $foundpath;

  if ($path eq $path_specifier) { # root
    $self->{expanded}=0;
    return;    
  }
  for $label (@path) {
    die "path '$foundpath$label' not found" unless exists $item->{subs}->{$label};
    $item = $item->{subs}->{$label};
    $foundpath .= $label.$path_specifier;
  }
  $item->{expanded}=0;
}

sub display {
  my ($caller_pkg, $caller_file, $caller_line) = caller;
  my $caller = "$caller_pkg::$caller_file line $caller_line";
  my $self=shift;
  my $class=ref($self) || die "$self is not an object [called from $caller]";

  die "odd parms passed to display" if @_%2;
  my %parms=(@_);

  # parms can be 
  #   method => "array"
  # or
  #   method => "delimited"
  #   method => "column_delimiter"
  #   method => "row_delimiter"
  #  
  # the array method will build the display and return it to the caller for
  # further processing, while the delimited method will cause this function
  # to separate the controls and lines with the delimiters specified
  # and print them to standard output immediately

  my $method = $parms{method} if $parms{method};
  die "unrecognized display method '$parms{method}'" 
    if  $parms{method} and $parms{method} !~/^(array)|(delimited)$/;
  
  my @display;

  my $label=$self->{label};
  my $show=$self->{show} || $self->{label};
  my $icon='<img src="'.$self->{icon}.'" '.
    join (" ", map "$_=\"" . $self->icon_img_tribs->{$_} . "\"", keys %{$self->icon_img_tribs}) .">" 
    if $self->{icon};

  my %spantags;
  $spantags{style} = $self->{selected} 
    ? join ("; ", map "$_: $selected_label_style{$_}", keys %selected_label_style) 
    : join ("; ", map "$_: $label_style{$_}", keys %label_style);

  $spantags{onclick}=$self->{onclick} unless $self->{link} || !exists($self->{onclick});

  my $spanned_label = "<span".
    join ("", map " $_=\"$spantags{$_}\"", keys %spantags) .
    ">". &HTMLEncode($show) ."&nbsp;</span>"; 

  my ($linked_icon, $linked_label); 
  if ($self->{link}) {
    my %these_tribs = %{$self->link_tribs};
    %these_tribs=(%these_tribs, %{$self->{link_tribs}}) if $self->{link_tribs};
    $these_tribs{href} = $self->{link};
    $these_tribs{onclick} = $self->{onclick} if exists $self->{onclick};
    
    $linked_icon = "<a ". 
      join (" ", map "$_=\"$these_tribs{$_}\"", keys %these_tribs) .
      ">$icon</a>" if $icon;
    $linked_label = "<a ". 
      join (" ", map "$_=\"$these_tribs{$_}\"", keys %these_tribs) .
      ">$spanned_label</a>";
  }
  else {
    $linked_icon = $icon if $icon;
    $linked_label = $spanned_label;
  }

  if ($self->{selected}) {
    if ($linked_icon) {
      $linked_icon="<span id=MyItem>$linked_icon</span>";
    }
    else {
      $linked_label="<span id=MyItem>$linked_label</span>";
    }
  }

  my @links;
  push @links, $linked_icon if $linked_icon;
  push @links, "&nbsp;$linked_label";
  push @display, [@links];

  if ($self->{expanded}) {
    my $itemcount=scalar keys %{$self->{subs}};
    my $itemnum;
    for $sub_label (keys %{$self->{subs}}) {
      my $item=$self->{subs}->{$sub_label};
      $itemnum++;
      my $which= $itemnum < $itemcount ? 'next':'last';
      my $state = keys %{$item->{subs}} ? 
        ($item->{expanded} ? 'expanded' : 'collapsed') : 'leaf';
      my $control = "<img src=\"".$self->treetrunk->{$which}{$state}."\" " .
        join (" ", map "$_=\"" . $self->control_img_tribs->{$_} . " \"", keys %{$self->control_img_tribs}) .">"; 
      my $spacer = "<img src=\"".$self->treetrunk->{$which}{spacer}."\" " .
        join (" ", map "$_=\"" . $self->control_img_tribs->{$_} . "\"", keys %{$self->control_img_tribs}) .">";
      
      my $control_link;
      unless ($state eq 'leaf') {
        if ($state eq 'expanded' and $item->{collapse_link}) {
          $control_link=$item->{collapse_link}
        }
        if ($state eq 'collapsed' and $item->{expand_link}) {
          $control_link=$item->{expand_link};
        }
      }
      my $control_tagged;
      if ($control_link) {
        $self->control_link_tribs->{href}=$control_link;
        $control_tagged= "<a ".join (" ", 
          map "$_=\"" . $self->control_link_tribs->{$_} . "\"", keys %{$self->control_link_tribs}
        ) .">$control</a>";
      }
      else {
        $control_tagged=$control;
      }

      my @subs_display=$item->display(method=>'array');

      push @display, [$control_tagged, @{shift @subs_display}];
      while (@subs_display) {
        push @display, [$spacer, @{shift @subs_display}];
      }
    }
  }
  if ($method eq 'array') {
    return @display ;
  }
  else {
    print join "$parms{row_delimiter}", (
      map join ("$parms{column_delimiter}", @{$_}), @display
    )
  }
}

sub URLEncode{
  my $string=shift;

  # encode just URL-breaking characters
  $string=~s/([+#"&=])/"%". sprintf "%lx", unpack("C", $1)/eg;

  # encode all non-alphanumics
  # $string=~s/([^a-zA-Z0-9])/"%". sprintf "%lx", unpack("C", $1)/eg;

  return $string;
}

sub HTMLEncode{
  my $string=shift;
  my @ent=(
    '&' => '&amp;',  # amp has to come first
    '>' => '&gt;', 
    '<' => '&lt;', 
    '"' => '&quot;', 
  );
  while (@ent) {
    my ($char, $ent) = (shift @ent, shift @ent);
    $string =~ s/$char/$ent/g; 
  }
  return $string;
}


1;

__END__

=head1 NAME 

HTML::Tree - Perl module to generate Hierarchical Tree widgets for HTML 
Navigation which can are expandable and collapsable


=head1 DESCRIPTION

This module enables a CGI program to generate and control a nested tree 
visually similar to the folder trees used by graphical operating systems to 
navigate the file system, and preserve the state of that tree, such as what
node is currently selected and which nodes are expanded or collapsed, across
multiple invocations of the calling script, that is to say, as a visitor 
moves from page to page of your web application or around your website.


=head1 SYNOPSIS

  # instantiate a new Tree object
  $mytree=new HTML::Tree;
  

=head1 COPYRIGHT

    HTML::Tree - HTML Hierarchical Expandable Collapsable Tree Navigation 
    widget generator
    
    Copyright (C) 2000 Power Data Development

    Support, upgrades and custom implementations are available from 
    Power Data Development http://power-data.com

    Please direct inquiries about this software to program@power-data.com 
    General inquiries may be sent to info@power-data.com 

    This library is free software; you can redistribute it and/or
    modify it under the terms of the GNU Lesser General Public
    License as published by the Free Software Foundation; either
    version 2.1 of the License, or (at your option) any later version.
 
    This library is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
    Lesser General Public License for more details.
    
    You should have received a copy of the GNU Lesser General Public
    License along with this library; if not, write to the Free Software
    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

    Or you can grab a copy from http://power-data.com/lgpl-license.html

=head1 AUTHOR

David Kaufman, dkaufman@power-data.com
    
=cut