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	wakaba	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;