The London Perl and Raku Workshop takes place on 26th Oct 2024. If your company depends on Perl, please consider sponsoring and/or attending.
#!/usr/bin/env perl

use strict;
use warnings;

use DBI;

use DBIx::Tree;

use File::Spec;
use File::Temp;

use Tk;
use Tk::Tree;
use Tk::Label;

use vars qw(@list);   # the list of items in the tree.

my($dir)  = File::Temp -> newdir;
my($file) = File::Spec -> catfile($dir, 'test.sqlite');
my(@opts) =
(
$ENV{DBI_DSN}  || "dbi:SQLite:dbname=$file",
$ENV{DBI_USER} || '',
$ENV{DBI_PASS} || '',
);

my $dbh = DBI->connect(@opts, {RaiseError => 0, PrintError => 1, AutoCommit => 1});

if ( !defined $dbh ) {
    die $DBI::errstr;
}

# Create a new instance of the DBIx::Tree object.
#
my $dbtree = new DBIx::Tree( connection => $dbh,
                            table      => 'food',
                            method     => sub { disp_tree(@_) },
                            columns    => ['id', 'food', 'parent_id'],
                            start_id   => '001');

# Execute the query, and form the tree.
#
$dbtree->traverse;

# Create a new main window.
#
my $top = new MainWindow( -title  => "Tree" );

# Create a scrolled Tree widget.  Behind the scenes, we're forming
# each of the tree elements as a directory style listing. For example,
# Skim Milk is represented as "Dairy/Beverages/Skim Milk".  As long
# as we add the elements in the order in which they appear in the
# tree, the tree will be able to figure out which element is the
# parent of each node we add.
#
my $tree = $top->Scrolled( 'Tree',
                           -separator       => '/',
                           -exportselection => 1,
                           -scrollbars      => 'osoe',
                           -height => 20,
                           -width  => -1);
# Pack the tree.
#
$tree->pack( -expand => 'yes',
             -fill   => 'both',
             -padx   => 10,
             -pady   => 10,
             -side   => 'top' );

# When we ran $dbtree->tree earlier, the @list array was populated.
# It doesn't have a top element, so we need to pre-pend one to the
# list ('/' below).
#
foreach ( '/', @list ) {

    # We don't want the user to see "Dairy/Beverages/Skim Milk",
    # so we'll strip off all but the last words for the label.
    #
    my $text = (split( /\//, $_ ))[-1];

    # If we're on /, let's make its label blank.
    #
    if ($_ eq '/') {
        $text = "";
    }

    # Add the item (in $_) with $text as the label.
    #
    $tree->add( $_, -text => $text );

}

$tree->autosetmode();

my $ok = $top->Button( -text      => 'Ok',
                       -underline => 0,
                       -width     => 6,
                       -command   => sub { $dbh->disconnect; exit } );

my $cancel = $top->Button( -text      => 'Cancel',
                           -underline => 0,
                           -width     => 6,
                           -command   => sub { $dbh->disconnect; exit } );

$ok->pack( -side => 'left', -padx => 10,  -pady => 10 );
$cancel->pack( -side => 'right', -padx => 10, -pady => 10 );

MainLoop();
$dbh->disconnect;

# This is the callback for the $dbtree->tree method. Each time
# A node is added, this method is called.
#
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;
}