t/read.tree.t fails with version 1.33 on Windows

[shawnlaffan]

Presumably related to the shift to File::Slurper but I have not diagnosed any further.

Sample fail reports on CPAN Testers:
http://www.cpantesters.org/cpan/report/76d46504-71fb-1014-b65d-b70acf55203a
http://www.cpantesters.org/cpan/report/039b1135-7a55-1014-a877-98872bbe1311
http://www.cpantesters.org/cpan/report/c9d83ae4-6bf9-1014-8029-b1e672673db0

Test log from the first link is below to save checking (and in case CPAN Testers is slow).

# Testing Tree::DAG_Node V 1.33
# Using ExtUtils::MakeMaker V 7.72
# Using File::Slurper V 0.014
# Using strict V 1.08
# Using utf8 V 1.13_01
# Using warnings V 1.23
t/00.versions.t ............. ok
t/about.perl.t .............. ok
# Warning: Don't try this at home kids. Some trees get into an infinite loop.
t/cut.and.paste.subtrees.t .. ok
t/load.t .................... ok

#   Failed test 'Utf8 attributes: Output tree matches shipped tree'
#   at t/read.tree.t line 31.
Wide character in print at C:\home\grapefruit\perl5\lib\perl5/Test2/Formatter/TAP.pm line 125.
#          got: 'Root. Attributes: {}
#     |--- ��. Attributes: {# => "����"}
#     |    |--- �¢. Attributes: {# => "�¢�¢"}
#     |    |    |--- ��. Attributes: {# => "����"}
#     |    |--- �¤. Attributes: {# => "�¤�¤"}
#     |    |--- �©. Attributes: {# => "�©�©"}
#     |         |--- ��. Attributes: {# => "����"}
#     |              |--- �±. Attributes: {# => "�±�±"}
#     |                   |--- ��. Attributes: {# => "����"}
#     |                        |--- �´. Attributes: {# => "�´�´"}
#     |                        |--- �´. Attributes: {# => "�´�´"}
#     |--- ��. Attributes: {# => "����"}
#          |--- �®. Attributes: {# => "�®�®"}
#          |    |--- �©. Attributes: {# => "�©�©"}
#          |--- �£. Attributes: {# => "�£�£"}
#          |--- �. Attributes: {# => "��"}
#          |--- �. Attributes: {# => "��"}
#          |--- ��xX. Attributes: {# => "��xX��xX"}
#               |--- �­. Attributes: {# => "�­�­"}
#               |--- �º. Attributes: {# => "�º�º"}
#               |--- �«. Attributes: {# => "�«�«"}
#               |--- �». Attributes: {# => "�»�»"}
# '
#     expected: 'Root. Attributes: {}
#     |--- ��. Attributes: {# => "����"}
#     |    |--- �¢. Attributes: {# => "�¢�¢"}
#     |    |    |--- ��. Attributes: {# => "����"}
#     |    |--- �¤. Attributes: {# => "�¤�¤"}
#     |    |--- �©. Attributes: {# => "�©�©"}
#     |         |--- ��. Attributes: {# => "����"}
#     |              |--- �±. Attributes: {# => "�±�±"}
#     |                   |--- ��. Attributes: {# => "����"}
#     |                        |--- �´. Attributes: {# => "�´�´"}
#     |                        |--- �´. Attributes: {# => "�´�´"}
#     |--- ��. Attributes: {# => "����"}
#          |--- �®. Attributes: {# => "�®�®"}
#          |    |--- �©. Attributes: {# => "�©�©"}
#          |--- �£. Attributes: {# => "�£�£"}
#          |--- �. Attributes: {# => "��"}
#          |--- �. Attributes: {# => "��"}
#          |--- ��xX. Attributes: {# => "��xX��xX"}
#               |--- �­. Attributes: {# => "�­�­"}
#               |--- �º. Attributes: {# => "�º�º"}
#               |--- �«. Attributes: {# => "�«�«"}
#               |--- �». Attributes: {# => "�»�»"}
# '
# Looks like you failed 1 test of 3.
t/read.tree.t ............... 
Dubious, test returned 1 (wstat 256, 0x100)
Failed 1/3 subtests 
t/string2hash.t ............. ok

Test Summary Report
-------------------
t/read.tree.t             (Wstat: 256 (exited 1) Tests: 3 Failed: 1)
  Failed test:  3
  Non-zero exit status: 1
Files=6, Tests=26,  2 wallclock secs ( 0.09 usr +  0.05 sys =  0.14 CPU)
Result: FAIL
Failed 1/6 test programs. 1/26 subtests failed.
dmake.exe:  Error code 255, while making 'test_dynamic'

[ronsavage]

Hi Shawn Thanx for the report. Could you please try the attached DAG_Node.pm. It has a 1 line patch. The original and this version both work on my Debian box, but you are running Strawberry Perl under MS Windows (shudder) so I suspect my use of 'UTF-8' explicitly in the read statement at line 1116 caused the problem.

…

On 2025-04-22 06:34, shawnlaffan wrote: Presumably related to the shift to File::Slurper but I have not diagnosed any further. Sample fail reports on CPAN Testers: http://www.cpantesters.org/cpan/report/76d46504-71fb-1014-b65d-b70acf55203a

