aboutsummaryrefslogtreecommitdiff
path: root/Perl/Zinc/Debug.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Perl/Zinc/Debug.pm')
-rw-r--r--Perl/Zinc/Debug.pm315
1 files changed, 170 insertions, 145 deletions
diff --git a/Perl/Zinc/Debug.pm b/Perl/Zinc/Debug.pm
index cb84c54..935709c 100644
--- a/Perl/Zinc/Debug.pm
+++ b/Perl/Zinc/Debug.pm
@@ -497,6 +497,150 @@ sub findintree {
} # end findintree
+sub searchInTree {
+
+ my $zinc = shift;
+ $searchtree_tl->destroy if $searchtree_tl and Tk::Exists($searchtree_tl);
+ $searchtree_tl = $zinc->Toplevel;
+ $searchtree_tl->title("Find string in tree");
+ my $fm = $searchtree_tl->Frame->pack(-side => 'top');
+ $fm->Label(-text => "Find : ",
+ )->pack(-side => 'left', -padx => 10, -pady => 10);
+ my $entry = $fm->Entry(-width => 20)->pack(-side => 'left',
+ -padx => 10, -pady => 10);
+ my $status = $searchtree_tl->Label(-foreground => 'sienna',
+ )->pack(-side => 'top');
+ my $ep = 1;
+ my $searchfunc = sub {
+ my $side = shift;
+ my $found = 0;
+ #print "ep=$ep side=$side\n";
+ $status->configure(-text => "");
+ $status->update;
+ $searchTreeEntryValue = $entry->get();
+ $searchTreeEntryValue = quotemeta($searchTreeEntryValue);
+ my $text;
+ while ($ep) {
+ $ep = $tree->info($side, $ep);
+ unless ($ep) {
+ $ep = 1;
+ $found = 0;
+ last;
+ }
+ $text = $tree->entrycget($ep, -text);
+ if ($text =~ /$searchTreeEntryValue/) {
+ $tree->see($ep);
+ $tree->selectionClear;
+ $tree->anchorSet($ep);
+ $tree->selectionSet($ep);
+ $found = 1;
+ last;
+ }
+ }
+ #print "searchTreeEntryValue=$searchTreeEntryValue found=$found\n";
+ $status->configure(-text => "Search string not found") unless $found > 0;
+ };
+
+ my $fm2 = $searchtree_tl->Frame->pack(-side => 'top');
+ $fm2->Button(-text => 'Prev',
+ -command => sub {&$searchfunc('prev');},
+ )->pack(-side => 'left', -pady => 10);
+ $fm2->Button(-text => 'Next',
+ -command => sub {&$searchfunc('next');},
+ )->pack(-side => 'left', -pady => 10);
+ $fm2->Button(-text => 'Close',
+ -command => sub {$searchtree_tl->destroy},
+ )->pack(-side => 'right', -pady => 10);
+ $entry->focus;
+ $entry->delete(0, 'end');
+ $entry->insert(0, $searchTreeEntryValue) if $searchTreeEntryValue;
+ $entry->bind('<Key-Return>', sub {&$searchfunc('next');});
+
+} # end searchInTree
+
+
+sub extractinfo {
+ my $zinc = shift;
+ my $item = shift;
+ my $format = shift;
+ my $option = shift;
+ my $titleflag = shift;
+ $option =~ s/^\s+//;
+ $option =~ s/\s+$//;
+ #print "option=[$option]\n";
+ my @info;
+ $WARNING = 0;
+ eval {@info = $zinc->itemcget($item, $option)};
+ #print "eval $option = (@info) $@\n";
+ return if $@;
+ return if @info == 0;
+ my $info;
+ my $sep = ($format eq 'column') ? "\n " : ", ";
+ if ($titleflag) {
+ $info = $sep."[$option] ".$info[0];
+ } else {
+ $info = $sep.$info[0];
+ }
+ if (@info > 1) {
+ shift(@info);
+ for (@info) {
+ if ($format eq 'column') {
+ if (length($info." ".$_) > 40) {
+ if ($titleflag) {
+ $info .= $sep."[$option] ".$_;
+ } else {
+ $info .= $sep.$_;
+ }
+ } else {
+ $info .= ", $_";
+ }
+ } else {
+ $info .= $sep.$_;
+ }
+ }
+ }
+ $WARNING = 1;
+ return $info;
+
+} # end extractinfo
+
+
+sub scangroup {
+
+ my ($zinc, $tree, $group, $path, $format, @optionstodisplay) = @_;
+ my @items = $zinc->find('withtag', "$group.");
+ for my $item (@items) {
+ my $Type = ucfirst($zinc->type($item));
+ my $info = " ";
+ if (@optionstodisplay == 1) {
+ $info .= &extractinfo($zinc, $item, $format, $optionstodisplay[0]);
+ } elsif (@optionstodisplay > 1) {
+ for my $opt (@optionstodisplay) {
+ $info .= &extractinfo($zinc, $item, $format, $opt, 1);
+ }
+ }
+ if ($Type eq "Group") {
+ $tree->add($path.".".$item,
+ -text => "$Type($item)$info",
+ -style => 'group',
+ );
+ &scangroup($zinc, $tree, $item, $path.".".$item, $format, @optionstodisplay);
+ } else {
+ $tree->add($path.".".$item,
+ -text => "$Type($item)$info",
+ -style => 'item',
+ );
+ }
+ }
+
+} # end scangroup
+
+#---------------------------------------------------------------------------
+#
+# Functions used to build code
+#
+#---------------------------------------------------------------------------
+
# build perl code corresponding to a branch of the items tree
sub buildCode {
@@ -525,7 +669,7 @@ sub buildCode {
} else {
push(@code, &buildItem($zinc, $item, 1));
}
- push(@code, &buildend);
+ push(@code, &buildEnd);
my $file = $zinc->getSaveFile(-filetypes => [['Perl Files', '.pl'],
['All Files', '*']],
@@ -543,7 +687,7 @@ sub buildCode {
} # end buildCode
-sub buildend {
+sub buildEnd {
my @code;
push(@code, 'for (keys(%items)) {');
@@ -552,7 +696,7 @@ sub buildend {
push(@code, 'MainLoop;');
return @code
-} # end buildend
+} # end buildEnd
# build a node of tree (corresponding to a TkZinc group item)
@@ -562,13 +706,18 @@ sub buildGroup {
my $item = shift;
my $group = shift;
my @code;
+ # creation
push(@code, '$items{'.$item.'}=$zinc->add("group", '.$group.', ');
# options
push(@code, &buildOptions($zinc, $item));
push(@code, ');');
push(@code, '');
+ # coords
push(@code, '$zinc->coords($items{'.$item.'}, ['.
join(',', $zinc->coords($item)).']);');
+ # transformations
+ push(@code, &buildTransformations($zinc, $item));
+
my @items = $zinc->find('withtag', "$item.");
for my $it (reverse(@items)) {
if ($zinc->type($it) eq 'group') {
@@ -592,7 +741,7 @@ sub buildItem {
my @code;
my $numfields = 0;
my $numcontours = 0;
- # type group and initargs
+ # creation
my $initstring = '$items{'.$item.'}=$zinc->add("'.$type.'", '.$group.', ';
if ($type eq 'tabular' or $type eq 'track' or $type eq 'waypoint') {
$numfields = $zinc->itemcget($item, -numfields);
@@ -623,11 +772,13 @@ sub buildItem {
push(@code, &buildOptions($zinc, $item));
push(@code, ');');
push(@code, '');
+ # fields
if ($numfields > 0) {
for (my $i=0; $i < $numfields; $i++) {
push(@code, &buildField($zinc, $item, $i));
}
}
+ # contours
if ($numcontours > 1) {
for (my $i=1; $i < $numcontours; $i++) {
my (@coords) = $zinc->coords($item);
@@ -644,6 +795,9 @@ sub buildItem {
push(@code, ' '.$coordstr.');');
}
}
+ # transformations
+ push(@code, &buildTransformations($zinc, $item));
+
return @code;
} # end buildItem
@@ -667,6 +821,17 @@ sub buildField {
} # end buildField
+sub buildTransformations {
+
+ my $zinc = shift;
+ my $item = shift;
+ my @tr = $zinc->tget($item);
+ my @code;
+ return ('$zinc->tset($items{'.$item.'}, '.join(", ", @tr).');');
+
+} # end buildTransformations
+
+
sub buildOptions {
my $zinc = shift;
@@ -695,7 +860,7 @@ sub buildOptions {
push(@code, " ".$option.' => "'.$value.'", ');
} elsif (ref($value) eq 'ARRAY') {
- push(@code, " ".$option." => [qw/".join(' ', @$value)."/], ");
+ push(@code, " ".$option." => [qw(".join(' ', @$value).")], ");
} else {
push(@code, " ".$option." => '".$value."', ");
@@ -705,146 +870,6 @@ sub buildOptions {
} # end buildOptions
-
-sub searchInTree {
-
- my $zinc = shift;
- $searchtree_tl->destroy if $searchtree_tl and Tk::Exists($searchtree_tl);
- $searchtree_tl = $zinc->Toplevel;
- $searchtree_tl->title("Find string in tree");
- my $fm = $searchtree_tl->Frame->pack(-side => 'top');
- $fm->Label(-text => "Find : ",
- )->pack(-side => 'left', -padx => 10, -pady => 10);
- my $entry = $fm->Entry(-width => 20)->pack(-side => 'left',
- -padx => 10, -pady => 10);
- my $status = $searchtree_tl->Label(-foreground => 'sienna',
- )->pack(-side => 'top');
- my $ep = 1;
- my $searchfunc = sub {
- my $side = shift;
- my $found = 0;
- #print "ep=$ep side=$side\n";
- $status->configure(-text => "");
- $status->update;
- $searchTreeEntryValue = $entry->get();
- $searchTreeEntryValue = quotemeta($searchTreeEntryValue);
- my $text;
- while ($ep) {
- $ep = $tree->info($side, $ep);
- unless ($ep) {
- $ep = 1;
- $found = 0;
- last;
- }
- $text = $tree->entrycget($ep, -text);
- if ($text =~ /$searchTreeEntryValue/) {
- $tree->see($ep);
- $tree->selectionClear;
- $tree->anchorSet($ep);
- $tree->selectionSet($ep);
- $found = 1;
- last;
- }
- }
- #print "searchTreeEntryValue=$searchTreeEntryValue found=$found\n";
- $status->configure(-text => "Search string not found") unless $found > 0;
- };
-
- my $fm2 = $searchtree_tl->Frame->pack(-side => 'top');
- $fm2->Button(-text => 'Prev',
- -command => sub {&$searchfunc('prev');},
- )->pack(-side => 'left', -pady => 10);
- $fm2->Button(-text => 'Next',
- -command => sub {&$searchfunc('next');},
- )->pack(-side => 'left', -pady => 10);
- $fm2->Button(-text => 'Close',
- -command => sub {$searchtree_tl->destroy},
- )->pack(-side => 'right', -pady => 10);
- $entry->focus;
- $entry->delete(0, 'end');
- $entry->insert(0, $searchTreeEntryValue) if $searchTreeEntryValue;
- $entry->bind('<Key-Return>', sub {&$searchfunc('next');});
-
-} # end searchInTree
-
-
-sub extractinfo {
- my $zinc = shift;
- my $item = shift;
- my $format = shift;
- my $option = shift;
- my $titleflag = shift;
- $option =~ s/^\s+//;
- $option =~ s/\s+$//;
- #print "option=[$option]\n";
- my @info;
- $WARNING = 0;
- eval {@info = $zinc->itemcget($item, $option)};
- #print "eval $option = (@info) $@\n";
- return if $@;
- return if @info == 0;
- my $info;
- my $sep = ($format eq 'column') ? "\n " : ", ";
- if ($titleflag) {
- $info = $sep."[$option] ".$info[0];
- } else {
- $info = $sep.$info[0];
- }
- if (@info > 1) {
- shift(@info);
- for (@info) {
- if ($format eq 'column') {
- if (length($info." ".$_) > 40) {
- if ($titleflag) {
- $info .= $sep."[$option] ".$_;
- } else {
- $info .= $sep.$_;
- }
- } else {
- $info .= ", $_";
- }
- } else {
- $info .= $sep.$_;
- }
- }
- }
- $WARNING = 1;
- return $info;
-
-} # end extractinfo
-
-
-sub scangroup {
-
- my ($zinc, $tree, $group, $path, $format, @optionstodisplay) = @_;
- my @items = $zinc->find('withtag', "$group.");
- for my $item (@items) {
- my $Type = ucfirst($zinc->type($item));
- my $info = " ";
- if (@optionstodisplay == 1) {
- $info .= &extractinfo($zinc, $item, $format, $optionstodisplay[0]);
- } elsif (@optionstodisplay > 1) {
- for my $opt (@optionstodisplay) {
- $info .= &extractinfo($zinc, $item, $format, $opt, 1);
- }
- }
- if ($Type eq "Group") {
- $tree->add($path.".".$item,
- -text => "$Type($item)$info",
- -style => 'group',
- );
- &scangroup($zinc, $tree, $item, $path.".".$item, $format, @optionstodisplay);
- } else {
- $tree->add($path.".".$item,
- -text => "$Type($item)$info",
- -style => 'item',
- );
- }
- }
-
-} # end scangroup
-
-
#---------------------------------------------------------------------------
#
# Functions related to search in a rectangular area
generated by cgit v1.1 at 2024-11-03 01:31:58 +0000