SWE/DB/DOM.pm

package SWE::DB::DOM;
use strict;

require Message::DOM::DOMImplementation;

sub new ($) {
  my $self = bless {
    root_directory_name => './',
    root_key => ['HomePage'],
    leaf_suffix => '.txt',
  }, shift;
  return $self;
} # new

my $get_file_name = sub {
  my ($self, $key) = @_;
  $key = $self->{root_key} if @$key == 0;
  
  my $file_name = $self->{root_directory_name} .
      join '-', map { s/(.)/sprintf '%02X', ord $1/ges; $_ } @$key;
  $file_name .= $self->{leaf_suffix};
  
  return $file_name;
}; # $get_file_name

sub get_data ($$) {
  my $self = $_[0];
  my $key = [@{$_[1]}];

  my $file_name = $get_file_name->($self, $key);

  unless (-f $file_name) {
    return undef;
  }

  open my $file, '<:encoding(utf8)', $file_name or die "$0: $file_name: $!";
  return _load_dom ($file);
} # get_data

sub set_data ($$$) {
  my $self = $_[0];
  my $key = [@{$_[1]}];
  my $dom = $_[2];

  my $file_name = $get_file_name->($self, $key);
  
  open my $file, '>:encoding(utf8)', $file_name or die "$0: $file_name: $!";
  _store_dom ($file, $dom);
} # set_data

sub _load_dom ($) {
  my $handle = shift;

  my $dom = Message::DOM::DOMImplementation->new;
  my @node = ($dom->create_document);

  $node[0]->strict_error_checking (0);
  $node[0]->dom_config->set_parameter
    ('http://suika.fam.cx/www/2006/dom-config/strict-document-children' => 0);

  my $unescape = sub {
    my $s = shift;
    $s =~ s/\\([0-9A-Fa-f]{2})/pack 'C', hex $1/ge;
    return $s;
  }; # $unescape

  while (<$handle>) {
    tr/\x0D\x0A//d;
    if (s/^n(\d+);//) {
      $node[$1] = $unescape->($_);
    } elsif (s/^t(\d+);//) {
      my $parent_id = $1;
      $node[$parent_id]->append_child
          ($node[0]->create_text_node ($unescape->($_)));
    } elsif (s/^e(\d+);(\d+);(\d+);//) {
      my ($this_id, $parent_id, $ns_id) = ($1, $2, $3);
      $node[$this_id] = $node[0]->create_element_ns
          ($node[$ns_id], [undef, $unescape->($_)]);
      $node[$parent_id]->append_child ($node[$this_id]);
    } elsif (s/^a(\d+);(\d+);([^;]+);//) {
      my ($parent_id, $ns_id, $ln) = ($1, $2, $3);
      $node[$parent_id]->set_attribute_ns
          ($node[$ns_id], [undef, $unescape->($ln)], $unescape->($_));
    }
  }

  return $node[0];
} # _load_dom

sub _store_dom ($$) {
  my $handle = shift;
  my @item = ([0, shift]);

  my $escape = sub {
    my $v = $_[0];
    $v =~ s/([;\\\x0D\x0A])/sprintf '\\%02X', ord $1/ge;
    return $v;
  }; # $escape

  my $ns;
  my $next_id = 1;
  while (@item) {
    my ($parent_id, $node) = @{shift @item};
    if ($node->node_type == $node->ELEMENT_NODE) {
      my $nsuri = $node->namespace_uri // '';
      my $nsid = $ns->{$nsuri};
      unless (defined $nsid) {
        $nsid = $next_id++;
        $ns->{$nsuri} = $nsid;
        print $handle "n", $nsid, ';', $escape->($nsuri), "\n";
      }
      my $el_id = $next_id++;
      print $handle "e", $el_id, ';', $parent_id, ';', $nsid, ';',
          $escape->($node->manakai_local_name), "\n";
      for my $attr (@{$node->attributes}) {
        my $nsuri = $attr->namespace_uri // '';
        my $nsid = $ns->{$nsuri};
        unless (defined $nsid) {
          $nsid = $next_id++;
          $ns->{$nsuri} = $nsid;
          print $handle "n", $nsid, ';', $escape->($nsuri), "\n";
        }
        print $handle "a", $el_id, ';', $nsid, ';', 
            $escape->($attr->manakai_local_name), ';',
            $escape->($attr->value), "\n";
      }
      unshift @item, map {[$el_id, $_]} @{$node->child_nodes}; 
    } elsif ($node->node_type == $node->TEXT_NODE or
             $node->node_type == $node->CDATA_SECTION_NODE) {
      print $handle "t", $parent_id, ';', $escape->($node->data), "\n";
    } elsif ($node->node_type == $node->DOCUMENT_NODE or
             $node->node_type == $node->DOCUMENT_FRAGMENT_NODE) {
      unshift @item, map {[0, $_]} @{$node->child_nodes}; 
    }
  }
} # _store_dom