-- Cheers Ron Savage savage.net.au quantumiq.au symboliciq.au package Tree::DAG_Node; use strict; use warnings; use warnings qw(FATAL utf8); # Fatalize encoding glitches. our $Debug = 0; our $VERSION = '1.33'; use File::Slurper 'read_lines'; # ----------------------------------------------- sub add_daughter { # alias ***@***.***) = @_; ***@***.***); } # ----------------------------------------------- sub add_daughters { # write-only method my($mother, @daughters) = @_; return unless @daughters; # no-op return $mother->_add_daughters_wrapper( sub { push @{$_[0]}, $_[1]; }, @daughters ); } # ----------------------------------------------- sub add_daughter_left { # alias ***@***.***) = @_; ***@***.***); } # ----------------------------------------------- sub add_daughters_left { # write-only method my($mother, @daughters) = @_; return unless @daughters; return $mother->_add_daughters_wrapper( sub { unshift @{$_[0]}, $_[1]; }, @daughters ); } # ----------------------------------------------- sub _add_daughters_wrapper { my($mother, $callback, @daughters) = @_; return unless @daughters; my %ancestors; @Ancestors{ $mother->ancestors } = undef; # This could be made more efficient by not bothering to compile # the ancestor list for $mother if all the nodes to add are # daughterless. # But then you have to CHECK if they're daughterless. # If $mother is [big number] generations down, then it's worth checking. foreach my $daughter ***@***.***) { # which may be () die "daughter must be a node object!" unless UNIVERSAL::can($daughter, 'is_node'); printf "Mother : %s (%s)\n", $mother, ref $mother if $Debug; printf "Daughter: %s (%s)\n", $daughter, ref $daughter if $Debug; printf "Adding %s to %s\n", ($daughter->name() || $daughter), ($mother->name() || $mother) if $Debug > 1; die 'Mother (' . $mother -> name . ") can't be its own daughter\n" if $mother eq $daughter; die "$daughter (" . ($daughter->name || 'no_name') . ") is an ancestor of $mother (" . ($mother->name || 'no_name') . "), so can't became its daughter\n" if exists $ancestors{$daughter}; my $old_mother = $daughter->{'mother'}; next if defined($old_mother) && ref($old_mother) && $old_mother eq $mother; # noop if $daughter is already $mother's daughter $old_mother->remove_daughters($daughter) if defined($old_mother) && ref($old_mother); &{$callback}($mother->{'daughters'}, $daughter); } $mother->_update_daughter_links; # need only do this at the end return; } # ----------------------------------------------- sub add_left_sister { # alias ***@***.***) = @_; ***@***.***); } # ----------------------------------------------- sub add_left_sisters { # write-only method my($this, @new) = @_; return() unless @new; @new = ***@***.***, $this); shift @new; pop @new; # kill the copies of $this return @new; } # ----------------------------------------------- sub add_right_sister { # alias ***@***.***) = @_; ***@***.***); } # ----------------------------------------------- sub add_right_sisters { # write-only method my($this, @new) = @_; return() unless @new; @new = $this->replace_with($this, @new); shift @new; shift @new; # kill the copies of $this return @new; } # ----------------------------------------------- sub address { my($it, $address) = @_[0,1]; if(defined($address) && length($address)) { # given the address, return the node. # invalid addresses return undef my $root = $it->root; my @Parts = map {$_ + 0} $address =~ m/(\d+)/g; # generous! die "Address \"$address\" is an ill-formed address" unless @Parts; die "Address \"$address\" must start with '0'" unless ***@***.***) == 0; my $current_node = $root; ***@***.***) { # no-op for root my $ord = shift @Parts; my @daughters = @{$current_node->{'daughters'}}; if($#daughters < $ord) { # illegal address print "* $address has an out-of-range index ($ord)!" if $Debug; return undef; } $current_node = $daughters[$ord]; unless(ref($current_node)) { print "* $address points to or thru a non-node!" if $Debug; return undef; } } return $current_node; } else { # given the node, return the address my @Parts = (); my $current_node = $it; my $mother; while(defined( $mother = $current_node->{'mother'} ) && ref($mother)) { unshift @Parts, $current_node->my_daughter_index; $current_node = $mother; } return join(':', 0, @Parts); } } # ----------------------------------------------- sub ancestors { my $this = shift; my $mama = $this->{'mother'}; # initial condition return () unless ref($mama); # I must be root! # Could be defined recursively, as: # if(ref($mama = $this->{'mother'})){ # return($mama, $mama->ancestors); # } else { # return (); # } # But I didn't think of that until I coded the stuff below, which is # faster. my @Ancestors = ( $mama ); # start off with my mama while(defined( $mama = $mama->{'mother'} ) && ref($mama)) { # Walk up the tree ***@***.***, $mama); # This turns into an infinite loop if someone gets stupid # and makes this tree cyclic! Don't do it! } return @Ancestors; } # ----------------------------------------------- sub attribute { # alias ***@***.***) = @_; ***@***.***); } # ----------------------------------------------- sub attributes { # read/write attribute-method # expects a ref, presumably a hashref my $this = shift; if(@_) { die "my parameter must be a reference" unless ref($_[0]); $this->{'attributes'} = $_[0]; } return $this->{'attributes'}; } # ----------------------------------------------- sub clear_daughters { # write-only method my($mother) = $_[0]; my @daughters = @{$mother->{'daughters'}}; @{$mother->{'daughters'}} = (); foreach my $one ***@***.***) { next unless UNIVERSAL::can($one, 'is_node'); # sanity check $one->{'mother'} = undef; } # Another, simpler, way to do it: # $mother->remove_daughters($mother->daughters); return @daughters; # NEW } # ----------------------------------------------- sub common { # Return the lowest node common to all these nodes... # Called as $it->common($other) or ***@***.***) my @Ones = @_; # all nodes I was given my($first, @Others) = @_; return $first unless @Others; # degenerate case my %ones; @Ones{ @Ones } = undef; foreach my $node ***@***.***) { die "TILT: node \"$node\" is not a node" unless UNIVERSAL::can($node, 'is_node'); my %first_lineage; @first_lineage{$first, $first->ancestors} = undef; my $higher = undef; # the common of $first and $node my @my_lineage = $node->ancestors; Find_Common: ***@***.***_lineage) { if(exists $first_lineage{$my_lineage[0]}) { $higher = $my_lineage[0]; last Find_Common; } shift @my_lineage; } return undef unless $higher; $first = $higher; } return $first; } # ----------------------------------------------- sub common_ancestor { my @Ones = @_; # all nodes I was given my($first, @Others) = @_; return $first->{'mother'} unless @Others; # which may be undef if $first is the root! my %ones; @Ones{ @Ones } = undef; # my arguments my $common = ***@***.***); if(exists($ones{$common})) { # if the common is one of my nodes... return $common->{'mother'}; # and this might be undef, if $common is root! } else { return $common; # which might be null if that's all common came up with } } # ----------------------------------------------- sub copy { my($from, $o) = @_[0,1]; $o = {} unless ref $o; # Straight dup, and bless into same class. my $to = bless { %$from }, ref($from); # Null out linkages. $to -> _init_mother; $to -> _init_daughters; # Dup the 'attributes' attribute. if ($$o{'no_attribute_copy'}) { $$to{attributes} = {}; } else { my $attrib_copy = ref($to->{'attributes'}); if ($attrib_copy) { if ($attrib_copy eq 'HASH') { # Dup the hashref. $$to{'attributes'} = { %{$$to{'attributes'}} }; } elsif ($attrib_copy = UNIVERSAL::can($to->{'attributes'}, 'copy') ) { # $attrib_copy now points to the copier method. $$to{'attributes'} = &{$attrib_copy}($from); } # Otherwise I don't know how to copy it; leave as is. } } $$o{'from_to'}{$from} = $to; # SECRET VOODOO # ...autovivifies an anon hashref for 'from_to' if need be # This is here in case I later want/need a table corresponding # old nodes to new. return $to; } # ----------------------------------------------- sub copy_at_and_under { my($from, $o) = @_[0,1]; $o = {} unless ref $o; my @daughters = map($_->copy_at_and_under($o), @{$from->{'daughters'}}); my $to = $from->copy($o); ***@***.***) if @daughters; return $to; } # ----------------------------------------------- sub copy_tree { my($this, $o) = @_[0,1]; my $root = $this->root; $o = {} unless ref $o; my $new_root = $root->copy_at_and_under($o); return $new_root; } # ----------------------------------------------- sub daughters { # read-only attrib-method: returns a list. my $this = shift; if(@_) { # undoc'd and disfavored to use as a write-method die "Don't set daughters with daughters anymore\n"; warn "my parameter must be a listref" unless ref($_[0]); $this->{'daughters'} = $_[0]; $this->_update_daughter_links; } #return $this->{'daughters'}; return @{$this->{'daughters'} || []}; } # ------------------------------------------------ sub decode_lol { my($self, $result) = @_; ***@***.***) = $result; my($obj); my($ref_type); ***@***.***); do { $obj = shift @workList; $ref_type = ref $obj; if ($ref_type eq 'ARRAY') { unshift @workList, @$obj; } elsif ($ref_type eq 'HASH') { push @stack, {%$obj}; } elsif ($ref_type) { die "Unsupported object type $ref_type\n"; } else { push @stack, $obj; } } while ***@***.***); return ***@***.***; } # End of decode_lol. # ----------------------------------------------- sub delete_tree { my $it = $_[0]; $it->root->walk_down({ # has to be callbackback, not callback 'callbackback' => sub { %{$_[0]} = (); bless($_[0], 'DEADNODE'); # cause become dead! cause become dead! return 1; } }); return; # Why DEADNODE? Because of the nice error message: # "Can't locate object method "leaves_under" via package "DEADNODE"." # Moreover, DEADNODE doesn't provide is_node, so fails my can() tests. } sub DEADNODE::delete_tree { return; } # in case you kill it AGAIN!!!!! AND AGAIN AND AGAIN!!!!!! OO-HAHAHAHA! # ----------------------------------------------- sub depth_under { my $node = shift; my $max_depth = 0; $node->walk_down({ '_depth' => 0, 'callback' => sub { my $depth = $_[1]->{'_depth'}; $max_depth = $depth if $depth > $max_depth; return 1; }, }); return $max_depth; } # ----------------------------------------------- sub descendants { # read-only method: return a list of my descendants my $node = shift; my @list = $node->self_and_descendants; shift @list; # lose myself. return @list; } # ----------------------------------------------- sub draw_ascii_tree { # Make a "box" for this node and its possible daughters, recursively. # The guts of this routine are horrific AND recursive! # Feel free to send me better code. I worked on this until it # gave me a headache and it worked passably, and then I stopped. my $it = $_[0]; my $o = ref($_[1]) ? $_[1] : {}; ***@***.***, @daughter_boxes, $width, @daughters); @daughters = @{$it->{'daughters'}}; $o->{'no_name'} = 0 unless exists $o->{'no_name'}; $o->{'h_spacing'} = 1 unless exists $o->{'h_spacing'}; $o->{'h_compact'} = 1 unless exists $o->{'h_compact'}; $o->{'v_compact'} = 1 unless exists $o->{'v_compact'}; my $printable_name; if($o->{'no_name'}) { $printable_name = '*'; } else { $printable_name = defined $it->name ? $it->name : $it; $printable_name =~ tr<\cm\cj\t >< >s; $printable_name = "<$printable_name>"; } ***@***.***)) { # I am a leaf! # Now add the top parts, and return. @box = ("|", $printable_name); } else { @daughter_boxes = map { &draw_ascii_tree($_, $o) } @daughters; my $max_height = 0; foreach my $box ***@***.***_boxes) { my $h = @$box; $max_height = $h if $h > $max_height; } @box = ('') x $max_height; # establish the list foreach my $one ***@***.***_boxes) { my $length = length($one->[0]); my $height = @$one; #now make all the same height. my $deficit = $max_height - $height; if($deficit > 0) { push @$one, ( scalar( ' ' x $length ) ) x $deficit; $height = scalar(@$one); } # Now tack 'em onto @box ########################################################## # This used to be a sub of its own. Ho-hum. my($b1, $b2) = ***@***.***, $one); my($h1, $h2) = (scalar(@$b1), scalar(@$b2)); ***@***.***, $to_chop); if($o->{'h_compact'}) { # Try for h-scrunching. my @diffs; my $min_diff = length($b1->[0]); # just for starters foreach my $line (0 .. ($h1 - 1)) { my $size_l = 0; # length of terminal whitespace my $size_r = 0; # length of initial whitespace $size_l = length($1) if $b1->[$line] =~ /( +)$/s; $size_r = length($1) if $b2->[$line] =~ /^( +)/s; my $sum = $size_l + $size_r; $min_diff = $sum if $sum < $min_diff; push @diffs, [$sum, $size_l, $size_r]; } $to_chop = $min_diff - $o->{'h_spacing'}; $to_chop = 0 if $to_chop < 0; } if(not( $o->{'h_compact'} and $to_chop )) { # No H-scrunching needed/possible foreach my $line (0 .. ($h1 - 1)) { $b1->[ $line ] .= $b2->[ $line ] . (' ' x $o->{'h_spacing'}); } } else { # H-scrunching is called for. foreach my $line (0 .. ($h1 - 1)) { my $r = $b2->[$line]; # will be the new line my $remaining = $to_chop; if($remaining) { my($l_chop, $r_chop) = @{$diffs[$line]}[1,2]; if($l_chop) { if($l_chop > $remaining) { $l_chop = $remaining; $remaining = 0; } elsif($l_chop == $remaining) { $remaining = 0; } else { # remaining > l_chop $remaining -= $l_chop; } } if($r_chop) { if($r_chop > $remaining) { $r_chop = $remaining; $remaining = 0; } elsif($r_chop == $remaining) { $remaining = 0; } else { # remaining > r_chop $remaining -= $r_chop; # should never happen! } } substr($b1->[$line], -$l_chop) = '' if $l_chop; substr($r, 0, $r_chop) = '' if $r_chop; } # else no-op $b1->[ $line ] .= $r . (' ' x $o->{'h_spacing'}); } # End of H-scrunching ickyness } # End of ye big tack-on } # End of the foreach daughter_box loop # remove any fencepost h_spacing if($o->{'h_spacing'}) { foreach my $line ***@***.***) { substr($line, -$o->{'h_spacing'}) = '' if length($line); } } # end of catenation die "SPORK ERROR 958203: Freak!!!!!" unless @box; # Now tweak the pipes my $new_pipes = $box[0]; my $pipe_count = $new_pipes =~ tr<|><+>; if($pipe_count < 2) { $new_pipes = "|"; } else { my($init_space, $end_space); # Thanks to Gilles Lamiral for pointing out the need to set to '', # to avoid -w warnings about undeffiness. if( $new_pipes =~ s<^( +)><>s ) { $init_space = $1; } else { $init_space = ''; } if( $new_pipes =~ s<( +)$><>s ) { $end_space = $1 } else { $end_space = ''; } $new_pipes =~ tr< ><->; substr($new_pipes,0,1) = "/"; substr($new_pipes,-1,1) = "\\"; $new_pipes = $init_space . $new_pipes . $end_space; # substr($new_pipes, int((length($new_pipes)), 1)) / 2) = "^"; # feh } # Now tack on the formatting for this node. if($o->{'v_compact'} == 2) { ***@***.*** == 1) { unshift @box, "|", $printable_name; } else { unshift @box, "|", $printable_name, $new_pipes; } } elsif ($o->{'v_compact'} == 1 and @daughters == 1) { unshift @box, "|", $printable_name; } else { # general case unshift @box, "|", $printable_name, $new_pipes; } } # Flush the edges: my $max_width = 0; foreach my $line ***@***.***) { my $w = length($line); $max_width = $w if $w > $max_width; } foreach my $one ***@***.***) { my $space_to_add = $max_width - length($one); next unless $space_to_add; my $add_left = int($space_to_add / 2); my $add_right = $space_to_add - $add_left; $one = (' ' x $add_left) . $one . (' ' x $add_right); } return ***@***.***; # must not return a null list! } # ----------------------------------------------- sub dump_names { my($it, $o) = @_[0,1]; $o = {} unless ref $o; my @out = (); $o->{'_depth'} ||= 0; $o->{'indent'} ||= ' '; $o->{'tick'} ||= ''; $o->{'callback'} = sub { my($this, $o) = @_[0,1]; ***@***.***, join('', $o->{'indent'} x $o->{'_depth'}, $o->{'tick'}, defined $this->name ? $this->name : $this, "\n" ) ); return 1; } ; $it->walk_down($o); return @out; } # ----------------------------------------------- sub format_node { my($self, $options, $node) = @_; my($s) = $node -> name; $s .= '. Attributes: ' . $self -> hashref2string($node -> attributes) if (! $$options{no_attributes}); return $s; } # End of format_node. # ----------------------------------------------- sub generation { my($node, $limit) = @_[0,1]; return $node if $node eq $limit || not( defined($node->{'mother'}) && ref($node->{'mother'}) ); # bailout return map(@{$_->{'daughters'}}, $node->{'mother'}->generation($limit)); # recurse! # Yup, my generation is just all the daughters of my mom's generation. } # ----------------------------------------------- sub generation_under { my($node, @rest) = @_; return ***@***.***); } # ----------------------------------------------- sub hashref2string { my($self, $hashref) = @_; $hashref ||= {}; return '{' . join(', ', map{qq|$_ => "$$hashref{$_}"|} sort keys %$hashref) . '}'; } # End of hashref2string. # ----------------------------------------------- sub _init { # method my $this = shift; my $o = ref($_[0]) eq 'HASH' ? $_[0] : {}; # Sane initialization. $this->_init_mother($o); $this->_init_daughters($o); $this->_init_name($o); $this->_init_attributes($o); return; } # ----------------------------------------------- sub _init_attributes { # to be called by an _init my($this, $o) = @_[0,1]; $this->{'attributes'} = {}; # Undocumented and disfavored. Consider this just an example. $this->attributes( $o->{'attributes'} ) if exists $o->{'attributes'}; } # ----------------------------------------------- sub _init_daughters { # to be called by an _init my($this, $o) = @_[0,1]; $this->{'daughters'} = []; # Undocumented and disfavored. Consider this just an example. $this->set_daughters( @{$o->{'daughters'}} ) if ref($o->{'daughters'}) && (@{$o->{'daughters'}}); # DO NOT use this option (as implemented) with new_daughter or # new_daughter_left!!!!! # BAD THINGS MAY HAPPEN!!! } # ----------------------------------------------- sub _init_mother { # to be called by an _init my($this, $o) = @_[0,1]; $this->{'mother'} = undef; # Undocumented and disfavored. Consider this just an example. ( $o->{'mother'} )->add_daughter($this) if defined($o->{'mother'}) && ref($o->{'mother'}); # DO NOT use this option (as implemented) with new_daughter or # new_daughter_left!!!!! # BAD THINGS MAY HAPPEN!!! } # ----------------------------------------------- sub _init_name { # to be called by an _init my($this, $o) = @_[0,1]; $this->{'name'} = undef; # Undocumented and disfavored. Consider this just an example. $this->name( $o->{'name'} ) if exists $o->{'name'}; } # ----------------------------------------------- sub is_daughter_of { my($it,$mama) = @_[0,1]; return $it->{'mother'} eq $mama; } # ----------------------------------------------- sub is_node { return 1; } # always true. # NEVER override this with anything that returns false in the belief # that this'd signal "not a node class". The existence of this method # is what I test for, with the various "can()" uses in this class. # ----------------------------------------------- sub is_root { my($self) = @_; return defined $self -> mother ? 0 : 1; } # End of is_root. # ----------------------------------------------- sub leaves_under { # read-only method: return a list of all leaves under myself. # Returns myself in the degenerate case of being a leaf myself. my $node = shift; my @list = (); $node->walk_down({ 'callback' => sub { my $node = $_[0]; my @daughters = @{$node->{'daughters'}}; ***@***.***, $node) unless @daughters; return 1; } }); die "Spork Error 861: ***@***.*** has no contents!?!?" unless @list; # impossible return @list; } # ----------------------------------------------- sub left_sister { my $it = $_[0]; my $mother = $it->{'mother'}; return undef unless $mother; my @Sisters = @{$mother->{'daughters'}}; return undef if @Sisters == 1; # I'm an only daughter my $left = undef; foreach my $one ***@***.***) { return $left if $one eq $it; $left = $one; } die "SPORK ERROR 9757: I'm not in my mother's daughter list!?!?"; } # ----------------------------------------------- sub left_sisters { my $it = $_[0]; my $mother = $it->{'mother'}; return() unless $mother; my @Sisters = @{$mother->{'daughters'}}; return() if @Sisters == 1; # I'm an only daughter my @out = (); foreach my $one ***@***.***) { return @out if $one eq $it; push @out, $one; } die "SPORK ERROR 9767: I'm not in my mother's daughter list!?!?"; } # ----------------------------------------------- sub lol_to_tree { my($class, $lol, $seen_r) = @_[0,1,2]; $seen_r = {} unless ref($seen_r) eq 'HASH'; return if ref($lol) && $seen_r->{$lol}++; # catch circularity $class = ref($class) || $class; my $node = $class->new(); unless(ref($lol) eq 'ARRAY') { # It's a terminal node. $node->name($lol) if defined $lol; return $node; } return $node unless @$lol; # It's a terminal node, oddly represented # It's a non-terminal node. my @options = @$lol; unless(ref($options[-1]) eq 'ARRAY') { # This is what separates this method from simple_lol_to_tree ***@***.***)); } foreach my $d ***@***.***) { # Scan daughters (whether scalars or listrefs) $node->add_daughter( $class->lol_to_tree($d, $seen_r) ); # recurse! } return $node; } # ----------------------------------------------- sub mother { # read-only attrib-method: returns an object (the mother node) my $this = shift; die "I'm a read-only method!" if @_; return $this->{'mother'}; } # ----------------------------------------------- sub my_daughter_index { # returns what number is my index in my mother's daughter list # special case: 0 for root. my $node = $_[0]; my $ord = -1; my $mother = $node->{'mother'}; return 0 unless $mother; my @Sisters = @{$mother->{'daughters'}}; die "SPORK ERROR 6512: My mother has no kids!!!" unless @Sisters; Find_Self: for(my $i = 0; $i < @Sisters; $i++) { if($sisters[$i] eq $node) { $ord = $i; last Find_Self; } } die "SPORK ERROR 2837: I'm not a daughter of my mother?!?!" if $ord == -1; return $ord; } # ----------------------------------------------- sub name { # read/write attribute-method. returns/expects a scalar my $this = shift; $this->{'name'} = $_[0] if @_; return $this->{'name'}; } # ----------------------------------------------- sub new { # constructor my $class = shift; $class = ref($class) if ref($class); # tchristic style. why not? my $o = ref($_[0]) eq 'HASH' ? $_[0] : {}; # o for options hashref my $it = bless( {}, $class ); print "Constructing $it in class $class\n" if $Debug; $it->_init( $o ); return $it; } # ----------------------------------------------- sub new_daughter { my($mother, @options) = @_; my $daughter = ***@***.***); push @{$mother->{'daughters'}}, $daughter; $daughter->{'mother'} = $mother; return $daughter; } # ----------------------------------------------- sub new_daughter_left { my($mother, @options) = @_; my $daughter = ***@***.***); unshift @{$mother->{'daughters'}}, $daughter; $daughter->{'mother'} = $mother; return $daughter; } # ----------------------------------------------- sub node2string { my($self, $options, $node, $vert_dashes) = @_; my($depth) = scalar($node -> ancestors) || 0; my($sibling_count) = defined $node -> mother ? scalar $node -> self_and_sisters : 1; my($offset) = ' ' x 5; ***@***.***) = map{$$vert_dashes[$_] || $offset} 0 .. $depth - 1; @$vert_dashes = ( @indent, ($sibling_count == 1 ? $offset : ' |'), ); if ($sibling_count == ($node -> my_daughter_index + 1) ) { $$vert_dashes[$depth] = $offset; } return join('' => @indent[1 .. $#indent]) . ($depth ? ' |--- ' : '') . $self -> format_node($options, $node); } # End of node2string. # ----------------------------------------------- sub quote_name { my($self, $name) = @_; return "'$name'"; } # End of quote_name. # ----------------------------------------------- sub random_network { # constructor or method. my $class = $_[0]; my $o = ref($_[1]) ? $_[1] : {}; my $am_cons = 0; my $root; if(ref($class)){ # I'm a method. $root = $_[0]; # build under the given node, from same class. $class = ref $class; $am_cons = 0; } else { # I'm a constructor $root = $class->new; # build under a new node, with class named. $root->name("Root"); $am_cons = 1; } my $min_depth = $o->{'min_depth'} || 2; my $max_depth = $o->{'max_depth'} || ($min_depth + 3); my $max_children = $o->{'max_children'} || 4; my $max_node_count = $o->{'max_node_count'} || 25; die "max_children has to be positive" if int($max_children) < 1; my @mothers = ( $root ); my @children = ( ); my $node_count = 1; # the root Gen: foreach my $depth (1 .. $max_depth) { last if $node_count > $max_node_count; Mother: foreach my $mother ***@***.***) { last Gen if $node_count > $max_node_count; my $children_number; if($depth <= $min_depth) { until( $children_number = int(rand(1 + $max_children)) ) {} } else { $children_number = int(rand($max_children)); } Beget: foreach (1 .. $children_number) { last Gen if $node_count > $max_node_count; my $node = $mother->new_daughter; $node->name("Node$node_count"); ++$node_count; ***@***.***, $node); } } @mothers = @children; @children = (); last unless @mothers; } return $root; } # ----------------------------------------------- sub read_attributes { my($self, $s) = @_; my($attributes); my($name); if ($s =~ /^(.+)\. Attributes: (\{.*\})$/) { ($name, $attributes) = ($1, $self -> string2hashref($2) ); } else { ($name, $attributes) = ($s, {}); } return Tree::DAG_Node -> new({name => $name, attributes => $attributes}); } # End of read_attributes. # ----------------------------------------------- sub read_tree { my($self, $file_name) = @_; my($count) = 0; my($last_indent) = 0; my($test_string) = '--- '; my($test_length) = length $test_string; my($indent); my($node); my($offset); my($root); ***@***.***); my($tos); for my $line (read_lines($file_name) ) { $count++; if ($count == 1) { $root = $node = $self -> read_attributes($line); } else { $indent = index($line, $test_string); if ($indent > $last_indent) { $tos = $node; push @stack, $node, $indent; } elsif ($indent < $last_indent) { $offset = $last_indent; while ($offset > $indent) { $offset = pop @stack; $tos = pop @stack; } push @stack, $tos, $offset; } # Warning: The next line must set $node. # Don't put the RHS into the call to add_daughter()! $node = $self -> read_attributes(substr($line, $indent + $test_length) ); $last_indent = $indent; $tos -> add_daughter($node); } } return $root; } # End of read_tree. # ----------------------------------------------- sub remove_daughters { # write-only method my($mother, @daughters) = @_; die "mother must be an object!" unless ref $mother; return unless @daughters; my %to_delete; @daughters = grep {ref($_) and defined($_->{'mother'}) and $mother eq $_->{'mother'} } @daughters; return unless @daughters; @to_delete{ @daughters } = undef; # This could be done better and more efficiently, I guess. foreach my $daughter ***@***.***) { $daughter->{'mother'} = undef; } my $them = $mother->{'daughters'}; @$them = grep { !exists($to_delete{$_}) } @$them; # $mother->_update_daughter_links; # unnecessary return; } # ----------------------------------------------- sub remove_daughter { # alias ***@***.***) = @_; ***@***.***); } # ----------------------------------------------- sub replace_with { # write-only method my($this, @replacements) = @_; if(not( defined($this->{'mother'}) && ref($this->{'mother'}) )) { # if root foreach my $replacement ***@***.***) { $replacement->{'mother'}->remove_daughters($replacement) if $replacement->{'mother'}; } # make 'em roots } else { # I have a mother my $mother = $this->{'mother'}; ***@***.*** = grep(($_ eq $this || $_->{'mother'} ne $mother), # @replacements); @replacements = grep { $_ eq $this || not(defined($_->{'mother'}) && ref($_->{'mother'}) && $_->{'mother'} eq $mother ) } @replacements; # Eliminate sisters (but not self) # i.e., I want myself or things NOT with the same mother as myself. $mother->set_daughters( # old switcheroo map($_ eq $this ? ***@***.***) : $_ , @{$mother->{'daughters'}} ) ); # and set_daughters does all the checking and possible # unlinking } return($this, @replacements); } # ----------------------------------------------- sub replace_with_daughters { # write-only method my($this) = $_[0]; # takes no params other than the self my $mother = $this->{'mother'}; return($this, $this->clear_daughters) unless defined($mother) && ref($mother); my @daughters = $this->clear_daughters; my $sib_r = $mother->{'daughters'}; @$sib_r = map($_ eq $this ? ***@***.***) : $_, @$sib_r # old switcheroo ); foreach my $daughter ***@***.***) { $daughter->{'mother'} = $mother; } return($this, @daughters); } # ----------------------------------------------- sub right_sister { my $it = $_[0]; my $mother = $it->{'mother'}; return undef unless $mother; my @Sisters = @{$mother->{'daughters'}}; return undef if @Sisters == 1; # I'm an only daughter my $seen = 0; foreach my $one ***@***.***) { return $one if $seen; $seen = 1 if $one eq $it; } die "SPORK ERROR 9777: I'm not in my mother's daughter list!?!?" unless $seen; return undef; } # ----------------------------------------------- sub right_sisters { my $it = $_[0]; my $mother = $it->{'mother'}; return() unless $mother; my @Sisters = @{$mother->{'daughters'}}; return() if @Sisters == 1; # I'm an only daughter my @out; my $seen = 0; foreach my $one ***@***.***) { push @out, $one if $seen; $seen = 1 if $one eq $it; } die "SPORK ERROR 9787: I'm not in my mother's daughter list!?!?" unless $seen; return @out; } # ----------------------------------------------- sub root { my $it = $_[0]; my @Ancestors = ($it, $it->ancestors); return $ancestors[-1]; } # ----------------------------------------------- sub self_and_descendants { # read-only method: return a list of myself and any/all descendants my $node = shift; my @list = (); $node->walk_down({ 'callback' => sub { push @list, $_[0]; return 1;}}); die "Spork Error 919: ***@***.*** has no contents!?!?" unless @list; # impossible return @list; } # ----------------------------------------------- sub self_and_sisters { my $node = $_[0]; my $mother = $node->{'mother'}; return $node unless defined($mother) && ref($mother); # special case return @{$node->{'mother'}->{'daughters'}}; } # ----------------------------------------------- sub set_daughters { # write-only method my($mother, @them) = @_; $mother->clear_daughters; ***@***.***) if @them; # yup, it's that simple } # ----------------------------------------------- sub simple_lol_to_tree { my($class, $lol, $seen_r) = @_[0,1,2]; $class = ref($class) || $class; $seen_r = {} unless ref($seen_r) eq 'HASH'; return if ref($lol) && $seen_r->{$lol}++; # catch circularity my $node = $class->new(); unless(ref($lol) eq 'ARRAY') { # It's a terminal node. $node->name($lol) if defined $lol; return $node; } # It's a non-terminal node. foreach my $d (@$lol) { # scan daughters (whether scalars or listrefs) $node->add_daughter( $class->simple_lol_to_tree($d, $seen_r) ); # recurse! } return $node; } # ----------------------------------------------- sub sisters { my $node = $_[0]; my $mother = $node->{'mother'}; return() unless $mother; # special case return grep($_ ne $node, @{$node->{'mother'}->{'daughters'}} ); } # ----------------------------------------------- sub string2hashref { my($self, $s) = @_; $s ||= ''; my($result) = {}; my($k); my($v); if ($s) { # Expect: # 1: The presence of the comma in "(',')" complicates things, so we can't use split(/\s*,\s*/, $s). # {x => "(',')"} # 2: The presence of "=>" complicates things, so we can't use split(/\s*=>\s*/). # {x => "=>"} # 3: So, assume ', ' is the outer separator, and then ' => ' is the inner separator. # Firstly, clean up the input, just to be safe. # None of these will match output from hashref2string($h). $s =~ s/^\s*\{*//; $s =~ s/\s*\}\s*$/\}/; my($finished) = 0; # The first '\' is for UltraEdit's syntax hiliting. my($reg_exp) = qr/ ([\"'])([^"']*?)\1\s*=>\s*(["'])([^"']*?)\3,?\s* | (["'])([^"']*?)\5\s*=>\s*(.*?),?\s* | (.*?)\s*=>\s*(["'])([^"']*?)\9,?\s* | (.*?)\s*=>\s*(.*?),?\s* /sx; ***@***.***); while (! $finished) { if ($s =~ /$reg_exp/gc) { push @got, defined($2) ? ($2, $4) : defined($6) ? ($6, $7) : defined($8) ? ($8, $10) : ($11, $12); } else { $finished = 1; } } $result = ***@***.***}; } return $result; } # End of string2hashref. # ----------------------------------------------- sub tree_to_lol { # I haven't /rigorously/ tested this. my($it, $o) = @_[0,1]; # $o is currently unused anyway $o = {} unless ref $o; my $out = []; my @lol_stack = ($out); $o->{'callback'} = sub { my($this, $o) = @_[0,1]; my $new = []; push @{$lol_stack[-1]}, $new; ***@***.***_stack, $new); return 1; } ; $o->{'callbackback'} = sub { my($this, $o) = @_[0,1]; my $name = defined $this->name ? $it -> quote_name($this->name) : 'undef'; push @{$lol_stack[-1]}, $name; pop @lol_stack; return 1; } ; $it->walk_down($o); die "totally bizarre error 12416" unless ref($out->[0]); $out = $out->[0]; # the real root return $out; } # ----------------------------------------------- sub tree_to_lol_notation { my($it, $o) = @_[0,1]; $o = {} unless ref $o; my @out = (); $o->{'_depth'} ||= 0; $o->{'multiline'} = 0 unless exists($o->{'multiline'}); my $line_end; if($o->{'multiline'}) { $o->{'indent'} ||= ' '; $line_end = "\n"; } else { $o->{'indent'} ||= ''; $line_end = ''; } $o->{'callback'} = sub { my($this, $o) = @_[0,1]; ***@***.***, $o->{'indent'} x $o->{'_depth'}, "[$line_end", ); return 1; } ; $o->{'callbackback'} = sub { my($this, $o) = @_[0,1]; my $name = defined $this->name ? $it -> quote_name($this->name) : 'undef'; ***@***.***, $o->{'indent'} x ($o->{'_depth'} + 1), "$name$line_end", $o->{'indent'} x $o->{'_depth'}, "],$line_end", ); return 1; } ; $it->walk_down($o); return join('', @out); } # ----------------------------------------------- sub tree_to_simple_lol { # I haven't /rigorously/ tested this. my $root = $_[0]; return $root->name unless scalar($root->daughters); # special case we have to nip in the bud my($it, $o) = @_[0,1]; # $o is currently unused anyway $o = {} unless ref $o; my $out = []; my @lol_stack = ($out); $o->{'callback'} = sub { my($this, $o) = @_[0,1]; my $new; my $name = defined $this->name ? $it -> quote_name($this->name) : 'undef'; $new = scalar($this->daughters) ? [] : $name; # Terminal nodes are scalars, the rest are listrefs we'll fill in # as we recurse the tree below here. push @{$lol_stack[-1]}, $new; ***@***.***_stack, $new); return 1; } ; $o->{'callbackback'} = sub { pop @lol_stack; return 1; }; $it->walk_down($o); die "totally bizarre error 12416" unless ref($out->[0]); $out = $out->[0]; # the real root return $out; } # ----------------------------------------------- sub tree_to_simple_lol_notation { my($it, $o) = @_[0,1]; $o = {} unless ref $o; my @out = (); $o->{'_depth'} ||= 0; $o->{'multiline'} = 0 unless exists($o->{'multiline'}); my $line_end; if($o->{'multiline'}) { $o->{'indent'} ||= ' '; $line_end = "\n"; } else { $o->{'indent'} ||= ''; $line_end = ''; } $o->{'callback'} = sub { my($this, $o) = @_[0,1]; if(scalar($this->daughters)) { # Nonterminal ***@***.***, $o->{'indent'} x $o->{'_depth'}, "[$line_end", ); } else { # Terminal my $name = defined $this->name ? $it -> quote_name($this->name) : 'undef'; push @out, $o->{'indent'} x $o->{'_depth'}, "$name,$line_end"; } return 1; } ; $o->{'callbackback'} = sub { my($this, $o) = @_[0,1]; ***@***.***, $o->{'indent'} x $o->{'_depth'}, "], $line_end", ) if scalar($this->daughters); return 1; } ; $it->walk_down($o); return join('', @out); } # ----------------------------------------------- sub tree2string { my($self, $options, $tree) = @_; $options ||= {}; $$options{no_attributes} ||= 0; $tree ||= $self; ***@***.***); ***@***.***_dashes); $tree -> walk_down ({ callback => sub { my($node) = @_; push @out, $self -> node2string($options, $node, ***@***.***_dashes); return 1, }, _depth => 0, }); return ***@***.***; } # End of tree2string. # ----------------------------------------------- sub unlink_from_mother { my $node = $_[0]; my $mother = $node->{'mother'}; $mother->remove_daughters($node) if defined($mother) && ref($mother); return $mother; } # ----------------------------------------------- sub _update_daughter_links { # Eliminate any duplicates in my daughters list, and update # all my daughters' links to myself. my $this = shift; my $them = $this->{'daughters'}; # Eliminate duplicate daughters. my %seen = (); @$them = grep { ref($_) && not($seen{$_}++) } @$them; # not that there should ever be duplicate daughters anyhoo. foreach my $one (@$them) { # linkage bookkeeping die "daughter <$one> isn't an object!" unless ref $one; $one->{'mother'} = $this; } return; } # ----------------------------------------------- sub walk_down { my($this, $o) = @_[0,1]; # All the can()s are in case an object changes class while I'm # looking at it. die "I need options!" unless ref($o); die "I need a callback or a callbackback" unless ( ref($o->{'callback'}) || ref($o->{'callbackback'}) ); my $callback = ref($o->{'callback'}) ? $o->{'callback'} : undef; my $callbackback = ref($o->{'callbackback'}) ? $o->{'callbackback'} : undef; my $callback_status = 1; print "Callback: $callback Callbackback: $callbackback\n" if $Debug; printf "* Entering %s\n", ($this->name || $this) if $Debug; $callback_status = &{ $callback }( $this, $o ) if $callback; if($callback_status) { # Keep recursing unless callback returned false... and if there's # anything to recurse into, of course. my @daughters = UNIVERSAL::can($this, 'is_node') ? @{$this->{'daughters'}} : (); ***@***.***) { $o->{'_depth'} += 1; #print "Depth " , $o->{'_depth'}, "\n"; foreach my $one ***@***.***) { $one->walk_down($o) if UNIVERSAL::can($one, 'is_node'); # and if it can do "is_node", it should provide a walk_down! } $o->{'_depth'} -= 1; } } else { printf "* Recursing below %s pruned\n", ($this->name || $this) if $Debug; } # Note that $callback_status doesn't block callbackback from being called if($callbackback){ if(UNIVERSAL::can($this, 'is_node')) { # if it's still a node! print "* Calling callbackback\n" if $Debug; scalar( &{ $callbackback }( $this, $o ) ); # scalar to give it the same context as callback } else { print "* Can't call callbackback -- $this isn't a node anymore\n" if $Debug; } } if($Debug) { if(UNIVERSAL::can($this, 'is_node')) { # if it's still a node! printf "* Leaving %s\n", ($this->name || $this) } else { print "* Leaving [no longer a node]\n"; } } return; } # ----------------------------------------------- 1; =pod =encoding utf-8 =head1 NAME Tree::DAG_Node - An N-ary tree =head1 SYNOPSIS =head2 Using as a base class package Game::Tree::Node; use parent 'Tree::DAG_Node'; # Now add your own methods overriding/extending the methods in C<Tree::DAG_Node>... =head2 Using as a class on its own use Tree::DAG_Node; my($root) = Tree::DAG_Node -> new({name => 'root', attributes => {uid => 0} }); $root -> add_daughter(Tree::DAG_Node -> new({name => 'one', attributes => {uid => 1} }) ); $root -> add_daughter(Tree::DAG_Node -> new({name => 'two', attributes => {} }) ); $root -> add_daughter(Tree::DAG_Node -> new({name => 'three'}) ); # Attrs default to {}. Or: my($count) = 0; my($tree) = Tree::DAG_Node -> new({name => 'Root', attributes => {'uid' => $count} }); Or: my $root = Tree::DAG_Node -> new(); $root -> name("I'm the tops"); $root -> attributes({uid => 0}); my $new_daughter = $root -> new_daughter; $new_daughter -> name('Another node'); $new_daughter -> attributes({uid => 1}); ... Lastly, for fancy wrappers - called _add_daughter() - around C<new()>, see these modules: L<Marpa::Demo::StringParser> and L<GraphViz2::Marpa>. Both of these modules use L<Moo>. See scripts/*.pl for other samples. =head2 Using with utf-8 data read_tree($file_name) works with utf-8 data. See t/read.tree.t and t/tree.utf8.attributes.txt. Such a file can be created by redirecting the output of tree2string() to a file of type utf-8. See the docs for L<Encode> for the difference between utf8 and utf-8. In brief, use utf-8. See also scripts/write_tree.pl and scripts/read.tree.pl and scripts/read.tree.log. =head1 DESCRIPTION This class encapsulates/makes/manipulates objects that represent nodes in a tree structure. The tree structure is not an object itself, but is emergent from the linkages you create between nodes. This class provides the methods for making linkages that can be used to build up a tree, while preventing you from ever making any kinds of linkages which are not allowed in a tree (such as having a node be its own mother or ancestor, or having a node have two mothers). This is what I mean by a "tree structure", a bit redundantly stated: =over 4 =item o A tree is a special case of an acyclic directed graph =item o A tree is a network of nodes where there's exactly one root node Also, the only primary relationship between nodes is the mother-daughter relationship. =item o No node can be its own mother, or its mother's mother, etc =item o Each node in the tree has exactly one parent Except for the root of course, which is parentless. =item o Each node can have any number (0 .. N) daughter nodes A given node's daughter nodes constitute an I<ordered> list. However, you are free to consider this ordering irrelevant. Some applications do need daughters to be ordered, so I chose to consider this the general case. =item o A node can appear in only one tree, and only once in that tree Notably (notable because it doesn't follow from the two above points), a node cannot appear twice in its mother's daughter list. =item o There's an idea of up versus down Up means towards to the root, and down means away from the root (and towards the leaves). =item o There's an idea of left versus right Left is toward the start (index 0) of a given node's daughter list, and right is toward the end of a given node's daughter list. =back Trees as described above have various applications, among them: representing syntactic constituency, in formal linguistics; representing contingencies in a game tree; representing abstract syntax in the parsing of any computer language -- whether in expression trees for programming languages, or constituency in the parse of a markup language document. (Some of these might not use the fact that daughters are ordered.) (Note: B-Trees are a very special case of the above kinds of trees, and are best treated with their own class. Check CPAN for modules encapsulating B-Trees; or if you actually want a database, and for some reason ended up looking here, go look at L<AnyDBM_File>.) Many base classes are not usable except as such -- but C<Tree::DAG_Node> can be used as a normal class. You can go ahead and say: use Tree::DAG_Node; my $root = Tree::DAG_Node->new(); $root->name("I'm the tops"); $new_daughter = Tree::DAG_Node->new(); $new_daughter->name("More"); $root->add_daughter($new_daughter); and so on, constructing and linking objects from C<Tree::DAG_Node> and making useful tree structures out of them. =head1 A NOTE TO THE READER This class is big and provides lots of methods. If your problem is simple (say, just representing a simple parse tree), this class might seem like using an atomic sledgehammer to swat a fly. But the complexity of this module's bells and whistles shouldn't detract from the efficiency of using this class for a simple purpose. In fact, I'd be very surprised if any one user ever had use for more that even a third of the methods in this class. And remember: an atomic sledgehammer B<will> kill that fly. =head1 OBJECT CONTENTS Implementationally, each node in a tree is an object, in the sense of being an arbitrarily complex data structure that belongs to a class (presumably C<Tree::DAG_Node>, or ones derived from it) that provides methods. The attributes of a node-object are: =over =item o mother -- this node's mother. undef if this is a root =item o daughters -- the (possibly empty) list of daughters of this node =item o name -- the name for this node Need not be unique, or even printable. This is printed in some of the various dumper methods, but it's up to you if you don't put anything meaningful or printable here. =item o attributes -- whatever the user wants to use it for Presumably a hashref to whatever other attributes the user wants to store without risk of colliding with the object's real attributes. (Example usage: attributes to an SGML tag -- you definitely wouldn't want the existence of a "mother=foo" pair in such a tag to collide with a node object's 'mother' attribute.) Aside from (by default) initializing it to {}, and having the access method called "attributes" (described a ways below), I don't do anything with the "attributes" in this module. I basically intended this so that users who don't want/need to bother deriving a class from C<Tree::DAG_Node>, could still attach whatever data they wanted in a node. =back "mother" and "daughters" are attributes that relate to linkage -- they are never written to directly, but are changed as appropriate by the "linkage methods", discussed below. The other two (and whatever others you may add in derived classes) are simply accessed thru the same-named methods, discussed further below. =head2 About The Documented Interface Stick to the documented interface (and comments in the source -- especially ones saying "undocumented!" and/or "disfavored!" -- do not count as documentation!), and don't rely on any behavior that's not in the documented interface. Specifically, unless the documentation for a particular method says "this method returns thus-and-such a value", then you should not rely on it returning anything meaningful. A I<passing> acquaintance with at least the broader details of the source code for this class is assumed for anyone using this class as a base class -- especially if you're overriding existing methods, and B<definitely> if you're overriding linkage methods. =head1 MAIN CONSTRUCTOR, AND INITIALIZER =over =item the constructor CLASS->new() or CLASS->new($options) This creates a new node object, calls $object->_init($options) to provide it sane defaults (like: undef name, undef mother, no daughters, 'attributes' setting of a new empty hashref), and returns the object created. (If you just said "CLASS->new()" or "CLASS->new", then it pretends you called "CLASS->new({})".) See also the comments under L</new($hashref)> for options supported in the call to new(). If you use C<Tree::DAG_Node> as a superclass, and you add attributes that need to be initialized, what you need to do is provide an _init method that calls $this->SUPER::_init($options) to use its superclass's _init method, and then initializes the new attributes: sub _init { my($this, $options) = @_[0,1]; $this->SUPER::_init($options); # call my superclass's _init to # init all the attributes I'm inheriting # Now init /my/ new attributes: $this->{'amigos'} = []; # for example } =item the constructor $obj->new() or $obj->new($options) Just another way to get at the L</new($hashref)> method. This B<does not copy> $obj, but merely constructs a new object of the same class as it. Saves you the bother of going $class = ref $obj; $obj2 = $class->new; =item the method $node->_init($options) Initialize the object's attribute values. See the discussion above. Presumably this should be called only by the guts of the L</new($hashref)> constructor -- never by the end user. Currently there are no documented options for putting in the $options hashref, but (in case you want to disregard the above rant) the option exists for you to use $options for something useful in a derived class. Please see the source for more information. =item see also (below) the constructors "new_daughter" and "new_daughter_left" =back =head1 METHODS =head2 add_daughter(LIST) An exact synonym for L</add_daughters(LIST)>. =head2 add_daughters(LIST) This method adds the node objects in LIST to the (right) end of $mother's I<daughter> list. Making a node N1 the daughter of another node N2 also means that N1's I<mother> attribute is "automatically" set to N2; it also means that N1 stops being anything else's daughter as it becomes N2's daughter. If you try to make a node its own mother, a fatal error results. If you try to take one of a node N1's ancestors and make it also a daughter of N1, a fatal error results. A fatal error results if anything in LIST isn't a node object. If you try to make N1 a daughter of N2, but it's B<already> a daughter of N2, then this is a no-operation -- it won't move such nodes to the end of the list or anything; it just skips doing anything with them. =head2 add_daughter_left(LIST) An exact synonym for L</add_daughters_left(LIST)>. =head2 add_daughters_left(LIST) This method is just like L</add_daughters(LIST)>, except that it adds the node objects in LIST to the (left) beginning of $mother's daughter list, instead of the (right) end of it. =head2 add_left_sister(LIST) An exact synonym for L</add_left_sisters(LIST)>. =head2 add_left_sisters(LIST) This adds the elements in LIST (in that order) as immediate left sisters of $node. In other words, given that B's mother's daughter-list is (A,B,C,D), calling B->add_left_sisters(X,Y) makes B's mother's daughter-list (A,X,Y,B,C,D). If LIST is empty, this is a no-op, and returns empty-list. This is basically implemented as a call to $node->replace_with(LIST, $node), and so all replace_with's limitations and caveats apply. The return value of $node->add_left_sisters(LIST) is the elements of LIST that got added, as returned by replace_with -- minus the copies of $node you'd get from a straight call to $node->replace_with(LIST, $node). =head2 add_right_sister(LIST) An exact synonym for L</add_right_sisters(LIST)>. =head2 add_right_sisters(LIST) Just like add_left_sisters (which see), except that the elements in LIST (in that order) as immediate B<right> sisters of $node; In other words, given that B's mother's daughter-list is (A,B,C,D), calling B->add_right_sisters(X,Y) makes B's mother's daughter-list (A,B,X,Y,C,D). =head2 address() =head2 address(ADDRESS) With the first syntax, returns the address of $node within its tree, based on its position within the tree. An address is formed by noting the path between the root and $node, and concatenating the daughter-indices of the nodes this passes thru (starting with 0 for the root, and ending with $node). For example, if to get from node ROOT to node $node, you pass thru ROOT, A, B, and $node, then the address is determined as: =over 4 =item o ROOT's my_daughter_index is 0 =item o A's my_daughter_index is, suppose, 2 A is index 2 in ROOT's daughter list. =item o B's my_daughter_index is, suppose, 0 B is index 0 in A's daughter list. =item o $node's my_daughter_index is, suppose, 4 $node is index 4 in B's daughter list. =back The address of the above-described $node is, therefore, "0:2:0:4". (As a somewhat special case, the address of the root is always "0"; and since addresses start from the root, all addresses start with a "0".) The second syntax, where you provide an address, starts from the root of the tree $anynode belongs to, and returns the node corresponding to that address. Returns undef if no node corresponds to that address. Note that this routine may be somewhat liberal in its interpretation of what can constitute an address; i.e., it accepts "0.2.0.4", besides "0:2:0:4". Also note that the address of a node in a tree is meaningful only in that tree as currently structured. (Consider how ($address1 cmp $address2) may be magically meaningful to you, if you meant to figure out what nodes are to the right of what other nodes.) =head2 ancestors() Returns the list of this node's ancestors, starting with its mother, then grandmother, and ending at the root. It does this by simply following the 'mother' attributes up as far as it can. So if $item IS the root, this returns an empty list. Consider that scalar($node->ancestors) returns the ply of this node within the tree -- 2 for a granddaughter of the root, etc., and 0 for root itself. =head2 attribute() =head2 attribute(SCALAR) Exact synonyms for L</attributes()> and L</attributes(SCALAR)>. =head2 attributes() =head2 attributes(SCALAR) In the first form, returns the value of the node object's "attributes" attribute. In the second form, sets it to the value of SCALAR. I intend this to be used to store a reference to a (presumably anonymous) hash the user can use to store whatever attributes he doesn't want to have to store as object attributes. In this case, you needn't ever set the value of this. (_init has already initialized it to {}.) Instead you can just do... $node->attributes->{'foo'} = 'bar'; ...to write foo => bar. =head2 clear_daughters() This unlinks all $mother's daughters. Returns the list of what used to be $mother's daughters. Not to be confused with L</remove_daughters(LIST)>. =head2 common(LIST) Returns the lowest node in the tree that is ancestor-or-self to the nodes $node and LIST. If the nodes are far enough apart in the tree, the answer is just the root. If the nodes aren't all in the same tree, the answer is undef. As a degenerate case, if LIST is empty, returns $node. =head2 common_ancestor(LIST) Returns the lowest node that is ancestor to all the nodes given (in nodes $node and LIST). In other words, it answers the question: "What node in the tree, as low as possible, is ancestor to the nodes given ($node and LIST)?" If the nodes are far enough apart, the answer is just the root -- except if any of the nodes are the root itself, in which case the answer is undef (since the root has no ancestor). If the nodes aren't all in the same tree, the answer is undef. As a degenerate case, if LIST is empty, returns $node's mother; that'll be undef if $node is root. =head2 copy($option) Returns a copy of the calling node (the invocant). E.g.: my($copy) = $node -> copy; $option is a hashref of options, with these (key => value) pairs: =over 4 =item o no_attribute_copy => $Boolean If set to 1, do not copy the node's attributes. If not specified, defaults to 0, which copies attributes. =back =head2 copy_at_and_under() =head2 copy_at_and_under($options) This returns a copy of the subtree consisting of $node and everything under it. If you pass no options, copy_at_and_under pretends you've passed {}. This works by recursively building up the new tree from the leaves, duplicating nodes using $orig_node->copy($options_ref) and then linking them up into a new tree of the same shape. Options you specify are passed down to calls to $node->copy. =head2 copy_tree() =head2 copy_tree($options) This returns the root of a copy of the tree that $node is a member of. If you pass no options, copy_tree pretends you've passed {}. This method is currently implemented as just a call to $this->root->copy_at_and_under($options), but magic may be added in the future. Options you specify are passed down to calls to $node->copy. =head2 daughters() This returns the (possibly empty) list of daughters for $node. =head2 decode_lol($lol) Returns an arrayref having decoded the deeply nested structure $lol. $lol will be the output of either tree_to_lol() or tree_to_simple_lol(). See scripts/read.tree.pl, and it's output file scripts/read.tree.log. =head2 delete_tree() Destroys the entire tree that $node is a member of (starting at the root), by nulling out each node-object's attributes (including, most importantly, its linkage attributes -- hopefully this is more than sufficient to eliminate all circularity in the data structure), and then moving it into the class DEADNODE. Use this when you're finished with the tree in question, and want to free up its memory. (If you don't do this, it'll get freed up anyway when your program ends.) If you try calling any methods on any of the node objects in the tree you've destroyed, you'll get an error like: Can't locate object method "leaves_under" via package "DEADNODE". So if you see that, that's what you've done wrong. (Actually, the class DEADNODE does provide one method: a no-op method "delete_tree". So if you want to delete a tree, but think you may have deleted it already, it's safe to call $node->delete_tree on it (again).) The L</delete_tree()> method is needed because Perl's garbage collector would never (as currently implemented) see that it was time to de-allocate the memory the tree uses -- until either you call $node->delete_tree, or until the program stops (at "global destruction" time, when B<everything> is unallocated). Incidentally, there are better ways to do garbage-collecting on a tree, ways which don't require the user to explicitly call a method like L</delete_tree()> -- they involve dummy classes, as explained at L<http://mox.perl.com/misc/circle-destroy.pod> However, introducing a dummy class concept into C<Tree::DAG_Node> would be rather a distraction. If you want to do this with your derived classes, via a DESTROY in a dummy class (or in a tree-metainformation class, maybe), then feel free to. The only case where I can imagine L</delete_tree()> failing to totally void the tree, is if you use the hashref in the "attributes" attribute to store (presumably among other things) references to other nodes' "attributes" hashrefs -- which 1) is maybe a bit odd, and 2) is your problem, because it's your hash structure that's circular, not the tree's. Anyway, consider: # null out all my "attributes" hashes $anywhere->root->walk_down({ 'callback' => sub { $hr = $_[0]->attributes; %$hr = (); return 1; } }); # And then: $anywhere->delete_tree; (I suppose L</delete_tree()> is a "destructor", or as close as you can meaningfully come for a circularity-rich data structure in Perl.) See also L</WHEN AND HOW TO DESTROY THE TREE>. =head2 depth_under() Returns an integer representing the number of branches between this $node and the most distant leaf under it. (In other words, this returns the ply of subtree starting of $node. Consider scalar($it->ancestors) if you want the ply of a node within the whole tree.) =head2 descendants() Returns a list consisting of all the descendants of $node. Returns empty-list if $node is a terminal_node. (Note that it's spelled "descendants", not "descendents".) =head2 draw_ascii_tree([$options]) Here, the [] refer to an optional parameter. Returns an arrayref of lines suitable for printing. Draws a nice ASCII-art representation of the tree structure. The tree looks like: | <Root> /-------+-----+---+---\ | | | | | <I> <H> <D> <E> <B> /---\ /---\ | | | | | | | <F> <F> <C> <J> <J> <J> <J> | | | | | | <G> <G> <K> <L> <K> <L> | | <M> <M> | | <N> <N> | | <O> <O> See scripts/cut.and.paste.subtrees.pl. Example usage: print map("$_\n", @{$tree->draw_ascii_tree}); I<draw_ascii_tree()> takes parameters you set in the $options hashref: =over 4 =item o h_compact Takes 0 or 1. Sets the extent to which I<draw_ascii_tree()> tries to save horizontal space. If I think of a better scrunching algorithm, there'll be a "2" setting for this. Default: 1. =item o h_spacing Takes a number 0 or greater. Sets the number of spaces inserted horizontally between nodes (and groups of nodes) in a tree. Default: 1. =item o no_name If true, I<draw_ascii_tree()> doesn't print the name of the node; it simply prints a "*". Default: 0 (i.e., print the node name.) =item o v_compact Takes a number 0, 1, or 2. Sets the degree to which I<draw_ascii_tree()> tries to save vertical space. Defaults to 1. =back The code occasionally returns trees that are a bit cock-eyed in parts; if anyone can suggest a better drawing algorithm, I'd be appreciative. See also L</tree2string($options, [$some_tree])>. =head2 dump_names($options) Returns an array. Dumps, as an indented list, the names of the nodes starting at $node, and continuin

