Commit 4a6285c9 authored by Christian Fibich's avatar Christian Fibich Committed by Stefan Tauner
Browse files

vecs/fiji#59: More search options for Nets in the Net Selection Dialog

The dialog offers now:

* Substring search (searches for the entered string as substring)
* Globbing (converts glob to regex by FIJI::TextGlob)
* Conventional Perl Regexes
parent 37c103ba
#-------------------------------------------------------------------------------
# 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:
# Glob strings to Regexes
#
# Based on Text::Glob by Richard Clamp <richardc@unixbeard.net>
#-------------------------------------------------------------------------------
package FIJI::TextGlob;
use strict;
use Exporter;
use vars qw/$VERSION @ISA @EXPORT_OK
$strict_leading_dot $strict_wildcard_slash/;
$VERSION = '0.11';
@ISA = 'Exporter';
@EXPORT_OK = qw( glob_to_regex glob_to_regex_string match_glob );
$strict_leading_dot = 1;
$strict_wildcard_slash = 1;
use constant debug => 0;
sub glob_to_regex {
my $glob = shift;
my $regex = glob_to_regex_string($glob);
return qr/^$regex$/;
}
sub glob_to_regex_string
{
my $glob = shift;
my $seperator = $Text::Glob::seperator;
$seperator = "/" unless defined $seperator;
$seperator = quotemeta($seperator);
my ($regex, $in_curlies, $escaping);
local $_;
my $first_byte = 1;
for ($glob =~ m/(.)/gs) {
if ($first_byte) {
if ($strict_leading_dot) {
$regex .= '(?=[^\.])' unless $_ eq '.';
}
$first_byte = 0;
}
if ($_ eq '/') {
$first_byte = 1;
}
if ($_ eq '.' || $_ eq '(' || $_ eq ')' || $_ eq '|' ||
$_ eq '+' || $_ eq '^' || $_ eq '$' || $_ eq '@' || $_ eq '%' ) {
$regex .= "\\$_";
}
elsif ($_ eq '*') {
$regex .= $escaping ? "\\*" :
$strict_wildcard_slash ? "(?:(?!$seperator).)*" : ".*";
}
elsif ($_ eq '?') {
$regex .= $escaping ? "\\?" :
$strict_wildcard_slash ? "(?!$seperator)." : ".";
}
elsif ($_ eq '{') {
$regex .= $escaping ? "\\{" : "(";
++$in_curlies unless $escaping;
}
elsif ($_ eq '}' && $in_curlies) {
$regex .= $escaping ? "}" : ")";
--$in_curlies unless $escaping;
}
elsif ($_ eq ',' && $in_curlies) {
$regex .= $escaping ? "," : "|";
}
elsif ($_ eq "\\") {
if ($escaping) {
$regex .= "\\\\";
$escaping = 0;
}
else {
$escaping = 1;
}
next;
}
elsif ($_ eq "[") {
$regex .= "\\[";
}
else {
$regex .= $_;
$escaping = 0;
}
$escaping = 0;
}
print "# $glob $regex\n" if debug;
return $regex;
}
sub match_glob {
print "# ", join(', ', map { "'$_'" } @_), "\n" if debug;
my $glob = shift;
my $regex = glob_to_regex $glob;
local $_;
grep { $_ =~ $regex } @_;
}
1;
__END__
=head1 NAME
Text::Glob - match globbing patterns against text
=head1 SYNOPSIS
use FIJI::TextGlob qw( match_glob glob_to_regex );
print "matched\n" if match_glob( "foo.*", "foo.bar" );
# prints foo.bar and foo.baz
my $regex = glob_to_regex( "foo.*" );
for ( qw( foo.bar foo.baz foo bar ) ) {
print "matched: $_\n" if /$regex/;
}
=head1 DESCRIPTION
Text::Glob implements glob(3) style matching that can be used to match
against text, rather than fetching names from a filesystem. If you
want to do full file globbing use the File::Glob module instead.
=head2 Routines
=over
=item match_glob( $glob, @things_to_test )
Returns the list of things which match the glob from the source list.
=item glob_to_regex( $glob )
Returns a compiled regex which is the equivalent of the globbing
pattern.
=item glob_to_regex_string( $glob )
Returns a regex string which is the equivalent of the globbing
pattern.
=back
=head1 SYNTAX
The following metacharacters and rules are respected.
=over
=item C<*> - match zero or more characters
C<a*> matches C<a>, C<aa>, C<aaaa> and many many more.
=item C<?> - match exactly one character
C<a?> matches C<aa>, but not C<a>, or C<aaa>
=item Character sets/ranges
C<example.[ch]> matches C<example.c> and C<example.h>
C<demo.[a-c]> matches C<demo.a>, C<demo.b>, and C<demo.c>
=item alternation
C<example.{foo,bar,baz}> matches C<example.foo>, C<example.bar>, and
C<example.baz>
=item leading . must be explicitly matched
C<*.foo> does not match C<.bar.foo>. For this you must either specify
the leading . in the glob pattern (C<.*.foo>), or set
C<$Text::Glob::strict_leading_dot> to a false value while compiling
the regex.
=item C<*> and C<?> do not match the seperator (i.e. do not match C</>)
C<*.foo> does not match C<bar/baz.foo>. For this you must either
explicitly match the / in the glob (C<*/*.foo>), or set
C<$Text::Glob::strict_wildcard_slash> to a false value while compiling
the regex, or change the seperator that Text::Glob uses by setting
C<$Text::Glob::seperator> to an alternative value while compiling the
the regex.
=back
=head1 COPYRIGHT
Based on Text::Glob by Richard Clamp <richardc@unixbeard.net>
Original Copyright notice:
Copyright (C) 2002, 2003, 2006, 2007 Richard Clamp. All Rights Reserved.
This module is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut
......@@ -28,6 +28,7 @@ use Scalar::Util 'blessed';
use Time::HiRes qw(time);
use Clone qw(clone);
use threads;
use threads::shared;
......@@ -38,6 +39,9 @@ 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 base qw(Tk::Frame);
Construct Tk::Widget 'FIJINetSelection';
......@@ -88,9 +92,16 @@ sub _populate_widget {
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 regex enable checkbox
$self->{'search_regex'} = 1;
my $search_regex_checkbox = $search_entry_labframe->Checkbutton(-text=>'Regular Expression',-variable=>\$self->{'search_regex'})->grid(-row=>1,-column=>0,-padx=>5,-pady=>0,-sticky=>'w');
# 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});
}
$search_entry_labframe->gridColumnconfigure(0,-weight=>1);
......@@ -231,19 +242,19 @@ sub _populate_widget {
# 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');
#$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;
$self->Busy;
if ($self->{'search_regex'}) {
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 {"" =~ m!$regex!};
eval {"" =~ qr($regex)};
if ($@) {
my $msg = "Error in regular expression: $@";
$logger->error("$msg");
......@@ -256,16 +267,21 @@ sub _match_nets {
$self->Unbusy;
return
}
$regex = qr/$regex/;
} elsif ($self->{'search_mode'} eq 'Substring') {
$regex = qr/\Q$regex\E/;
} else {
die("Invalid search mode");
}
$self->Busy;
# filter nets by regex - we could use grep but that segfaults somewhere in the TCL wrapper
my @matching_nets;
for my $net (@{$self->{'nets'}}) {
if ($self->{'search_regex'}) {
push @matching_nets, $net if ($net =~ m!$regex!);
} else {
push @matching_nets, $net if ($net =~ m!\Q$regex\E!);
}
push @matching_nets, $net if ($net =~ $regex);
}
my @filtered_nets = sort(@matching_nets);
......
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