Upgrade 4.0.17 clean.
[usit-rt.git] / lib / RT / Pod / HTML.pm
1 # BEGIN BPS TAGGED BLOCK {{{
2 #
3 # COPYRIGHT:
4 #
5 # This software is Copyright (c) 1996-2013 Best Practical Solutions, LLC
6 #                                          <sales@bestpractical.com>
7 #
8 # (Except where explicitly superseded by other copyright notices)
9 #
10 #
11 # LICENSE:
12 #
13 # This work is made available to you under the terms of Version 2 of
14 # the GNU General Public License. A copy of that license should have
15 # been provided with this software, but in any event can be snarfed
16 # from www.gnu.org.
17 #
18 # This work is distributed in the hope that it will be useful, but
19 # WITHOUT ANY WARRANTY; without even the implied warranty of
20 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
21 # General Public License for more details.
22 #
23 # You should have received a copy of the GNU General Public License
24 # along with this program; if not, write to the Free Software
25 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
26 # 02110-1301 or visit their web page on the internet at
27 # http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
28 #
29 #
30 # CONTRIBUTION SUBMISSION POLICY:
31 #
32 # (The following paragraph is not intended to limit the rights granted
33 # to you to modify and distribute this software under the terms of
34 # the GNU General Public License and is only of importance to you if
35 # you choose to contribute your changes and enhancements to the
36 # community by submitting them to Best Practical Solutions, LLC.)
37 #
38 # By intentionally submitting any modifications, corrections or
39 # derivatives to this work, or any other work intended for use with
40 # Request Tracker, to Best Practical Solutions, LLC, you confirm that
41 # you are the copyright holder for those contributions and you grant
42 # Best Practical Solutions,  LLC a nonexclusive, worldwide, irrevocable,
43 # royalty-free, perpetual, license to use, copy, create derivative
44 # works based on those contributions, and sublicense and distribute
45 # those contributions and any derivatives thereof.
46 #
47 # END BPS TAGGED BLOCK }}}
48
49 use strict;
50 use warnings;
51
52 package RT::Pod::HTML;
53 use base 'Pod::Simple::XHTML';
54
55 use HTML::Entities qw//;
56
57 __PACKAGE__->_accessorize(
58     "batch"
59 );
60
61 sub new {
62     my $self = shift->SUPER::new(@_);
63     $self->index(1);
64     $self->anchor_items(1);
65     return $self;
66 }
67
68 sub decode_entities {
69     my $self = shift;
70     return HTML::Entities::decode_entities($_[0]);
71 }
72
73 sub perldoc_url_prefix { "http://metacpan.org/module/" }
74
75 sub html_header { '' }
76 sub html_footer {
77     my $self = shift;
78     my $toc  = "../" x ($self->batch_mode_current_level - 1);
79     return '<a href="./' . $toc . '">&larr; Back to index</a>';
80 }
81
82 sub start_F {
83     $_[0]{'scratch_F'} = $_[0]{'scratch'};
84     $_[0]{'scratch'}   = "";
85 }
86 sub end_F   {
87     my $self = shift;
88     my $text = $self->{scratch};
89     my $file = $self->decode_entities($text);
90
91     if (my $local = $self->resolve_local_link($file)) {
92         $text = qq[<a href="$local">$text</a>];
93     }
94
95     $self->{'scratch'} = delete $self->{scratch_F};
96     $self->{'scratch'} .= "<i>$text</i>";
97 }
98
99 sub _end_head {
100     my $self = shift;
101     $self->{scratch} = '<a href="#___top">' . $self->{scratch} . '</a>';
102     return $self->SUPER::_end_head(@_);
103 }
104
105 sub resolve_pod_page_link {
106     my $self = shift;
107     my ($name, $section) = @_;
108
109     # Only try to resolve local links if we're in batch mode and are linking
110     # outside the current document.
111     return $self->SUPER::resolve_pod_page_link(@_)
112         unless $self->batch_mode and $name;
113
114     my $local = $self->resolve_local_link($name, $section);
115
116     return $local
117         ? $local
118         : $self->SUPER::resolve_pod_page_link(@_);
119 }
120
121 sub resolve_local_link {
122     my $self = shift;
123     my ($name, $section) = @_;
124
125     $name .= ""; # stringify name, it may be an object
126
127     $section = defined $section
128         ? '#' . $self->idify($section, 1)
129         : '';
130
131     my $local;
132     if ($name =~ /^RT(::(?!Extension::|Authen::)|$)/ or $self->batch->found($name)) {
133         $local = join "/",
134                   map { $self->encode_entities($_) }
135                 split /::/, $name;
136     }
137     elsif ($name =~ /^rt([-_]|$)/) {
138         $local = $self->encode_entities($name);
139     }
140     elsif ($name =~ /^(\w+)_Config(\.pm)?$/) {
141         $name  = "$1_Config";
142         $local = "$1_Config";
143     }
144     # These matches handle links that look like filenames, such as those we
145     # parse out of F<> tags.
146     elsif (   $name =~ m{^(?:lib/)(RT/[\w/]+?)\.pm$}
147            or $name =~ m{^(?:docs/)(.+?)\.pod$})
148     {
149         $name  = join "::", split '/', $1;
150         $local = join "/",
151                   map { $self->encode_entities($_) }
152                 split /\//, $1;
153     }
154
155     if ($local) {
156         # Resolve links correctly by going up
157         my $found = $self->batch->found($name);
158         my $depth = $self->batch_mode_current_level
159                   + ($found ? -1 : 1);
160         return ($depth ? "../" x $depth : "") . ($found ? "" : "rt/latest/") . "$local.html$section";
161     } else {
162         return;
163     }
164 }
165
166 sub batch_mode_page_object_init {
167     my ($self, $batch, $module, $infile, $outfile, $depth) = @_;
168     $self->SUPER::batch_mode_page_object_init(@_[1..$#_]);
169     $self->batch( $batch );
170     return $self;
171 }
172
173 1;