view release on metacpan or  search on metacpan

lib/Perl6/Perldoc/Parser.pm  view on Meta::CPAN

        if ($block->{typename} eq '(use)') {
            my $source = $block->{source};
            if (eval "require $source") {
                my %options = (
                    %{ $block->{config}{use}||{} },
                    %{ $block->{options} || {} },
                );
                $source->import(\%options);
            }
            else {
                _err_use_cant_load($source, $line_num, \@errors);
                next TOKEN;
            }
        }

        push @{ $stack[-1]{content} }, $block;

        ### Implicitly terminated block: $block
    }

    # Apply global processing to root of data structure...
    my $root = pop(@stack);

    # Number all numbered blocks...
    my $state_ref = { errors => \@errors };
    _resolve_numbering($root, $state_ref);

    # Convert internal hash-based representation to objects...
    my $tree = _create_objects($root, $state_ref);

    # Build and install any tables-of-content for P<toc:...> codes...
    TOC:
    for my $toc_placement_obj (@toc_placements) {
        next TOC if $toc_placement_obj->{content}[0] !~ m{\A \s* toc:}xms;

        # Replace P<toc:...>'s contents with TOC...
        $toc_placement_obj->{content}
            = [ _build_toc($tree, $toc_placement_obj) ];

        # Set flag to ignore this node on subsequent TOC-building passes...
        $toc_placement_obj->{ignore_toc} = 1;
    }

    # Aggregrate and return information in an object...
    return bless {
        tree     => $tree,
        errors   => \@errors,
        warnings => \@warnings,
    }, 'Perl6::Perldoc::Parser::ReturnVal';

}

# Build the table of contents for a given P<toc:> request...
sub _build_toc {
    my ($data_structure, $placement_obj) = @_;

    # Work out what's in the TOC (including the =item/=item1 alias)...
    my $requested_types = $placement_obj->{target};
       $requested_types =~ s{\A \s* toc: \s*}{}xms;
    my %toc_wants; 
       @toc_wants{ split m/\s+/, $requested_types } = ();
    if (exists $toc_wants{item} || exists $toc_wants{item1}) {
       @toc_wants{qw< item item1 >} = ();
    }

    # Build flat list of tocitems into nested toclists...
    my @toc_stack = [];
    for my $toc_entry ( _walk_toc($data_structure, \%toc_wants) ) {
        my $level = $toc_entry->{level};

        # Increase nesting for higher numbered items...
        while ($level > @toc_stack) {
            push @toc_stack, [];
        }
        # Decrease nesting for lower numbered items...
        while ($level < @toc_stack) {
            my $content = pop @toc_stack;
            push @{ $toc_stack[-1] }, Perl6::Perldoc::Block::toclist->new({
                typename => 'toclist',
                style    => 'implicit',
                content  => $content,
                range    => {},
            });
        }
        # Insert the item into the hierarchy...
        push @{ $toc_stack[-1] }, $toc_entry;
    }

    # Nest any unclosed lists...
    while (@toc_stack > 1) {
        my $content = pop @toc_stack;
        push @{ $toc_stack[-1] }, Perl6::Perldoc::Block::toclist->new({
            typename => 'toclist',
            style    => 'implicit',
            content  => $content,
            range    => {},
        });
    }

    # Retrieve a flat list of tocitem blocks representing the TOC...
    return @{ $toc_stack[-1] };
}

# Blocks without an inherent nesting level default to this nesting...
my $DEFAULT_LEVEL = 5;