[shawnlaffan]

The pm file was mangled by either github or gmail, but I think the change was this one below?

If so it does not fix the tests.

diff --git a/lib/Tree/DAG_Node.pm b/lib/Tree/DAG_Node.pm
index 75cd83c..da57908 100644
--- a/lib/Tree/DAG_Node.pm
+++ b/lib/Tree/DAG_Node.pm
@@ -1113,7 +1113,7 @@ sub read_tree
        my(@stack);
        my($tos);

-       for my $line (read_lines($file_name, 'UTF-8', 0) )
+       for my $line (read_lines($file_name) )
        {
                $count++;

Checking the generated and expected files shows they are the same. Ditto for the console dumps.

[ronsavage]

Hi Shawn Thanx. But I am confused. You say it does not fix the tests, but you also say the generated and expected files are the same, In the latter clause, do you mean the same as each other, in which case the patch worked, or the same as in before and after the patch, in which case the error is still there?

On 2025-04-23 02:01, shawnlaffan wrote: The pm file was mangled by either github or gmail, but I think the change was this one below? If so it does not fix the tests. diff --git a/lib/Tree/DAG_Node.pm b/lib/Tree/DAG_Node.pm index 75cd83c..da57908 100644 --- a/lib/Tree/DAG_Node.pm +++ b/lib/Tree/DAG_Node.pm @@ -1113,7 +1113,7 @@ sub read_tree ***@***.***); my($tos); - for my $line (read_lines($file_name, 'UTF-8', 0) ) + for my $line (read_lines($file_name) ) { $count++; Checking the generated and expected files shows they are the same. Ditto for the console dumps.

-- Cheers Ron Savage savage.net.au quantumiq.au symboliciq.au

[shawnlaffan]

It is somewhat confusing.

The files are the same when checked using an external tool (the compare plugin in notepad++).

However, the tests are failing when run under the test harness.

[shawnlaffan]

I added some more debugging and the lengths of the two strings were 1000 and 978. The difference is the newlines.

Converting all those in the tests gets things to pass, but that is obviously fixing the symptoms. Ideally it would be fixed at the source (if windows line endings are an issue).

diff --git a/t/read.tree.t b/t/read.tree.t
index 27b600e..218673a 100644
--- a/t/read.tree.t
+++ b/t/read.tree.t
@@ -28,7 +28,11 @@ sub process
        print $fh "$_\n" for @{$root -> tree2string({no_attributes => $no_attr})};
        close $fh;

-       is(read_text($input_file_name), read_text($test_file_name), "\u$file_name attributes: Output tree matches shipped tree");
+       my $got = read_text($input_file_name);
+       my $exp = read_text($test_file_name);
+       $exp =~ s/[\r\n]+/\n/gms;
+       $got =~ s/[\r\n]+/\n/gms;
+       is($got, $exp, "\u$file_name attributes: Output tree matches shipped tree");

[ronsavage]

Hi Shawn Ahhh. That is vital info. Thanx. Thinking aloud here... The files I ship are UTF-8 and the test t/read.tree.t at line 17 sets utf8 when it writes a new test file. But my patch to DAG_Node.pm removed the explicit UTF8 so File::Slurper's read_text() is defaulting to CRLF. Yet the test files contradicts that. When I patch line 17 to not use utf8, the tests fail on my machine. Sigh. I suspect I'll switch to File::Slurper's read_binary() and write_binary() methods, and then explicitly use utf8 to write the test files so they match what I ship. It's 3:37pm here now in Melbourne, so I may not get back to you today.

…

I added some more debugging and the lengths of the two strings were 1000 and 978. The difference is the newlines.

-- Cheers Ron Savage savage.net.au quantumiq.au symboliciq.au

[shawnlaffan]

Thanks Ron.

The solution/workaround might well be to convert anything from File::Slurper using s/[\r\n]/\n/gms, although File::Slurper does have the $crlf flag to convert them. Maybe that was simply not passed correctly before.

[ronsavage]

Hi Shawn Yes, that may well be the best solution. Then it does not matter how the files were written, nor under which OS they were written.

…

On 2025-04-23 05:55, shawnlaffan wrote: Thanks Ron. The solution/workaround might well be to convert anything from File::Slurper using s/[\r\n]/\n/gms, although File::Slurper does have the $crlf flag to convert them. Maybe that was simply not passed correctly before.

-- Cheers Ron Savage savage.net.au quantumiq.au symboliciq.au

[ronsavage]

Hi Shawn Please see attached. I will not release V 1.34 to CPAN until I hear back from you :-).

