Pod::Parser::Groffmom - Convert POD to a format groff_mom can handle.

    use Pod::Parser::Groffmom;
    my $foo  = Pod::Parser::Groffmom->new();
    my $file = 't/test_pod.pod';
    open my $fh, '<', $file 
      or die "Cannot open ($file) for reading: $!";
    $parser->parse_from_filehandle($fh);
    print $parser->mom;

  groff -mom my.mom > my.ps

 Salvador FandiE<ntilde>o

 Salvador FandiE<241>o

    perldoc Pod::Parser::Groffmom

package Pod::Parser::Groffmom;

use warnings;
use strict;
use Carp qw(carp croak);
use Perl6::Junction 'any';
use Pod::Parser::Groffmom::Color ':all';
use Pod::Parser::Groffmom::Entities 'entity_to_num';

use Moose;
use MooseX::NonMoose;
use Moose::Util::TypeConstraints 'enum';
extends qw(Pod::Parser);

# order of MOM_METHODS is very important.  See '.COPYRIGHT' in mom docs.
my @MOM_METHODS  = qw(title subtitle author copyright);
my @MOM_BOOLEANS = qw(cover newpage toc);
my %IS_MOM       = map { uc($_) => 1 } ( @MOM_METHODS, @MOM_BOOLEANS );

foreach my $method ( __PACKAGE__->mom_methods, __PACKAGE__->mom_booleans ) {

    # did we find this thing in the POD?
    has $method => ( is => 'rw', isa => 'Bool' );

    # let's set the actual value to what we found
    has "mom_$method" => ( is => 'rw', isa => 'Str' );

    # it was set in the contructor
    has "$method\_set_in_constructor" => ( is => 'rw', isa => 'Bool' );

    # Also store them in plain text in case people need 'em
    has "original_$method" => ( is => 'rw', isa => 'Str' );
}

# This is an embarrasing, nasty hack.
sub get_mom_and_ctr_methods {
    my ( $class, $method ) = @_;
    return ( "mom_$method", "$method\_set_in_constructor" );
}

sub BUILD {
    my $self = shift;
    foreach my $method ( __PACKAGE__->mom_methods, __PACKAGE__->mom_booleans )
    {
        my ( $mom, $set_in_contructor )
          = $self->get_mom_and_ctr_methods($method);
        if ( my $value = $self->$mom ) {
            my $orig = "original_$method";
            $self->$orig($value);
            $self->$set_in_contructor(1);
        }
    }
}

has head    => ( is => 'rw' );
has subhead => ( is => 'rw' );
has mom     => ( is => 'rw', isa => 'Str', default => '' );
has toc => ( is => 'rw', => isa => 'Bool' );
has highlight    => ( is => 'rw' );
has last_title   => ( is => 'rw', isa => 'Str' );
has in_file_mode => ( is => 'ro', isa => 'Bool', default => 0, writer => 'set_in_file_mode' );

# list helpers
has in_list_mode => ( is => 'rw', isa => 'Int', default => 0 );
has list_data    => ( is => 'rw', isa => 'Str', default => '' );
has list_type => ( is => 'rw', isa => enum( [ '', qw/BULLET DIGIT/ ] ) );

has fh => ( is => 'rw' );
has file_name => ( is => 'rw', isa => 'Str' );

sub mom_methods  {@MOM_METHODS}
sub mom_booleans {@MOM_BOOLEANS}

sub is_mom {
    my ( $self, $command, $paragraph ) = @_;
    if ( $command =~ /^head[123]/ ) {
        return 1 if $paragraph eq 'NAME';    # special alias for 'TITLE'
        return $IS_MOM{$paragraph};
    }
    elsif ( $command eq 'for' ) {
        if ( $paragraph =~ /^mom\s+(?:newpage|toc|cover)/i ) {
            return 1;
        }
    }
}

our $VERSION = '0.042';
$VERSION = eval $VERSION;

