html-webhacc/WebHACC/Output.pm

package WebHACC::Output;
use strict;

require IO::Handle;
use Scalar::Util qw/refaddr/;

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 ($$;%) {
  my ($self, $content, %opt) = @_;
  $self->start_tag ('code', %opt);
  $self->text ($content);
  $self->html ('</code>');
} # code

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

sub dt ($$;%) {
  my ($self, $content, %opt) = @_;
  $self->start_tag ('dt', %opt);
  $self->text ($content);
} # dt

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


my $get_node_path = sub ($) {
  my $node = shift;
  my @r;
  while (defined $node) {
    my $rs;
    if ($node->node_type == 1) {
      $rs = $node->node_name;
      $node = $node->parent_node;
    } elsif ($node->node_type == 2) {
      $rs = '@' . $node->node_name;
      $node = $node->owner_element;
    } elsif ($node->node_type == 3) {
      $rs = '"' . $node->data . '"';
      $node = $node->parent_node;
    } elsif ($node->node_type == 9) {
      @r = ('') unless @r;
      $rs = '';
      $node = $node->parent_node;
    } else {
      $rs = '#' . $node->node_type;
      $node = $node->parent_node;
    }
    unshift @r, $rs;
  }
  return join '/', @r;
}; # $get_node_path

sub node_link ($$) {
  my ($self, $node) = @_;
  $self->xref ($get_node_path->($node), target => 'node-' . refaddr $node);
} # node_link

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