XML-DB/DB.pm

=head1 NAME

XML::DB - emulate a native xml database using DBI

=head1 SYNOPSIS

=head1 DESCRIPTION

Ehrm... ;)

=head1 FUNCTIONS

=head1 SEE ALSO

=head1 AUTHOR

This perl extension was written by Marc Lehmann <pcg@goof.com>

=head1 BUGS

=cut

package XML::DB;

use XML::Parser;
use PApp::SQL;

#require Exporter;
BEGIN {
   $VERSION = 0.01;

   use base DynaLoader;

   bootstrap XML::DB $VERSION;
}

sub new {
   my $class = shift;
   bless { @_ }, $class;
}

sub seq {
   sql_insertid sql_exec "update $_[0]_seq set n = last_insert_id(n + 1)";
}

sub name_id {
   # not threadsafe
   sql_ufetch $_[0]{dbh}, "select i from name where n = ? and v = ?", "$_[1]", $_[2]
      or sql_insertid sql_exec $_[0]{dbh}, "insert into name values (NULL, ?, ?)", "$_[1]", $_[2];

}

sub new_xml_insert_parser {
   my $self = shift;
   my $dbh = $self->{dbh};

   my $did = 55;
   my $max = 1 + sql_fetch $dbh, "select max(l) from node";

   my $n = $max + 1;

   my @l;
   my @attr;

   new XML::Parser
      Namespaces => 1,
      NoExpand   => 1,
      Handlers   => {
         Comment => sub {
            ++$n;
            sql_exec $dbh, "insert into node values (?, ?, 'comment', NULL)",
                           $n, $n+1;
            sql_exec $dbh, "insert into value values (?, ?)",
                           $n, $_[1];
            ++$n;
         },
         Char => sub {
            ++$n;
            sql_exec $dbh, "insert into node values (?, ?, 'pcdata', NULL)",
                           $n, $n+1;
            sql_exec $dbh, "insert into value values (?, ?)",
                           $n, $_[1];
            ++$n;
         },
         Start => sub {
            my ($parser, $element, @attrs) = @_;
            push @l, ++$n;
            push @attr, \@attrs;
         },
         End => sub {
            my ($parser, $element) = @_;
            my $attr = pop @attr;
            my $l = pop @l;
            sql_exec $dbh, "insert into node values (?, ?, 'element', ?)",
                           $l, ++$n, $self->name_id($parser->namespace($element), $element);

            for (my $i = 0; $i < @$attr;  $i += 2) {
               sql_exec $dbh, "insert into attr values (?, ?, ?)",
                              $l, $self->name_id($parser->namespace($attr->[$i]), $attr->[$i]),
                              $attr->[$i+1];
            }
         },
         Final => sub {
            sql_exec $dbh, "insert into node values (?, ?, 'root', NULL)",
                           $max*1, ++$n;
         },
      },
      @_,
   ;
}

sub get_fragment {
   my ($self, $ol) = @_;

   my $or = sql_fetch $self->{dbh}, "select r from node where l = ?", $ol;
   my $st = sql_exec $self->{dbh}, \my($l, $r, $t, $ns, $name, $value),
                     "select node.l, node.r, node.t, name.n, name.v, value.v
                      from node left join name on (node.n = name.i)
                                left join value on (node.l = value.l)
                      where node.l > ? and node.r < ? order by node.l",
                     $ol, $or;

   my $ot;
   my @stack;
   my $doc = "";
   my (%nsp, $nsps, $nso);
   my $nsp = "a";

   my $expand_name = sub {
      $_[0] ? ($nsp{$_[0]} ||= do {
                      $nsps .= " xmlns:$nsp='$_[0]'";
                      $nsp++;
                   }) . ":$_[1]"
            : $_[1];
   };

   while ($st->fetch) {
      if ($l > $or) {
         ($ol, $or, $oc) = @{pop @stack};

         $doc .= "</$oc>";
      }

      if ($t eq "element") {
         push @stack, [$ol, $or, $name];
         ($ol, $or) = ($l, $r);

         $doc .= "<" . $expand_name->($ns, $name);
         $nso ||= length $doc;

         my $st = sql_exec $self->{dbh}, \my($ns, $name, $value),
                           "select name.n, name.v, attr.v
                            from attr inner join name on (attr.k = name.i)
                            where attr.l = ?",
                           $l;
         while ($st->fetch) {
            $doc .= " " . $expand_name->($ns, $name) . "='" . $value ."'";
         }
         
         $doc .= ">";
      } elsif ($t eq "pcdata" or $t eq "comment") {
         $doc .= $value;
      } elsif ($t eq "entity") {
      } elsif ($t eq "pi") {
      } elsif ($t eq "doctype") {
      } else {
         die "FATAL: database corrupt, unexpected nodetype '$t'";
      }
   }

   substr $doc, $nso, 0, $nsps;
   $doc;
}

1;


