view release on metacpan or  search on metacpan

lib/CPANPLUS/YACSmoke/ReAssemble.pm  view on Meta::CPAN

                    ? '{'.join( ' ', keys(%{$path->[$n]})).'}'
                    : $path->[$n]
                ;
                $msg .= $n == $offset ? "<$atom>" : $atom;
            }
            print "# at path ($msg)\n";
        }

        if( $offset >= @$path ) {
            push @$path, { $token => [ $token, @in ], '' => undef };
            $debug and print "#   added remaining @{[_dump($path)]}\n";
            last;
        }
        elsif( $token ne $path->[$offset] ) {
            $debug and print "#   token $token not present\n";
            splice @$path, $offset, @$path-$offset, {
                length $token
                    ? ( _node_key($token) => [$token, @in])
                    : ( '' => undef )
                ,
                $path->[$offset] => [@{$path}[$offset..$#{$path}]],
            };
            $debug and print "#   path=@{[_dump($path)]}\n";
            last;
        }
        elsif( not @in ) {
            $debug and print "#   last token to add\n";
            if( defined( $path->[$offset+1] )) {
                ++$offset;
                if( ref($path->[$offset]) eq 'HASH' ) {
                    $debug and print "#   add sentinel to node\n";
                    $path->[$offset]{''} = undef;
                }
                else {
                    $debug and print "#   convert <$path->[$offset]> to node for sentinel\n";
                    splice @$path, $offset, @$path-$offset, {
                        ''               => undef,
                        $path->[$offset] => [ @{$path}[$offset..$#{$path}] ],
                    };
                }
            }
            else {
                # already seen this pattern
                ++$self->{stats_dup};
            }
            last;
        }
        # if we get here then @_ still contains a token
        ++$offset;
    }
    $list;
}

sub _insert_node {
    my $self   = shift;
    my $path   = shift;
    my $offset = shift;
    my $token  = shift;
    my $debug  = shift;
    my $path_end = [@{$path}[$offset..$#{$path}]];
    # NB: $path->[$offset] and $[path_end->[0] are equivalent
    my $token_key = _re_path($self, [$token]);
    $debug and print "#  insert node(@{[_dump($token)]}:@{[_dump(\@_)]}) (key=$token_key)",
        " at path=@{[_dump($path_end)]}\n";
    if( ref($path_end->[0]) eq 'HASH' ) {
        if( exists($path_end->[0]{$token_key}) ) {
            if( @$path_end > 1 ) {
                my $path_key = _re_path($self, [$path_end->[0]]);
                my $new = {
                    $path_key  => [ @$path_end ],
                    $token_key => [ $token, @_ ],
                };
                $debug and print "#   +bifurcate new=@{[_dump($new)]}\n";
                splice( @$path, $offset, @$path_end, $new );
            }
            else {
                my $old_path = $path_end->[0]{$token_key};
                my $new_path = [];
                while( @$old_path and _node_eq( $old_path->[0], $token )) {
                    $debug and print "#  identical nodes in sub_path ",
                        ref($token) ? _dump($token) : $token, "\n";
                    push @$new_path, shift(@$old_path);
                    $token = shift @_;
                }
                if( @$new_path ) {
                    my $new;
                    my $token_key = $token;
                    if( @_ ) {
                        $new = {
                            _re_path($self, $old_path) => $old_path,
                            $token_key => [$token, @_],
                        };
                        $debug and print "#  insert_node(bifurc) n=@{[_dump([$new])]}\n";
                    }
                    else {
                        $debug and print "#  insert $token into old path @{[_dump($old_path)]}\n";
                        if( @$old_path ) {
                            $new = ($self->_insert_path( $old_path, $debug, [$token] ))->[0];
                        }
                        else {
                            $new = { '' => undef, $token => [$token] };
                        }
                    }
                    push @$new_path, $new;
                }
                $path_end->[0]{$token_key} = $new_path;
                $debug and print "#   +_insert_node result=@{[_dump($path_end)]}\n";
                splice( @$path, $offset, @$path_end, @$path_end );
            }
        }
        elsif( not _node_eq( $path_end->[0], $token )) {
            if( @$path_end > 1 ) {
                my $path_key = _re_path($self, [$path_end->[0]]);
                my $new = {
                    $path_key  => [ @$path_end ],
                    $token_key => [ $token, @_ ],
                };
                $debug and print "#   path->node1 at $path_key/$token_key @{[_dump($new)]}\n";
                splice( @$path, $offset, @$path_end, $new );
            }
            else {