# Walk DOM tree extracting blocks specified to be part of TOC...
use Scalar::Util qw< reftype >;
sub _walk_toc {
    my ($node, $wanted_ref) = @_;

    my $node_type = reftype($node) || q{};

    # Hashes are nodes: check if this one (and its subnodes) should be included
    if ($node_type eq 'HASH') {
        return if $node->{ignore_toc};

        my $node_class = $node->{typename};
        my @this_node;

        # Is this node part of the TOC?

lib/Perl6/Perldoc/Parser.pm  view on Meta::CPAN

            my ($top)    = splice(@{$pre_sep}, 0, 2);
            my ($bottom) = splice(@{$post_sep}, 0, 2);

            my $content = join("\n", @{$cell});

            # Remove common horizontal whitespace prefix...
            if ($content =~ m{\A ([^\S\n]+)}xms) {
                my $prefix = $1;
                $content =~ s{^$prefix}{}gms;  # No /x so whitespace significant
            }

            open my $fh, '<', \$content
                or die "Internal error: could not parse table content";

            # Recursively parse content as Pod...
            $content
                = Perl6::Perldoc::Parser->parse($fh, {
                        all_pod=>1,
                        allow=>$allow_ref,
                        config_stack=>$config_stack_ref,
                  })->{tree}->{content};

            # Add cell to list for row...
            push @cell_objs, bless {
                content => $content,
                left    => join("\n", @{$left_sep}),
                right   => join("\n", @{$right_sep}),
                top     => $top,
                bottom  => $bottom,
                header  => $has_head && $row_index == 0,
            }, 'Perl6::Perldoc::Block::table::Cell';

            # Move left (right separator becomes left separator)
            $left_sep = $right_sep;
        }

        # Add the new row object...
        push @rows, bless {
             cells => \@cell_objs,
        }, 'Perl6::Perldoc::Block::table::Row';

        # Move downwards...
        $pre_sep = $post_sep;
    }

    return \@rows;
}

# Build entire table...
sub _build_table {
    my ($text, $allow_ref, $config_stack_ref) = @_;

    # Remove surrounding blank lines...
    $text =~ s{\A ($HWS* \n)+ | (^ $HWS* \n?)+ \z}{}gxms;

    # Remove top/bottom border...
    $text =~ s{\A ($ROW_SEP_LINE)}{}xms;     my $top_sep    = $1 || q{};
    $text =~ s{\n ($ROW_SEP_LINE) \Z}{}xms;  my $bottom_sep = $1 || q{};

    # Decompose into separated rows...
    my ($first_row, $first_sep, @rest) = split m{($ROW_SEP_LINE)}xms, $text;
    my $has_head = @rest != 0 && $first_sep =~ $NWS_ROW_SEP;

    my @rows = @rest == 0 ? (split m{(\n)}xms, $text)
             : @rest == 1 && !$bottom_sep ?
                            ($first_row, $first_sep, split m{(\n)}xms, $rest[0])
             :              ($first_row, $first_sep, @rest)
             ;

    my @separators = ($top_sep, @rows[grep {$_%2!=0} 0..$#rows], $bottom_sep);
    my @cells      = @rows[grep {$_%2==0} 0..$#rows];

    return _build_table_rows(
        $text, $has_head, \@cells, \@separators, $allow_ref, $config_stack_ref
    );
}

# Class to represent individual table row...
package Perl6::Perldoc::Block::table::Row;

# Read-only accessor for individual cells...
sub cells {
    my ($self) = @_; 
    my $vals_ref = $self->{cells};
    if (!wantarray) {
        if (@{ $vals_ref } > 1) {
            require Carp and Carp::carp(
                "Multivalued accessor cells() called in scalar context"
            );
        }
        return $vals_ref->[0];
    }
    return @{ $vals_ref };
}

# Class to represent individual table cell...
package Perl6::Perldoc::Block::table::Cell;

# Read-only content accessor...
sub content {
    my ($self) = @_; 
    my $vals_ref = $self->{content};
    if (!wantarray) {
        if (@{ $vals_ref } > 1) {
            require Carp and Carp::carp(
                "Multivalued accessor content() called in scalar context"
            );
        }
        return $vals_ref->[0];
    }
    return @{ $vals_ref };
}

# Is this a header row?
sub is_header {
    my ($self) = @_; 
    return $self->{header};
}


1;

__END__

=head1 NAME