view release on metacpan or  search on metacpan

Tixish/DirTree.pm  view on Meta::CPAN

package Tk::DirTree;
# DirTree -- TixDirTree widget
#
# Derived from DirTree.tcl in Tix 4.1
#
# Chris Dean <ctdean@cogit.com>

use strict;
use vars qw($VERSION);
$VERSION = '4.022';

use Tk;
use Tk::Derived;
use Tk::Tree;
use Cwd;
use DirHandle;
use File::Spec qw();

use base  qw(Tk::Derived Tk::Tree);
use strict;

Construct Tk::Widget 'DirTree';

my $sep = $^O eq 'MSWin32' ? '\\' : '/';

*_fs_encode = eval { require Encode; 1 } ? sub { Encode::encode("iso-8859-1", $_[0]) } : sub { $_[0] };

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 => $sep,
		    -itemtype => 'imagetext',
		  );
}

sub DirCmd {
    my( $w, $dir, $showhidden ) = @_;
    $dir .= $sep 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:$!"
  }
 $path = File::Spec->canonpath($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]);