File Coverage

blib/lib/Pod/Manual.pm

Criterion	Covered	Total	%
statement	19	21	90.4
branch			n/a
condition			n/a
subroutine	7	7	100.0
pod			n/a
total	26	28	92.8

package Pod::Manual;

use Object::InsideOut;

use warnings;
no warnings qw/ uninitialized /;
use strict;
use Carp;

use Cwd;
use XML::LibXML;
use Pod::XML;
use Pod::2::DocBook;
use Pod::Find qw/ pod_where /;
use File::Temp qw/ tempfile tempdir /;
use File::Copy;
use List::MoreUtils qw/ any /;
use Params::Validate;

our $VERSION = '0.08_04';

my @parser_of        :Field;
my @dom_of           :Field;
my @appendix_of      :Field;
my @root_of          :Field;
my @ignore_sections  :Field
                     :Set(set_ignore)
                     :Arg(Name => 'ignore_sections', Type => 'array')
                     ;
my @appendix_sections :Field
                      :Args(Name => 'appendix_sections', Type => 'array')
                      :Set(set_appendix_sections)
                      ;
my @title            :Field
                     :Arg(title)
                     :Get(get_title);
my @unique_id        :Field;
my @pdf_generator    :Field
                     :Arg(Name => 'pdf_generator', Default => 'latex', Pre => sub { lc $_[4] if $_[4]} )
                     :Std(Name => 'pdf_generator', Pre => sub { lc $_[4] } )
                     :Type(sub { grep { $_[0] eq $_ } qw/ prince latex / } )
                     ;
my @prince_css       :Field
                     :Arg('prince_css')
                     :Set(set_prince_css)
                     ;


### Special accessors ##########################################