sub _trim {
    local $_ = $_[1];
    s/^\s+|\s+$//gs;
    return $_;
}

sub _escape {
    my ( $self, $text ) = @_;
    $text =~ s/"/\\[dq]/g;

    # This is a quick and nasty hack, but we assume that we escape all
    # backslashes unless they look like they're followed by a mom escape
    $text =~ s/\\(?!\[\w+\])/\\\\/g;

    # We need to do this list dots appear at the beginning of a line an look
    # like mom macros.  This can happen if you have a some inline sequences
    # terminating a sentence (e.g. "See the module S<C<Foo::Module>>.").
    $text =~ s/^\./\\N'46'/;
    $text =~ s/\n\./\n\\N'46'/g;

    # cheap attempt to combat issue with some inline sequences ending a
    # sentence and forcing a linebreak with the final period on a line by
    # itself.
    $text =~ s/([[:upper:]]<+[^>]*>+)\./$1\\N'46'/g;

    return $text;
}

sub command {
    my ( $self, $command, $paragraph, $line_num ) = @_;

    # reset mom_methods
    $self->$_(0) foreach $self->mom_methods;
    $paragraph = $self->_trim($paragraph);

    my $is_mom = $self->is_mom( $command, $paragraph );
    $paragraph = lc $paragraph if $is_mom;
    if ($is_mom) {
        $self->parse_mom( $command, $paragraph, $line_num );
    }
    else {
        $self->build_mom( $command, $paragraph, $line_num );
    }
}

sub parse_mom {
    my ( $self, $command, $paragraph, $line_num ) = @_;
    $paragraph = 'title' if $paragraph eq 'name';
    foreach my $method ( $self->mom_methods ) {
        my ( $mom, $set_in_contructor )
          = $self->get_mom_and_ctr_methods($method);
        if ( $paragraph eq $method ) {
            if ( my $item = $self->$mom ) {
                croak("Tried to reset $method ($item) at line $line_num")
                  unless $self->$set_in_contructor;
            }
            $self->$method(1);
            return;
        }
    }
    $self->mom_cover(1)             if $paragraph =~ /^mom\s+cover/i;
    $self->mom_toc(1)               if $paragraph =~ /^mom\s+toc/i;
    $self->add_to_mom(".NEWPAGE\n") if $paragraph =~ /^mom\s+newpage/i;
}

{
    my %command_handler = (
        head1 => sub {
            my ( $self, $paragraph ) = @_;
            $self->last_title($paragraph);
            $paragraph = $self->interpolate($paragraph);
            $self->add_to_mom(qq{.HEAD "$paragraph"\n\n});
        },
        head2 => sub {
            my ( $self, $paragraph ) = @_;
            $self->last_title($paragraph);
            $paragraph = $self->interpolate($paragraph);
            $self->add_to_mom(qq{.SUBHEAD "$paragraph"\n\n});
        },
        head3 => sub {
            my ( $self, $paragraph ) = @_;
            $paragraph = $self->interpolate($paragraph);
            $self->last_title($paragraph);
            $self->add_to_mom(qq{\\f[B]$paragraph\\f[P]\n\n});
        },
        for => sub {
            my ( $self, $paragraph ) = @_;
            if ( $paragraph =~ /^mom\s+tofile\s+(.*?)\s*$/i ) {
                if ( my $file = $1 ) {
                    if ( -f $file ) {
                        unlink $file or croak("Could not unlink($file): $!");
                    }
                    open my $fh, '>>', $file
                      or croak("Could not open ($file) for appending: $!");
                    close $self->fh if $self->fh;
                    $self->fh($fh);
                    $self->file_name($file);
                }
                elsif ( not $self->file_name ) {
                    croak("'=for mom tofile' found but filename not set");
                }
            }
        },
        begin => sub {
            my ( $self, $paragraph ) = @_;
            $paragraph = $self->_trim($paragraph);
            if ( $paragraph =~ /^(highlight)(?:\s+(.*))?$/i ) {
                my ( $target, $language ) = ( $1, $2 );
                if ( $target && !$language ) {
                    $language = 'Perl';
                }
                $self->highlight( get_highlighter($language) );
            }
            elsif ( $paragraph =~ /^mom\s+tofile\s*/i ) {
                $self->set_in_file_mode(1);
            }
        },
        end => sub {
            my ( $self, $paragraph ) = @_;
            $paragraph = $self->_trim($paragraph);
            if ( $paragraph eq 'highlight' ) {
                $self->highlight('');
            }
            elsif ( $paragraph =~ /^mom\s+tofile\s*/i ) {
                $self->set_in_file_mode(0);
            }
        },
        pod => sub { },    # noop
    );

    sub handler_for {
        my ( $self, $command ) = @_;
        return $command_handler{$command};
    }
}

