File Coverage

blib/lib/Pod/Simple/Pandoc.pm

Criterion	Covered	Total	%
statement	185	209	88.5
branch	62	86	72.0
condition	12	24	50.0
subroutine	32	34	94.1
pod	6	9	66.6
total	297	362	82.0

package Pod::Simple::Pandoc;
use strict;
use warnings;
use 5.010;

our $VERSION = '0.346.0';

use Pod::Simple::SimpleTree;
use Pandoc::Elements;
use Pandoc::Filter::HeaderIdentifiers;
use Pod::Pandoc::Modules;
use Pandoc;
use File::Find ();
use File::Spec;
use IPC::Run3;
use Carp;
use utf8;

sub new {
    my ( $class, %opt ) = @_;

    $opt{parse} ||= [];
    if ( $opt{parse} eq '*' ) {
        $opt{parse} = [ pandoc->require('1.12')->input_formats ];
    }

    $opt{podurl} //= 'https://metacpan.org/pod/';

    bless \%opt, $class;
}

sub _parser {
    my $self = shift;

    my $parser = Pod::Simple::SimpleTree->new;
    $parser->nix_X_codes(1);         # ignore X<...> codes
    $parser->nbsp_for_S(1);          # map S<...> to U+00A0 (non-breaking space)
    $parser->merge_text(1);          # emit text nodes combined
    $parser->no_errata_section(1);   # omit errata section
    $parser->complain_stderr(1);     # TODO: configure
    $parser->accept_target('*');     # include all data sections

    # remove shortest leading whitespace string from verbatim sections
    $parser->strip_verbatim_indent(
        sub {
            my $indent = length $_[0][1];
            for ( @{ $_[0] } ) {
                $_ =~ /^(\s*)/;
                $indent = length($1) if length($1) < $indent;
            }
            ' ' x $indent;
        }
    );

    return $parser;
}

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

    # Pod::Simple::parse_file does not detect this
    croak "Can't use directory as a source for parse_file" if -d $file;

    my $doc = $self->parse_tree( $self->_parser->parse_file($file)->root );

    if ( !ref $file and $file ne '-' ) {
        $doc->meta->{file} = MetaString($file);
    }

    $doc;
}

sub parse_module {
    my ( $self, $name ) = @_;

    # map module name to name
    run3 [ 'perldoc', '-lm', $name ], undef, \$name;
    croak $? if $?;
    chomp $name;

    $self->parse_file($name);
}

sub parse_string {
    my ( $self, $string ) = @_;
    $self->parse_tree( $self->_parser->parse_string_document($string)->root );
}

sub parse_tree {
    my $doc = Pandoc::Filter::HeaderIdentifiers->new->apply( _pod_element(@_) );

    my $sections = $doc->outline(1)->{sections};
    if ( my ($name) = grep { $_->{header}->string eq 'NAME' } @$sections ) {

        # TODO: support formatting
        my $text = $name->{blocks}->[0]->string;
        my ( $title, $subtitle ) = $text =~ m{^\s*([^ ]+)\s*[:-]*\s*(.+)};
        $doc->meta->{title}    = MetaString($title)    if $title;
        $doc->meta->{subtitle} = MetaString($subtitle) if $subtitle;
    }

    $doc;
}

sub parse_and_merge {
    my ( $self, @input ) = @_;

    my $doc;

    foreach my $file (@input) {

        my $cur =
          ( $file ne '-' and not -e $file )
          ? $self->parse_module($file)
          : $self->parse_file($file);

        if ($doc) {
            push @{ $doc->content }, @{ $cur->content };
        }
        else {
            $doc = $cur;
        }
    }

    return unless $doc;

    if ( @input > 1 ) {
        $doc->meta->{file} = MetaList [ map { MetaString $_ } @input ];
    }

    return $doc;
}

