view release on metacpan or  search on metacpan

lib/Tk/SimpleFileSelect.pm  view on Meta::CPAN

use Tk::DialogBox;
use Tk::Toplevel;
use Tk::LabEntry;
use Cwd;

our $VERSION = 1.29;
our @EXPORT_OK = qw(glob_to_re);

Construct Tk::Widget 'SimpleFileSelect';

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

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

sub Populate {
    my ($w, $args) = @_;
    $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' ],
        '-initialtext'      => [ 'PASSIVE', undef, undef, '' ],
        '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}{-initialtext});
    $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}, # Can't set -width to `SCALAR(0x34dca94)'
        #-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}{-initialtext}=$lb->get($lb->curselection)) });
    
    my $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->bind( '<Escape>', [$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;