package Tk::SimpleFileSelect;
my $RCSRevKey = '$Revision: 0.63 $';
$RCSRevKey =~ /Revision: (.*?) /;
$VERSION=0.63;
use vars qw($VERSION @EXPORT_OK);
@EXPORT_OK = qw(glob_to_re);

use Tk qw(Ev);
use strict;
use Carp;
use base qw(Tk::Toplevel);
use Tk::widgets qw(LabEntry Button Frame Listbox Scrollbar);
use File::Basename;

Construct Tk::Widget 'SimpleFileSelect';

sub Cancel {
  my ($cw) = @_;
  $cw -> withdraw;
  return '';
}

sub Accept_dir {
 my ($cw,$new) = @_;
 my $dir  = $cw->cget('-directory');
 $cw->configure(-directory => "$dir/$new", -title => "$dir/$new" );
}

sub Open {
  my ($cw) = @_;
  my ($entry,$path);
  $entry = $cw -> Subwidget('file_entry') -> get;
  $path = $cw -> {'Configure'}{'-directory'};
  if (defined $entry and length($entry)) {
    if ( -d "$path/$entry" ) {
      $cw -> directory( "$path/$entry" );
      $cw -> Accept_dir;
    } else {
      $cw -> {Selected} = "$path/$entry";
    }
  }
}

sub Populate {
    my ($w, $args) = @_;
    require Tk::Listbox;
    require Tk::Button;
    require Tk::Dialog;
    require Tk::DialogBox;
    require Tk::Toplevel;
    require Tk::LabEntry;
    require Cwd;
    $w->SUPER::Populate($args);

    $w->ConfigSpecs(
        -font             => ['CHILDREN',undef,undef,
			      '*-helvetica-medium-r-*-*-12-*'],
        -width            => [ ['dir_list'], undef, undef, 30 ],
        -height           => [ ['dir_list'], undef, undef, 14 ],
        -directory        => [ 'METHOD', undef, undef, '.' ],
        -initialdir       => '-directory',
        -files            => [ 'PASSIVE', undef,undef,1 ],
        -selectedfile     => [ 'PASSIVE', undef,undef,''],
        -dotfiles         => [ 'PASSIVE', undef,undef,0 ],
        -filter           => [ 'METHOD',  undef, undef, undef ],
        '-accept'         => [ 'CALLBACK',undef,undef, undef ],
        -create           => [ 'PASSIVE', undef, undef, 0 ],
        -acceptlabel      => [ 'PASSIVE', undef, undef, 'Accept' ],
        DEFAULT           => [ 'dir_list' ],
    );

    $w->protocol('WM_DELETE_WINDOW' => ['Cancel', $w ]);
    $w->{'reread'} = 0;
    my $l = $w -> Component( Label => 'entry_label',-text => 'File Name: ');
    $l -> grid( -column => 1, -row => 3, -padx => 5, -pady => 5 );
    my $e = $w -> Component(Entry => 'file_entry',
		    -textvariable=>\$w->{Configure}{-selectedfile});
    $e->grid(-column => 2, -columnspan => 1, -padx => 5, -pady => 5,
	     -row => 3, -sticky => 'e,w' );
    $e->bind('<Return>' => [$w => 'Open', Ev(['getSelected'])]);
    my $lb = $w->Component( ScrlListbox    => 'dir_list',
        -scrollbars => 'se', -width => \$w -> {Configure}{-width},
	-height => \$w -> {Configure}{-height} );
    $lb -> Subwidget('yscrollbar') -> configure(-width=>10);
    $lb -> Subwidget('xscrollbar') -> configure(-width=>10);
    $lb->grid( -column => 2, -row => 1, -rowspan => 2, -padx => 5,
	    -pady => 5, -sticky => 'nsew' );
    $lb->bind('<Double-Button-1>' => [$w => 'Open', Ev(['getSelected'])]);
    $lb->bind('<Button-1>', sub {($w->{Configure}{-selectedfile}=
	    $lb->get($lb->curselection))&&($e->icursor( 'end' ))});
    $b = $w -> Button(-textvariable => \$w->{'Configure'}{'-acceptlabel'},
    -underline => 0,-command => [$w => 'Open', Ev(['getSelected']) ]);
    $b->grid(-column=>1,-row=>1,-padx=>5,-pady=>5,-sticky=>'sew');
    $b = $w->Button( -text => 'Cancel', -underline => 0,
		     -command => [ 'Cancel', $w ]);
    $b->grid( -column => 1, -row => 2, -padx => 5, -pady => 5,
	    -sticky => 'new' );
    $w -> bind( '<Alt-c>', [$w => 'Cancel', $w]);
    $w -> Subwidget('file_entry') -> focus;
    $w -> eventAdd( '<<Accept>>', '<Alt-a>');
    $w -> bind('<<Accept>>', [$w => 'Open', Ev(['getSelected']) ]);
    $w->Delegates(DEFAULT => 'dir_list');
    return $w;
}

