1require 5.005_02;
2BEGIN { require warnings if $] >= 5.006; }
3use strict;
4use XML::STX;
5use XML::STX::Parser;
6use XML::STX::Runtime;
7
8# --------------------------------------------------
9package XML::STX::TrAX;
10# only base class for XML::STX; it acts as TransformerFactory
11@XML::STX::TrAX::ISA = qw(XML::STX::TrAX::Base);
12
13sub new_templates {
14    my ($self, $source) = @_;
15
16    $source = $self->_check_source($source);
17
18    my $p = XML::STX::Parser->new();
19    $p->{DBG} = $self->{DBG};
20    $p->{URIResolver} = $self->{URIResolver};
21    $p->{URIResolver}->{Parser} = $self->{Parser};
22    $p->{URIResolver}->{Writer} = $self->{Writer};
23    $p->{ErrorListener} = $self->{ErrorListener};
24    $p->{URI} = $source->{SystemId};
25
26    $source->{XMLReader}->{Handler} = $p;
27    $source->{XMLReader}->{Source} = $source->{InputSource};
28    my $sheet = $source->{XMLReader}->parse();
29    $sheet->{URI} = $source->{SystemId};
30
31    return XML::STX::TrAX::Templates->new($sheet,
32					  $self->{Parser}, $self->{Writer});
33}
34
35sub new_source {
36    my ($self, $uri, $reader) = @_;
37
38    $reader = $self->_get_parser() unless $reader;
39
40    return XML::STX::TrAX::SAXSource->new($reader, {SystemId => $uri});
41}
42
43sub new_result {
44    my ($self, $handler) = @_;
45
46    $handler = $self->_get_writer() unless $handler;
47
48    return XML::STX::TrAX::SAXResult->new($handler);
49}
50
51# shortcut: new transformation context for default templates
52sub new_transformer {
53    my ($self, $source) = @_;
54
55    my $templates = $self->new_templates($source);
56    return $templates->new_transformer;
57}
58
59
60# --------------------------------------------------
61package XML::STX::TrAX::Templates;
62
63sub new {
64    my ($class, $sheet, $parser, $writer) = @_;
65
66    my $self = bless {Stylesheet => $sheet,
67		      Parser => $parser,
68		      Writer => $writer,
69		     }, $class;
70    return $self;
71}
72
73# new transformation context
74sub new_transformer {
75    my $self = shift;
76
77    return XML::STX::TrAX::Transformer->new($self->{Stylesheet},
78					    $self->{Parser}, $self->{Writer});
79}
80
81
82# --------------------------------------------------
83package XML::STX::TrAX::Transformer;
84use Clone qw(clone);
85@XML::STX::TrAX::Transformer::ISA = qw(XML::STX::TrAX::Base XML::STX::Runtime);
86
87sub new {
88    my ($class, $sheet, $parser, $writer) = @_;
89
90    my $ll = exists $sheet->{Options}->{LoopLimit}
91      ? $sheet->{Options}->{LoopLimit} : 10000;
92
93    my $self = bless {Sheet => $sheet,
94		      Parameters => {},
95		      # implementation dependent options
96		      Options => {LoopLimit => $ll},
97		      Parser => $parser,
98		      Writer => $writer,
99		      URIResolver => XML::STX::TrAX::URIResolver->new($parser,
100								      $writer),
101		      ErrorListener => XML::STX::TrAX::ErrorListener->new(),
102		     }, $class;
103
104    return $self;
105}
106
107sub transform {
108    my ($self, $source, $result) = @_;
109
110    $source = $self->_check_source($source);
111    $result = $self->_check_result($result);
112
113    $source->{XMLReader}->{Handler} = $self;
114    $source->{XMLReader}->{Source} = $source->{InputSource};
115    $self->{Handler} = $result->{Handler};
116    $self->{Source} = [$source];
117
118    # stylesheet parameters
119    foreach (keys %{$self->{Sheet}->{dGroup}->{pars}}) {
120	if (exists $self->{Parameters}->{$_}) {
121	    my $seq = $self->_to_sequence($self->{Parameters}->{$_});
122	    $self->{Sheet}->{dGroup}->{vars}->[0]->{$_}->[0] = $seq;
123	    $self->{Sheet}->{dGroup}->{vars}->[0]->{$_}->[1] = clone($seq);
124
125	} else {
126	    $self->doError(510, 3, $_)
127	      if $self->{Sheet}->{dGroup}->{pars}->{$_};
128	}
129    }
130
131    return $source->{XMLReader}->parse();
132}
133
134sub clear_parameters {
135    my $self = shift;
136
137    $self->{Parameters} = {};
138}
139
140
141# --------------------------------------------------
142package XML::STX::TrAX::SAXSource;
143
144sub new {
145    my ($class, $XMLReader, $InputSource) = @_;
146
147    my $self = bless {XMLReader => $XMLReader,
148		      InputSource => $InputSource,
149		      SystemId => $InputSource->{SystemId},
150		     }, $class;
151    return $self;
152}
153
154
155# --------------------------------------------------
156package XML::STX::TrAX::SAXResult;
157
158sub new {
159    my ($class, $Handler, $SystemId) = @_;
160
161    my $self = bless {Handler => $Handler,
162		      SystemId => $SystemId,
163		     }, $class;
164    return $self;
165}
166
167
168# --------------------------------------------------
169package XML::STX::TrAX::URIResolver;
170@XML::STX::TrAX::URIResolver::ISA = qw(XML::STX::TrAX::Base);
171
172sub new {
173    my ($class, $parser, $writer) = @_;
174
175    my $self = bless {Parser => $parser,
176		      Writer => $writer,
177		     }, $class;
178    return $self;
179}
180
181sub resolve {
182    my ($self, $uri, $base) = @_;
183
184    # tbd: resolving with Sources
185
186    if ($base and $uri !~ /^[a-zA-Z]+[a-zA-Z\d\+\-\.]*:/) {
187	$base =~ s/[^\/]+$//;
188	$uri = $base . $uri;
189    }
190
191    my $reader = $self->_get_parser();
192    return XML::STX::TrAX::SAXSource->new($reader, {SystemId => $uri});
193}
194
195sub resolve_result {
196    my ($self, $uri, $base) = @_;
197
198    # tbd: resolving with Results
199
200    if ($base and $uri !~ /^[a-zA-Z]+[a-zA-Z\d\+\-\.]*:/) {
201	$base =~ s/[^\/]+$//;
202	$uri = $base . $uri;
203    }
204
205    my $handler = $self->_get_writer({Output => $uri});
206    return XML::STX::TrAX::SAXResult->new($handler, $uri);
207}
208
209
210# --------------------------------------------------
211package XML::STX::TrAX::ErrorListener;
212use Carp;
213
214sub new {
215    my $class = shift;
216    my $options = ($#_ == 0) ? shift : { @_ };
217
218    my $self = bless $options, $class;
219    return $self;
220}
221
222sub warning {
223    my ($self, $exception) = @_;
224
225    print STDERR $exception->{Message};
226}
227
228sub error {
229    my ($self, $exception) = @_;
230
231    print STDERR $exception->{Message};
232}
233
234sub fatal_error {
235    my ($self, $exception) = @_;
236
237    croak $exception->{Message};
238}
239
240# --------------------------------------------------
241package XML::STX::TrAX::Base;
242
243sub _get_parser() {
244    my $self = shift;
245    my $options = ($#_ == 0) ? shift : { @_ };
246
247    my @preferred = ('XML::SAX::ExpatXS',
248		     'XML::LibXML::SAX');
249
250    unshift @preferred, $self->{Parser} if $self->{Parser};
251
252    foreach (@preferred) {
253	$@ = undef;
254	eval "require $_;";
255	unless ($@) {
256	    return eval "$_->" . 'new($options)';
257	}    }
258    # fallback
259    return XML::SAX::PurePerl->new($options);
260}
261
262sub _get_writer() {
263    my $self = shift;
264    my $options = ($#_ == 0) ? shift : { @_ };
265
266    my @preferred = ('XML::SAX::Writer');
267
268    unshift @preferred, $self->{Writer} if $self->{Writer};
269
270    foreach (@preferred) {
271	$@ = undef;
272	eval "require $_;";
273	unless ($@) {
274	    return eval "$_->" . 'new($options)';
275	}    }
276    # fallback
277    return XML::STX::Writer->new($options);
278}
279
280sub _check_source {
281    my ($self, $source) = @_;
282
283    if (ref $source eq 'XML::STX::TrAX::SAXSource') {
284	return $source;
285
286    } elsif (ref $source eq 'HASH' and defined $source->{SystemId}) {
287	my $reader = $self->_get_parser();
288	return XML::STX::TrAX::SAXSource->new($reader, $source);
289
290    } elsif (not ref $source) {
291	my $reader = $self->_get_parser();
292	return XML::STX::TrAX::SAXSource->new($reader, {SystemId => $source});
293
294     } else {
295	     $self->doError(509, 3, ref $source, 'source');
296     }
297}
298
299sub _check_result {
300    my ($self, $result) = @_;
301
302    if (ref $result eq 'XML::STX::TrAX::SAXResult') {
303	return $result;
304
305    } elsif (not defined $result) {
306	my $writer = $self->_get_writer();
307	return XML::STX::TrAX::SAXResult->new($writer);
308
309     } else {
310	 $self->doError(509, 3, ref $result, 'result');
311     }
312}
313
3141;
315__END__
316
317=head1 NAME
318
319XML::STX::TrAX - a TrAX-like interface
320
321=head1 SYNOPSIS
322
323see XML::STX
324
325=head1 AUTHOR
326
327Petr Cimprich (Ginger Alliance), petr@gingerall.cz
328
329=head1 SEE ALSO
330
331XML::STX, perl(1).
332
333=cut
334