…

On 2025-04-23 05:55, shawnlaffan wrote: Thanks Ron. The solution/workaround might well be to convert anything from File::Slurper using s/[\r\n]/\n/gms, although File::Slurper does have the $crlf flag to convert them. Maybe that was simply not passed correctly before.

-- Cheers Ron Savage savage.net.au quantumiq.au symboliciq.au

[shawnlaffan]

Thanks Ron, but I think the email attachment was eaten by github. Can you try attaching it to the issue on the web interface?

[ronsavage]

Hi Shawn
I've uploaded the attachment to http://savage.net.au/misc/Tree-DAG_Node-1.34.tgz
See how you go.

[shawnlaffan]

No luck, unfortunately. The maps returned an array of 1's given that's what s/// returns for one change. My suggestion also did not clear the carriage returns - focusing only on \r seems to fix that.

Some modified code is below that deletes all carriage returns and gets all but one test to pass.

The debugging diagnostics show which whitespace characters are in the strings. It would seem the 'With attributes' test file contains an extra leading space for many lines (also below). Does this matter for the format?

diff --git a/t/read.tree.t b/t/read.tree.t
index 984e7d3..2ff68ed 100644
--- a/t/read.tree.t
+++ b/t/read.tree.t
@@ -30,10 +30,18 @@ sub process

        # Ensure inter-OS compatability.

