lib/Frey/Pod.pm

package Frey::Pod;
use Moose;

=head1 NAME

Frey::Pod - display documentation

=cut

extends 'Frey::Class::Loader';
with 'Frey::Web', 'Frey::File';

has 'class' => (
        is => 'rw',
        isa => 'Str',
        required => 1,
        default => 'Frey::Manual',
);

use Pod::Find qw/pod_where/;
use Data::Dump qw/dump/;

=head2 as_markup

 my $html = $o->as_markup;

 my ( $toc_html, $html ) = $o->as_markup;

=cut

sub as_markup {
        my $self = shift;
        my $class = $self->class;
        use Pod::Simple::HTML;
        my $path = pod_where( { -inc => 1 }, $class );
        return $self->error( "Can't find pod for $class\n" ) unless $path;
        my $pod = $self->read_file( $path );
        my $converter = Pod::Simple::HTML->new();
        my $body;
        my $my_classes = join('|', $self->classes);
        $converter->output_string( \$body );
        $converter->parse_string_document($pod);
        $body =~ s{.*?<body [^>]+>}{}s;
        $body =~ s{</body>\s*</html>\s*$}{};
        $body =~ s!%3A%3A!::!g;
#       $body =~ s{<a href="http://search\.cpan\.org/perldoc\?($my_classes)"([^>]*)>}{<a href="/$1"$2>}g;
        $body =~ s{<a href="http://(search\.cpan\.org/perldoc\?)([^"]+)"([^>]*)>([^<]+)<([^>]+)>}{<a href="/$2"$3>$4<$5><sup><a target="$1" title="CPAN" style="text-decoration: none" href="http://$1$2"$3>&loz;<$5></sup>}g;
        $body =~ s!</li>\n\t<ul>!<ul>!;
        $body =~ s!</ul>!</ul></li>!;
        $body =~ s!<p></p>!!;
        $body =~ s!__index__!index!g;

        our @toc = ();

        sub heading {
                my ($level,$html) = @_;
                push @toc, { $level => $html };
                warn "## heading $level $html" if $self->debug;
                qq|<$level>$html</$level>|;
        }
        $body =~ s{<(h\d+)>(.+?)</\1>}{heading($1,$2)}egs;

        $self->title( $class );

