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