1;
1	package SWE::DB::DOM;
2	use strict;
3
4	require Message::DOM::DOMImplementation;
5
6	sub new ($) {
7	my $self = bless {
8	root_directory_name => './',
9	root_key => ['HomePage'],
10	leaf_suffix => '.txt',
11	}, shift;
12	return $self;
13	} # new
14
15	my $get_file_name = sub {
16	my ($self, $key) = @_;
17	$key = $self->{root_key} if @$key == 0;
18
19	my $file_name = $self->{root_directory_name} .
20	join '-', map { s/(.)/sprintf '%02X', ord $1/ges; $_ } @$key;
21	$file_name .= $self->{leaf_suffix};
22
23	return $file_name;
24	}; # $get_file_name
25
26	sub get_data ($$) {
27	my $self = $_[0];
28	my $key = [@{$_[1]}];
29
30	my $file_name = $get_file_name->($self, $key);
31
32	unless (-f $file_name) {
33	return undef;
34	}
35
36	open my $file, '<:encoding(utf8)', $file_name or die "$0: $file_name: $!";
37	return _load_dom ($file);
38	} # get_data
39
40	sub set_data ($$$) {
41	my $self = $_[0];
42	my $key = [@{$_[1]}];
43	my $dom = $_[2];
44
45	my $file_name = $get_file_name->($self, $key);
46
47	open my $file, '>:encoding(utf8)', $file_name or die "$0: $file_name: $!";
48	_store_dom ($file, $dom);
49	} # set_data
50
51	sub _load_dom ($) {
52	my $handle = shift;
53
54	my $dom = Message::DOM::DOMImplementation->new;
55	my @node = ($dom->create_document);
56
57	$node[0]->strict_error_checking (0);
58	$node[0]->dom_config->set_parameter
59	('http://suika.fam.cx/www/2006/dom-config/strict-document-children' => 0);
60
61	my $unescape = sub {
62	my $s = shift;
63	$s =~ s/\\([0-9A-Fa-f]{2})/pack 'C', hex $1/ge;
64	return $s;
65	}; # $unescape
66
67	while (<$handle>) {
68	tr/\x0D\x0A//d;
69	if (s/^n(\d+);//) {
70	$node[$1] = $unescape->($_);
71	} elsif (s/^t(\d+);//) {
72	my $parent_id = $1;
73	$node[$parent_id]->append_child
74	($node[0]->create_text_node ($unescape->($_)));
75	} elsif (s/^e(\d+);(\d+);(\d+);//) {
76	my ($this_id, $parent_id, $ns_id) = ($1, $2, $3);
77	$node[$this_id] = $node[0]->create_element_ns
78	($node[$ns_id], [undef, $unescape->($_)]);
79	$node[$parent_id]->append_child ($node[$this_id]);
80	} elsif (s/^a(\d+);(\d+);([^;]+);//) {
81	my ($parent_id, $ns_id, $ln) = ($1, $2, $3);
82	$node[$parent_id]->set_attribute_ns
83	($node[$ns_id], [undef, $unescape->($ln)], $unescape->($_));
84	}
85	}
86
87	return $node[0];
88	} # _load_dom
89
90	sub _store_dom ($$) {
91	my $handle = shift;
92	my @item = ([0, shift]);
93
94	my $escape = sub {
95	my $v = $_[0];
96	$v =~ s/([;\\\x0D\x0A])/sprintf '\\%02X', ord $1/ge;
97	return $v;
98	}; # $escape
99
100	my $ns;
101	my $next_id = 1;
102	while (@item) {
103	my ($parent_id, $node) = @{shift @item};
104	if ($node->node_type == $node->ELEMENT_NODE) {
105	my $nsuri = $node->namespace_uri // '';
106	my $nsid = $ns->{$nsuri};
107	unless (defined $nsid) {
108	$nsid = $next_id++;
109	$ns->{$nsuri} = $nsid;
110	print $handle "n", $nsid, ';', $escape->($nsuri), "\n";
111	}
112	my $el_id = $next_id++;
113	print $handle "e", $el_id, ';', $parent_id, ';', $nsid, ';',
114	$escape->($node->manakai_local_name), "\n";
115	for my $attr (@{$node->attributes}) {
116	my $nsuri = $attr->namespace_uri // '';
117	my $nsid = $ns->{$nsuri};
118	unless (defined $nsid) {
119	$nsid = $next_id++;
120	$ns->{$nsuri} = $nsid;
121	print $handle "n", $nsid, ';', $escape->($nsuri), "\n";
122	}
123	print $handle "a", $el_id, ';', $nsid, ';',
124	$escape->($attr->manakai_local_name), ';',
125	$escape->($attr->value), "\n";
126	}
127	unshift @item, map {[$el_id, $_]} @{$node->child_nodes};
128	} elsif ($node->node_type == $node->TEXT_NODE or
129	$node->node_type == $node->CDATA_SECTION_NODE) {
130	print $handle "t", $parent_id, ';', $escape->($node->data), "\n";
131	} elsif ($node->node_type == $node->DOCUMENT_NODE or
132	$node->node_type == $node->DOCUMENT_FRAGMENT_NODE) {
133	unshift @item, map {[0, $_]} @{$node->child_nodes};
134	}
135	}
136	} # _store_dom
137
138	1;