FIJISearchWidget.pm 4.42 KB
 Stefan Tauner committed Oct 03, 2017 1 2 3 #----------------------------------------------------------------------- # Fault InJection Instrumenter (FIJI) # https://embsys.technikum-wien.at/projects/vecs/fiji  Stefan Tauner committed Oct 03, 2017 4 #  Stefan Tauner committed Oct 13, 2017 5 6 7 8 # The creation of this file has been supported by the publicly funded # R&D project Josef Ressel Center for Verification of Embedded Computing # Systems (VECS) managed by the Christian Doppler Gesellschaft (CDG). #  Stefan Tauner committed Oct 03, 2017 9 10 # Copyright (C) 2017 Christian Fibich # Copyright (C) 2017 Stefan Tauner  Stefan Tauner committed Oct 03, 2017 11 #  Stefan Tauner committed Oct 03, 2017 12 13 # This module is free software; you can redistribute it and/or modify # it under the same terms as Perl itself.  Stefan Tauner committed Oct 03, 2017 14 #  Stefan Tauner committed Oct 03, 2017 15 16 17 18 19 20 # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. # # See the LICENSE file for more details. #-----------------------------------------------------------------------  Stefan Tauner committed Oct 03, 2017 21 22 23 24 25  ## @file # @brief Contains class \ref Tk::FIJISearchWidget ## @class Tk::FIJISearchWidget  Stefan Tauner committed Oct 03, 2017 26 27 # @brief Tk Widget presenting a search/filter mask  Stefan Tauner committed Oct 03, 2017 28 29 30 31 32 33 34 package Tk::FIJISearchWidget; use strict; use warnings; use utf8; use Tk;  Stefan Tauner committed Oct 03, 2017 35 use Tk::widgets qw(Entry Button Frame Checkbutton Radiobutton Balloon);  Stefan Tauner committed Oct 03, 2017 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 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 {  Stefan Tauner committed Oct 03, 2017 66 $regex = "$string";  Stefan Tauner committed Oct 03, 2017 67 68  } } elsif ($self->{'search_mode'} eq 'Substring') {  Stefan Tauner committed Oct 03, 2017 69  $regex = "\Q$string\E";  Stefan Tauner committed Oct 03, 2017 70 71 72 73 74 75 76 77 78 79 80 81 82 83  } 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 {  Stefan Tauner committed Oct 03, 2017 84 85  my $ci_str = ($self->{'case_insensitive'}) ? "(?i)" : ""; $regex = qr/$ci_str$regex/;  Stefan Tauner committed Oct 03, 2017 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 $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');  Christian Fibich committed Oct 03, 2017 103  Tk::FIJIUtils::entry_rebind($search_entry);  Stefan Tauner committed Oct 03, 2017 104 105 106 107 108 109 110  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('', sub {$search_button->invoke; $_[0]->break; });$self->gridColumnconfigure(0, -weight => 1); $search_entry->focus();$self->{'search_mode'} = 'Substring'; # Default to substring  Stefan Tauner committed Oct 03, 2017 111  my $search_mode_frame =$self->Frame()->grid(-row => 1, -column => 0, -padx => 5, -pady => 0, -sticky => 'ew');  Stefan Tauner committed Oct 03, 2017 112 113 114 115 116 117 118 119 120  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}); }  Stefan Tauner committed Oct 03, 2017 121 122 123  my $insensitive_cb =$search_mode_frame->Checkbutton(-text => 'Case-insensitive', -variable => \$self->{'case_insensitive'})->pack(-side => 'right');$balloon_widget->attach(\$insensitive_cb, -msg => 'Use case-insensitive search if enabled');  Stefan Tauner committed Oct 03, 2017 124 }