/[Frey]/branches/no-pager/lib/Frey/Pod.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Diff of /branches/no-pager/lib/Frey/Pod.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

trunk/lib/Frey/Pod.pm revision 138 by dpavlin, Tue Jul 15 19:10:56 2008 UTC branches/no-pager/lib/Frey/Pod.pm revision 738 by dpavlin, Sat Dec 6 15:29:10 2008 UTC
# Line 9  Frey::Pod - display documentation Line 9  Frey::Pod - display documentation
9    
10  extends 'Frey::ClassLoader';  extends 'Frey::ClassLoader';
11  with 'Frey::Web';  with 'Frey::Web';
12    with 'Frey::File';
13    
14  has 'class' => (  has 'class' => (
15          is => 'rw',          is => 'rw',
16          isa => 'Str',          isa => 'Str',
17          required => 1,          required => 1,
18            default => 'Frey::Manual',
19  );  );
20    
21  use File::Slurp;  use Pod::Find qw/pod_where/;
22  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
23    
24  sub html {  sub as_markup {
25          my ( $self, $req ) = @_;          my $self = shift;
26          my $f = { $req->params };          my $class = $self->class;
         my $class = delete( $f->{class} ) || $self->class;  
         $req->print( $self->page( title => $class, body => $self->markup( $class ) ) );  
 }  
   
 sub markup {  
         my ( $self, $class ) = @_;  
         $class ||= $self->class;  
27          use Pod::Simple::HTML;          use Pod::Simple::HTML;
28          my $path = eval { $self->package_path( $class ) };          my $path = pod_where( { -inc => 1 }, $class );
29          return if $@;          return $self->error( "Can't find pod for $class\n" ) unless $path;
30          my $pod = read_file( $path );          my $pod = $self->read_file( $path );
31          my $converter = Pod::Simple::HTML->new();          my $converter = Pod::Simple::HTML->new();
32          my $body;          my $body;
33          my $my_classes = join('|', $self->classes);          my $my_classes = join('|', $self->classes);
# Line 41  sub markup { Line 36  sub markup {
36          $body =~ s{.*?<body [^>]+>}{}s;          $body =~ s{.*?<body [^>]+>}{}s;
37          $body =~ s{</body>\s*</html>\s*$}{};          $body =~ s{</body>\s*</html>\s*$}{};
38          $body =~ s!%3A%3A!::!g;          $body =~ s!%3A%3A!::!g;
39          $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\?($my_classes)"([^>]*)>}{<a href="/$1"$2>}g;
40            $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;
41          $body =~ s!</li>\n\t<ul>!<ul>!;          $body =~ s!</li>\n\t<ul>!<ul>!;
42          $body =~ s!</ul>!</ul></li>!;          $body =~ s!</ul>!</ul></li>!;
43          $body =~ s!<p></p>!!;          $body =~ s!<p></p>!!;
44          $body =~ s!__index__!index!g;          $body =~ s!__index__!index!g;
45          return $body;  
46            our @toc = ();
47    
48            sub heading {
49                    my ($level,$html) = @_;
50                    push @toc, { $level => $html };
51                    warn "# heading $level $html";
52                    qq|<$level>$html</$level>|;
53            }
54            $body =~ s{<(h\d+)>(.+?)</\1>}{heading($1,$2)}egs;
55    
56            $self->title( $class );
57    
58    #       $body .= $self->html_dump( $toc );
59            warn "# toc ", dump( @toc );
60    
61            my $toc_html = '';
62            my $current_level = 0;
63            foreach my $entry ( @toc ) {
64                    my ( $level, $html ) = %$entry;
65    
66                    if ( $level =~ m{h(\d+)} ) {
67                            my $num = $1;
68                            if ( $num > $current_level ) {
69                                    if ( ! $toc_html ) { # first ul
70                                            $toc_html .= qq|<ul class="first">|;
71                                    } else {
72                                            $toc_html .= qq|<ul>|;
73                                    }
74                            } elsif ( $num < $current_level ) {
75                                    $toc_html .= qq|</ul>|;
76                            }
77                            $current_level = $num;
78                    }
79    
80                    my $target = $html;
81                    $target =~ s{<[^>]+/?>}{}gs; # remove html
82                    $target = qq|<a href="#$2">$target</a>| if $html =~ m{<a[^<]+name=(['"]?)([^'"<]+?)\1[^<]+>};
83    
84                    $toc_html .= qq|<li title="$level">$target</li>\n|;
85            }
86    
87            if ( $toc_html ) {
88                    $self->add_css(qq|
89                            .pod-toc {
90                                    float: right;
91                                    background: #eee;
92                                    font-size: 80%;
93                            }
94                            .pod-toc .first {
95                                    padding-left: 1em;
96                                    padding-right: 1em;
97                            }
98                            .pod-toc ul > li {
99                                    list-style: none;
100                            }
101                            .pod-toc a {
102                                    text-decoration: none;
103                            }
104                    |);
105                    $toc_html = qq|<div class="pod-toc">$toc_html</div>|;
106            }
107    
108            return $toc_html . $body;
109    
110  }  }
111    
112  1;  1;
Legend:
Removed from v.138  
changed lines
  Added in v.738
  ViewVC Help
Powered by ViewVC 1.1.26