| 1 |
package WebHACC::Output; |
package WebHACC::Output; |
| 2 |
use strict; |
use strict; |
| 3 |
|
|
| 4 |
require IO::Handle; |
require IO::Handle; |
| 5 |
|
use Scalar::Util qw/refaddr/; |
| 6 |
|
|
| 7 |
my $htescape = sub ($) { |
my $htescape = sub ($) { |
| 8 |
my $s = $_[0]; |
my $s = $_[0]; |
| 115 |
shift->html ('</code></pre>'); |
shift->html ('</code></pre>'); |
| 116 |
} # end_code_block |
} # end_code_block |
| 117 |
|
|
| 118 |
sub code ($$) { |
sub code ($$;%) { |
| 119 |
shift->html ('<code>' . $htescape->(shift) . '</code>'); |
my ($self, $content, %opt) = @_; |
| 120 |
|
$self->start_tag ('code', %opt); |
| 121 |
|
$self->text ($content); |
| 122 |
|
$self->html ('</code>'); |
| 123 |
} # code |
} # code |
| 124 |
|
|
| 125 |
|
sub script ($$;%) { |
| 126 |
|
my ($self, $content, %opt) = @_; |
| 127 |
|
$self->start_tag ('script', %opt); |
| 128 |
|
$self->html ($content); |
| 129 |
|
$self->html ('</script>'); |
| 130 |
|
} # script |
| 131 |
|
|
| 132 |
|
sub dt ($$;%) { |
| 133 |
|
my ($self, $content, %opt) = @_; |
| 134 |
|
$self->start_tag ('dt', %opt); |
| 135 |
|
$self->text ($content); |
| 136 |
|
} # dt |
| 137 |
|
|
| 138 |
sub link ($$%) { |
sub link ($$%) { |
| 139 |
my ($self, $content, %opt) = @_; |
my ($self, $content, %opt) = @_; |
| 140 |
$self->html ('<a href="' . $htescape->($opt{url}) . '">'); |
$self->start_tag ('a', %opt, href => $opt{url}); |
| 141 |
$self->text ($content); |
$self->text ($content); |
| 142 |
$self->html ('</a>'); |
$self->html ('</a>'); |
| 143 |
} # link |
} # link |
| 149 |
$self->html ('</a>'); |
$self->html ('</a>'); |
| 150 |
} # xref |
} # xref |
| 151 |
|
|
| 152 |
|
sub link_to_webhacc ($$%) { |
| 153 |
|
my ($self, $content, %opt) = @_; |
| 154 |
|
$opt{url} = './?uri=' . $self->encode_url_component ($opt{url}); |
| 155 |
|
$self->link ($content, %opt); |
| 156 |
|
} # link_to_webhacc |
| 157 |
|
|
| 158 |
|
|
| 159 |
|
my $get_node_path = sub ($) { |
| 160 |
|
my $node = shift; |
| 161 |
|
my @r; |
| 162 |
|
while (defined $node) { |
| 163 |
|
my $rs; |
| 164 |
|
if ($node->node_type == 1) { |
| 165 |
|
$rs = $node->node_name; |
| 166 |
|
$node = $node->parent_node; |
| 167 |
|
} elsif ($node->node_type == 2) { |
| 168 |
|
$rs = '@' . $node->node_name; |
| 169 |
|
$node = $node->owner_element; |
| 170 |
|
} elsif ($node->node_type == 3) { |
| 171 |
|
$rs = '"' . $node->data . '"'; |
| 172 |
|
$node = $node->parent_node; |
| 173 |
|
} elsif ($node->node_type == 9) { |
| 174 |
|
@r = ('') unless @r; |
| 175 |
|
$rs = ''; |
| 176 |
|
$node = $node->parent_node; |
| 177 |
|
} else { |
| 178 |
|
$rs = '#' . $node->node_type; |
| 179 |
|
$node = $node->parent_node; |
| 180 |
|
} |
| 181 |
|
unshift @r, $rs; |
| 182 |
|
} |
| 183 |
|
return join '/', @r; |
| 184 |
|
}; # $get_node_path |
| 185 |
|
|
| 186 |
|
sub node_link ($$) { |
| 187 |
|
my ($self, $node) = @_; |
| 188 |
|
$self->xref ($get_node_path->($node), target => 'node-' . refaddr $node); |
| 189 |
|
} # node_link |
| 190 |
|
|
| 191 |
sub nav_list ($) { |
sub nav_list ($) { |
| 192 |
my $self = shift; |
my $self = shift; |
| 193 |
$self->html (q[<ul class="navigation" id="nav-items">]); |
$self->html (q[<ul class="navigation" id="nav-items">]); |
| 194 |
for (@{$self->{nav}}) { |
for (@{$self->{nav}}) { |
| 195 |
$self->html (qq[<li><a href="@{[$htescape->($_->[0])]}">@{[$htescape->($_->[1])]}</a>]); |
$self->html (qq[<li><a href="#@{[$htescape->($_->[0])]}">@{[$htescape->($_->[1])]}</a>]); |
| 196 |
} |
} |
| 197 |
$self->html ('</ul>'); |
$self->html ('</ul>'); |
| 198 |
} # nav_list |
} # nav_list |
| 199 |
|
|
| 200 |
|
|
| 201 |
|
sub encode_url_component ($$) { |
| 202 |
|
shift; |
| 203 |
|
require Encode; |
| 204 |
|
my $s = Encode::encode ('utf8', shift); |
| 205 |
|
$s =~ s/([^0-9A-Za-z_.~-])/sprintf '%%%02X', ord $1/ge; |
| 206 |
|
return $s; |
| 207 |
|
} # encode_url_component |
| 208 |
|
|
| 209 |
1; |
1; |
Parent Directory
| 
Revision Log
| 
Patch