File Coverage

blib/lib/Pod/POM/View/Restructured.pm

Criterion	Covered	Total	%
statement	159	247	64.3
branch	35	88	39.7
condition	6	39	15.3
subroutine	27	33	81.8
pod	18	21	85.7
total	245	428	57.2

# AUTHOR: Don Owens
# AUTHOR: Jeff Fearn
# AUTHOR: Alex Muntada
# OWNER: 2010 Don Owens
# OWNER: 2016 Jeff Fearn
# OWNER: 2016-2021 Alex Muntada
# LICENSE: Perl_5


use strict;
use warnings;
use Data::Dumper ();

use Pod::POM;

package Pod::POM::View::Restructured;

our $VERSION = '1.000003'; # VERSION

use base 'Pod::POM::View::Text';


sub new {
    my ($class, $params) = @_;
    $params = { } unless $params and UNIVERSAL::isa($params, 'HASH');

    my $self = bless { seen_something => 0, title_set => 0, params => { } }, ref($class) || $class;

    my $callbacks = $params->{callbacks};
    $callbacks = { } unless $callbacks;
    $self->{callbacks} = $callbacks;
    $self->{namespace} = delete($params->{namespace});

    return $self;
}

sub convert_file {
    my ($self, $source_file, $title, $dest_file, $callbacks) = @_;

    my $cb;
    if ($callbacks) {
        $cb = { %{ $self->{callbacks} }, %$callbacks };
    }
    else {
        $cb = $self->{callbacks};
    }

    my $view = Pod::POM::View::Restructured->new({ callbacks => $cb, namespace => $self->{namespace} });
    my $parser = Pod::POM->new;

    unless (-r $source_file) {
        warn "can't read source file $source_file";
        return;
    }

    my $pom = $parser->parse_file($source_file);

    $view->{title_set} = 1 if defined($title);
    my $out = $pom->present($view);

    if (defined($title)) {
        $out = $self->_build_header($title, '#', 1) . "\n" . $out;
    }
    else {
        $title = $view->{title};
    }

    if (defined($dest_file) and $dest_file ne '') {
        my $out_fh;
        if (UNIVERSAL::isa($dest_file, 'GLOB')) {
            $out_fh = $dest_file;
        }
        else {
            unless (open($out_fh, '>', $dest_file)) {
                warn "couldn't open output file $dest_file";
                return;
            }
        }

        print $out_fh $out;
        close $out_fh;
    }

    my $rv = { content => $out, title => $title };

    return $rv;
}

sub convert_files {
    my ($self, $file_spec, $index_file, $index_title, $out_dir) = @_;

    my $index_fh = $self->_get_file_handle($index_file, '>');

    if ($index_fh and defined($index_title) and $index_title ne '') {
        my $header = $self->_build_header($index_title, '#', 1);
#         my $line = '#' x length($index_title);
#         my $header = $line . "\n" . $index_title . "\n" . $line . "\n\n";

        print $index_fh $header;

        print $index_fh "\nContents:\n\n";
        print $index_fh ".. toctree::\n";
        print $index_fh "   :maxdepth: 1\n\n";
    }

    my $count = 0;
    my $toc = '';
    foreach my $spec (@$file_spec) {
        $count++;
        my $data = $self->convert_file($spec->{source_file}, $spec->{title},
                                       $spec->{dest_file}, $spec->{callbacks});

        my $this_title = $data->{title};
        # print STDERR Data::Dumper->Dump([ $this_title ], [ 'this_title' ]) . "\n\n";

        unless (defined($this_title) and $this_title !~ /\A\s*\Z/) {
            $this_title = 'section_' . $count;
        }

        my $name = $spec->{dest_file};
        if (defined($name)) {
            $name =~ s/\.rst\Z//;
        }
        else {
            ($name = $this_title) =~ s/\W/_/g;
            my $dest_file = $out_dir . '/' . $name . '.rst';
            my $out_fh;

            unless (open($out_fh, '>', $dest_file)) {
                warn "couldn't open output file $dest_file";
                return;
            }

            print $out_fh $data->{content};
            close $out_fh;
        }

        unless ($spec->{no_toc}) {
            $toc .= '   ' . $name . "\n";
        }

        if ($index_fh and not $spec->{no_toc}) {
            print $index_fh "   " . $name . "\n";
        }
    }

    if ($index_fh) {
        print $index_fh "\n";
    }

    return { toc => $toc };
}

