package IOC::Config::XML::SAX::Handler;
use strict;
use warnings;
our $VERSION = '0.02';
use IOC::Exceptions;
use IOC::Registry;
use IOC::Container;
use IOC::Service;
use IOC::Service::Literal;
use IOC::Service::ConstructorInjection;
use IOC::Service::SetterInjection;
use IOC::Service::Prototype;
use IOC::Service::Prototype::ConstructorInjection;
use IOC::Service::Prototype::SetterInjection;
use IOC::Service::Parameterized;
use base qw(XML::SAX::Base);
sub new {
my $class = shift;
my $self = $class->SUPER::new(@_);
$self->{registry} = undef;
$self->{current} = undef;
$self->{current_service} = undef;
return $self;
}
## XML::SAX Handlers
sub start_element {
my ($self, $el) = @_;
my $type = lc($el->{Name});
if ($type eq 'registry') {
$self->_createRegistry($el);
}
elsif (defined($self->{registry})) {
if ($type eq 'container') {
$self->_createContainer($el);
}
elsif ($type eq 'service') {
$self->_createService($el);
}
elsif ($type eq 'class') {
$self->_createClass($el);
}
elsif ($type eq 'parameter') {
$self->_createConstructorParameter($el);
}
elsif ($type eq 'setter') {
$self->_createSetterParameter($el);
}
}
else {
throw IOC::ConfigurationError "$type is not allowed unless a Registry is created first";
}
}
sub end_element {
my ($self, $el) = @_;
my $name = lc($el->{Name});
if ($name eq 'container') {
$self->_finishContainer();
}
elsif ($name eq 'service') {
$self->_finishService();
}
}
sub characters {
my ($self, $el) = @_;
my $data = $el->{Data};
return if $data =~ /^\s+$/;
$self->_handleServiceCharacterData($data) if $self->{current_service};
}
## basic utility routines
sub _getName {
my ($self, $el) = @_;
return $el->{Attributes}->{'{}name'}->{Value};
}
sub _getValue {
my ($self, $el, $key) = @_;
return undef unless exists $el->{Attributes}->{'{}' . $key};
return $el->{Attributes}->{'{}' . $key}->{Value};
}
sub _compilePerl {
my ($self, $perl) = @_;
my $value = eval $perl;
throw IOC::OperationFailed "Could not compile '$perl'", $@ if $@;
return $value;
}
## IOC::Registry handler
sub _createRegistry {
my ($self, $el) = @_;
(!defined($self->{registry})) ||
throw IOC::ConfigurationError "We already have a registry";
$self->{registry} = IOC::Registry->new();
$self->{current} = $self->{registry};
}
## IOC::Container handler(s)
sub _createContainer {
my ($self, $el) = @_;
($self->_getValue($el, 'name'))
|| throw IOC::ConfigurationError "Container must have name";
my $c = IOC::Container->new($self->_getName($el));
if ($self->{current}->isa('IOC::Registry')) {
$self->{current}->registerContainer($c);
}
elsif ($self->{current}->isa('IOC::Container')) {
$self->{current}->addSubContainer($c);
}
$self->{current} = $c;
}
sub _finishContainer {
my ($self) = @_;
($self->{current})
|| throw IOC::ConfigurationError "This should never happen";
$self->{current} = $self->{current}->getParentContainer()
if $self->{current}->isa('IOC::Container') &&
!$self->{current}->isRootContainer();
}
## IOC::Service::* handler(s)
sub _createService {
my ($self, $el) = @_;
(!$self->{current}->isa('IOC::Registry')) ||
throw IOC::ConfigurationError "Services must be within containers";
($self->_getValue($el, 'name'))
|| throw IOC::ConfigurationError "Service must have name";
$self->{current_service} = {
name => $self->_getName($el),
type => $self->_getValue($el, 'type'),
prototype => $self->_getValue($el, 'prototype'),
};
}
sub _createClass {
my ($self, $el) = @_;
($self->{current_service}) ||
throw IOC::ConfigurationError "Class must be within Services";
$self->{current_service}->{class} = {
name => $self->_getName($el),
constructor => $self->_getValue($el, 'constructor')
};
}
sub _createConstructorParameter {
my ($self, $el) = @_;
($self->{current_service} &&
($self->{current_service}->{type} eq 'ConstructorInjection' &&
exists $self->{current_service}->{class})) ||
throw IOC::ConfigurationError "Paramter must be after Class and must be within Services";
unless (exists $self->{current_service}->{parameters}) {
$self->{current_service}->{parameters} = [];
}
push @{$self->{current_service}->{parameters}} => {
type => $self->_getValue($el, 'type')
};
}
sub _createSetterParameter {
my ($self, $el) = @_;
($self->{current_service} &&
($self->{current_service}->{type} eq 'SetterInjection' &&
exists $self->{current_service}->{class})) ||
throw IOC::ConfigurationError "Paramter must be after Class and must be within Services";
unless (exists $self->{current_service}->{setters}) {
$self->{current_service}->{setters} = [];
}
push @{$self->{current_service}->{setters}} => {
name => $self->_getName($el)
};
}
sub _handleServiceCharacterData {
my ($self, $data) = @_;
if ($self->{current_service}->{parameters}) {
$self->{current_service}->{parameters}->[-1]->{data} = $data;
}
if ($self->{current_service}->{setters}) {
$self->{current_service}->{setters}->[-1]->{data} = $data;
}
else {
$self->{current_service}->{data} = $data;
}
}
sub _finishService {
my ($self) = @_;
my $service_desc = $self->{current_service};
$service_desc->{service_class} = 'IOC::Service';
$service_desc->{service_class} .= '::Prototype'
if $service_desc->{prototype} && lc($service_desc->{prototype}) ne 'false';
# NOTE:
# this allows for us to add on more Service
# types without too much trouble ...
my $constructor = $self->can('__makeService' . ($service_desc->{type} || ''));
if ($constructor) {
$self->$constructor($service_desc);
}
else {
throw IOC::ConfigurationError "Unrecognized type : " . $service_desc->{type};
}
$self->{current_service} = undef;
}
## ultra-private Service constructors
sub __makeService {
my ($self, $service_desc) = @_;
# we have a plain Service
($service_desc->{data})
|| throw IOC::ConfigurationError "No sub in Service";
$self->{current}->register(
$service_desc->{service_class}->new(
$service_desc->{name} => $self->_compilePerl('sub { ' . $service_desc->{data} . ' }')
)
);
}
sub __makeServiceParameterized {
my ($self, $service_desc) = @_;
# we have a plain Service
($service_desc->{data})
|| throw IOC::ConfigurationError "No sub in Service";
$self->{current}->register(
IOC::Service::Parameterized->new(
$service_desc->{name} => $self->_compilePerl('sub { ' . $service_desc->{data} . ' }')
)
);
}
sub __makeServiceLiteral {
my ($self, $service_desc) = @_;
(exists $service_desc->{data})
|| throw IOC::ConfigurationError "Cant make a Literal without a value";
$self->{current}->register(
IOC::Service::Literal->new($service_desc->{name} => $service_desc->{data})
);
}
sub __makeServiceConstructorInjection {
my ($self, $service_desc) = @_;
(exists $service_desc->{class} &&
($service_desc->{class}->{name} && $service_desc->{class}->{constructor}))
|| throw IOC::ConfigurationError "Cant make a ConstructorInjection without a class";
my @parameters;
@parameters = map {
if ($_->{type}) {
if ($_->{type} eq 'component') {
IOC::Service::ConstructorInjection->ComponentParameter($_->{data})
}
elsif ($_->{type} eq 'perl') {
$self->_compilePerl($_->{data})
}
else {
throw IOC::ConfigurationError "Unknown Type: " . $_->{type}
}
}
else {
(defined $_->{data})
|| throw IOC::ConfigurationError "No data";
$_->{data}
}
} @{$service_desc->{parameters}}
if exists $service_desc->{parameters};
$service_desc->{service_class} .= '::ConstructorInjection';
$self->{current}->register(
$service_desc->{service_class}->new($service_desc->{name} => (
$service_desc->{class}->{name},
$service_desc->{class}->{constructor},
\@parameters
))
);
}
sub __makeServiceSetterInjection {
my ($self, $service_desc) = @_;
(exists $service_desc->{class} &&
($service_desc->{class}->{name} && $service_desc->{class}->{constructor}))
|| throw IOC::ConfigurationError "Cant make a ConstructorInjection without a class";
my @setters;
@setters = map {
{ $_->{name} => $_->{data} }
} @{$service_desc->{setters}}
if exists $service_desc->{setters};
$service_desc->{service_class} .= '::SetterInjection';
$self->{current}->register(
$service_desc->{service_class}->new($service_desc->{name} => (
$service_desc->{class}->{name},
$service_desc->{class}->{constructor},
\@setters
))
);
}
1;
__END__
=head1 NAME
IOC::Config::XML::SAX::Handler - An XML::SAX handler to read IOC Config files
=head1 SYNOPSIS
use IOC::Config::XML::SAX::Handler; # used by IOC::Config::XML
=head1 DESCRIPTION
This class is used by L<IOC::Config::XML> to construct the L<IOC::Registry> object hierarchy from the given XML document. There are no user serviceable parts in this module really. But if you want to add handling for any type of custom L<IOC::Container> or L<IOC::Service> subclasses, this would be the place to do it.
=head1 METHODS
These are methods used by XML::SAX. Consult that modules documentation for more information about them.
=over 4
=item B<new>
=item B<start_element>
=item B<end_element>
=item B<characters>
=back
=head1 BUGS
None that I am aware of. Of course, if you find a bug, let me know, and I will be sure to fix it.
=head1 CODE COVERAGE
I use B<Devel::Cover> to test the code coverage of my tests, see the CODE COVERAGE section of L<IOC> for more information.
=head1 SEE ALSO
=over 4
=item L<XML::SAX>
=item L<XML::SAX::Base>
=back
=head1 AUTHOR
stevan little, E<lt>stevan@iinteractive.comE<gt>
=head1 COPYRIGHT AND LICENSE
Copyright 2004-2007 by Infinity Interactive, Inc.
L<http://www.iinteractive.com>
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut