html-webhacc/WebHACC/Output.pm

package WebHACC::Output;
use strict;
require IO::Handle;

my $htescape = sub ($) {
  my $s = $_[0];
  $s =~ s/&/&amp;/g;
  $s =~ s/</&lt;/g;
  $s =~ s/>/&gt;/g;
  $s =~ s/"/&quot;/g;
  $s =~ s{([\x00-\x09\x0B-\x1F\x7F-\xA0\x{FEFF}\x{FFFC}-\x{FFFF}])}{
    sprintf '<var>U+%04X</var>', ord $1;
  }ge;
  return $s;
};

sub new ($) {
  return bless {nav => []}, shift;
} # new

sub input ($;$) {
  if (@_ > 1) {
    if (defined $_[1]) {
      $_[0]->{input} = $_[1];
    } else {
      delete $_[0]->{input};
    }
  }
  
  return $_[0]->{input};
} # input

sub handle ($;$) {
  if (@_ > 1) {
    if (defined $_[1]) {
      $_[0]->{handle} = $_[1];
    } else {
      delete $_[0]->{handle};
    }
  }
  
  return $_[0]->{handle};
} # handle

sub set_utf8 ($) {
  binmode shift->{handle}, ':utf8';
} # set_utf8

sub set_flush ($) {
  shift->{handle}->autoflush (1);
} # set_flush

sub unset_flush ($) {
  shift->{handle}->autoflush (0);
} # unset_flush

sub html ($$) {
  shift->{handle}->print (shift);
} # html

sub text ($$) {
  shift->html ($htescape->(shift));
} # text

sub url ($$%) {
  my ($self, $url, %opt) = @_;
  $self->html (q[<code class=uri>&lt;]);
  $self->link ($url, %opt, url => $url);
  $self->html (q[></code>]);
} # url

sub start_tag ($$%) {
  my ($self, $tag_name, %opt) = @_;
  $self->html ('<' . $htescape->($tag_name)); # escape for safety
  if (exists $opt{id}) {
    my $id = $self->input->id_prefix . $opt{id};
    $self->html (' id="' . $htescape->($id) . '"');
    delete $opt{id};
  }
  for (keys %opt) {    # for safety
    $self->html (' ' . $htescape->($_) . '="' . $htescape->($opt{$_}) . '"');
  }
  $self->html ('>');
} # start_tag

sub end_tag ($$) {
  shift->html ('</' . $htescape->(shift) . '>');
} # end_tag

sub start_section ($%) {
  my ($self, %opt) = @_;
  $self->html ('<div class=section');
  if (defined $opt{id}) {
    my $id = $self->input->id_prefix . $opt{id};
    $self->html (' id="' . $htescape->($id) . '"');
    push @{$self->{nav}}, [$id => $opt{short_title} || $opt{title}] 
        unless $self->input->nested;
  }
  $self->html ('><h2>' . $htescape->($opt{title}) . '</h2>');
} # start_section

sub end_section ($) {
  my $self = shift;
  $self->html ('</div>');
  $self->{handle}->flush;
} # end_section

sub start_code_block ($) {
  shift->html ('<pre><code>');
} # start_code_block

sub end_code_block ($) {
  shift->html ('</code></pre>');
} # end_code_block

sub code ($$) {
  shift->html ('<code>' . $htescape->(shift) . '</code>');
} # code

sub link ($$%) {
  my ($self, $content, %opt) = @_;
  $self->start_tag ('a', %opt, href => $opt{url});
  $self->text ($content);
  $self->html ('</a>');
} # link

sub xref ($$%) {
  my ($self, $content, %opt) = @_;
  $self->html ('<a href="#' . $htescape->($self->input->id_prefix . $opt{target}) . '">');
  $self->text ($content);
  $self->html ('</a>');
} # xref

sub link_to_webhacc ($$%) {
  my ($self, $content, %opt) = @_;
  $opt{url} = './?uri=' . $self->encode_url_component ($opt{url});
  $self->link ($content, %opt);
} # link_to_webhacc

sub nav_list ($) {
  my $self = shift;
  $self->html (q[<ul class="navigation" id="nav-items">]);
  for (@{$self->{nav}}) {
    $self->html (qq[<li><a href="@{[$htescape->($_->[0])]}">@{[$htescape->($_->[1])]}</a>]);
  }
  $self->html ('</ul>');
} # nav_list


sub encode_url_component ($$) {
  shift;
  require Encode;
  my $s = Encode::encode ('utf8', shift);
  $s =~ s/([^0-9A-Za-z_.~-])/sprintf '%%%02X', ord $1/ge;
  return $s;
} # encode_url_component

