[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
texinfo/tp Texinfo/Common.pm Texinfo/Structurin...
|
From: |
Patrice Dumas |
|
Subject: |
texinfo/tp Texinfo/Common.pm Texinfo/Structurin... |
|
Date: |
Wed, 29 Feb 2012 21:48:10 +0000 |
CVSROOT: /sources/texinfo
Module name: texinfo
Changes by: Patrice Dumas <pertusus> 12/02/29 21:48:10
Modified files:
tp/Texinfo : Common.pm Structuring.pm
tp/t : test_tree_copy.t
Log message:
Better copy_tree, when doing the skeleton of the tree collect the new
reference, then in a second pass use the reference to complete the
structures in 'extra'.
Use it instead of dclone, as dlcone clones all the tree<going through
the parent.
CVSWeb URLs:
http://cvs.savannah.gnu.org/viewcvs/texinfo/tp/Texinfo/Common.pm?cvsroot=texinfo&r1=1.137&r2=1.138
http://cvs.savannah.gnu.org/viewcvs/texinfo/tp/Texinfo/Structuring.pm?cvsroot=texinfo&r1=1.124&r2=1.125
http://cvs.savannah.gnu.org/viewcvs/texinfo/tp/t/test_tree_copy.t?cvsroot=texinfo&r1=1.1&r2=1.2
Patches:
Index: Texinfo/Common.pm
===================================================================
RCS file: /sources/texinfo/texinfo/tp/Texinfo/Common.pm,v
retrieving revision 1.137
retrieving revision 1.138
diff -u -b -r1.137 -r1.138
--- Texinfo/Common.pm 26 Feb 2012 22:01:48 -0000 1.137
+++ Texinfo/Common.pm 29 Feb 2012 21:48:10 -0000 1.138
@@ -1444,39 +1444,195 @@
# extra->def_arg
-sub copy_tree($$);
-sub copy_tree($$)
+sub _copy_tree($$$);
+sub _copy_tree($$$)
{
my $current = shift;
my $parent = shift;
+ my $reference_associations = shift;
my $new = {};
+ $reference_associations->{$current} = $new;
$new->{'parent'} = $parent if ($parent);
foreach my $key ('type', 'cmdname', 'text') {
$new->{$key} = $current->{$key} if (exists($current->{$key}));
}
foreach my $key ('args', 'contents') {
if ($current->{$key}) {
+ if (ref($current->{$key}) ne 'ARRAY') {
+ my $command_or_type = '';
+ if ($new->{'cmdname'}) {
+ $command_or_type = '@'.$new->{'cmdname'};
+ } elsif ($new->{'type'}) {
+ $command_or_type = $new->{'type'};
+ }
+ print STDERR "Not an array [$command_or_type] $key
".ref($current->{$key})."\n";
+ }
$new->{$key} = [];
+ $reference_associations->{$current->{$key}} = $new->{$key};
foreach my $child (@{$current->{$key}}) {
- push @{$new->{$key}}, copy_tree($child, $new);
+ push @{$new->{$key}}, _copy_tree($child, $new,
$reference_associations);
}
}
}
if ($current->{'extra'}) {
$new->{'extra'} = {};
foreach my $key (keys %{$current->{'extra'}}) {
- if (!ref($current->{'extra'}->{$key})) {
- $new->{'extra'}->{$key} = $current->{'extra'}->{$key};
+ if ($current->{'cmdname'} and $current->{'cmdname'} eq 'multitable'
+ and $key eq 'prototypes') {
+ $new->{'extra'}->{$key} = [];
+ $reference_associations->{$current->{'extra'}->{$key}} = $new->{$key};
+ foreach my $child (@{$current->{'extra'}->{$key}}) {
+ push @{$new->{'extra'}->{$key}},
+ _copy_tree($child, $new, $reference_associations);
}
+ } elsif (!ref($current->{'extra'}->{$key})) {
+ $new->{'extra'}->{$key} = $current->{'extra'}->{$key};
}
- if ($current->{'extra'}->{'end_command'}) {
- # FIXME this should be a ref to the end command instead...
- $new->{'extra'}->{'end_command'} = 1;
}
}
return $new;
}
+# Not used.
+sub _collect_references($$);
+sub _collect_references($$)
+{
+ my $current = shift;
+ my $references = shift;
+ foreach my $key ('args', 'contents') {
+ if ($current->{$key}) {
+ $references->{$current->{$key}} = $current->{$key};
+ foreach my $child (@{$current->{$key}}) {
+ $references->{$child} = $child;
+ _collect_references($child, $references);
+ }
+ }
+ }
+}
+
+sub _substitute_references_in_array($$$);
+sub _substitute_references_in_array($$$)
+{
+ my $array = shift;
+ my $reference_associations = shift;
+ my $context = shift;
+
+ my $result = [];
+ my $index = 0;
+ foreach my $item (@{$array}) {
+ if (!ref($item)) {
+ push @{$result}, $item;
+ } elsif ($reference_associations->{$item}) {
+ push @{$result}, $reference_associations->{$item};
+ } elsif (ref($item) eq 'ARRAY') {
+ push @$result,
+ _substitute_references_in_array($item, $reference_associations,
+ "$context [$index]");
+ } elsif (defined($item->{'text'})) {
+ my $new_text = _copy_tree($item, undef, $reference_associations);
+ substitute_references($item, $new_text, $reference_associations);
+ push @{$result}, $new_text;
+ } else {
+ print STDERR "Trouble with $context [$index] (".ref($item).")\n";
+ push @{$result}, undef;
+ }
+ $index++;
+ }
+ return $result;
+}
+
+sub substitute_references($$$);
+sub substitute_references($$$)
+{
+ my $current = shift;
+ my $new = shift;
+ my $reference_associations = shift;
+
+ foreach my $key ('args', 'contents') {
+ if ($new->{$key}) {
+ my $index = 0;
+ foreach my $child (@{$new->{$key}}) {
+ substitute_references($child, $current->{$key}->[$index],
+ $reference_associations);
+ $index++;
+ }
+ }
+ }
+ if ($current->{'extra'}) {
+ foreach my $key (keys %{$current->{'extra'}}) {
+ if (ref($current->{'extra'}->{$key})) {
+ my $command_or_type = '';
+ if ($new->{'cmdname'}) {
+ $command_or_type = '@'.$new->{'cmdname'};
+ } elsif ($new->{'type'}) {
+ $command_or_type = $new->{'type'};
+ }
+
+ if ($current->{'cmdname'} and $current->{'cmdname'} eq 'multitable'
+ and $key eq 'prototypes') {
+ my $index = 0;
+ foreach my $child (@{$new->{'extra'}->{$key}}) {
+ substitute_references($child,
$current->{'extra'}->{$key}->[$index],
+ $reference_associations);
+ $index++;
+ }
+ } elsif ($reference_associations->{$current->{'extra'}->{$key}}) {
+ $new->{'extra'}->{$key}
+ = $reference_associations->{$current->{'extra'}->{$key}};
+ #print STDERR "Done [$command_or_type]: $key\n";
+ } else {
+ if (ref($current->{'extra'}->{$key}) eq 'ARRAY') {
+
+ #print STDERR "Array $command_or_type -> $key\n";
+ $new->{'extra'}->{$key} = _substitute_references_in_array(
+ $current->{'extra'}->{$key}, $reference_associations,
+ "[$command_or_type]{$key}");
+ } else {
+ if (($current->{'cmdname'}
+ and ($current->{'cmdname'} eq 'listoffloats'
+ or $current->{'cmdname'} eq 'float')
+ and $key eq 'type')
+ or ($key eq 'index_entry')
+ or ($current->{'type'}
+ and $current->{'type'} eq 'menu_entry'
+ and $key eq 'menu_entry_node')) {
+ foreach my $type_key (keys(%{$current->{'extra'}->{$key}})) {
+ if (!ref($current->{'extra'}->{$key}->{$type_key})) {
+ $new->{'extra'}->{$key}->{$type_key}
+ = $current->{'extra'}->{$key}->{$type_key};
+ } elsif
($reference_associations->{$current->{'extra'}->{$key}->{$type_key}}) {
+ $new->{'extra'}->{$key}->{$type_key}
+ =
$reference_associations->{$current->{'extra'}->{$key}->{$type_key}};
+ } elsif (ref($current->{'extra'}->{$key}->{$type_key}) eq
'ARRAY') {
+ $new->{'extra'}->{$key}->{$type_key}
+ = _substitute_references_in_array(
+ $current->{'extra'}->{$key}->{$type_key},
+ $reference_associations,
+ "[$command_or_type]{$key}{$type_key}");
+ } else {
+ print STDERR "Not substituting [$command_or_type]{$key}:
$type_key\n";
+ }
+ }
+ } else {
+ print STDERR "Not substituting [$command_or_type]: $key
($current->{'extra'}->{$key})\n";
+ }
+ }
+ }
+ }
+ }
+ }
+}
+
+sub copy_tree($;$)
+{
+ my $current = shift;
+ my $parent = shift;
+ my $reference_associations = {};
+ my $copy = _copy_tree($current, $parent, $reference_associations);
+ substitute_references($current, $copy, $reference_associations);
+ return $copy;
+}
+
sub modify_tree($$$;$);
sub modify_tree($$$;$)
{
Index: Texinfo/Structuring.pm
===================================================================
RCS file: /sources/texinfo/texinfo/tp/Texinfo/Structuring.pm,v
retrieving revision 1.124
retrieving revision 1.125
diff -u -b -r1.124 -r1.125
--- Texinfo/Structuring.pm 26 Feb 2012 22:01:48 -0000 1.124
+++ Texinfo/Structuring.pm 29 Feb 2012 21:48:10 -0000 1.125
@@ -29,7 +29,7 @@
# for error messages
use Texinfo::Convert::Texinfo;
-use Storable qw(dclone);
+use Carp qw(cluck);
require Exporter;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
@@ -430,6 +430,8 @@
if (@correct_level_offset_commands) {
push @{$contents[-1]->{'contents'}}, @correct_level_offset_commands;
}
+ #print STDERR "* $current_section_level
"._print_root_command_texi($current_section)."\n";
+ #print STDERR " $next_section_level
"._print_root_command_texi($next_section)."\n";
while ($next_section_level - $current_section_level > 1) {
$current_section_level++;
my $new_section = {'cmdname' =>
@@ -457,6 +459,7 @@
'contents' => [],
'parent' => $new_section->{'args'}->[0]->{'contents'}->[1]}];
push @contents, $new_section;
+ #print STDERR " -> "._print_root_command_texi($new_section)."\n";
}
my @set_level_offset_commands = _correct_level($next_section,
$contents[-1], -1);
@@ -1365,7 +1368,7 @@
if ($content->{'cmdname'} eq 'top') {
$new_node_tree = {'contents' => [{'text' => 'Top'}]};
} else {
- $new_node_tree = dclone({'contents'
+ $new_node_tree = Texinfo::Common::copy_tree({'contents'
=> $content->{'extra'}->{'misc_content'}});
}
my $new_node = _new_node ($self, $new_node_tree);
@@ -1386,6 +1389,17 @@
return address@hidden;
}
+sub _copy_contents($)
+{
+ my $contents = shift;
+ if (ref($contents) ne 'ARRAY') {
+ cluck "$contents not an array";
+ return undef;
+ }
+ my $copy = Texinfo::Common::copy_tree({'contents' => $contents});
+ return $copy->{'contents'};
+}
+
sub _new_node_menu_entry($$)
{
my $self = shift;
@@ -1395,7 +1409,8 @@
my $menu_entry_node = {'type' => 'menu_entry_node'};
$menu_entry_node->{'contents'}
- = dclone ($node_contents);
+ = _copy_contents ($node_contents);
+
foreach my $content (@{$menu_entry_node->{'contents'}}) {
$content->{'parent'} = $menu_entry_node;
}
@@ -1579,9 +1594,9 @@
and $node->{'extra'}->{'associated_section'}->{'extra'}
and
$node->{'extra'}->{'associated_section'}->{'extra'}->{'misc_content'}) {
$node_title_contents
- =
dclone($node->{'extra'}->{'associated_section'}->{'extra'}->{'misc_content'});
+ =
_copy_contents($node->{'extra'}->{'associated_section'}->{'extra'}->{'misc_content'});
} else {
- $node_title_contents = dclone($node->{'extra'}->{'node_content'});
+ $node_title_contents =
_copy_contents($node->{'extra'}->{'node_content'});
}
my $menu_comment = {'type' => 'menu_comment'};
$menu_comment->{'contents'}->[0] = {'type' => 'preformatted',
@@ -1599,7 +1614,7 @@
foreach my $menu (@{$node->{'menus'}}) {
foreach my $entry (@{$menu->{'contents'}}) {
if ($entry->{'type'} and $entry->{'type'} eq 'menu_entry') {
- push @master_menu_contents, dclone($entry);
+ push @master_menu_contents, Texinfo::Common::copy_tree($entry);
}
}
}
Index: t/test_tree_copy.t
===================================================================
RCS file: /sources/texinfo/texinfo/tp/t/test_tree_copy.t,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -b -r1.1 -r1.2
--- t/test_tree_copy.t 29 Dec 2011 23:24:49 -0000 1.1
+++ t/test_tree_copy.t 29 Feb 2012 21:48:10 -0000 1.2
@@ -72,16 +72,15 @@
';
my $tree = Texinfo::Parser::parse_texi_text(undef, $text);
-
+my $reference_associations = {};
my $copy = Texinfo::Common::copy_tree($tree, undef);
my $texi_tree = Texinfo::Convert::Texinfo::convert($tree);
is ($text, $texi_tree, "tree to texi and original match");
-#print STDERR diff(\$text, \$texi_tree);
-
my $texi_copy = Texinfo::Convert::Texinfo::convert($copy);
+is ($texi_copy, $texi_tree, "tree and copy to texi match");
#{
# local $Data::Dumper::Purity = 1;
@@ -90,8 +89,4 @@
#}
-is ($texi_copy, $texi_tree, "tree and copy to texi match");
-
-#print STDERR diff(\$texi_copy, \$texi_tree);
-
1;