sub translate {
    my ($bs,$ch) = @_;
    return "\\$ch" if (length $bs);
    return '.*'  if ($ch eq '*');
    return '.'   if ($ch eq '?');
    return "\\."  if ($ch eq '.');
    return "\\/" if ($ch eq '/');
    return "\\\\" if ($ch eq '\\');
    return $ch;
}

sub glob_to_re {
    my $regex = shift;
    $regex =~ s/(\\?)(.)/&translate($1,$2)/ge;
    return sub { shift =~ /^${regex}$/ };
}

sub filter {
    my ($cw,$val) = @_;
    my $var = \$cw->{Configure}{'-filter'};
    if (@_ > 1 || !defined($$var)) {
	$val = '*' unless defined $val;
	$$var = $val;
	$cw->{'match'} = glob_to_re($val)  unless defined $cw->{'match'};
	unless ($cw->{'reread'}++) {
	    $cw->Busy;
	    if( ( $cw -> cget( '-connected' ) ) =~ /1/ ) {
		$cw->afterIdle(['rereadRemote',$cw,$cw->cget('-directory')])
		} else {
		    $cw->afterIdle(['reread',$cw,$cw->cget('-directory')]);
		}
	}
    }
    return $$var;
}

sub defaultextension {
    my ($cw,$val) = @_;
    if (@_ > 1) {
	$val = ".$val" if ($val !~ /^\./);
	$cw->filter("*$val");
    } else {
	$val = $cw->filter;
	my ($ext) = $val =~ /(\.[^\.]*)$/;
	return $ext;
    }
}