1;
1	wakaba	1.1	package WebHACC::Output;
2			use strict;
3			require IO::Handle;
4
5			my $htescape = sub ($) {
6			my $s = $_[0];
7			$s =~ s/&/&/g;
8			$s =~ s/</</g;
9			$s =~ s/>/>/g;
10			$s =~ s/"/"/g;
11			$s =~ s{([\x00-\x09\x0B-\x1F\x7F-\xA0\x{FEFF}\x{FFFC}-\x{FFFF}])}{
12			sprintf '<var>U+%04X</var>', ord $1;
13			}ge;
14			return $s;
15			};
16
17			sub new ($) {
18			return bless {nav => []}, shift;
19			} # new
20
21			sub input ($;$) {
22			if (@_ > 1) {
23			if (defined $_[1]) {
24			$_[0]->{input} = $_[1];
25			} else {
26			delete $_[0]->{input};
27			}
28			}
29
30			return $_[0]->{input};
31			} # input
32
33			sub handle ($;$) {
34			if (@_ > 1) {
35			if (defined $_[1]) {
36			$_[0]->{handle} = $_[1];
37			} else {
38			delete $_[0]->{handle};
39			}
40			}
41
42			return $_[0]->{handle};
43			} # handle
44
45			sub set_utf8 ($) {
46			binmode shift->{handle}, ':utf8';
47			} # set_utf8
48
49			sub set_flush ($) {
50			shift->{handle}->autoflush (1);
51			} # set_flush
52
53			sub unset_flush ($) {
54			shift->{handle}->autoflush (0);
55			} # unset_flush
56
57			sub html ($$) {
58			shift->{handle}->print (shift);
59			} # html
60
61			sub text ($$) {
62			shift->html ($htescape->(shift));
63			} # text
64
65			sub url ($$%) {
66			my ($self, $url, %opt) = @_;
67			$self->html (q[<code class=uri><]);
68			$self->link ($url, %opt, url => $url);
69			$self->html (q[></code>]);
70			} # url
71
72			sub start_tag ($$%) {
73			my ($self, $tag_name, %opt) = @_;
74			$self->html ('<' . $htescape->($tag_name)); # escape for safety
75			if (exists $opt{id}) {
76			my $id = $self->input->id_prefix . $opt{id};
77			$self->html (' id="' . $htescape->($id) . '"');
78			delete $opt{id};
79			}
80			for (keys %opt) { # for safety
81			$self->html (' ' . $htescape->($_) . '="' . $htescape->($opt{$_}) . '"');
82			}
83			$self->html ('>');
84			} # start_tag
85
86			sub end_tag ($$) {
87			shift->html ('</' . $htescape->(shift) . '>');
88			} # end_tag
89
90			sub start_section ($%) {
91			my ($self, %opt) = @_;
92			$self->html ('<div class=section');
93			if (defined $opt{id}) {
94			my $id = $self->input->id_prefix . $opt{id};
95			$self->html (' id="' . $htescape->($id) . '"');
96			push @{$self->{nav}}, [$id => $opt{short_title} \|\| $opt{title}]
97			unless $self->input->nested;
98			}
99			$self->html ('><h2>' . $htescape->($opt{title}) . '</h2>');
100			} # start_section
101
102			sub end_section ($) {
103			my $self = shift;
104			$self->html ('</div>');
105			$self->{handle}->flush;
106			} # end_section
107
108			sub start_code_block ($) {
109			shift->html ('<pre><code>');
110			} # start_code_block
111
112			sub end_code_block ($) {
113			shift->html ('</code></pre>');
114			} # end_code_block
115
116			sub code ($$) {
117			shift->html ('<code>' . $htescape->(shift) . '</code>');
118			} # code
119
120			sub link ($$%) {
121			my ($self, $content, %opt) = @_;
122	wakaba	1.2	$self->start_tag ('a', %opt, href => $opt{url});
123	wakaba	1.1	$self->text ($content);
124			$self->html ('</a>');
125			} # link
126
127			sub xref ($$%) {
128			my ($self, $content, %opt) = @_;
129			$self->html ('<a href="#' . $htescape->($self->input->id_prefix . $opt{target}) . '">');
130			$self->text ($content);
131			$self->html ('</a>');
132			} # xref
133
134	wakaba	1.2	sub link_to_webhacc ($$%) {
135			my ($self, $content, %opt) = @_;
136			$opt{url} = './?uri=' . $self->encode_url_component ($opt{url});
137			$self->link ($content, %opt);
138			} # link_to_webhacc
139
140	wakaba	1.1	sub nav_list ($) {
141			my $self = shift;
142			$self->html (q[<ul class="navigation" id="nav-items">]);
143			for (@{$self->{nav}}) {
144			$self->html (qq[<li><a href="@{[$htescape->($_->[0])]}">@{[$htescape->($_->[1])]}</a>]);
145			}
146			$self->html ('</ul>');
147			} # nav_list
148	wakaba	1.2
149
150			sub encode_url_component ($$) {
151			shift;
152			require Encode;
153			my $s = Encode::encode ('utf8', shift);
154			$s =~ s/([^0-9A-Za-z_.~-])/sprintf '%%%02X', ord $1/ge;
155			return $s;
156			} # encode_url_component
157	wakaba	1.1
158			1;