Beefy Boxes and Bandwidth Generously Provided by pair Networks
go ahead... be a heretic


by ChOas (Curate)
on Sep 03, 2001 at 12:05 UTC ( #109829=perlcraft: print w/replies, xml ) Need Help??

   1: I don`t know if this is Craft, or a hack, I DO know that
   2: it comes in handy (For me, since I am not a complete master 
   3: of regular expressions (not until japhy's) book at least ;))
   5: I am sure there is something like this out there, but I haven`t
   6: bothered to look (sometimes it is just more fun to do something 
   7: yourself ;)
   9: What does it do ?
  11: It draws you a little Tk window, and allows you to enter a string
  12: and let a RegEx loose on it.
  13: Dynamically the result of the RegEx is shown, and updated, so you
  14: can see exactly what the result is of a change in the RegEx, or the
  15: string.
  17: TODO: 
  19:      - Do something about that UI! ;)
  20:      - Put an another eval in the function so $1..n are really
  21:        1..n, instead of 1..5 ;)
  22:      - Support for @+ @-
  23:      - Clean up code ;)
  24:      - Loads of stuff
  26: Code will be updated soon, I hope ;)
  28: Update: Implemented List context feature, as suggested by Jepri
  30: The Code: 
  31: #!/usr/bin/perl -w
  32: use strict;
  33: use Tk;
  35: sub KeyPress;
  37: my $MW=MainWindow->new;
  39: my $AsList;
  40: my %Border=qw(-relief raised);
  41: my %Fill=qw(-fill both);
  43: my $Top   =$MW->Frame->pack(-side=>'top');
  44: my $TopLeft  =$Top->Frame(%Border)->pack(-side=>'left');
  45: my $TopRight =$Top->Frame(%Border)->pack(-side=>'left');
  47: my $RegLabel=$TopLeft->Label(%Border,-text=>'RegExp')->pack(%Fill);
  48: my $TextLabel=$TopLeft->Label(%Border,-text=>'Text')->pack(%Fill);
  49: my $AsListBox=$Top->Checkbutton(-text=>'List context',-variable=>\$AsList,-command=>\&KeyPress)->pack();
  50: $Border{-bd}=1;
  51: my $RegExp=$TopRight->Entry(-width=>30)->pack();
  52: my $Text=$TopRight->Entry(-width=>30)->pack();
  54: my $ResultTextFrame =$MW->Frame(%Border)->pack(-side=>'left');
  55: my $ResultTextLabel=$ResultTextFrame->Label(-justify=>'left',-text=>"PreMatch:\nMatch:\nPostMatch:\nResult:\n\$1..n")->pack(%Fill);
  57: my $ResultFrame  =$MW->Frame(%Border)->pack(-side=>'left',%Fill);
  58: my $ResultLabel=$ResultFrame->Label(-justify=>'left',-text=>"none\nnone\nnone\nnone")->pack(%Fill);
  61: $MW->bind('all', '<KeyPress>', \&KeyPress);
  62: MainLoop();
  64: sub KeyPress
  65: {
  66:  local $^W=0;
  67:  my $RegEx=$RegExp->get;
  68:  my $Text =$Text->get;
  69:  my (@Dollar,@Result,$Result,$Match,$PreMatch,$PostMatch);
  70:  my $Function;
  71:  my $FieldCodes=join "",'$Match=$&;',
  72:                         '$PreMatch=$`;',
  73:                         "\$PostMatch=\$';",
  74:                         "\$Dollar[0]=\$1;",
  75:                         "\$Dollar[1]=\$2;",
  76:                         "\$Dollar[2]=\$3;",
  77:                         "\$Dollar[3]=\$4;",
  78:                         "\$Dollar[4]=\$5;";
  79:  if (!$AsList)
  80:  {
  81:   $Function=join "",'($Result=$Text)=~',"$RegEx;",$FieldCodes;
  82:  }
  83:  else 
  84:  {
  85:   $Function=join "",'@Result=($Text=~',"$RegEx);",$FieldCodes;
  86:  };
  87:  eval $Function;
  88:  $Result||=join "|",@Result;
  89:  $Match||='none'; $PreMatch||='none'; $PostMatch||='none';
  90:  $ResultLabel->configure(-text=>"$PreMatch\n$Match\n$PostMatch\n$Result\n@Dollar"); 
  91:  $ResultLabel->update;
  92: };

Replies are listed 'Best First'.
Re: Test-a-Rex
by jepri (Parson) on Sep 03, 2001 at 13:25 UTC
    Very nice. ++ from me. There are a few points though:

    If you are going to put comments in the code, put # signs in front of them (lines 1-26).

    Remember that you can catch the matchs as a list, like this:  my @matchs = ( $text =~ /$regexp/ ); So you can catch any number of matchs. This would mean using special cases for your function.

    There are two other regexp analysers that I know of, but I would encourage you to continue work on yours because I haven't yet seen one that does perl regexps properly.

    I didn't believe in evil until I dated it.

      Michel Lambert's Rebug and Mark-Jason Dominus' Rx are two good Perl-oriented regex debuggers. After I write the new version of my regex parser, Michel will be incorporating the parser into his debugger.

      Jeff[japhy]Pinyan: Perl, regex, and perl hacker.
      s++=END;++y(;-P)}y js++=;shajsj<++y(p-q)}?print:??;

Re: Test-a-Rex
by patgas (Friar) on Sep 03, 2001 at 19:40 UTC

    Pretty cool. I'm getting some errors, though, whenever I enter an 's' or 'q' by itself in the RegExp box. I took a quick look at your code, but regexes make my brain hurt, and I'm definitely not qualified to give advice.

    Scalar found where operator expected at (eval 90) line 1, near "q;$Match=$&;$PreMatch"
    Scalar found where operator expected at (eval 131) line 1, near "s;$Match=$&;$PreMatch=$`;$PostMatch"

    Hope that helps...

    "We're experiencing some Godzilla-related turbulence..."


      Yeah, known problem.. but I think I`ll take it as-is,
      it results from the program unleashing the regex, even while
      it is not totally finished, it being in an eval won`t crash the
      program, but the eval does....

      I might have opted for a 'try-it' button after one finishes writing
      the regex, but I think part of the strength of this program is that
      you can see the different matches/results while you are building/writing
      the regex


      print "profeth still\n" if /bird|devil/;
        Just swtich off warnings for that section with no warnings; or trap the warning call with $SIG{__WARN__} or redirect STDERR to /dev/null with open STDERR, ">/dev/null";

        I recommend the third. You can redirect to anywhere (say a "log" file) for systems with no /dev/null

        I didn't believe in evil until I dated it.

      Well, I haven't used eval too much, but isn't there a way to catch it if it dies? Then you can just print a little error message in the status boxes if it blows up... Just a thought.

      "We're experiencing some Godzilla-related turbulence..."

Log In?

What's my password?
Create A New User
Node Status?
node history
Node Type: perlcraft [id://109829]
Approved by root
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others examining the Monastery: (9)
As of 2021-01-20 21:02 GMT
Find Nodes?
    Voting Booth?