sub build_mom {
    my ( $self, $command, $paragraph, $line_num ) = @_;
    $paragraph = $self->_escape($paragraph);
    if ( any(qw/over item back/) eq $command ) {
        $self->build_list( $command, $paragraph, $line_num );
    }
    elsif ( my $handler = $self->handler_for($command) ) {
        $self->$handler($paragraph);
    }
    else {
        carp("Unknown command (=$command $paragraph) at line $line_num");
    }
}

sub build_list {
    my ( $self, $command, $paragraph, $line_num ) = @_;
    if ( 'over' eq $command ) {
        $self->in_list_mode( $self->in_list_mode + 1 );
        $self->list_type('');
    }
    elsif ( 'back' eq $command ) {
        if ( $self->in_list_mode == 0 ) {
            warn "=back without =over at line $line_num";
            return;
        }
        else {
            $self->in_list_mode( $self->in_list_mode - 1 );
            $self->list_data( $self->list_data . ".LIST END\n" );
        }
        if ( !$self->in_list_mode ) {
            my $list
              = ".L_MARGIN 1.25i\n" . $self->list_data . "\n.L_MARGIN 1i\n";
            $self->add_to_mom($list);
            $self->list_data('');
        }
    }
    elsif ( 'item' eq $command ) {
        if ( not $self->in_list_mode ) {
            carp(
                "Found (=item $paragraph) outside of list at line $line_num.  Discarding"
            );
            return;
        }
        $paragraph =~ /^(\*|\d+)?\s*(.*)/;
        my ( $list_type, $item ) = ( $1, $2 );
        $list_type ||= '';
        $list_type = '*' ne $list_type ? 'DIGIT' : 'BULLET';

        # default to BULLET if we cannot identify the list type
        if ( not $self->list_type ) {
            $self->list_type($list_type);
            $self->list_data( $self->list_data . ".LIST $list_type\n" );
        }
        $item = $self->interpolate($item);
        $self->add_to_list(".ITEM\n$item\n");
    }
}

sub add_to_mom {
    my ( $self, $text ) = @_;
    return unless defined $text;
    $self->mom( ( $self->mom ) . $text );
}

sub add_to_list {
    my ( $self, $text ) = @_;
    return unless defined $text;
    $text = $self->interpolate($text);

    # This horror of horrors is because we want simple lists to be single
    # spaced, unless there are further details after the =item line, in which
    # case an extra newline is needed for pleasant formatting.
    my $break = '';
    if ( $self->list_data =~ /\n.ITEM\n.*\n$/ && $text !~ /^.ITEM/ ) {
        $break = "\n";
    }
    $self->list_data( ( $self->list_data ) . "$break$text" );
}

