#!/usr/bin/perl -w
use strict;
use Tk;
use vars qw(@list);
open (PWD, "../PWD")
or die "Could not open PWD for reading!";
my @dbiparms;
while(<PWD>) {
chomp;
push @dbiparms, $_;
}
close (PWD);
use DBI;
my $dbh = DBI->connect(@dbiparms);
if ( !defined $dbh ) {
die $DBI::errstr;
}
my $tree = new DBIx::Tree( connection => $dbh,
table => 'food',
method => sub { disp_tree(@_) },
columns => ['food_id', 'food', 'parent_id'],
start_id => '001');
$tree->traverse;
my $mw = MainWindow->new();
my $hlist = $mw->HList(
-itemtype => 'text',
-separator => '/',
-width => -1,
-height => 10,
-selectmode => 'single',
);
my $scroll = $mw->Scrollbar(-command => ['yview', $hlist]);
$hlist->configure(-yscrollcommand => ['set', $scroll]);
$hlist->pack(-side => 'left', -fill => 'y', -expand => 1);
$scroll->pack(-side => 'right', -fill => 'y');
foreach ( '/', @list ) {
my $text;
$text = (split( /\//, $_ ))[-1];
$hlist->add($_, -text=>$text);
}
MainLoop;
sub disp_tree {
my %parms = @_;
my $item = $parms{item};
my @parent_name = @{ $parms{parent_name} };
my $treeval;
foreach (@parent_name) {
s/^\s+//;
s/\s+$//;
$treeval .= "$_/";
}
$item =~ s/^\s+//;
$item =~ s/\s+$//;
$treeval .= $item;
push @list, $treeval;
}
############# close the dbh
$dbh->disconnect;