sub is_perl_file {
    my $file = shift;
    return 1 if $file =~ /\.(pm|pod)$/;
    if ( -x $file ) {
        open( my $fh, '<', $file ) or return;
        return 1 if $fh and ( <$fh> // '' ) =~ /^#!.*perl/;
    }
    0;
}

sub parse_dir {
    my ( $parser, $directory ) = @_;
    my $files = {};

    File::Find::find(
        {
            no_chdir => 1,
            wanted   => sub {
                my $file = $_;
                return unless is_perl_file($file);
                my $doc = $parser->parse_file($file);
                my $base = File::Spec->abs2rel( $directory, $file );
                $base =~ s/\.\.$//;
                $doc->meta->{base} = MetaString $base;
                $files->{$file} = $doc;
            }
        },
        $directory
    );

    $files;
}

sub parse_modules {
    my ( $parser, $dir, %opt ) = @_;

    my $modules = Pod::Pandoc::Modules->new;
    return $modules unless -d $dir;

    my $files = $parser->parse_dir($dir);
    foreach my $file ( sort keys %$files ) {
        my $doc = $files->{$file};
        my $module = File::Spec->abs2rel( $file, $dir );
        $module =~ s{\.(pm|pod)$}{}g;
        $module =~ s{/}{::}g;
        if ( ( $doc->metavalue('title') // $module ) eq $module ) {
            my $old = $modules->{$module};
            my $skipped = $modules->add( $module => $doc ) ? $old : $doc;
            if ( $skipped and not $opt{quiet} ) {
                warn $skipped->metavalue('file')
                  . " skipped for "
                  . $modules->{$module}->metavalue('file') . "\n";
            }
        }
        else {
            warn "$file NAME does not match module\n" unless $opt{quiet};
        }
    }

    $modules;
}

my %POD_ELEMENT_TYPES = (
    Document => sub {
        Document {}, [ _pod_content(@_) ];
    },
    Para => sub {
        Para [ _pod_content(@_) ];
    },
    I => sub {
        Emph [ _pod_content(@_) ];
    },
    B => sub {
        Strong [ _pod_content(@_) ];
    },
    L => \&_pod_link,
    C => sub {
        Code attributes {}, _pod_flatten(@_);
    },
    F => sub {
        Code attributes { classes => ['filename'] }, _pod_flatten(@_);
    },
    head1 => sub {
        Header 1, attributes {}, [ _pod_content(@_) ];
    },
    head2 => sub {
        Header 2, attributes {}, [ _pod_content(@_) ];
    },
    head3 => sub {
        Header 3, attributes {}, [ _pod_content(@_) ];
    },
    head4 => sub {
        Header 4, attributes {}, [ _pod_content(@_) ];
    },
    Verbatim => sub {
        CodeBlock attributes {}, _pod_flatten(@_);
    },
    'over-bullet' => sub {
        BulletList [ _pod_list(@_) ];
    },
    'over-number' => sub {
        OrderedList [ 1, DefaultStyle, DefaultDelim ], [ _pod_list(@_) ];
    },
    'over-text' => sub {
        DefinitionList [ _pod_list(@_) ];
    },
    'over-block' => sub {
        BlockQuote [ _pod_content(@_) ];
    },
    'for' => \&_pod_data,
);

# option --smart
sub _str {
    my $s = shift;
    $s =~ s/\.\.\./…/g;
    Str $s;
}

# map a single element or text to a list of Pandoc elements
sub _pod_element {
    my ( $self, $element ) = @_;

    if ( ref $element ) {
        my $type = $POD_ELEMENT_TYPES{ $element->[0] } or return;
        $type->( $self, $element );
    }
    else {
        my $n = 0;
        map { $n++ ? ( Space, _str($_) ) : _str($_) }
          split( /\s+/, $element, -1 );
    }
}

# map the content of a Pod element to a list of Pandoc elements
sub _pod_content {
    my ( $self, $element ) = @_;
    my $length = scalar @$element;
    map { _pod_element( $self, $_ ) } @$element[ 2 .. ( $length - 1 ) ];
}

# stringify the content of an element
sub _pod_flatten {
    my $string = '';
    my $walk;
    $walk = sub {
        my ($element) = @_;
        my $n = scalar @$element;
        for ( @$element[ 2 .. $n - 1 ] ) {
            if ( ref $_ ) {
                $walk->($_);
            }
            else {
                $string .= $_;
            }
        }
    };
    $walk->( $_[1] );

    return $string;
}

# map link
sub _pod_link {
    my ( $self, $link ) = @_;
    my $type    = $link->[1]{type};
    my $to      = $link->[1]{to};
    my $section = $link->[1]{section};
    my $url     = '';

    if ( $type eq 'url' ) {
        $url = "$to";
    }
    elsif ( $type eq 'man' ) {
        if ( $to =~ /^([^(]+)(?:[(](\d+)[)])?$/ ) {

            # TODO: configure MAN_URL, e.g.
            # http://man7.org/linux/man-pages/man{section}/{name}.{section}.html
            $url = "http://linux.die.net/man/$2/$1";

            # TODO: add section to URL if given
        }
    }
    elsif ( $type eq 'pod' ) {
        if ($to) {
            $url = $self->{podurl} . $to;
        }
        if ($section) {
            $section = header_identifier("$section") unless $to; # internal link
            $url .= "#" . $section;
        }
    }

    return Link attributes {}, [ _pod_content( $self, $link ) ], [ $url, '' ];
}

# map data section
sub _pod_data {
    my ( $self, $element ) = @_;
    my $target = lc( $element->[1]{target} );

    my $length = scalar @$element;
    my $content = join "\n\n", map { $_->[2] }
      grep { $_->[0] eq 'Data' } @$element[ 2 .. $length - 1 ];

    # cleanup HTML and Tex blocks
    if ( $target eq 'html' ) {
        $content = "$content" if $content !~ /^<.+>$/s;
    }
    elsif ( $target =~ /^(la)?tex$/ ) {

        # TODO: more intelligent check & grouping, especiall at the end
        $content = "\\begingroup $content \\endgroup" if $content !~ /^[\\{]/;
        $target = 'tex';
    }

    # parse and insert known formats if requested
    my $format = $target eq 'tex' ? 'latex' : $target;
    if ( grep { $format eq $_ } @{ $self->{parse} } ) {
        utf8::decode($content);
        my $doc = pandoc->parse( $format => $content, '--smart' );
        return @{ $doc->content };
    }

    RawBlock( $target, "$content\n" );

    # TODO: add Null element to not merge with following content
}

# map a list (any kind)
sub _pod_list {
    my ( $self, $element ) = @_;
    my $length = scalar @$element;

    my $deflist = $element->[2][0] eq 'item-text';
    my @list;
    my $item = [];

    my $push_item = sub {
        return unless @$item;
        if ($deflist) {
            my $term = shift @$item;
            push @list, [ $term->content, [$item] ];
        }
        else {
            push @list, $item;
        }
    };

    foreach my $e ( @$element[ 2 .. $length - 1 ] ) {
        my $type = $e->[0];
        if ( $type =~ /^item-(number|bullet|text)$/ ) {
            $push_item->();
            $item = [ Plain [ _pod_content( $self, $e ) ] ];
        }
        else {
            if ( @$item == 1 and $item->[0]->name eq 'Plain' ) {

                # first block element in item should better be Paragraph
                $item->[0] = Para $item->[0]->content;
            }
            push @$item, _pod_element( $self, $e );
        }
    }
    $push_item->();

    # BulletList/OrderedList: [ @blocks ], ...
    # DefinitionList: [ [ @inlines ], [ @blocks ] ], ...
    return @list;
}

1;
__END__