sub end_input {
    my $self = shift;
    my $mom  = '';

    if ( $self->fh ) {
        my $filename = $self->file_name;
        close $self->fh or croak("Could not close ($filename): $!");
    }

    foreach my $method ( $self->mom_methods ) {
        my $mom_method = "mom_$method";
        my $macro      = ".\U$method";
        if ( my $item = $self->$mom_method ) {

            # handle double quotes later
            $mom .= qq{$macro "$item"\n};
        }
    }
    if ( $self->mom_cover ) {
        my $cover = ".COVER";
        foreach my $method ( $self->mom_methods ) {
            my $mom_method = "mom_$method";
            next unless $self->$mom_method;
            $cover .= " \U$method";
        }
        $mom .= "$cover\n";
    }
    my $color_definitions = Pod::Parser::Groffmom::Color->color_definitions;
    $mom .= <<"END";
.PRINTSTYLE TYPESET
\\#
.FAM H
.PT_SIZE 12
\\#
$color_definitions
.START
END
    $self->mom( $mom .= $self->mom );
    $self->mom( $self->mom . ".TOC\n" ) if $self->mom_toc;
}

sub add_to_file {
    my ( $self, $data ) = @_;
    croak("Not in file mode!") unless $self->in_file_mode;
    my $fh = $self->fh or croak("No filehandle found");
    print $fh $data;
}

sub verbatim {
    my ( $self, $verbatim, $paragraph, $line_num ) = @_;
    if ( $self->in_file_mode ) {
        $self->add_to_file($verbatim);
        return;
    }
    $verbatim =~ s/\s+$//s;
    if ( $self->highlight ) {
        $verbatim = $self->highlight->highlightText($verbatim);
    }
    else {
        $verbatim = $self->_escape($verbatim);
    }
    $self->add( sprintf <<'END' => $verbatim );
.FAM C
.PT_SIZE 10
.LEFT
.L_MARGIN 1.25i
%s
.QUAD
.L_MARGIN 1i
.FAM H
.PT_SIZE 12

END
}

sub textblock {
    my ( $self, $textblock, $paragraph, $line_num ) = @_;

    if ( $self->in_file_mode ) {
        $self->add_to_file($textblock);
        return;
    }

    my $original_textblock = $textblock;

    # newlines can lead to strange things happening the new text on the next
    # line is interpreted as a command to mom.
    $textblock =~ s/\n/ /g;
    $textblock = $self->_escape( $self->_trim($textblock) );
    $textblock = $self->interpolate( $textblock, $line_num );
    foreach my $method ( $self->mom_methods ) {
        my ( $mom, $set_in_contructor )
          = $self->get_mom_and_ctr_methods($method);

        if ( $self->$method ) {

            # Don't override these values if set in the contructor
            if ( not $self->$set_in_contructor ) {

                my $orig = "original_$method";
                $self->$orig($original_textblock);

                # This was set in command()
                $self->$mom($textblock);
            }
            return;
        }
    }
    $self->add("$textblock\n\n");
}

sub add {
    my ( $self, $data ) = @_;
    my $add = $self->in_list_mode ? 'add_to_list' : 'add_to_mom';
    $self->$add($data);
}