sub get_appendix_sections {
    my $self = shift;
    return $appendix_sections[ $$self ] ? @{ $appendix_sections[ $$self ] }
                                       : ()
                                       ;
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

sub get_ignore_sections {
    my $self = shift;

    return unless $ignore_sections[ $$self ];

    return @{ $ignore_sections[ $$self ] };
}

sub get_prince_css {
    my $self = shift;

    unless ( $prince_css[$$self] ) {

        # try to find the stylesheet
                                                    #<<< perltidy off
        my ($css) = grep { -f $_ }
                    map  { $_ . '/lib/prince/style/docbook.css' }
                         qw# /usr /usr/local #;
                                                    #>>>

        $self->set_prince_css($css) if $css;
    }

    return $prince_css[$$self];
}

sub unique_id {
    return ++$unique_id[ ${$_[0]} ];
}

sub _init :Init {
    my $self = shift;
    my $args_ref = shift;

    my $parser = $parser_of[ $$self ] = XML::LibXML->new;

    $dom_of[ $$self ] = $parser->parse_string(
        ''  </td>
</tr>

<tr>
<td  class="h" >
<a name="98">98</a>
</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s">             . $self->get_title  </td>
</tr>

<tr>
<td  class="h" >
<a name="99">99</a>
</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td >

 

</td>

<td class="s">             . ''
    );

    $dom_of[ $$self ]->setEncoding( 'iso-8859-1' );

    $root_of[ $$self ] = $dom_of[ $$self ]->documentElement;

    $appendix_of[ $$self ] = undef;

}

sub set_title {
    my( $self, $title ) = @_;

    $title[ $$self ] = $title;

    return unless $dom_of[ $$self ];

    my $title_node = $dom_of[ $$self ]->findnodes( '/book/bookinfo/title')
                                      ->[0];
    # remove any possible title already there
    $title_node->removeChild( $_ ) for $title_node->childNodes;

    $title_node->appendText( $title );

    return;
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

sub _find_module_pod {
    my $self = shift;
    my $module = shift;

    my $file_location = pod_where( { -inc => 1 }, $module )
        or die "couldn't find pod for module $module\n";

    local $/ = undef;
    open my $pod_fh, '<', $file_location
        or die "can't open pod file $file_location: $!";

    return <$pod_fh>;
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

sub _convert_pod_to_xml {
    my $self = shift;
    my $pod = shift;

    my $parser = Pod::2::DocBook->new ( doctype => 'chapter',);

    my $podxml;
    local *STDOUT;
    open STDOUT, '>', \$podxml;
    open my $input_fh, '<', \$pod;
    $parser->parse_from_filehandle( $input_fh );

    my $dom = eval {
        $parser_of[ $$self ]->parse_string( $podxml )
    } or die "error while converting raw pod to xml for '$pod': $@";

    return $dom;
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

sub _get_podxml {
    my $self = shift;
    my $pod = shift;

    my $pod_location = pod_where( { -inc => 1 }, $pod );

    my $parser = Pod::XML->new;

    my $podxml;
    local *STDOUT;
    open STDOUT, '>', \$podxml;
    $parser->parse_from_file( $pod_location );
    close STDOUT;

    $podxml =~ s/xmlns=".*?"//;
    $podxml =~ s#]]>\n

    my $dom = eval {
        $parser_of[ $$self ]->parse_string( $podxml )
    } or die "error while converting raw pod to xml for '$pod': $@";

    return $dom;
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

sub add_chapters {
    my $self = shift;
    my $options = 'HASH' eq ref $_[-1] ?   pop @_ : { };

    $self->add_chapter( $_ => $options ) for @_;
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~


sub add_chapter {
    my $self = shift;
    my $chapter = shift;

    my %option = validate( @_, {
            ignore_sections   => { default => [ $self->get_ignore_sections ] },
            appendix_sections => { default => [ $self->get_appendix_sections ] },
            set_title => 0,
        } );

    # simplify things later
    for my $i ( qw/ ignore_sections appendix_sections / ) {
        unless ( ref $option{ $i } ) {
            $option{$i} = [ $option{$i} ];
        }
    }

    my $podxml;

    # the chapter can be passed as various things
    if ( $chapter =~ /\n/ ) {   # it's pure pod
        $podxml = $self->_convert_pod_to_xml( $chapter );
    }
    elsif ( -f $chapter ) {     # it's a file
        local $/ = undef;
        open my $pod_fh, '<', $chapter
            or die "can't open pod file $chapter: $!";
        $podxml = $self->_convert_pod_to_xml( <$pod_fh> );
    }
    else {                     # it's a module name
        $podxml = $self->_convert_pod_to_xml(
                        $self->_find_module_pod( $chapter )
        );
    }

    my $dom = $dom_of[ $$self ];

    my $subdoc = $podxml->documentElement;
    #my $docbook = XML::XPathScript->new->transform( $podxml,
    #        $Pod::Manual::PodXML2Docbook::stylesheet );

    #my $subdoc = eval {
    #    XML::LibXML->new->parse_string( $docbook )->documentElement;
    #};

    if ( $@ ) {
        croak "chapter couldn't be converted to docbook: $@";
    }

    # give the chapter an id if there isn't
    unless ( $subdoc->getAttribute( 'id' ) ) {
        $subdoc->setAttribute( 'id' => 'chapter-'.$self->unique_id );
    }

    # fudge the id of the sections as well
    for my $s ( $subdoc->findnodes( '//section' ) ) {
        $s->setAttribute( id => 'section-'.$self->unique_id );
    }

    # fix the title
    if ( my ( $node ) = $subdoc->findnodes( 'section[title/text()="NAME"]' ) ) {
        my $title = $node->findvalue( 'para/text()' );
        my ( $title_node ) = $subdoc->findnodes( 'title' );
        $title_node->appendText( $title );
        if ( $title =~ /-/ ) {
            my ( $short ) = split /\s*-\s*/, $title;

            my $abbrev = $title_node->ownerDocument->createElement( 'titleabbrev' );
            $abbrev->appendText( $short );

            $title_node->appendChild( $abbrev );
        }
        $node->unbindNode;
    }

    # trash sections we don't want to see
    for my $section ( $subdoc->findnodes( 'section' ) ) {
        my $title = $section->findvalue( 'title/text()' );
        if ( any { $_ eq $title } @{ $option{ignore_sections} } ) {
            $section->unbindNode;
        }
    }

    # give abbreviations to all section titles
    for my $title ( $subdoc->findnodes( 'section/title' ) ) {
        next if $title->findnodes( 'titleabbrev' );  #already there
        my $abbrev = $title->ownerDocument->createElement( 'titleabbrev' );
        my $text = $title->toString;
        $title->appendChild( $abbrev );
        # FIXME
        $text =~ s/^<.*?>//;
        $text =~ s#$##;
        if ( length( $text ) > 20 ) {
            # heuristics... *cross fingers*
            $text =~ s/\s+-.*$//;  # something - like this
            $text =~ s/\(.*?\)/( ... )/;
        }
        $abbrev->appendText( $text );
    }


    # use the title of that section if the 'doc_title' option is
    # used, or if there are no title given yet
    if ( $option{set_title} or not defined $self->get_title ) {
        my $title = $subdoc->findvalue( '/chapter/title/text()' );
        $title =~ s/\s*-.*//;  # remove desc after the '-'
        $self->set_title( $title ) if $title;
    }


    $dom->adoptNode( $subdoc );

    # if there is no appendix, it adds the chapter
    # at the end of the document
    $root_of[ $$self ]->insertBefore( $subdoc, $appendix_of[ $$self ] );

    for my $section_title ( @{ $option{appendix_sections} } ) {
        $self->_add_to_appendix(
            grep { $_->findvalue( 'title/text()' ) eq $section_title }
                    $subdoc->findnodes( 'section' )
        );
    }

    return $self;
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

sub as_dom {
    my $self = shift;
    return $dom_of[ $$self ];
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

sub as_docbook {
    my $self = shift;
    my %option = ref $_[0] eq 'HASH' ? %{ $_[0] } : () ;

    # generate the toc
    $self->generate_toc;

    my $dom = $dom_of[ $$self ];

    if ( my $css = $option{ css } ) {
        # make a copy of the dom so that we're not stuck with the PI
        $dom = $parser_of[ $$self ]->parse_string( $dom->toString );

        my $pi = $dom->createPI( 'xml-stylesheet'
                                    => qq{href="$css" type="text/css"} );
        $dom->insertBefore( $pi, $dom->firstChild );
    }


    return $dom->toString;
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

sub generate_toc {
    my $self = shift;
    my $dom = $dom_of[ $$self ];

    # if there's already a toc, nuke it
    for ( $dom->findnodes( 'toc' ) ) {
        $_->unbindNode;
    }

    my $toc = $dom->createElement( 'toc' );
    my ( $bookinfo ) = $dom->findnodes( '/book/bookinfo' );
    $bookinfo->parentNode->insertAfter( $toc, $bookinfo );

    for my $chapter ( $dom->findnodes( '/book/chapter' ),
                      $dom->findnodes( '/book/appendix' ) ) {
        $self->add_entry_to_toc( 0, $toc, $chapter );
    }
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

sub tag_content {
    my $node;
    my $text;
    $text .= $_->toString for $node->childNodes;
    return $text;
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

sub add_entry_to_toc {
    my ( $self, $level, $toc, $chapter ) = @_;

    my $tocchap = $chapter->ownerDocument->createElement(
        $level == 0 ? 'tocchap' : 'toclevel'.$level
    );
    $toc->addChild( $tocchap );

    my $title = $chapter->findvalue( 'title/titleabbrev/text()' )
              || $chapter->findvalue( 'title/text()' );

    my $tocentry = $chapter->ownerDocument->createElement( 'tocentry' );
    $tocchap->addChild( $tocentry );
    $tocentry->setAttribute( href => '#'.$chapter->getAttribute( 'id' ) );
    $tocentry->appendText( $title );

    for my $child ( $chapter->findnodes( 'section' ) ) {
        $self->add_entry_to_toc( $level + 1, $tocchap, $child );
    }
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

sub as_latex {
    my $self = shift;

    eval {
        require XML::XPathScript;
        require Pod::Manual::Docbook2LaTeX;
    };

    croak 'as_latex() requires module XML::XPathScript to be installed'
        if $@;

    my $xps = XML::XPathScript->new;

    my $docbook = eval { $xps->transform(
         $self->as_docbook => $Pod::Manual::Docbook2LaTeX::stylesheet
    ) } ;

    croak "couldn't convert to docbook: $@" if $@;

    return $docbook;
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

sub generate_pdf_using_prince {
    my ( $self, $filename ) = @_;

    # if no css, we must create our own

    my $docbook = $self->as_docbook({ css =>
            $self->local_prince_css( '.' ) });

    open my $db_fh, '>', 'manual.docbook'
        or croak "can't open file 'manual.docbook' for writing: $!";

    print $db_fh $docbook;
    close $db_fh;

    system 'prince', 'manual.docbook', '-o', 'manual.pdf';
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

sub generate_pdf_using_latex {
    my ( $self ) = @_;

   my $latex = $self->as_latex;

   open my $latex_fh, '>', 'manual.tex'
       or croak "can't write to 'manual.tex': $!";
   print {$latex_fh} $latex;
   close $latex_fh;

    for ( 1..2 ) {       # two times to populate the toc
        system "pdflatex -interaction=batchmode manual.tex > /dev/null";
           # and croak "problem running pdflatex: $!";
    }

}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

sub save_as_pdf {
    # TODO: add -force argument
    my $self = shift;

    my %option;

    if ( ref $_[-1] eq 'HASH' ) {
        my @a = %{$_[-1]};
        %option = validate( @a, { force => 0 } );
    }

    my $filename = shift
        or croak 'save_as_pdf: requires a filename as an argument';

    $filename =~ s/\.pdf$//
        or croak "save_as_pdf: filename '$filename'"
                ."must have suffix '.pdf'";

    if ( -f $filename.'.pdf' ) {
        if ( $option{force} ) {
            unlink $filename.'.pdf'
                or die "can't remove file $filename.pdf: $!\n";
        }
        else {
            croak "file $filename.pdf already exist";
        }
    }

    my $original_dir = cwd();    # let's remember where we are

    my $tmpdir = tempdir( 'podmanualXXXX', CLEANUP => 1 );

    chdir $tmpdir or die "can't switch to dir $tmpdir: $!\n";

    #if ( $filename =~ s#^(.*)/## ) {
    #    chdir $1 or croak "can't chdir to $1: $!";
    #}

    if ( $self->get_pdf_generator eq 'latex' ) {
        $self->generate_pdf_using_latex( $filename, $original_dir );
    }
    elsif( $self->get_pdf_generator eq 'prince' ) {
        $self->generate_pdf_using_prince( $filename, $original_dir );
    }


    chdir $original_dir;

    copy( $tmpdir.'/manual.pdf' => $filename.'.pdf' ) or die $!;

    return 1;
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

sub create_appendix {
    my $self = shift;

    return $appendix_of[ $$self ] if $appendix_of[ $$self ];

    my $appendix = $root_of[ $$self ]->new( 'appendix' );
    $appendix->setAttribute(  id => 'appendix-'.$self->unique_id );

    $root_of[ $$self ]->appendChild( $appendix );

    my $label = $appendix->new( 'title' );
    $label->appendText( 'Appendix' );
    $appendix->appendChild( $label );
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

sub get_appendix {
    my ( $self, $create_if_missing ) = @_;

    return $create_if_missing ? $self->create_appendix : $appendix_of[ $$self ];
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

sub _add_to_appendix {
    my ( $self, @nodes ) = @_;

    my $appendix = $self->get_appendix(1);

    $appendix->appendChild( $_ ) for @nodes;

    return $self;
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

sub local_prince_css {
    my $self = shift;
    my $tempdir = shift;

    my $css;

    if ( my $prince = $self->get_prince_css ) {
        $css = qq{\@import '$prince';\n};
    }

    $css .= <<'END_CSS';
bookinfo title {
    font-size: 24pt;
    text-align: center;
}

tocentry { display: block;  }
tocentry::after { content: leader(".") target-counter(attr(href), page); }

toclevel1, toclevel2, toclevel3,
toclevel4, toclevel5, toclevel6 {
    display: block;
    position: inherit;
    padding-left: 20px;
}

bookinfo > title {
    string-set: doctitle content();
}


title {
    string-set: currentSection content();
}

section > title {
    margin-top: 5px;
    font: 14pt;
}

chapter > section > title > titleabbrev,
appendix > section > title > titleabbrev
{
    display: block;
    font: 10pt;
    flow: static(currentSection);
}

chapter > title > titleabbrev,
appendix > title > titleabbrev {
    display: block;
    font: 10pt;
    text-align: left;
    flow: static(currentChapter);
}

chapter > title > titleabbrev,
appendix > title > titleabbrev {
    string-set: currentChapter content();
}

@page:first {
    @top-left { content: normal }
    @top-right { content: normal }
    @bottom-left { content: normal }
    @bottom-right { content: normal }
}

chapter > title::before {
    display: none;
}

chapter > title,
appendix > title {
    text-align: left;
}



emphasis[role="italic"] {
    font-style: italic;
}


@page {
    @bottom-left {
        content: string(doctitle)
    }
    @bottom-right {
        content: counter(page);
        font-style: italic
    }
    @top-right {
        content: flow(currentSection);
    }
    @top-left {
        content: flow(currentChapter);
    }
}

appendix {
    page-break-before: always;
    display: block;
}

appendix > title {
    font-size: 24pt;
    font-weight: bold;
}
END_CSS

    open my $css_fh, '>', 'docbook.css'
        or croak "can't open file docbook.css for writing: $!";
    print $css_fh $css;

    return 'docbook.css';
}

'end of Pod::Manual'; # Magic true value required at end of module

__END__