Beefy Boxes and Bandwidth Generously Provided by pair Networks
Keep It Simple, Stupid
 
PerlMonks  

Regex Lab

by boo_radley (Parson)
on May 06, 2002 at 19:21 UTC ( [id://164418]=CUFP: print w/replies, xml ) Need Help??

This is a redux of the wx regex tester I created some time back. I've posted it in a separate node because I've cleaned up the code signifigantly and improved the interface to allow for finer controls in your regex experimentations. substitutions have been broken down into 2 parts so that you can test your regex in m// and s// form, and the various flags have been set apart as checkboxes.
Output has been polished, HTMLized and colorized, no more plain text display.
Additionally, if you have YAPE::Regex::Explain, you'll have the option to get an explaination of what's happening, node by node in the regex. I wanted to work more with dissecting regex nodes, but I had serious issues compiling Devel::Regex, which is what I think I needed to use to do so. If you have some insight on this (either compiling, or other regular expression related diagnostics) I'd be delighted to hear your advice.
The only other thing I'd like to add is a paste-to-clipboard option, and that won't be available until the next release of wxwindows.
This software is licensed under the same terms as perl itself.
use Wx; package MyApp; use strict; use vars qw(@ISA); @ISA=qw(Wx::App); sub OnInit { my($this) = @_; # create new MyFrame my( $frame ) = MyFrame->new( "Regex Lab", Wx::Point->new( 50, 50 ), Wx::Size->new( 450, 350 ) ); $this->SetTopWindow($frame); $frame->Show(1); 1; } package MyFrame; use strict; use vars qw(@ISA); @ISA=qw(Wx::Frame); use Wx qw(wxTE_MULTILINE wxWidth wxHeight wxLeft wxTop wxBottom wxID_CANCEL wxALIGN_RIGHT ); use Wx qw(wxBITMAP_TYPE_BMP wxBITMAP_TYPE_XPM); use Wx::Event qw(EVT_BUTTON EVT_CHECKBOX); use Wx::HTML; use Wx qw(:dnd); use Wx::DND; my $has_yape; if (eval {require YAPE::Regex::Explain}){ $has_yape="yes"; # a true value. print "YAPE::Regex::Explain found, enabling functionality"; } else { print "YAPE::Regex::Explain *not* found, ignoring\n"; print "This module adds extra functionality to the script" } # even -no_xhtml doesn't satisfy wx::htmlwindow # use CGI qw (:html -no_xhtml); # oh yeah, this is gonna be *clean*... + *tsk* # TODO: Clean up HTML... see if CGI can make nice with the htmlwindow use vars qw(@flags %flag_info); use CGI qw(escapeHTML); sub new { my( $class ) = shift; my( $this ) = $class->SUPER::new( undef, -1, $_[0], $_[1], $_[2] ) +; @flags = qw(g i m s x e); %flag_info = ( # all from perlre g=>"Match globally, i.e., find all occurrences.", i=>"Do case-insensitive pattern matching.", m=>"Treat string as multiple lines.", s=>"Treat string as single line.", x=>"Use extended regular expressions.", e=>"Evaluate the right side as an expression. (not implemented +)" # TODO: Implement this :) ); # # load an icon and set it as frame icon # $this->SetIcon( Wx::GetWxPerlIcon() ); # # load gui elements in # a sensible tab order # $this->{Panel} = Wx::Panel->new($this,0,[0,0],[1000,1000]); $this->{RegexLabel}= Wx::StaticText->new($this->{Panel},-1,'regex +string :'); $this->{RegexText} = Wx::TextCtrl->new( $this->{Panel}, -1, '\b([b +-df-hj-np-tv-z])(\w+)', [0, 250], [100, 50], wxTE_MULTILINE ); $this->{ReplCheck} = Wx::CheckBox->new( $this->{Panel}, -1, "Make +mine a replacement!"); $this->{ReplLabel}= Wx::StaticText->new($this->{Panel},-1,'replace +ment string :'); $this->{ReplText} = Wx::TextCtrl->new( $this->{Panel}, -1, '$2-$1a +y', [0, 250], [100, 50], wxTE_MULTILINE ); $this->{TestLabel}= Wx::StaticText->new($this->{Panel},-1,'Test st +ring :' ); $this->{TestText} = Wx::TextCtrl->new( $this->{Panel}, -1, 'hello +world!', [0, 250], [100, 50], wxTE_MULTILINE); $this->{RunButton} = Wx::Button->new($this->{Panel}, -1, 'Test reg +ex'); $this->{FlagsLabel}= Wx::StaticText->new($this->{Panel},-1,'Flags +:'); # # add flags and YAPE (yape only if user has # the module installed) # # since we don't really want explain as a # flag to add to an re, we push it, # create the checkbox # and then pop it off when we're done. # my $x=125; push @flags,"Explain" if $has_yape; foreach (@flags) { $this->{"flag_$_"} = Wx::CheckBox->new( $this->{Panel}, -1, +$_ ); my $arghargharghargh = Wx::LayoutConstraints->new; # why can't + I just do all this in the SetConstraints? bah $arghargharghargh->top->SameAs($this->{RunButton},wxTop,5); $arghargharghargh->left->Absolute ($x); $arghargharghargh->height->AsIs; $arghargharghargh->width->AsI +s; $this->{"flag_$_"}->SetConstraints ($arghargharghargh); $x+=30; } pop @flags,"Explain" if $has_yape; # done with flags, bah. $this->{ResultText} = Wx::HtmlWindow->new ($this->{Panel} ); $this->{ResultText}->SetBorders(0); $this->CreateStatusBar(1); $this->{Panel}->SetAutoLayout( 1 ); my $b1 = Wx::LayoutConstraints->new(); my $b2 = Wx::LayoutConstraints->new(); my $b3 = Wx::LayoutConstraints->new(); my $b4 = Wx::LayoutConstraints->new(); my $b5 = Wx::LayoutConstraints->new(); my $b6 = Wx::LayoutConstraints->new(); my $b7 = Wx::LayoutConstraints->new(); my $b8 = Wx::LayoutConstraints->new(); # added later... my $b9 = Wx::LayoutConstraints->new(); # added later... my $b10 = Wx::LayoutConstraints->new(); # added later... $b1->left->Absolute(00); $b1->top->Absolute(0); $b1->width->AsIs(); $b1->height->AsIs(); $this->{RegexLabel}->SetConstraints($b1); $b2->left->RightOf ($this->{RegexLabel}); $b2->top->SameAs ($this->{RegexLabel}, wxTop); $b2->right->RightOf($this->{Panel}); $b2->height->AsIs(); $this->{RegexText}->SetConstraints($b2); $b8->left->Absolute(0); $b8->top->Below($this->{ReplText},10); $b8->width->SameAs ($this->{ReplLabel}, wxWidth); $b8->height->AsIs(); $this->{TestLabel}->SetConstraints ($b8); $b10->left->SameAs($this->{RegexLabel},wxLeft); $b10->top->Below ($this->{RegexText}, wxTop); $b10->right->RightOf($this->{Panel},-2); $b10->height->AsIs(); $this->{ReplCheck}->SetConstraints ($b10); $b3->left->Absolute(0); $b3->top->Below($this->{ReplCheck},10); $b3->width->SameAs ($this->{RegexLabel}, wxWidth); $b3->height->SameAs ($this->{ReplText}, wxHeight); $this->{ReplLabel}->SetConstraints ($b3); $b9->left->RightOf ($this->{TestLabel}); $b9->top->SameAs ($this->{TestLabel}, wxTop); $b9->right->RightOf($this->{Panel},-2); $b9->height->AsIs(); $this->{TestText}->SetConstraints ($b9); $b4->left->RightOf ($this->{TestLabel}); $b4->top->Below ($this->{ReplCheck}, 5); $b4->right->RightOf($this->{Panel},-2); $b4->height->AsIs(); $this->{ReplText}->SetConstraints ($b4); $b5->top->Below($this->{TestText}, 5); $b5->left->Absolute (0); $b5->height->AsIs(); $b5->width->AsIs(); $this->{RunButton}->SetConstraints ($b5); $b6->top->Below($this->{RunButton}, 5); $b6->left->Absolute (0); $b6->bottom->Below ($this->{Panel} ); $b6->width->PercentOf($this->{Panel}, wxWidth, 100);; $this->{ResultText}->SetConstraints ($b6); $b7->top->SameAs ($this->{RunButton},wxTop,5); $b7->left->RightOf($this->{RunButton},5); $b7->width->AsIs;$b7->height->AsIs; $this->{FlagsLabel}->SetConstraints($b7); $this->SetStatusText( "Regex Tester", 0 ); # add handler for button EVT_BUTTON( $this, $this->{RunButton}, \&OnRunButton ); EVT_CHECKBOX ($this, $this->{ReplCheck}, \&OnReplCheck); # set the replacement options to false to begin with... # they can be enabled with a foreach ($this->{flag_e}, $this->{ReplText}) { $_->Enable(0); } $this; } sub OnRunButton { # runs the regex. #################### # html color block my $matchcolor = '"#66ff66"'; my $capturecolor = '"#ffff66"'; my $errorcolor = '"#ff6666"'; my $flagcolor = '"#cc3399"'; my $svarcolor = '"#993399"'; my $explaincolor = '"#993366"'; # end html colors #################### my $this=shift; my $resulttext; $resulttext = "<html><body><table border=\"0\">"; my $retext=$this->{RegexText}->GetValue(); my $testtext = $this->{TestText}->GetValue(); my $repltext = $this->{ReplText}->GetValue(); my $testtext2 = $testtext; # prep for substitutions. my $ismatch; my @match; my $c_re; $c_re = $retext; eval {qr/$retext/}; if ($@) { # error in re, bail early my $fn= $0; #($err =$@)=~s/at $fn.+$//; $resulttext.= ("<tr><td bgcolor=$errorcolor>Error in regex tex +t : $@</td></tr>"); $resulttext.=("</table></body><\html>"); $this->{ResultText}->SetPage ($resulttext); return }; my $re_flags; # flags that are to be set my $re_noflags="-"; # flags to be negated # construct flags my $is_global = $this->{"flag_g"}->GetValue(); foreach (qw (x i s m)){ # the subset of regex flags that exist in +a compiled re if ($this->{"flag_$_"}->GetValue()){ $resulttext.="<tr><td bgcolor=$flagcolor colspan=\"2\">Usi +ng $_ flag<br><center>$flag_info{$_}</center></td></tr>"; $re_flags.= $_; } else { $re_noflags.= $_; } } # flags that foreach (qw (g e)){ if ($this->{"flag_$_"}->GetValue()){ $resulttext.="<tr><td bgcolor=$flagcolor colspan=\"2\">Usi +ng $_ flag<br><center>$flag_info{$_}</center></td></tr>"; } } #done with flag construction # # if I use the re created by qr// above, # I'll get 2 sets of flags which looked # like (?-xism:(?i)$retext). # this old code remains below for context # eval {@match= $c_re=qr/$re_flags$retext/}; #hacky, yes, but bett +er than the giant eval block that existed before. $c_re = "(?$re_flags$re_noflags:$c_re)"; # # OK, at this point, the regex is complete! # it took a lot of effort to recreate what qr// # can do, and I don't recommend it :) # # # YAPE::REGEX::EXPLAIN SECTION # if ($has_yape) { if( $this->{flag_Explain}->GetValue()){ my $yape_text=YAPE::Regex::Explain->new($c_re)->explain; # $yape_text = escapeHTML ($yape_text); $yape_text =~ s/\-{70}/<hr width="50%">/g; $yape_text =~ s/(\n)/<br>$1/g; $resulttext .= "<tr><td bgcolor=$explaincolor colspan=\"2\"><center><h2>E +xplanation</h2></center>$yape_text</td></tr>"; } } ######################### # begin the matching! ######################### # # firstly, check to see if there's any match there at all... # if ($testtext2=~/$c_re/) { # we match! if ($is_global){@match = ($testtext2=~/$c_re/g)} $resulttext.="<tr><td bgcolor=$matchcolor colspan=\"2\"><cente +r><strong>".emfont("This is a match\n")."</strong></center></td></tr> +"; $resulttext.="<tr><td bgcolor=$matchcolor><strong>Regex text i +s : </strong></td><td bgcolor=$matchcolor>$retext </td></tr>"; $resulttext.="<tr><td bgcolor=$matchcolor><strong>Compiled reg +ex is : </strong><td bgcolor=$matchcolor>'$c_re'</td></tr>"; if ($is_global){ # output global matches in ordered list form @match= map {"'$_'"}@match; $resulttext .="<tr><td bgcolor=$capturecolor colspan=\"2\" +><center><strong>Listing global matches</strong></center></td></tr>\n +"; $resulttext .="<tr><td bgcolor=$capturecolor colspan=\"2\" +><ol>"; $resulttext .=join "\n",(map {"<li>$_</li>"} @match); $resulttext .= "</ol></td></tr>"; $resulttext.="<tr><td bgcolor=$capturecolor colspan=\"2\"> +<center><strong>Done listing matches</strong></center></td></tr>\n"; } else { # not a global search, but matches may exist $this->SetStatusText( "Match finding", 0 ); if (defined $1){ # print out $1, $2, etc. $resulttext.=("<tr><td bgcolor=$capturecolor colspan=\ +"2\"><center><strong>Listing matches</strong></center></tr></td>"); no strict qw(refs); # booga booga! my $ct=1; while (defined ${"$ct"}) { $resulttext.=("<tr><td bgcolor=$capturecolor colsp +an=\"2\">\$$ct is : '". ${"$ct"} ."'</td></tr>\n"); $ct++; } $resulttext.="<tr><td bgcolor=$capturecolor colspan=\" +2\"><center><strong>Done listing matches</strong></center></td></tr>\ +n"; } else { print "not found\n"; } } } else { # no match. so sorry. return early. $resulttext.=("<tr><td bgcolor=$errorcolor colspan=\"2\">No ma +tch."); if ($retext=~/\n/) { $resulttext.=("<br />Found a newline in the regex, maybe y +ou meant to enable /x?<br />"); } $resulttext.=("</td></tr></table></body><\html>"); $this->{ResultText}->SetPage ($resulttext); return } ######################### # now see if we should be substituting ######################### # # # if ($this->{ReplCheck}->GetValue ){ if ($is_global) { # # hey, thanks, Chmrr! # this thing makes me cringe but she works. # the first /e makes the replacement text # "contents of $repltext" # and the second evaluates that. # I do this in case the user has backreferences in the # replacement text. # my $match =($testtext2=~s/$c_re/"\"$repltext\""/eeg); $resulttext .="<tr><td bgcolor=$capturecolor colspan=\"2\" +><center><strong>Substitution global match count : $match</strong></c +enter></td></tr>\n"; } else { $testtext2=~s/$c_re/"\"$repltext\""/ee; $this->SetStatusText( "Match finding", 0 ); } unless ($testtext eq $testtext2) { $resulttext.=("<tr><td bgcolor=$capturecolor colspan=\"2\" +><strong><center>Replacement</center></strong>Contents of test text c +hanged :<br>\nWas : '$testtext'<br>\nIs now : '$testtext2'<br>\n</td +></tr>"); } } unless ($is_global) { #these don't seem like they'd matter in a gl +obal match/search... $resulttext.= "<tr><td align=\"center\" bgcolor=$svarcolor colspan=\"2\" +>".emfont ("\$&")." is '$&'</td></tr>". "<tr><td align=\"center\" bgcolor=$svarcolor colspan=\"2\" +>".emfont ("\$`")." is '$`'</td></tr>". "<tr><td align=\"center\" bgcolor=$svarcolor colspan=\"2\" +>".emfont ("\$'")." is '$''</td></tr>". "<tr><td align=\"center\" bgcolor=$svarcolor colspan=\"2\" +>".emfont ("\$+")." is '$+'</td></tr>"; } $resulttext.="</td></tr></table></body><\html>"; $this->{ResultText}->SetPage ($resulttext); my $data = Wx::TextDataObject->new( "ahoyhoy" ) || print "no open data +"; } sub OnReplCheck { my $this = shift; my $en = $this->{ReplCheck}->GetValue; $_->Enable($en) foreach ($this->{flag_e}, $this->{ReplText}) } sub emfont { # weeping, weeping. return '<em> <font size="+1">'. $_[0]."</font> </em>"; } package main; my $app = new MyApp; $app->MainLoop();

Replies are listed 'Best First'.
Re: Regex Lab
by Anonymous Monk on Jun 21, 2011 at 14:40 UTC
    Many years passed, wxWindows was renamed to wxWidgets, some defaults changed, wxLayoutConstraints was deprecated, now this code needs
    package MyFrame; ... sub new { ... $_->Layout for $this->GetChildren;### THIS $this; }

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: CUFP [id://164418]
Approved by VSarkiss
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others rifling through the Monastery: (6)
As of 2024-03-28 19:12 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found