#       $body .= $self->html_dump( $toc );
        warn "# toc ", dump( @toc );

        my $toc_html = '';
        my $current_level = 0;
        foreach my $entry ( @toc ) {
                my ( $level, $html ) = %$entry;

                if ( $level =~ m{h(\d+)} ) {
                        my $num = $1;
                        if ( $num > $current_level ) {
                                if ( ! $toc_html ) { # first ul
                                        $toc_html .= qq|<ul class="first">|;
                                } else {
                                        $toc_html .= qq|<ul>|;
                                }
                        } elsif ( $num < $current_level ) {
                                $toc_html .= qq|</ul>|;
                        }
                        $current_level = $num;
                }

                my $target = $html;
                $target =~ s{<[^>]+/?>}{}gs; # remove html
                $target = qq|<a href="#$2">$target</a>| if $html =~ m{<a[^<]+name=(['"]?)([^'"<]+?)\1[^<]+>};

                $toc_html .= qq|<li title="$level">$target</li>\n|;
        }

        $toc_html .= qq|</ul>| while ( $current_level-- );

        if ( $toc_html && ! wantarray ) {
                $self->add_css(qq|
                        .pod-toc {
                                float: right;
                                background: #eee;
                                font-size: 80%;
                        }
                        .pod-toc .first {
                                padding-left: 1em;
                                padding-right: 1em;
                        }
                        .pod-toc ul > li {
                                list-style: none;
                        }
                        .pod-toc a {
                                text-decoration: none;
                        }

                |);
                $toc_html = qq|<div class="pod-toc">$toc_html</div>|;
        }

        $self->add_css(qq|
                pre {
                        color: #444;
                        border: 1px solid #eee;
                        padding-top: 0.5em;
                        padding-bottom: 0.5em;
                }
        |);

        return ( $toc_html , $body ) if wantarray; 
        return   $toc_html . $body;

}

__PACKAGE__->meta->make_immutable;
no Moose;

1;
1	dpavlin	126	package Frey::Pod;
2			use Moose;
3
4			=head1 NAME
5
6			Frey::Pod - display documentation
7
8			=cut
9
10	dpavlin	797	extends 'Frey::Class::Loader';
11	dpavlin	1133	with 'Frey::Web', 'Frey::File';
12	dpavlin	126
13			has 'class' => (
14			is => 'rw',
15			isa => 'Str',
16			required => 1,
17	dpavlin	724	default => 'Frey::Manual',
18	dpavlin	126	);
19
20	dpavlin	724	use Pod::Find qw/pod_where/;
21	dpavlin	126	use Data::Dump qw/dump/;
22
23	dpavlin	1034	=head2 as_markup
24
25			my $html = $o->as_markup;
26
27			my ( $toc_html, $html ) = $o->as_markup;
28
29			=cut
30
31	dpavlin	455	sub as_markup {
32	dpavlin	178	my $self = shift;
33			my $class = $self->class;
34	dpavlin	126	use Pod::Simple::HTML;
35	dpavlin	356	my $path = pod_where( { -inc => 1 }, $class );
36	dpavlin	694	return $self->error( "Can't find pod for $class\n" ) unless $path;
37	dpavlin	724	my $pod = $self->read_file( $path );
38	dpavlin	126	my $converter = Pod::Simple::HTML->new();
39			my $body;
40			my $my_classes = join('\|', $self->classes);
41			$converter->output_string( \$body );
42			$converter->parse_string_document($pod);
43			$body =~ s{.*?<body [^>]+>}{}s;
44			$body =~ s{</body>\s</html>\s$}{};
45	dpavlin	130	$body =~ s!%3A%3A!::!g;
46	dpavlin	356	# $body =~ s{<a href="http://search\.cpan\.org/perldoc\?($my_classes)"([^>]*)>}{<a href="/$1"$2>}g;
47	dpavlin	376	$body =~ s{<a href="http://(search\.cpan\.org/perldoc\?)([^"]+)"([^>]*)>([^<]+)<([^>]+)>}{<a href="/$2"$3>$4<$5><sup><a target="$1" title="CPAN" style="text-decoration: none" href="http://$1$2"$3>&loz;<$5></sup>}g;
48	dpavlin	126	$body =~ s!</li>\n\t<ul>!<ul>!;
49			$body =~ s!</ul>!</ul></li>!;
50			$body =~ s!<p></p>!!;
51			$body =~ s!__index__!index!g;
52	dpavlin	724
53			our @toc = ();
54
55			sub heading {
56			my ($level,$html) = @_;
57			push @toc, { $level => $html };
58	dpavlin	800	warn "## heading $level $html" if $self->debug;
59	dpavlin	724	qq\|<$level>$html</$level>\|;
60			}
61			$body =~ s{<(h\d+)>(.+?)</\1>}{heading($1,$2)}egs;
62
63	dpavlin	691	$self->title( $class );
64	dpavlin	379
65	dpavlin	724	# $body .= $self->html_dump( $toc );
66			warn "# toc ", dump( @toc );
67
68			my $toc_html = '';
69			my $current_level = 0;
70			foreach my $entry ( @toc ) {
71			my ( $level, $html ) = %$entry;
72
73			if ( $level =~ m{h(\d+)} ) {
74			my $num = $1;
75			if ( $num > $current_level ) {
76			if ( ! $toc_html ) { # first ul
77			$toc_html .= qq\|<ul class="first">\|;
78			} else {
79			$toc_html .= qq\|<ul>\|;
80			}
81			} elsif ( $num < $current_level ) {
82			$toc_html .= qq\|</ul>\|;
83			}
84			$current_level = $num;
85			}
86
87			my $target = $html;
88			$target =~ s{<[^>]+/?>}{}gs; # remove html
89			$target = qq\|<a href="#$2">$target</a>\| if $html =~ m{<a[^<]+name=(['"]?)([^'"<]+?)\1[^<]+>};
90
91			$toc_html .= qq\|<li title="$level">$target</li>\n\|;
92			}
93
94	dpavlin	1034	$toc_html .= qq\|</ul>\| while ( $current_level-- );
95
96			if ( $toc_html && ! wantarray ) {
97	dpavlin	724	$self->add_css(qq\|
98			.pod-toc {
99			float: right;
100			background: #eee;
101			font-size: 80%;
102			}
103			.pod-toc .first {
104			padding-left: 1em;
105			padding-right: 1em;
106			}
107			.pod-toc ul > li {
108			list-style: none;
109			}
110			.pod-toc a {
111			text-decoration: none;
112			}
113	dpavlin	800
114	dpavlin	724	\|);
115			$toc_html = qq\|<div class="pod-toc">$toc_html</div>\|;
116			}
117
118	dpavlin	800	$self->add_css(qq\|
119			pre {
120			color: #444;
121			border: 1px solid #eee;
122			padding-top: 0.5em;
123			padding-bottom: 0.5em;
124			}
125			\|);
126
127	dpavlin	1034	return ( $toc_html , $body ) if wantarray;
128			return $toc_html . $body;
129	dpavlin	724
130	dpavlin	126	}
131
132	dpavlin	1133	__PACKAGE__->meta->make_immutable;
133			no Moose;
134
135	dpavlin	126	1;