The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl

#demonstrates the usage of the HList widget.

use strict;
use CGI qw(:standard);
use CGI::Widget::HList;
use CGI::Widget::HList::Node;

my $ROOT = '/home/allenday/public_html/dbrowse';

my %o = map {$_=>1} param("o");
my %c = map {$_=>1} param("c");

#lets make the tree
my $root = CGI::Widget::HList::Node->new();
   $root->name("curio/");
   $root->link(\&alink);
   $root->close unless $o{$root->name};
descend($root,$ROOT);

print header();
print start_html;
my $hlist = CGI::Widget::HList->new(-root=>$root,
																		-render_node=>\&nlink,
																		);
print $hlist->html;
print end_html;

#recurse through directories
sub descend {
		my($parent,$base) = @_;
		my @content = get_content($base);

		foreach my $c (@content){
				my $daughter = CGI::Widget::HList::Node->new;
				$parent->add_daughter($daughter);
				$daughter->name("$base/$c");
				$daughter->link(\&alink);
				next if -f "$base/$c";

				$daughter->close unless $o{$c};
				$daughter->pregnant(1) unless $o{$c};

				descend($daughter,"$base/$c") if $o{$c};
		}
}

sub nlink {
		my $node = shift;
		my $name = $node->name;
		$name =~ s!.+/(.+)!$1!;
    my %to = %o;
    my %tc = %c;

    my $img = 
				$node->pregnant  ?     $hlist->img_close  :
				$node->state     ? 
						$node->daughters ? $hlist->img_open :
								$hlist->img_leaf   :
						$node->daughters ? $hlist->img_close  :
								$hlist->img_leaf   ;

		$to{$name} ? delete $to{$name} && $tc{$name}++ 
 		           : $to{$name}++ ;

    my $o = keys %to ? ";o=".join ";o=",keys %to : '' ;
		my $c = keys %tc ? ";c=".join ";c=",keys %tc : '' ;

		my $return = a({-name=>$name});
		$return   .= ($node->daughters || $node->pregnant)
				           ? a({-href=>script_name."?".$o.$c."#".$name},$img)
									 : $img;

		return $return;
}

sub alink {
		my $node = shift;
		my $name = $node->name;
		$name =~ s!.+/(.+)!$1!;

		return font({-size=>"-1"},
           "$name ".(sprintf "%8.2f",((stat $node->name)[7])/1048576)."MB") 
    if -f $node->name;

		return font({-size=>"-1"},$name);
}

sub get_content {
		my $path = shift;
		my @return = ();
    opendir(D,$path);
		foreach my $d (readdir(D)){
				next if $d =~ /^[\.]+$/;
				push @return, $d ;
		}
		closedir(D);
		return sort @return;
}