=pod
=head1 NAME
create_question_list.pl - search the pod files for the questions
=head1 DESCRIPTION
Used to create the list in perlfaq.pod
=cut
use strict;
use warnings;
package inc::CreateQuestionList;
use Moose;
with
'Dist::Zilla::Role::FileGatherer',
'Dist::Zilla::Role::FileMunger';
use Template;
use HTML::TreeBuilder;
use Pod::Simple::XHTML;
my $HTML_CHARSET = 'UTF-8';
sub gather_files {
my $self = shift;
require Dist::Zilla::File::InMemory;
$self->add_file(
Dist::Zilla::File::InMemory->new({
name => 'lib/perlfaq.pod',
content => '', # filled in later
})
);
return;
}
sub munge_files {
my $self = shift;
my ($file) = grep { $_->name eq 'lib/perlfaq.pod' } @{$self->zilla->files};
my $encoded_content;
open my $fh, sprintf('>:encoding(%s)', $file->encoding), \$encoded_content
or $self->log_fatal('cannot open handle to create ' . $file->name . ' content: ' . $!);
my $the_questions = $self->get_questions();
my $tt = Template->new( { POST_CHOMP => 1, } );
$tt->process( 'inc/perlfaq.tt', { the_questions => $the_questions }, $fh)
|| die $tt->error();
close $fh;
$file->encoded_content($encoded_content);
}
sub get_questions {
my $self = shift;
my $out;
{
foreach my $pod_file (@{$self->zilla->files}) {
next unless $pod_file->name =~ /.pod$/;
next unless $pod_file->name =~ /\d/;
# next unless $pod_file->name =~ /3/;
my $parser = Pod::Simple::XHTML->new;
$parser->html_header('');
$parser->html_footer('');
$parser->html_charset($HTML_CHARSET);
my $html = '';
$parser->output_string( \$html );
open my $pod_fh, sprintf('<:encoding(%s)', $pod_file->encoding), \$pod_file->encoded_content
or $self->log_fatal('cannot open handle to ' . $pod_file->name . ' content: ' . $!);
$parser->parse_file($pod_fh);
my $root
= HTML::TreeBuilder->new_from_content($html); # empty tree
$root->elementify;
my @doc = $root->content_list();
my @body = $doc[1]->content_list();
my $html_nodes = scalar(@body);
my %data;
my @questions;
for ( my $i = 0; $i <= $html_nodes; $i++ ) {
my $h_node = $body[$i] || next;
my $tag = $h_node->tag;
next unless $tag =~ /^h/;
my $text = fetch_text($h_node);
if ( $tag eq 'h2' ) {
# All a bit hacky, but works - patches welcome
$text =~ s/</E<lt>/g;
$text =~ s/([^lt])>/$1E<gt>/g;
$text =~ s/CSTART/C</g;
$text =~ s/CEND/>/g;
push( @questions, $text );
} else {
$data{$tag}->{$text} = fetch_text( $body[ $i + 1 ] );
}
}
my $name = $data{'h1'}->{'NAME'};
my $desc = $data{'h1'}->{'DESCRIPTION'};
$name =~ s/(perlfaq.+) -/L<$1>:/;
$out .= "=head2 $name\n\n";
$out .= "$desc\n\n";
$out .= "=over 4\n\n";
foreach my $q (@questions) {
$out .= "=item *\n\n";
$out .= "$q\n\n";
}
$out .= "=back\n\n\n";
}
}
return $out;
}
sub fetch_text {
my $node = shift || return '';
my $start = '';
my $end = '';
if ( $node->tag eq 'code' ) {
# All a bit hacky, but works - patches welcome
$start = 'CSTART';
$end = 'CEND';
}
my @nodes = $node->content_list();
# Wrap CSTART/CEND and recurse down if needed
my $str
= $start
. ( join ' ', map { ref($_) ? fetch_text($_) : $_ } @nodes )
. $end;
$str =~ s/\s{2,}/ /g; # Remove extra spaces
$str =~ s/\s+$//; # Remove trailing white spaces
return $str;
}
1;