I have a Text widget ($text) that contains text that I've read in from a file. It looks something like this:
...
I need to find all the circles, grab their names, and put them into an array (to then be read into a tree widget, but that's another topic).
#!/usr/bin/perl
use strict;
use warnings;
use Data::Dumper qw(Dumper);
{
my $data = do { local $/; <DATA> };
$data =~ s/^ Shapes \s+? \{ (.*) \} \s+ $/$1/sx;
my @chunks;
push @chunks, [ $1, $2, $3 ]
while $data =~ /
Shape=Circle \s+
\{ \s+
name=(\w+) \s+
diameter=(\d+) \s+
color=(\w+) \s+
\}
/gsx;
print Dumper \@chunks;
}
__DATA__
Shapes
{
Shape=Circle
{
name=joe
diameter=3
color=blue
}
Shape=Circle
{
name=steve
diameter=5
color=red
}
}
outputs
$VAR1 = [
[
'joe',
'3',
'blue'
],
[
'steve',
'5',
'red'
]
];
| [reply]
[d/l]
[select] |
Thanks shigetsu, this works. I just need to figure out how to also extract the line.char info from where the matches were found in the text window.
| [reply] |
How could this be modified to account for other text? For example:
Shapes
{
Shape=Circle
{
name=joe
diameter=3
color=blue
{
random stuff
{
further depth
}
}
}
}
I think this just comes down to creating the right regex, but nothing I've tried is able to ignore the rest of the text. I still just want the circle and it's name. thx | [reply]
[d/l] |
This will parse the format you've indicated. It's pretty flexible about whitespace and accepts comments in most of the obvious places.
It produces the HoAoHs you see at the bottom of the page which gives you access to everything you need. As requested above, it parses, but ignores nested blocks below the first level.
It should deal with any number of Shape types and any number of key/value attribute pairs. Both key and value must not contain spaces.
#! perl -slw
use strict;
use re qw[ eval ];
use Data::Dump;
my %shapes;
my( $type, $key, $value );
my $reComment = qr[ \# .*? \n \s* ]x;
my $reWS = qr[ \s* | $reComment ]smx;
my $reNestedBlock;
$reNestedBlock = qr[
\{ (?> [^{}]+ | (??{ $reNestedBlock }) )+ \} $reWS
]smx;
my $reAttribs = qr[
$reComment
|
( (?> \w+ ) ) (?{ $key = $^N })
\s* = \s*
( \S+ ) (?{ $value = $^N })
(?{ $shapes{ $type }[-1]{ $key } = $value })
$reWS
]smx;
my $reShape = qr[
$reComment
|
Shape \s* = \s* ( (?> \w+ ) )
(?{ push @{ $shapes{ $type = $^N } }, {} })
$reWS+
\{ $reWS
(?> $reAttribs+ ) $reNestedBlock?
\} $reWS
]smx;
my $reShapes = qr[
Shapes $reWS \{ $reWS $reShape+ \}
]smx;
do{ local $/; <DATA> } =~ $reShapes or die "Failed to match!";
print dump \%shapes;
__DATA__
Shapes
{
Shape=Circle # A comment
{
name= joe
diameter=3
color=blue
# A comment
}
## Another one
Shape=Triangle{ name=Equilateral sides=3,3,3 color=green }
Shape=Triangle{ name = Right sides = 3,4,5 color = green }
Shape=Circle { name=steve diameter=5 color=red }
Shape=Square { name=steve2 size=5 color=black }
Shape = Square
{
name=fred2
size=3
color=yellow
{ random stuff { {{{{{{{{{{{{{{{fred}}}}}}}}}}}}}}} } }
}
Shape=Circle { # A comment
name = fred # a comment
diameter = 3
color = blue
{
random stuff
{
further depth
}
}
}
}
Output: C:\test>624564
{
Circle => [
{ color => "blue", diameter => 3, name => "joe" },
{ color => "red", diameter => 5, name => "steve" },
{ color => "blue", diameter => 3, name => "fred" },
],
Square => [
{ color => "black", name => "steve2", size => 5 },
{ color => "yellow", name => "fred2", size => 3 },
],
Triangle => [
{ color => "green", name => "Equilateral", sides => "3
+,3,3" },
{ color => "green", name => "Right", sides => "3,4,5"
+},
],
}
Two caveats:
- When it fails, it doesn't tell you why or where.
That's why I added the comment facility, it makes it resonably quick to locate errors.
- I'm not offering to maintain or extend it for you.
It's not horribly complicated, and with a little study you should be able to work out how to extend it if you need to.
I don't mind answering questions to help you, but do not expect to be able to ask for feature XYZ and just get code back. Ask for help in implemeting XYZ, post your attempt, and you'll probably get it.
Bear those in mind before you decide to use the above code.
Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
"Science is about questioning the status quo. Questioning authority".
In the absence of evidence, opinion is indistinguishable from prejudice.
| [reply]
[d/l]
[select] |
| [reply] |
| [reply] |
| [reply] |
... I was thinking of using the line.char references was so that I could insert the new circles in the correct place in the text ...
Rather than fighting to translate character offsets to line/char offsets in order to insert the additions, why not query the entire text, perform substitutions on that and then replace (delete/insert) the entire text?
Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
"Science is about questioning the status quo. Questioning authority".
In the absence of evidence, opinion is indistinguishable from prejudice.
| [reply] |
Without writing it for you, this script shows the general idea on using the search method of the Text widget.
#!/usr/bin/perl
use warnings;
use strict;
use Tk;
use Tk::LabEntry;
my $mw = MainWindow->new( -bg => 'black' );
$mw->geometry('100x30+100+15');
my $file_name = shift || $0;
my $file;
open (FH,"< $file_name");
read( FH, $file, -s FH );
close FH;
my $search_string = '';
my $kind = 'exact';
my $stringframe = $mw->Frame;
my $ss = $stringframe->LabEntry(
-label => 'Search string:',
-width => 40,
-labelPack => [qw/-side left -anchor w/],
-textvariable => \$search_string
)->pack(qw/-side left/);
my $ss_button = $stringframe->Button( -text => 'Highlight' );
$ss_button->pack(qw/-side left -pady 5 -padx 10/);
my $text = $mw->Scrolled(qw/Text -setgrid true -scrollbars e/);
$text->tagConfigure( 'search', -foreground => 'red',-background => '
+white' );
$text->insert('0.0', $file);
$text->mark(qw/set insert 0.0/);
my $subframe = $mw->Frame;
my $exact = $subframe->Radiobutton(
-text => 'Exact match',
-variable => \$kind,
-value => 'exact'
);
my $regexp = $subframe->Radiobutton(
-text => 'Regular expression',
-variable => \$kind,
-value => 'regexp'
);
$exact->pack( qw/-side left/, -fill => 'x' );
$regexp->pack( qw/-side right/, -fill => 'x' );
$stringframe->pack(qw/-side top -fill x/);
$subframe->pack(qw/-side top -fill x/);
$text->pack(qw/-expand yes -fill both/);
my $command = sub { &search_text($text,\$search_string,'search',$kind)
+ };
$ss_button->configure( -command => $command );
$ss->bind( '<Return>' => $command );
MainLoop;
######################################################################
+#3
sub search_text {
# The utility procedure below searches for all instances of a give
+n
# string in a text widget and applies a given tag to each instance
+ found.
# Arguments:
#
# w - The window in which to search. Must be a text widget.
# string - Reference to the string to search for. The search i
+s done
# using exact matching only; no special characters.
# tag - Tag to apply to each instance of a matching string.
my ( $w, $string, $tag, $kind ) = @_;
#print "@_\n";
return unless ref($string) && length($$string);
$w->tagRemove( $tag, qw/0.0 end/ );
my ( $current, $length ) = ( '1.0', 0 );
while (1) {
$current =
$w->search( -count => \$length, "-$kind", $$string, $current
+, 'end' );
last if not $current;
warn "Posn=$current count=$length\n",
$w->tagAdd( $tag, $current, "$current + $length char" );
$current = $w->index("$current + $length char");
}
} # end search_text
| [reply]
[d/l] |