-       my(@expected)   = map{s/[\r\n]/\n/gms} read_lines($input_file_name);
-       my(@got)                = map{s/[\r\n]/\n/gms} read_lines($test_file_name);
-
-       is(join('', @expected), join('', @got), "\u$file_name attributes: Output tree matches shipped tree");
+       my(@expected)   = map{s/\r$//gms; $_} read_lines($input_file_name);
+       my(@got)                = map{s/\r$//gms; $_} read_lines($test_file_name);
+       is_deeply(\@got, \@expected, "\u$file_name attributes: Output tree matches shipped tree");
+
+    for my $i (0..5) {
+        if (length $expected[$i] != length $got[$i]) {
+            diag "$i: " . length $expected[$i], ' ', length $got[$i];
+            diag $got[$i] =~ s/(\s)/ord($1).' '/gre;
+            diag $expected[$i] =~ s/(\s)/ord($1).' '/gre;
+            last;
+        }
+    }

 } # End of process.

t/read.tree.t ............... 4/?
#   Failed test 'With attributes: Output tree matches shipped tree'
#   at t/read.tree.t line 35.
#     Structures begin differing at:
#          $got->[1] = '    |--- :default. Attributes: {bracketed_name => "0", quantifier => "", real_name => ":default"}'
#     $expected->[1] = '   |--- :default. Attributes: {bracketed_name => "0", quantifier => "", real_name => ":default"}'
# 1: 96 97
# 32 32 32 32 |---32 :default.32 Attributes:32 {bracketed_name32 =>32 "0",32 quantifier32 =>32 "",32 real_name32 =>32 ":default"}
# 32 32 32 |---32 :default.32 Attributes:32 {bracketed_name32 =>32 "0",32 quantifier32 =>32 "",32 real_name32 =>32 ":default"}
# Looks like you failed 1 test of 5.
t/read.tree.t ............... Dubious, test returned 1 (wstat 256, 0x100)
Failed 1/5 subtests

[ronsavage]

I am both surprised and distressed that did not work. I'll spend time today on it of course.
Hold your breath - but not for too long....

[shawnlaffan]

It mostly works now. It's just the leading space for one format that remains as a sticking point.

[ronsavage]

The code you quoted above:

•   is_deeply(\@got, \@expected, "\u$file_name attributes: Output tree matches shipped tree");
  

Does not work:

Failed test 'Utf8 attributes: Output tree matches shipped tree'

at t/read.tree.t line 36.

got: 'ARRAY(0x55b8b6636470)'

expected: 'ARRAY(0x55b8b6636500)'

Failed test 'With attributes: Output tree matches shipped tree'

at t/read.tree.t line 36.

got: 'ARRAY(0x55b8b6e41bc8)'

expected: 'ARRAY(0x55b8b6e40270)'

Failed test 'Without attributes: Output tree matches shipped tree'

at t/read.tree.t line 36.

got: 'ARRAY(0x55b8b6e753f0)'

expected: 'ARRAY(0x55b8b6bff458)'

That's why I used join().