Commit 3ce68aa8 authored by Stefan Tauner's avatar Stefan Tauner
Browse files

Add FIJISearchWidget and use it in FIJINetSelection

Make the entry + search button + substring/globbing/regex choices
reusable as standalone widget.
parent 017240cf
......@@ -24,24 +24,12 @@ use warnings;
use utf8;
use Log::Log4perl qw(get_logger);
use Scalar::Util 'blessed';
use Time::HiRes qw(time);
use Clone qw(clone);
use threads;
use threads::shared;
use FIJI qw(:all);
use Tk;
use Tk::Adjuster;
use Tk::widgets qw(Listbox LabFrame Balloon Label Entry Pane Button Dialog Checkbutton CompleteEntry StatusBar NoteBook);
use Tk::FIJIUtils;
use Tk::FIJIModalDialog;
use FIJI::TextGlob;
$FIJI::TextGlob::strict_wildcard_slash = 0;
$FIJI::TextGlob::strict_leading_dot = 0;
use Tk::widgets qw(Listbox LabFrame Label Entry Button Checkbutton);
use Tk::FIJISearchWidget;
use base qw(Tk::Frame);
Construct Tk::Widget 'FIJINetSelection';
......@@ -73,39 +61,18 @@ sub Populate {
sub _populate_widget {
my $self = shift;
my $balloon_widget = $self->Balloon();
# Tab order depends on creation order.
# Thus, create in the following order
# 1. The search entry field (In a Labframe)
# 2. The search button (In a Scrolled in a Labframe)
# 3. The found listbox (In a Scrolled in a Labframe)
# 4. The select button
# 5. The unselect button
# 6. The selected listbox
# 1. The search entry field
my $search_entry_labframe = $self->LabFrame(-label=>'Net name filter');
$self->{'search_entry'} = $search_entry_labframe->Entry()->grid(-row=>0,-column=>0,-padx=>5,-pady=>5,-sticky=>'ew');
# 2a. The search button
my $search_button = $search_entry_labframe->Button(-text=>'Search', -command => [\&_match_nets, $self])->grid(-row=>0,-column=>1,-padx=>5,-pady=>5,-sticky=>'e');
$self->{'search_entry'}->bind('<Return>',sub {$search_button->invoke} );
# 2b. The search mode radio buttons
$self->{'search_mode'} = 'Substring';
my $search_mode_frame = $search_entry_labframe->Frame()->grid(-row=>1,-column=>0,-padx=>5,-pady=>0,-sticky=>'w');
my $search_modes = [{text => 'Substring', tooltip => 'Search for a substring in a net name - this is implicit *<string>*'},
{text => 'Glob', tooltip => 'Search for a net name using standard globbing symbols such as "*" and "?"'},
{text => 'Regex', tooltip => 'Search for a net name using Perl-Style regular expressions'}];
foreach (@$search_modes) {
my $rb = $search_mode_frame->Radiobutton(-text => $_->{text}, -value=> $_->{text}, -variable => \$self->{'search_mode'})->pack(-side=>'left');
$balloon_widget->attach($rb,-msg=>$_->{tooltip});
}
# 1. The search widget
# 2. The found listbox (In a Scrolled in a Labframe)
# 3. The select button
# 4. The unselect button
# 5. The selected listbox
$search_entry_labframe->gridColumnconfigure(0,-weight=>1);
# 1. The search widget
my $search_entry_widget = $self->FIJISearchWidget(-label => 'Net name filter', -callback => \&_match_nets, -userdata => $self);
# 3. The found listbox
# 2. The found listbox
my $found_listbox_labframe = $self->LabFrame(-label=>'Matching nets');
my $found_listbox_scroll = $found_listbox_labframe->Scrolled('Listbox',-scrollbars=>'osre',-selectmode=>'single')->pack(-expand=>1,-fill=>'both');
$self->{'found_listbox'} = $found_listbox_scroll->Subwidget('scrolled');
......@@ -117,7 +84,7 @@ sub _populate_widget {
$self->{'found_listbox'}->bind('<Down>', sub {$self->{'found_listbox'}->selectionClear(0,'end'); $self->{'found_listbox'}->selectionSet('active')} );
# 4. The select buttons
# 3. The select buttons
$self->{'select_button'} = $self->Button(-text=>'>',-state=>'disabled');
if ($self->{'select_multiple'}) {
......@@ -136,7 +103,7 @@ sub _populate_widget {
}
# 5. The unselect button
# 4. The unselect button
$self->{'unselect_button'} = $self->Button(-text=>'<',-state=>'disabled');
if ($self->{'select_multiple'}) {
......@@ -150,7 +117,7 @@ sub _populate_widget {
});
}
# 6. The selected lisbox
# 5. The selected lisbox
my $selected_listbox_labframe = $self->LabFrame(-label=>'Selected net');
my $selected_listbox_scroll = $selected_listbox_labframe->Scrolled('Listbox',-scrollbars=>'osre',-selectmode=>'single')->pack(-expand=>1,-fill=>'both');
$self->{'selected_listbox'} = $selected_listbox_scroll->Subwidget('scrolled');
......@@ -234,9 +201,7 @@ sub _populate_widget {
# place widgets
#$self->{'search_entry'}->grid(-column=>0,-row=>0,-columnspan=>3,-sticky=>'nsew');
#$search_button->grid(-column=>3,-row=>0,-sticky=>'nse');
$search_entry_labframe->grid(-column=>0,-row=>0,-columnspan=>4,-sticky=>'nsew');
$search_entry_widget->grid(-column=>0,-row=>0,-columnspan=>4,-sticky=>'nsew');
$found_listbox_labframe->grid(-column=>0,-row=>1,-columnspan=>1,-rowspan=>3,-sticky=>'nsew');
$selected_listbox_labframe->grid(-column=>2,-row=>1,-columnspan=>2,-rowspan=>3,-sticky=>'nsew');
$self->{'select_button'}->grid(-column=>1,-row=>1);
......@@ -248,44 +213,15 @@ sub _populate_widget {
$self->gridColumnconfigure(0, -weight => 1);
$self->gridColumnconfigure(2, -weight => 1);
$self->gridRowconfigure(3, -weight => 1);
# tooltip
$balloon_widget->attach($self->{'search_entry'},-msg=>'Search for net names');
#$balloon_widget->attach($search_regex_checkbox,-msg=>'Interpret search string as regular expression');
}
sub _match_nets {
my $logger = get_logger("");
my ($self) = @_;
my $regex = $self->{'search_entry'}->get;
if ($self->{'search_mode'} eq 'Glob') {
$regex = FIJI::TextGlob::glob_to_regex($regex);
} elsif ($self->{'search_mode'} eq 'Regex') {
# check if regex is valid:
eval {"" =~ qr($regex)};
if ($@) {
my $msg = "Error in regular expression: $@";
$logger->error("$msg");
my $d = $self->MainWindow->FIJIModalDialog(
-text => $msg,
-image => Tk::FIJIUtils::error_image($self->MainWindow),
-wraplength => 400,
-title => 'Error',
)->Show();
$self->Unbusy;
return
}
$regex = qr/$regex/;
} elsif ($self->{'search_mode'} eq 'Substring') {
$regex = qr/\Q$regex\E/;
} else {
die("Invalid search mode");
}
my ($regex, $self) = @_;
$self->Busy;
# TODO: check for (too many) spaces in regex?
# filter nets by regex - we could use grep but that segfaults somewhere in the TCL wrapper
my @matching_nets;
......
#-------------------------------------------------------------------------------
# University of Applied Sciences Technikum Wien
#
# Department of Embedded Systems
# http://embsys.technikum-wien.at
#
# Josef Ressel Center for Verification of Embedded Computing Systems
# http://vecs.technikum-wien.at
#
#-------------------------------------------------------------------------------
# Description:
# Generic Search/Filter Widget
#-------------------------------------------------------------------------------
## @file
# @brief Contains class \ref Tk::FIJISearchWidget
## @class Tk::FIJISearchWidget
# @brief Tk Widget to search for and select one of a number of strings (usually net names)
package Tk::FIJISearchWidget;
use strict;
use warnings;
use utf8;
use Tk;
use Tk::widgets qw(Entry Button Frame Radiobutton Balloon);
use Tk::FIJIModalDialog;
use FIJI::TextGlob;
$FIJI::TextGlob::strict_wildcard_slash = 0;
$FIJI::TextGlob::strict_leading_dot = 0;
use base qw(Tk::LabFrame);
Construct Tk::Widget 'FIJISearchWidget';
sub ClassInit {
my ($class, $mw) = @_;
$class->SUPER::ClassInit($mw);
my $self = bless {}, $class;
return $self;
}
sub callback {
my ($self, $search_entry) = @_;
my $string = $search_entry->get();
my $msg;
my $regex;
if ($self->{'search_mode'} eq 'Glob') {
$regex = FIJI::TextGlob::glob_to_regex($string);
} elsif ($self->{'search_mode'} eq 'Regex') {
# check if regex is valid:
eval { "" =~ qr($string) };
if ($@) {
$msg = "Error in regular expression: $@";
} else {
$regex = qr/$string/;
}
} elsif ($self->{'search_mode'} eq 'Substring') {
$regex = qr/\Q$string\E/;
} else {
$msg = "Invalid search mode. Please report a bug in module '" . $self->class() . "'!";
}
if (defined($msg)) {
my $d = $self->MainWindow->FIJIModalDialog(
-text => $msg,
-image => Tk::FIJIUtils::error_image($self->MainWindow),
-wraplength => 400,
-title => 'Error',
)->Show();
# $self->Unbusy; needed?
} else {
$self->cget('-callback')->($regex, $self->cget('-userdata'));
}
}
sub Populate {
my ($self, $args) = @_;
$self->ConfigSpecs(
-callback => [qw/PASSIVE undef undef undef/],
-userdata => [qw/PASSIVE undef undef undef/],
);
$self->SUPER::Populate($args);
my $balloon_widget = $self->Balloon();
my $search_entry = $self->Entry()->grid(-row => 0, -column => 0, -padx => 5, -pady => 5, -sticky => 'ew');
my $search_button = $self->Button(-text => 'Search', -command => [\&callback, $self, $search_entry,])->grid(-row => 0, -column => 1, -padx => 5, -pady => 5, -sticky => 'e');
$search_entry->bind('<Return>', sub { $search_button->invoke; $_[0]->break; });
$self->gridColumnconfigure(0, -weight => 1);
$search_entry->focus();
$self->{'search_mode'} = 'Substring'; # Default to substring
my $search_mode_frame = $self->Frame()->grid(-row => 1, -column => 0, -padx => 5, -pady => 0, -sticky => 'w');
my $search_modes = [
{text => 'Substring', tooltip => 'Search for a substring anywhere within the given string(s)'},
{text => 'Glob', tooltip => 'Search using standard globbing symbols ("*" and "?")'},
{text => 'Regex', tooltip => 'Search using Perl-compatible regular expressions (PCRE)'}
];
foreach (@$search_modes) {
my $rb = $search_mode_frame->Radiobutton(-text => $_->{text}, -value => $_->{text}, -variable => \$self->{'search_mode'})->pack(-side => 'left');
$balloon_widget->attach($rb, -msg => $_->{tooltip});
}
}
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment