1use strict;
2#use warnings;
3
4package RDF::Notation3::Template::TXML;
5
6
7use RDF::Notation3;
8
9############################################################
10
11@RDF::Notation3::Template::TXML::ISA = qw(RDF::Notation3);
12
13
14sub _process_statement {
15    my ($self, $subject, $properties) = @_;
16
17    $subject = $self->_expand_prefix($subject);
18    $subject =~ s/^<(.*)>$/$1/;
19
20    my $prev;
21    my $j = 0;
22    foreach (@$properties) {
23
24	if ($_->[0] ne 'i') {
25
26	    if ($j == 0 or $prev eq 'i') {
27		my @attr = ();
28
29		# nodeID is used for blank nodes
30		if ($subject =~ /^$self->{ansuri}(.*)$/) {
31		    push @attr, ['rdf:nodeID' => "$self->{nIDpref}$1"];
32		} else {
33		    push @attr, ['rdf:about' => $subject];
34		}
35
36		$self->doStartElement('rdf:Description', \@attr);
37	    }
38
39	    my ($attr, $pred) = $self->_process_predicate($_->[0]);
40	    $pred =~ s/^:(.*)$/$1/;
41
42	    for (my $i = 1; $i < scalar @$_; $i++) {
43		$_->[$i] = $self->_expand_prefix($_->[$i]);
44
45		my @attr = @$attr;
46		my $val = '';
47
48		# URI
49		if ($_->[$i] =~ s/^<(.*)>$/$1/) {
50		    # nodeID is used for blank nodes
51		    if ($_->[$i] =~ /^$self->{ansuri}(.*)$/) {
52			push @attr, ['rdf:nodeID' => "$self->{nIDpref}$1"];
53		    } else {
54			push @attr, ['rdf:resource' => $_->[$i]];
55		    }
56
57		# string2
58		} elsif ($_->[$i] =~ s/^"""(.*)"""$/$1/s) {
59		  $val = $_->[$i];
60
61		# string1
62		} elsif ($_->[$i] =~ s/^"(.*)"$/$1/) {
63		    $val = $_->[$i];
64
65		} else {
66		    $self->_do_error(402, $_->[$i]);
67		}
68
69# 		# URI
70# 		$_->[$i] =~ s/^<(.*)>$/$1/ and
71# 		  push @attr, ['rdf:resource' => $_->[$i]];
72# 		# string2
73# 		$_->[$i] =~ s/^"""(.*)"""$/$1/s and
74# 		  $val = $_->[$i];
75# 		# string1
76# 		$_->[$i] =~ s/^"(.*)"$/$1/ and
77# 		  $val = $_->[$i];
78
79		# escaping literals
80		$val =~ s/</&lt;/g;
81		$val =~ s/>/&gt;/g;
82		$val =~ s/&/&amp;/g;
83
84		$self->doElement($pred, \@attr, $val);
85		$self->{count}++;
86	    }
87
88	    if ($j == scalar @$properties - 1 or
89		($properties->[$j+1]->[0] eq 'i')) {
90		$self->doEndElement('rdf:Description');
91	    }
92
93	} else {
94	    # inverse mode (is, <-)
95	    for (my $i=2; $i < scalar @$_; $i++) {
96		$_->[$i] = $self->_expand_prefix($_->[$i]);
97		$_->[$i] =~ s/^<(.*)>$/$1/;
98
99		my @attr = ();
100		push @attr, [about => $_->[$i]];
101		$self->doStartElement('rdf:Description', \@attr);
102
103		my ($attr, $pred) = $self->_process_predicate($_->[1]);
104		my @attr2 = @$attr;
105		$pred =~ s/^:(.*)$/$1/;
106		push @attr2, ['rdf:resource' => $subject];
107
108		$self->doElement($pred, \@attr2, '');
109		$self->{count}++;
110
111		$self->doEndElement('rdf:Description');
112	    }
113	}
114	$prev = $_->[0];
115	$j++;
116    }
117}
118
119
120sub _expand_prefix {
121    my ($self, $qname) = @_;
122
123    foreach (keys %{$self->{ns}->{$self->{context}}}) {
124	$qname =~ s/^$_:(.*)$/<$self->{ns}->{$self->{context}}->{$_}$1>/;
125    }
126
127    if ($qname =~ /^([_a-zA-Z]\w*)*:[a-zA-Z]\w*$/) {
128	$self->_do_error(106, $qname);
129    }
130
131    return $qname;
132}
133
134
135sub _process_predicate {
136    my ($self, $name) = @_;
137    my @attr = ();
138
139    my $p = '';
140    my $pushed = 0;
141    if ($name =~ /^([_a-zA-Z]\w*)*:[a-zA-Z]\w*$/) {
142 	$p = $1;
143
144    } else { # not a QName - must be turned to QName
145	my $qnamed = 0;
146
147	# checking if the NS already exists
148	foreach (keys %{$self->{ns}->{$self->{context}}}) {
149	    my $ns = _escape_ns($self->{ns}->{$self->{context}}->{$_});
150	    if ($name =~ s/^<$ns([a-zA-Z]\w*)>$/$_:$1/) {
151		$qnamed = 1;
152		$p = $_;
153		last;
154	    }
155	}
156	# checking out hard-coded NS
157	unless ($qnamed) {
158	    foreach (keys %{$self->{hardns}}) {
159		my $ns = _escape_ns($self->{hardns}->{$_}->[1]);
160		if ($name =~ s/^<$ns([a-zA-Z]\w*)>$/$self->{hardns}->{$_}->[0]:$1/) {
161		    $p = $self->{hardns}->{$_}->[0];
162		    $self->{ns}->{$self->{context}}->{$p} =
163		      $self->{hardns}->{$_}->[1];
164		    $qnamed = 1;
165		    $p = $self->{hardns}->{$_}->[0];
166		    last;
167		}
168	    }
169	}
170	# inventing new NS
171	unless ($qnamed) {
172	    my $i = 1;
173	    my $pref = 'pref';
174	    while ($self->{ns}->{$self->{context}}->{$pref}) {
175		$pref = "$pref$i";
176		$i++;
177	    }
178	    if ($name =~ s/^<(.*?)([a-zA-Z]\w*)>$/$pref:$2/) {
179		push @attr, ["xmlns:$pref" => $1];
180		$qnamed = 1;
181		$pushed = 1;
182	    }
183	}
184	$self->_do_error(401, $name) unless $qnamed;
185    }
186
187    unless ($pushed) {
188	if ($p) {
189	    push @attr, ["xmlns:$p" => $self->{ns}->{$self->{context}}->{$p}];
190	    $self->_do_error(106, $name)
191	      unless $self->{ns}->{$self->{context}}->{$p};
192	} else {
193	    push @attr, ["xmlns" => $self->{ns}->{$self->{context}}->{''}];
194	    $self->_do_error(106, $name)
195	      unless $self->{ns}->{$self->{context}}->{''};
196	}
197    }
198
199    return (\@attr, $name);
200}
201
202
203sub _escape_ns {
204    my $ns = shift;
205
206    $ns =~ s/\+/\\+/;
207    $ns =~ s/\*/\\*/;
208    $ns =~ s/\?/\\?/;
209
210    return $ns;
211}
212
213
2141;
215
216
217__END__
218# Below is a documentation.
219
220=head1 NAME
221
222RDF::Notation3::Template::TXML - an RDF/XML converter template
223
224=head1 LICENSING
225
226Copyright (c) 2001 Ginger Alliance. All rights reserved. This program is free
227software; you can redistribute it and/or modify it under the same terms as
228Perl itself.
229
230=head1 AUTHOR
231
232Petr Cimprich, petr@gingerall.cz
233
234=head1 SEE ALSO
235
236perl(1), RDF::Notation3.
237
238=cut
239