view release on metacpan or  search on metacpan

lib/Compress/BraceExpansion.pm  view on Meta::CPAN

                my $output = $self->_print_tree_recurse( $pointers_of{ident $self}->{ $pointer } );
                $buffer .= $output;
                delete $tree_of{ident $self}->{ $pointer };
                $pointer = undef;
            }
        }
        if (wantarray( )) {
            # list context - only really useful when being called from within
            # a recursion.
            return ( $buffer, $pointer );
        }

        return $buffer;
    }

    # walk through the tree looking for ends that are identical.  If
    # identical ends are found on all branches, copy the branch off to a
    # temporary branch location and replace the originals with a link to
    # the new location.  Currently this only handles the cases where all
    # branches are identical from some point until the end of the strings.
    sub _merge_tree_recurse {
        my ( $self, $tree, $root ) = @_;

        unless ( $root ) { $root = $tree };

        my @nodes = keys %{ $tree };
        if ( @nodes == 1 ) {
            return ( $tree, $root ) if $nodes[0] eq 'end';
            ( $tree ) = $self->_merge_tree_recurse( $tree->{ $nodes[0] }, $root );
        } elsif ( @nodes > 1 ) {
            my @paths;
            for my $node ( @nodes ) {
                my $text = $self->_print_tree_recurse( $tree->{$node} );
                return ( $tree, $root ) unless $text;
                push @paths, $text;
            }

            # check for merge points in the tree.  if they exist,
            # transplant them.
            my $depth = _check_merge_point( @paths );
            if ( defined( $depth ) ) {
                #print "\n\n";
                #print "Merging at depth: $depth\n";
                #print Dumper @paths;
                #print "\n\n";
                $tree = $self->_transplant( $tree, $depth||1 );
            }
        }

        if (wantarray( )) {
            # list context - only really useful when being called
            # within a recursion
            return( $tree, $root );
        }

        return $root;
    }


    # given a data tree, a set of paths within that tree, and the depth
    # beyond which they are all identical, clone the paths and relocate
    # the identical branches on the POINTERS node.  Remove the specified
    # paths and replace them with a link to the new location.
    sub _transplant {
        my ( $self, $tree_h, $depth ) = @_;

        my @nodes = keys %{ $tree_h };

        my $id = $self->_get_new_pointer_id();
        #print "\nID: $id\n";
        my $pruned;

        for my $node ( @nodes ) {
            my ( $depth_pointer, $next_node );
            if ( $depth > 1 ) {
                $depth_pointer = $tree_h->{ $node };
                $next_node = (keys %{ $depth_pointer })[0];
                die "tried to transplant past end of tree" if $next_node eq 'end';
                if ( $depth > 2 ) {
                    for my $depth ( 2 .. $depth - 1) {
                        $depth_pointer = $depth_pointer->{ $next_node };
                        $next_node = (keys %{ $depth_pointer })[0];
                        die "tried to transplant past end of tree" if $next_node eq 'end';
                        #print "DEPTH:\n";
                        #print Dumper $depth_pointer;
                    }
                }
            } else {
                $depth_pointer = $tree_h;
                $next_node = $node;
            }

            # if this is the end of the tree, give up trying
            my $child_node = $depth_pointer->{ $next_node };
            my $child_node_name = (keys %{ $depth_pointer->{ $next_node } })[0];
            if ( $child_node_name eq 'end' ) {
                die "Error: Tried to transplant end of tree";
            }

            unless ( $pruned ) {
                $pruned = $depth_pointer->{ $next_node };
                #print "PRUNED:\n";
                #print Dumper $pruned;
            }
            $depth_pointer->{ $next_node } = { POINTER => $id };
        }
        $pointers_of{ident $self}->{ $id } = $pruned;

        return ( $tree_h );
    }

    # given a series of strings, determine the longest number of
    # characters that all strings have in common beginning from the tail
    # end.  Return the number of characters from the current location
    # (which will represent the number of hash levels deep) where the
    # similar strings begin.
    sub _check_merge_point {
        my ( @strings ) = @_;

        # search for the longest substring from the end that all strings
        # match.