Revision:	1.4
Committed:	Mon Apr 22 17:19:17 2002 UTC (22 years ago) by root
Branch:	MAIN
Changes since 1.3:	+54 -34 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	=head1 NAME
2
3			XML::DB - emulate a native xml database using DBI
4
5			=head1 SYNOPSIS
6
7			=head1 DESCRIPTION
8
9			Ehrm... ;)
10
11			=head1 FUNCTIONS
12
13			=head1 SEE ALSO
14
15			=head1 AUTHOR
16
17			This perl extension was written by Marc Lehmann <pcg@goof.com>
18
19			=head1 BUGS
20
21			=cut
22
23			package XML::DB;
24
25	root	1.2	use XML::Parser;
26			use PApp::SQL;
27
28	root	1.1	#require Exporter;
29	root	1.2	BEGIN {
30			$VERSION = 0.01;
31
32			use base DynaLoader;
33
34			bootstrap XML::DB $VERSION;
35			}
36
37			sub new {
38			my $class = shift;
39			bless { @_ }, $class;
40			}
41
42	root	1.3	sub seq {
43			sql_insertid sql_exec "update $_[0]_seq set n = last_insert_id(n + 1)";
44			}
45
46			sub name_id {
47			# not threadsafe
48			sql_ufetch $_[0]{dbh}, "select i from name where n = ? and v = ?", "$_[1]", $_[2]
49			or sql_insertid sql_exec $_[0]{dbh}, "insert into name values (NULL, ?, ?)", "$_[1]", $_[2];
50
51			}
52
53	root	1.2	sub new_xml_insert_parser {
54	root	1.3	my $self = shift;
55			my $dbh = $self->{dbh};
56
57	root	1.2	my $did = 55;
58	root	1.4	my $max = 1 + sql_fetch $dbh, "select max(l) from node";
59
60			my $n = $max + 1;
61	root	1.1
62	root	1.3	my @l;
63			my @attr;
64	root	1.1
65	root	1.2	new XML::Parser
66	root	1.3	Namespaces => 1,
67	root	1.2	NoExpand => 1,
68			Handlers => {
69	root	1.4	Comment => sub {
70			++$n;
71			sql_exec $dbh, "insert into node values (?, ?, 'comment', NULL)",
72			$n, $n+1;
73			sql_exec $dbh, "insert into value values (?, ?)",
74			$n, $_[1];
75			++$n;
76			},
77	root	1.2	Char => sub {
78	root	1.4	++$n;
79			sql_exec $dbh, "insert into node values (?, ?, 'pcdata', NULL)",
80			$n, $n+1;
81			sql_exec $dbh, "insert into value values (?, ?)",
82			$n, $_[1];
83			++$n;
84	root	1.2	},
85			Start => sub {
86	root	1.3	my ($parser, $element, @attrs) = @_;
87			push @l, ++$n;
88			push @attr, \@attrs;
89	root	1.2	},
90			End => sub {
91	root	1.3	my ($parser, $element) = @_;
92			my $attr = pop @attr;
93			my $l = pop @l;
94	root	1.4	sql_exec $dbh, "insert into node values (?, ?, 'element', ?)",
95			$l, ++$n, $self->name_id($parser->namespace($element), $element);
96	root	1.3
97			for (my $i = 0; $i < @$attr; $i += 2) {
98	root	1.4	sql_exec $dbh, "insert into attr values (?, ?, ?)",
99			$l, $self->name_id($parser->namespace($attr->[$i]), $attr->[$i]),
100			$attr->[$i+1];
101	root	1.3	}
102			},
103			Final => sub {
104	root	1.4	sql_exec $dbh, "insert into node values (?, ?, 'root', NULL)",
105			$max*1, ++$n;
106	root	1.2	},
107			},
108			@_,
109			;
110	root	1.3	}
111
112			sub get_fragment {
113	root	1.4	my ($self, $ol) = @_;
114	root	1.3
115	root	1.4	my $or = sql_fetch $self->{dbh}, "select r from node where l = ?", $ol;
116			my $st = sql_exec $self->{dbh}, \my($l, $r, $t, $ns, $name, $value),
117			"select node.l, node.r, node.t, name.n, name.v, value.v
118			from node left join name on (node.n = name.i)
119			left join value on (node.l = value.l)
120			where node.l > ? and node.r < ? order by node.l",
121			$ol, $or;
122	root	1.3
123			my $ot;
124			my @stack;
125			my $doc = "";
126	root	1.4	my (%nsp, $nsps, $nso);
127	root	1.3	my $nsp = "a";
128
129			my $expand_name = sub {
130	root	1.4	$_[0] ? ($nsp{$_[0]} \|\|= do {
131			$nsps .= " xmlns:$nsp='$_[0]'";
132			$nsp++;
133			}) . ":$_[1]"
134			: $_[1];
135	root	1.3	};
136
137			while ($st->fetch) {
138			if ($l > $or) {
139			($ol, $or, $oc) = @{pop @stack};
140
141			$doc .= "</$oc>";
142			}
143
144			if ($t eq "element") {
145	root	1.4	push @stack, [$ol, $or, $name];
146	root	1.3	($ol, $or) = ($l, $r);
147
148	root	1.4	$doc .= "<" . $expand_name->($ns, $name);
149			$nso \|\|= length $doc;
150	root	1.3
151	root	1.4	my $st = sql_exec $self->{dbh}, \my($ns, $name, $value),
152			"select name.n, name.v, attr.v
153			from attr inner join name on (attr.k = name.i)
154			where attr.l = ?",
155			$l;
156			while ($st->fetch) {
157			$doc .= " " . $expand_name->($ns, $name) . "='" . $value ."'";
158			}
159
160			$doc .= ">";
161			} elsif ($t eq "pcdata" or $t eq "comment") {
162			$doc .= $value;
163	root	1.3	} elsif ($t eq "entity") {
164			} elsif ($t eq "pi") {
165			} elsif ($t eq "doctype") {
166			} else {
167			die "FATAL: database corrupt, unexpected nodetype '$t'";
168			}
169			}
170
171	root	1.4	substr $doc, $nso, 0, $nsps;
172	root	1.3	$doc;
173	root	1.2	}
174	root	1.1
175			1;
176
177
178
179
180