view release on metacpan or  search on metacpan

lib/Tcl/pTk/DirTree.pm  view on Meta::CPAN

package Tcl::pTk::DirTree;
# DirTree -- TixDirTree widget
#
# Derived from DirTree.tcl in Tix 4.1
#
# Chris Dean <ctdean@cogit.com>
#
# John Cerney 10/24/08: Modified for Tcl::pTk

our ($VERSION) = ('1.11');

use Tcl::pTk;
use Tcl::pTk::Derived;
use Tcl::pTk::Tree;
use Cwd;
use DirHandle;

use base  qw(Tcl::pTk::Derived Tcl::pTk::Tree);
use strict;

Construct Tcl::pTk::Widget 'DirTree';


sub Populate {
    my( $cw, $args ) = @_;

    $cw->SUPER::Populate( $args );

    $cw->ConfigSpecs(
        -dircmd         => [qw/CALLBACK dirCmd DirCmd DirCmd/],
        -showhidden     => [qw/PASSIVE showHidden ShowHidden 0/],
        -image          => [qw/PASSIVE image Image folder/],
        -directory      => [qw/SETMETHOD directory Directory ./],
        -value          => '-directory' );

    $cw->configure( -separator => '/', -itemtype => 'imagetext' );
}

sub DirCmd {
    my( $w, $dir, $showhidden ) = @_;
    $dir .= "/" if $dir =~ /^[a-z]:$/i and $^O eq 'MSWin32';
    my $h = DirHandle->new( $dir ) or return();
    my @names = grep( $_ ne '.' && $_ ne '..', $h->read );
    @names = grep( ! /^[.]/, @names ) unless $showhidden;
    return( @names );
}

*dircmd = \&DirCmd;

sub fullpath
{
 my ($path) = @_;
 my $cwd = getcwd();
 if (CORE::chdir($path))
  {
   $path = getcwd();
   CORE::chdir($cwd) || die "Cannot cd back to $cwd:$!";
  }
 else
  {
   warn "Cannot cd to $path:$!"
  }
 return $path;
}

sub directory
{
    my ($w,$key,$val) = @_;
    # We need a value for -image, so its being undefined
    # is probably caused by order of handling config defaults
    # so defer it.
    $w->afterIdle([$w, 'set_dir' => $val]);
}

sub set_dir {
    my( $w, $val ) = @_;
    my $fulldir = fullpath( $val );