test/html-webhacc/mkcatalog.pl

#!/usr/bin/perl
use strict;
use encoding 'us-ascii', STDOUT => 'utf-8';

use lib qw[/home/httpd/html/www/markup/html/whatpm
           /home/wakaba/work/manakai2/lib];

my $HTML_NS = q<http://www.w3.org/1999/xhtml>;
my $SRC_NS = q<http://suika.fam.cx/~wakaba/archive/2007/wdcc-desc/>;
my $XML_NS = q<http://www.w3.org/XML/1998/namespace>;

require Message::DOM::DOMImplementation;
my $dom = Message::DOM::DOMImplementation->new;

my $doc;
{
  my $source_file_name = shift or die "$0: No source file specified\n";
  open my $source_file, '<', $source_file_name
      or die "$0: $source_file_name: $!";
  require Message::DOM::XMLParserTemp;
  $doc = Message::DOM::XMLParserTemp->parse_byte_stream
      ($source_file => $dom, undef, charset => 'utf-8');
  $doc->manakai_is_html (1);
}

my $target_lang = shift || 'en';
my @node = (@{$doc->child_nodes});
while (@node) {
  my $node = shift @node;
  if ($node->node_type == $node->ELEMENT_NODE) {
    if ($node->namespace_uri eq $HTML_NS) {
      unshift @node, @{$node->child_nodes};
    } elsif ($node->namespace_uri eq $SRC_NS) {
      if ($node->manakai_local_name eq 'item') {
        my $message;
        for (@{$node->child_nodes}) {
          if ($_->node_type == $_->ELEMENT_NODE and
              $_->namespace_uri eq $SRC_NS) {
            if ($_->manakai_local_name eq 'message') {
              if ($_->get_attribute_ns ($XML_NS, 'lang') eq $target_lang) {
                $message = $_;
                next;
              } else {
                $message ||= $_;
              }
            }
          }
        }

        my $entry = [];
        push @$entry, $node->get_attribute_ns (undef, 'name');
        my $level = $node->get_attribute_ns (undef, 'level');
        $entry->[-1] = $level . ':' . $entry->[-1] if defined $level;
        push @$entry, $node->get_attribute_ns (undef, 'class');
        push @$entry, $message->inner_html;
        s/\s+/ /g for @$entry;
        print join ';', @$entry;
        print "\n";
      } elsif ($node->manakai_local_name eq 'cat') {
        my $name = $node->get_attribute_ns (undef, 'name');
        my $text;
        for my $el (@{$node->child_nodes}) {
          next unless $el->node_type == $el->ELEMENT_NODE;
          next unless $el->manakai_local_name eq 'text';
          my $ns = $el->namespace_uri;
          next unless defined $ns and $ns eq $SRC_NS;
          
          my $lang = $el->get_attribute_ns ($XML_NS, 'lang');
          $text = $el->inner_html;
          if ($lang eq $target_lang) {
            last;
          }          
        }
        if (defined $text) {
          my $entry = [$name, undef, $text];
          s/\s+/ /g for @$entry;
          print join ';', @$entry;
          print "\n";
        }
      } else {
        warn "$0: ", $node->manakai_local_name, " is not supported\n";
      }
    }
  }
}
1	wakaba	1.1	#!/usr/bin/perl
2			use strict;
3			use encoding 'us-ascii', STDOUT => 'utf-8';
4
5			use lib qw[/home/httpd/html/www/markup/html/whatpm
6	wakaba	1.2	/home/wakaba/work/manakai2/lib];
7	wakaba	1.1
8			my $HTML_NS = q<http://www.w3.org/1999/xhtml>;
9			my $SRC_NS = q<http://suika.fam.cx/~wakaba/archive/2007/wdcc-desc/>;
10			my $XML_NS = q<http://www.w3.org/XML/1998/namespace>;
11
12			require Message::DOM::DOMImplementation;
13			my $dom = Message::DOM::DOMImplementation->new;
14
15			my $doc;
16			{
17			my $source_file_name = shift or die "$0: No source file specified\n";
18			open my $source_file, '<', $source_file_name
19			or die "$0: $source_file_name: $!";
20			require Message::DOM::XMLParserTemp;
21			$doc = Message::DOM::XMLParserTemp->parse_byte_stream
22			($source_file => $dom, undef, charset => 'utf-8');
23			$doc->manakai_is_html (1);
24			}
25
26	wakaba	1.3	my $target_lang = shift \|\| 'en';
27	wakaba	1.1	my @node = (@{$doc->child_nodes});
28			while (@node) {
29			my $node = shift @node;
30			if ($node->node_type == $node->ELEMENT_NODE) {
31			if ($node->namespace_uri eq $HTML_NS) {
32			unshift @node, @{$node->child_nodes};
33			} elsif ($node->namespace_uri eq $SRC_NS) {
34			if ($node->manakai_local_name eq 'item') {
35			my $message;
36			for (@{$node->child_nodes}) {
37			if ($_->node_type == $_->ELEMENT_NODE and
38			$_->namespace_uri eq $SRC_NS) {
39			if ($_->manakai_local_name eq 'message') {
40			if ($_->get_attribute_ns ($XML_NS, 'lang') eq $target_lang) {
41			$message = $_;
42			next;
43			} else {
44			$message \|\|= $_;
45			}
46			}
47			}
48			}
49
50			my $entry = [];
51			push @$entry, $node->get_attribute_ns (undef, 'name');
52			my $level = $node->get_attribute_ns (undef, 'level');
53			$entry->[-1] = $level . ':' . $entry->[-1] if defined $level;
54			push @$entry, $node->get_attribute_ns (undef, 'class');
55			push @$entry, $message->inner_html;
56			s/\s+/ /g for @$entry;
57			print join ';', @$entry;
58			print "\n";
59	wakaba	1.3	} elsif ($node->manakai_local_name eq 'cat') {
60			my $name = $node->get_attribute_ns (undef, 'name');
61			my $text;
62			for my $el (@{$node->child_nodes}) {
63			next unless $el->node_type == $el->ELEMENT_NODE;
64			next unless $el->manakai_local_name eq 'text';
65			my $ns = $el->namespace_uri;
66			next unless defined $ns and $ns eq $SRC_NS;
67
68			my $lang = $el->get_attribute_ns ($XML_NS, 'lang');
69			$text = $el->inner_html;
70			if ($lang eq $target_lang) {
71			last;
72			}
73			}
74			if (defined $text) {
75			my $entry = [$name, undef, $text];
76			s/\s+/ /g for @$entry;
77			print join ';', @$entry;
78			print "\n";
79			}
80	wakaba	1.1	} else {
81			warn "$0: ", $node->manakai_local_name, " is not supported\n";
82			}
83			}
84			}
85			}