Initial commit of OpenSPARC T2 design and verification files.

[OpenSPARC-T2-DV] / tools / perl-5.8.0 / lib / site_perl / 5.8.0 / sun4-solaris / Tk / DirTree.pm

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

use vars qw($VERSION);
$VERSION = '3.023'; # $Id: //depot/Tk8/Tixish/DirTree.pm#23 $

use Tk;
use Tk::Derived;
use Tk::Tree;
use Cwd;
use DirHandle;

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

Construct Tk::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 ) = @_;

    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 (chdir($path))
  {
   $path = getcwd();
   chdir($cwd) || die "Cannot cd back to $cwd:$!";
  }
 else
  {
   warn "Cannot cd to $path:$!"
  }
 return $path;
}

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

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

    my $parent = '/';
    if ($^O eq 'MSWin32')
     {
      if ($fulldir =~ s/^([a-z]:)//i)
       {
        $parent = $1;
       }
     }
    $w->add_to_tree( $parent, $parent)  unless $w->infoExists($parent);

    my @dirs = ($parent);
    foreach my $name (split( /[\/\\]/, $fulldir )) {
        next unless length $name;
        push @dirs, $name;
        my $dir = join( '/', @dirs );
        $w->add_to_tree( $dir, $name, $parent )
            unless $w->infoExists( $dir );
        $parent = $dir;
    }

    $w->OpenCmd( $parent );
    $w->setmode( $parent, 'close' );
}


sub OpenCmd {
    my( $w, $dir ) = @_;

    my $parent = $dir;
    $dir = '' if $dir eq '/';
    foreach my $name ($w->dirnames( $parent )) {
        next if ($name eq '.' || $name eq '..');
        my $subdir = "$dir/$name";
        next unless -d $subdir;
        if( $w->infoExists( $subdir ) ) {
            $w->show( -entry => $subdir );
        } else {
            $w->add_to_tree( $subdir, $name, $parent );
        }
    }
}

*opencmd = \&OpenCmd;

sub add_to_tree {
    my( $w, $dir, $name, $parent ) = @_;

    my $image = $w->Getimage( $w->cget('-image') );
    my $mode = 'none';
    $mode = 'open' if $w->has_subdir( $dir );

    my @args = (-image => $image, -text => $name);
    if( $parent ) {             # Add in alphabetical order.
        foreach my $sib ($w->infoChildren( $parent )) {
            if( $sib gt $dir ) {
                push @args, (-before => $sib);
                last;
            }
        }
    }

    $w->add( $dir, @args );
    $w->setmode( $dir, $mode );
}

sub has_subdir {
    my( $w, $dir ) = @_;
    foreach my $name ($w->dirnames( $dir )) {
        next if ($name eq '.' || $name eq '..');
        next if ($name =~ /^\.+$/);
        return( 1 ) if -d "$dir/$name";
    }
    return( 0 );
}

sub dirnames {
    my( $w, $dir ) = @_;
    my @names = $w->Callback( '-dircmd', $dir, $w->cget( '-showhidden' ) );
    return( @names );
}

__END__

#  Copyright (c) 1996, Expert Interface Technologies
#  See the file "license.terms" for information on usage and redistribution
#  of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#  The file man.macros and some of the macros used by this file are
#  copyrighted: (c) 1990 The Regents of the University of California.
#               (c) 1994-1995 Sun Microsystems, Inc.
#  The license terms of the Tcl/Tk distrobution are in the file
#  license.tcl.