sub _get_file_handle {
    my ($self, $file, $mode) = @_;

    return unless defined $file;

    if (ref($file) and UNIVERSAL::isa($file, 'GLOB')) {
        return $file;
    }

    $mode = '<' unless $mode;

    my $fh;
    if ($file ne '') {
        unless (open($fh, $mode, $file)) {
            warn "couldn't open input file $file: $!";
            return;
        }
    }

    return $fh;
}

sub view_pod {
    my ($self, $node) = @_;

    return $node->content()->present($self);
}

sub _generic_head {
    my ($self, $node, $marker, $do_overline) = @_;

    return scalar($self->_generic_head_multi($node, $marker, $do_overline));
}

sub _generic_head_multi {
    my ($self, $node, $marker, $do_overline) = @_;

    my $title = $node->title()->present($self);
    my $content = $node->content()->present($self);

    $title = ' ' if $title eq '';
    # my $section_line = $marker x length($title);

    my $section = $self->_build_header($title, $marker, $do_overline) . "\n" . $content;

    # my $section = $title . "\n" . $section_line . "\n\n" . $content;
    # if ($do_overline) {
    #     $section = $section_line . "\n" . $section;
    # }

    $section .= "\n";

    return wantarray ? ($section, $content, $title) : $section;
}

sub _build_header {
    my ($self, $text, $marker, $do_overline) = @_;

    my $line = $marker x length($text);
    my $header = $text . "\n" . $line . "\n";

    if ($do_overline) {
        $header = $line . "\n" . $header;
    }

    my $namespace = $self->{namespace};
    if($namespace) {
            my $a = $text;
            # prepend the namesspace to gaurantee document wide unique names
            $a = "$namespace\:\:$a" unless($text =~ /^$namespace/);
            $a =~ s/(?:\s)/-/g;

            $header = qq{.. _$a:\n\n} .  $header;
    }

    return "\n" . $header;
}

sub _do_indent {
    my ($self, $text, $indent_amount, $dbg) = @_;

    my $indent = ' ' x $indent_amount;

    # $indent = "'$dbg" . $indent . "'";

    my @lines = split /\n/, $text, -1;
    foreach my $line (@lines) {
        $line = $indent . $line;
    }

    return join("\n", @lines);
}

sub view_head1 {
    my ($self, $node) = @_;

    my ($section, $content, $title) = $self->_generic_head_multi($node, '*', 1);

    unless ($self->{seen_something} or $self->{title_set}) {
        if ($title eq 'NAME') {
            $self->{seen_something} = 1;

            if ($content =~ /\A\s*(\w+(?:::\w+)+)\s+-\s+/s) {
                my $mod_name = $1;
                $self->{module_name} = $mod_name;
                $self->{title} = $mod_name;
                $self->{title_set} = 1;

                $section = $self->_build_header($mod_name, '#', 1) . $section;

                # my $line = '#' x length($mod_name);
                # $section = $line . "\n" . $mod_name . "\n" . $line . "\n\n" . $section;
            }

            return $section;
        }
    }

    $self->{seen_something} = 1;
    return $section;
}

sub view_head2 {
    my ($self, $node) = @_;

    $self->{seen_something} = 1;
    return $self->_generic_head($node, '=');
}

sub view_head3 {
    my ($self, $node) = @_;

    $self->{seen_something} = 1;
    return $self->_generic_head($node, '-');
}

sub view_head4 {
    my ($self, $node) = @_;

    $self->{seen_something} = 1;
    return $self->_generic_head($node, '^');
}