sub directory {
    my ($cw,$dir) = @_;
    my $var = \$cw->{Configure}{'-directory'};
    if (@_ > 1 && defined $dir) {
	if (substr($dir,0,1) eq '~') {
	    if (substr($dir,1,1) eq '/') {
		$dir = $ENV{'HOME'} . substr($dir,1);
	    } else {
		my ($uid,$rest) = ($dir =~ m#^~([^/]+)(/.*$)#);
		$dir = (getpwnam($uid))[7] . $rest;
	    }
	}
	$dir =~ s#([^/\\])[\\/]+$#$1#;
	if (-d $dir) {
	    unless (Tk::tainting()) {
		my $pwd = Cwd::getcwd();
		if (chdir( (defined($dir) ? $dir : '') ) ) {
		    my $new = Cwd::getcwd();
		    if ($new) {
			$dir = $new;
		    } else {
			carp "Cannot getcwd in '$dir'";
		    }
		    chdir($pwd) || carp "Cannot chdir($pwd) : $!";
		    $cw->{Configure}{'-directory'} = $dir;
		    $cw->configure(-title=>$dir);
		} else {
		    $cw->BackTrace("Cannot chdir($dir) :$!");
		}
	    }
	    $$var = $dir;
	    unless ($cw->{'reread'}++) {
		$cw->Busy;
		$cw->afterIdle(['reread',$cw]);
	    }
	}
    }
    return $$var;
}



sub reread {
    my ($w) = @_;
    my $dir = $w->cget('-directory');
    my ($f, $seen);
    if (defined $dir) {
	if (!defined $w->cget('-filter') or $w->cget('-filter') eq '') {
	    $w->configure('-filter', '*');
	}
	my $dl = $w->Subwidget('dir_list');
	$dl->delete(0, 'end');
	local *DIR;
	my $h;
	if (opendir(DIR, $dir)) {
	    my $file = $w->cget('-selectedfile');
	    my $seen = 0;
	    my $accept = $w->cget('-accept');
	    foreach $f (sort(readdir(DIR))) {
		next if ($f eq '.');
		next if $f =~ /^\.[^\.]/ and ! $w -> {Configure}{-dotfiles} ;
		my $path = "$dir/$f";
		if (-d $path) {
		    $dl->insert('end', $f.'/');
		} elsif ($w -> cget('-files')) {
		    if (&{$w->{match}}($f)) {
			if (!defined($accept) || $accept->Call($path)) {
			    $seen = $dl->index('end') 
				if ($file && $f eq $file);
			    $dl->insert('end', $f);
			}
		    }
		}
	    }
	    closedir(DIR);
	    if ($seen) {
		$dl->selectionSet($seen);
		$dl->see($seen);
	    } else {
		$w->configure(-selectedfile => '') 
		    unless $w->cget('-create');
	    }
	}
	$w->{DirectoryString} = $dir . '/' . $w->cget('-filter');
	$w->{'reread'} = 0;
	$w->Unbusy;
    }
}

sub Error {
    my $cw  = shift;
    my $msg = shift;
    my $dlg = $cw->Subwidget('dialog');
    $dlg->configure(-text => $msg);
    $dlg->Show;
}

sub Show {
    my ($cw,@args) = @_;
    my $accel = lc(substr $cw->cget('-acceptlabel'),0,1);
    $cw -> eventAdd('<<Accept>>', "\<Alt-$accel\>");
    $cw -> waitVariable(\$cw->{Selected});
    $cw -> withdraw;
    return $cw -> {Selected};
}

1;

__END__


=head1 NAME

  SimpleFileSelect -- Easy-to-Use File Selection Widget

=head1 SYNOPSIS

  use Tk::SimpleFileSelect;

  my $fs = $mw -> Tk::SimpleFileSelect();
  my $file = $fs -> Show;

=head2 Options

=over 4

=item -font

Name of the font to display in the directory list and file
name entry.  The default is '*-helvetica-medium-r-*-*-12-*'.

=item -width

Width in character columns of the directory listbox.
The default is 30.

=item -height

Height in lines of the directory listbox.  The default is 14.

=item -directory

=item -initialdir

Path name of initial directory to display.  The default is '.'
(current directory).

=item -files

If non-zero, display files as well as directories.  The default
is 1 (display files).

=item -dotfiles

If non-zero, display normally hidden files that begin with '.'.
The default is 0 (don't display hidden files).

=item -acceptlabel

Text to display in the 'Accept' button to accept a file or
directory selection. Defaults to 'Accept'.  The first character
is underlined to correspond with an Alt- accelerator constructed
with the first letter of the label text.

=item -filter

Display only files matching this pattern.  The default is
'*' (all files).

=head1 DESCRIPTION

Tk::SimpleFileSelect is a easy-to-use file selection widget based
on the Tk::FileSelect widget, but returns only a file name.
It is the job of the calling program perform any operations on the
files named in the SimpleFileSelect's return value.

Clicking in the list box on a file or directory name selects
it and inserts the selected item in the entry box.  Double clicking
on a directory or entering it in the entry box changes to that
directory.

The Show() method causes the FileSelectWidget to wait until a
file is selected in the Listbox, a file name is entered
in the text entry widget, or the 'Close' button is clicked.

The return value is the pathname of a file selected in the
Listbox, or the fully qualified path name of a file given in the
text entry, or an empty string if no file name is specified.

=head1 ADVERTISED SUBWIDGETS

None.

=head1 VERSION INFORMATION

  $Id: SimpleFileSelect.pm,v 0.63 2001/10/04 12:59:02 kiesling Exp $

=head1 COPYRIGHT INFO

Tk::SimpleFileSelect is derived from the Tk::FileSelect widget
in the Perl/Tk library. It is freely distributable and modifiable
under the same conditions as Perl. Please refer to the file
"Artistic" in the distribution archive.

Please submit any bugs to the author, rkiesling@mainmatter.com.

=cut
