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_value {
   sql_insertid sql_exec $_[0]{dbh}, "insert into value values (NULL, ?)", $_[1];
}

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

   my $did = 55;
   my $n = 1;

   my @l;
   my @attr;

   new XML::Parser
      Namespaces => 1,
      NoExpand   => 1,
      Handlers   => {
         Char => sub {
            sql_exec $dbh, "insert into node values (?, ?, ?, 'pcdata', ?)",
                           $did, $n+1, $n+2, $self->new_value($_[1]);
            $n += 2;
         },
         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', ?)",
                           $did, $l, ++$n, $self->name_id($parser->namespace($element), $element);

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

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

   $ol ||= 1;

   my $or = sql_fetch $self->{dbh}, "select r from node where did = ? and l = ?", $did, $ol;
   my $st = sql_exec $self->{dbh}, \my($l, $r, $t, $c),
                     "select l, r, t, c from node where did = ?  and l > ? and r < ? order by l",
                     $did, $ol, $or;

   my $ot;
   my @stack;
   my $doc = "";
   my %ns;
   my $nso;
   my $nsp = "a";

   my $expand_name = sub {
      $ns{$_[0]} ||= $nsp++;
   };

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

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

      if ($t eq "element") {
         my ($ns, $name) = $expand_name->(sql_ufetch $self->{dbh}, "select ns, v from name where i = ?", $c);
         push @stack, [$ol, $or, $ns];
         ($ol, $or) = ($l, $r);

         $doc .= "<$ns";

         my $st = sql_exec $self->{dbh}, "select name.n, , v from
      } elsif ($t eq "pcdata") {
         $c = sql_ufetch $self->{dbh}, "select v from value where i = ?", $c;

         $doc .= "$c";

      } elsif ($t eq "entity") {
      } elsif ($t eq "pi") {
      } elsif ($t eq "doctype") {
      } else {
         die "FATAL: database corrupt, unexpected nodetype '$t'";
      }
   }

   $doc;
}

1;


Revision:	1.3
Committed:	Sun Apr 21 20:07:57 2002 UTC (22 years, 1 month ago) by root
Branch:	MAIN
Changes since 1.2:	+94 -9 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			sub new_value {
54			sql_insertid sql_exec $_[0]{dbh}, "insert into value values (NULL, ?)", $_[1];
55			}
56
57	root	1.2	sub new_xml_insert_parser {
58	root	1.3	my $self = shift;
59			my $dbh = $self->{dbh};
60
61	root	1.2	my $did = 55;
62			my $n = 1;
63	root	1.1
64	root	1.3	my @l;
65			my @attr;
66	root	1.1
67	root	1.2	new XML::Parser
68	root	1.3	Namespaces => 1,
69	root	1.2	NoExpand => 1,
70			Handlers => {
71			Char => sub {
72	root	1.3	sql_exec $dbh, "insert into node values (?, ?, ?, 'pcdata', ?)",
73			$did, $n+1, $n+2, $self->new_value($_[1]);
74			$n += 2;
75	root	1.2	},
76			Start => sub {
77	root	1.3	my ($parser, $element, @attrs) = @_;
78			push @l, ++$n;
79			push @attr, \@attrs;
80	root	1.2	},
81			End => sub {
82	root	1.3	my ($parser, $element) = @_;
83			my $attr = pop @attr;
84			my $l = pop @l;
85			sql_exec $dbh, "insert into node values (?, ?, ?, 'element', ?)",
86			$did, $l, ++$n, $self->name_id($parser->namespace($element), $element);
87
88			for (my $i = 0; $i < @$attr; $i += 2) {
89			sql_exec $dbh, "insert into attr values (?, ?, ?, ?)",
90			$did, $l, $self->name_id($parser->namespace($attr->[$i]), $attr->[$i]),
91			$self->new_value($attr->[$i+1]);
92			}
93			},
94			Final => sub {
95			sql_exec $dbh, "insert into node values (?, ?, ?, 'root', 0)",
96			$did, 1, ++$n;
97	root	1.2	},
98			},
99			@_,
100			;
101	root	1.3	}
102
103			sub get_fragment {
104			my ($self, $did, $ol) = @_;
105
106			$ol \|\|= 1;
107
108			my $or = sql_fetch $self->{dbh}, "select r from node where did = ? and l = ?", $did, $ol;
109			my $st = sql_exec $self->{dbh}, \my($l, $r, $t, $c),
110			"select l, r, t, c from node where did = ? and l > ? and r < ? order by l",
111			$did, $ol, $or;
112
113			my $ot;
114			my @stack;
115			my $doc = "";
116			my %ns;
117			my $nso;
118			my $nsp = "a";
119
120			my $expand_name = sub {
121			$ns{$_[0]} \|\|= $nsp++;
122			};
123
124			while ($st->fetch) {
125			if ($l > $or) {
126			($ol, $or, $oc) = @{pop @stack};
127
128			$doc .= "</$oc>";
129			}
130
131			if ($t eq "element") {
132			my ($ns, $name) = $expand_name->(sql_ufetch $self->{dbh}, "select ns, v from name where i = ?", $c);
133			push @stack, [$ol, $or, $ns];
134			($ol, $or) = ($l, $r);
135
136			$doc .= "<$ns";
137
138			my $st = sql_exec $self->{dbh}, "select name.n, , v from
139			} elsif ($t eq "pcdata") {
140			$c = sql_ufetch $self->{dbh}, "select v from value where i = ?", $c;
141
142			$doc .= "$c";
143
144			} elsif ($t eq "entity") {
145			} elsif ($t eq "pi") {
146			} elsif ($t eq "doctype") {
147			} else {
148			die "FATAL: database corrupt, unexpected nodetype '$t'";
149			}
150			}
151
152			$doc;
153	root	1.2	}
154	root	1.1
155			1;
156
157
158
159
160