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,'replacement string :'); $this->{ReplText} = Wx::TextCtrl->new( $this->{Panel}, -1, '$2-$1ay', [0, 250], [100, 50], wxTE_MULTILINE ); $this->{TestLabel}= Wx::StaticText->new($this->{Panel},-1,'Test string :' ); $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 regex'); $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->AsIs; $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 = ""; 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.= (""); $resulttext.=("
Error in regex text : $@
<\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.="Using $_ flag
$flag_info{$_}
"; $re_flags.= $_; } else { $re_noflags.= $_; } } # flags that foreach (qw (g e)){ if ($this->{"flag_$_"}->GetValue()){ $resulttext.="Using $_ flag
$flag_info{$_}
"; } } #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 better 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}/
/g; $yape_text =~ s/(\n)/
$1/g; $resulttext .= "

Explanation

$yape_text"; } } ######################### # 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.="
".emfont("This is a match\n")."
"; $resulttext.="Regex text is : $retext "; $resulttext.="Compiled regex is : '$c_re'"; if ($is_global){ # output global matches in ordered list form @match= map {"'$_'"}@match; $resulttext .="
Listing global matches
\n"; $resulttext .="
    "; $resulttext .=join "\n",(map {"
  1. $_
  2. "} @match); $resulttext .= "
"; $resulttext.="
Done listing matches
\n"; } else { # not a global search, but matches may exist $this->SetStatusText( "Match finding", 0 ); if (defined $1){ # print out $1, $2, etc. $resulttext.=("
Listing matches
"); no strict qw(refs); # booga booga! my $ct=1; while (defined ${"$ct"}) { $resulttext.=("\$$ct is : '". ${"$ct"} ."'\n"); $ct++; } $resulttext.="
Done listing matches
\n"; } else { print "not found\n"; } } } else { # no match. so sorry. return early. $resulttext.=("No match."); if ($retext=~/\n/) { $resulttext.=("
Found a newline in the regex, maybe you meant to enable /x?
"); } $resulttext.=("<\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 .="
Substitution global match count : $match
\n"; } else { $testtext2=~s/$c_re/"\"$repltext\""/ee; $this->SetStatusText( "Match finding", 0 ); } unless ($testtext eq $testtext2) { $resulttext.=("
Replacement
Contents of test text changed :
\nWas : '$testtext'
\nIs now : '$testtext2'
\n"); } } unless ($is_global) { #these don't seem like they'd matter in a global match/search... $resulttext.= "".emfont ("\$&")." is '$&'". "".emfont ("\$`")." is '$`'". "".emfont ("\$'")." is '$''". "".emfont ("\$+")." is '$+'"; } $resulttext.="<\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 ' '. $_[0]." "; } package main; my $app = new MyApp; $app->MainLoop();