sub view_item {
    my ($self, $node) = @_;

    $self->{seen_something} = 1;

    my $title = $node->title()->present($self);
    my $content = $node->content()->present($self);

    $title =~ s/\A\s+//;
    $title =~ s/\n/ /;
    $title = "- $title"
        unless $title =~ /
            # the line starts with
            \A
            # single unordered bullet,
            (?:(?:[-+] | \\[*])
            # or ordered bullet followed by dot,
            |     [1AaIi] \.
            # or ordered bullet within parens (first optional),
            | \(? [1AaIi] \)
            # then finally followed by whitespace.
            )\s
            /xms;
    # Make asterisk an actual bullet
    $title =~ s/ \A \\ [*]/*/xms;
    # $content =~ s/\n/\n /g;
    # $content = ' ' . $content;

    $self->{view_item_count}++;
    $content = $self->_do_indent($content, 1, "[[view_item_$self->{view_item_count}]]");

    return "\n" . $title . "\n" . $content . "\n\n";
}

sub view_over {
    my ($self, $node) = @_;

    my $content = $node->content()->present($self);
    # my $indent = $node->indent();

    return "\n" . $content;
}

sub view_text {
    my ($self, $node) = @_;

    my @lines = split /\n/, $node;
    foreach my $line (@lines) {
        $line =~ s/\A\s+//;
    }

    return join("\n", @lines);
}

sub view_textblock {
    my ($self, $text) = @_;

    return "\n" . $text . "\n";
}


sub view_verbatim {
    my ($self, $node) = @_;

    # (my $node_part = ' ' . $node) =~ s/\n/\n /g;
    my $node_part = $self->_do_indent($node . '', 1, '[[view_verbatim]]');

    my $block_part = ".. code-block:: perl\n\n";
    if (defined($self->{next_code_block})) {
        my $lang = $self->{next_code_block};
        delete $self->{next_code_block};

        if ($lang eq 'none') {
            # FIXME: need to output a preformatted paragraph here, but no highlighting
            $block_part = '';
        }
        else {
            $block_part = ".. code-block:: $lang\n\n";
        }
    }

    my $content = $block_part . $node_part;

    return "\n\n" . $content . "\n\n";
}

sub view_for {
    my ($self, $node) = @_;

    my $fmt = $node->format();

    # print STDERR "got for: fmt='$fmt', text='" . $node->text() . "'\n";

    if ($fmt eq 'pod2rst') {
        my $text = $node->text();
        if ($text =~ /\A\s*next-code-block\s*:\s*(\S+)/) {
            my $lang = $1;
            $self->{next_code_block} = $lang;
            return '';
        }

        return "\n". $node->text() . "\n\n";
    }

    return $self->SUPER::view_for($node);
}

sub view_seq_code {
    my ($self, $text) = @_;

    return '\ ``' . $text . '``\ ';
}

sub view_seq_bold {
    my ($self, $text) = @_;

    $text =~ s/\*/\\*/g;
    $text =~ s/\`/\\`/g;

    return '\ **' . $text . '**\ ';
}

sub view_seq_italic {
    my ($self, $text) = @_;

    $text =~ s/\*/\\*/g;
    $text =~ s/\`/\\`/g;

    return '\ *' . $text . '*\ ';
}

sub view_seq_file {
    my ($self, $text) = @_;

    $text =~ s/\*/\\*/g;
    $text =~ s/\`/\\`/g;

    return '\ *' . $text . '*\ ';
}

sub view_seq_text {
    my ($self, $node) = @_;

    my $text = $node . '';

    $text =~ s/\*/\\*/g;
    $text =~ s/\`/\\`/g;

    return $text;
}

sub view_seq_zero {
    return '';
}

sub view_seq_link {
    my ($self, $text) = @_;

    # FIXME: determine if has label, if manpage, etc., and pass that info along to the callback,
    #        instead of just the text, e.g.,
    #        $link_cb->($label, $name, $sec, $url);
    my $link_cb = $self->{callbacks}{link};
    if ($link_cb) {
        my ($url, $label) = $link_cb->($text);

        if (defined($url)) {
            if ($url eq '' and defined($label) and $label ne '') {
                $text = $label;
            }
            elsif (defined($label) and $label ne '') {
                $text = qq{`$label <$url>`_};
            }
            else {
                $text = qq{`$url <$url>`_};
            }

            return $text;
        }
    }

    my $url    = '';
    my $label  = '';
    my $module = $text;
    my $namespace = $self->{namespace};

    if ($text =~ m{\A/(.+)}) {
        (my $section = $1) =~ s/\A"(.+)"/$1/;
        $text = qq{`$section`_};
    }
    elsif ($text =~ m{\Ahttps?://}) {
        $text = qq{`$text <$text>`_};
    }
    elsif ($text =~ /::/) {
        $label = $text;
        if ($text =~ /\A(.+?)\|(.+::.+)/) {
            $label = $1;
            $module = $2;
        }

        # Links in this namespace are cross refereneces
        if (($namespace) and ($text =~ /^$namespace/)) {
            $module = qq{$namespace\:\:$module} unless($module =~ /^$namespace/);
            $module =~ s/(?:\s)/-/g;
            $text = qq{:ref:`$label <$module>`};
        }
        else {
            $module = $self->_url_encode($module);
            my $url = "http://search.cpan.org/search?query=$module&mode=module";
            $text = qq{`$label <$url>`_};
        }
    }

    return $text;
}

sub _url_encode {
    my ($self, $str) = @_;

    use bytes;
    $str =~ s{([^A-Za-z0-9_])}{sprintf("%%%02x", ord($1))}eg;
    return $str;
}



1;

__END__