{

    sub get_open_close_formats {
        my ( $self, $pod_seq, $format_code ) = @_;
        my $parent_format = $self->get_parent_format_code($pod_seq);
        my $open
          = $parent_format
          ? "\\f[P]\\f[${parent_format}$format_code]"
          : "\\f[$format_code]";
        my $close
          = $parent_format
          ? "\\f[P]\\f[$parent_format]"
          : "\\f[P]";
        return ( $open, $close );
    }
    my %handler_for = (
        I => {
            format_code => 'I',
            handler     => sub {    # italics
                my ( $self, $paragraph, $pod_seq ) = @_;
                my ( $open, $close )
                  = $self->get_open_close_formats( $pod_seq, 'I' );
                return "$open$paragraph$close";
            },
        },
        C => {
            format_code => 'C',
            handler     => sub {    # code
                my ( $self, $paragraph, $pod_seq ) = @_;
                my ( $open, $close )
                  = $self->get_open_close_formats( $pod_seq, 'C' );
                return "$open$paragraph$close";
              }
        },
        B => {
            format_code => 'B',
            handler     => sub {    # bold
                my ( $self, $paragraph, $pod_seq ) = @_;
                my ( $open, $close )
                  = $self->get_open_close_formats( $pod_seq, 'B' );
                return "$open$paragraph$close";
              }
        },
        E => {
            format_code => '',
            handler     => sub {    # entity
                my ( $self, $paragraph, $pod_seq ) = @_;
                my $num = entity_to_num($paragraph);
                return "\\N'$num'";
              }
        },
        L => {
            format_code => '',
            handler     => sub {    # link
                my ( $self, $paragraph, $pod_seq ) = @_;

           # This is legal because the POD docs are quite specific about this.
                my $strip_quotes = sub { $_[0] =~ s/^"|"$//g };

                if ( $paragraph !~ m{(?:/|\|)} ) {    # no / or |
                                                      # L<Net::Ping>
                    return "\\f[C]$paragraph\\f[P]";
                }
                elsif ( $paragraph =~ m{^([^/]*)\|(.+)$} ) {

                    # L<the Net::Ping module|Net::Ping>
                    # L<support section|PPI/SUPPORT>
                    my ( $text, $name ) = ( $1, $2 );

                    $strip_quotes->($_) foreach $text, $name;
                    if ( $name eq $text ) {
                        return "\\f[C]$text\\f[P]";
                    }
                    else {
                        return qq{$text (\\f[C]$name\\f[P])};
                    }
                }
                elsif ( $paragraph =~ m{^(.*)/(.*)} ) {
                    my ( $name, $text ) = ( $1, $2 );
                    $strip_quotes->($_) foreach $text, $name;
                    return "$text (\\f[C]$name\\f[P])";
                }
                else {

                    # XXX eventually we'll need better handling of this
                    warn "Unknown sequence format for L<$paragraph>";
                    return qq{"$paragraph"};
                }
              }
        },
        F => {
            format_code => 'I',
            handler     => sub {    # filename
                my ( $self, $paragraph, $pod_seq ) = @_;
                my ( $open, $close )
                  = $self->get_open_close_formats( $pod_seq, 'I' );
                return "$open$paragraph$close";
              }
        },
        S => {
            format_code => '',
            handler     => sub {    # non-breaking spaces
                my ( $self, $paragraph, $pod_seq ) = @_;
                $paragraph =~ s/\s/\\~/g;    # non-breaking space
                return " \\c\n.HYPHENATE OFF\n$paragraph\\c\n.HYPHENATE\n";
              }
        },
        Z => {
            format_code => '',
            handler     => sub {             # null-effect sequence
                my ( $self, $paragraph, $pod_seq ) = @_;
                return '';
              }
        },
        X => {
            format_code => '',
            handler     => sub {             # indexes
                my ( $self, $paragraph, $pod_seq ) = @_;
                return $paragraph;

                # XXX Rats.  Didn't work. mom doesn't do indexing
                # return "$paragraph\\c\n.IQ $paragraph\\c\n";
              }
        },
    );

    sub get_parent_format_code {
        my ( $self, $pod_seq ) = @_;

        # note that we only handle one level of nesting.  This should change
        # in the future.
        return '' unless $pod_seq;
        my $parent = $pod_seq->nested or return '';
        no warnings 'uninitialized';
        return $handler_for{ $parent->name }{format_code} || '';
    }

    sub sequence_handler {
        my ( $self, $sequence ) = @_;
        return $handler_for{$sequence};
    }
}

sub interior_sequence {
    my ( $self, $sequence, $paragraph, $pod_seq ) = @_;
    if ( my $handler = $self->sequence_handler($sequence) ) {
        $handler = $handler->{handler};
        return $self->$handler( $paragraph, $pod_seq );
    }
    else {
        carp(
            "Unknown sequence ($sequence<$paragraph>).  Stripping sequence code."
        );
        return $paragraph;
    }
}

no Moose;
__PACKAGE__->meta->make_immutable( inline_constructor => 0 );

1;    # End of Pod::Parser::Groffmom