# Copyrights 2008-2009 by Mark Overmeer. # For other contributors see ChangeLog. # See the manual pages for details on the licensing terms. # Pod stripped from pm file by OODoc 1.06. use warnings; use strict; package Geo::GML; use vars '$VERSION'; $VERSION = '0.15'; use base 'XML::Compile::Cache'; use Geo::GML::Util; use Log::Report 'geo-gml', syntax => 'SHORT'; use XML::Compile::Util qw/unpack_type pack_type type_of_node/; # map namespace always to the newest implementation of the protocol my %ns2version = ( &NS_GML => '3.1.1' , &NS_GML_32 => '3.2.1' ); # list all available versions my %info = ( '2.0.0' => { prefixes => {gml => NS_GML_200} , schemas => [ 'gml2.0.0/*.xsd' ] } , '2.1.1' => { prefixes => {gml => NS_GML_211} , schemas => [ 'gml2.1.1/*.xsd' ] } , '2.1.2' => { prefixes => {gml => NS_GML_212} , schemas => [ 'gml2.1.2/*.xsd' ] } , '2.1.2.0' => { prefixes => {gml => NS_GML_2120} , schemas => [ 'gml2.1.2.0/*.xsd' ] } , '2.1.2.1' => { prefixes => {gml => NS_GML_2121} , schemas => [ 'gml2.1.2.1/*.xsd' ] } , '3.0.0' => { prefixes => {gml => NS_GML_300, smil => NS_SMIL_20} , schemas => [ 'gml3.0.0/*/*.xsd' ] } , '3.0.1' => { prefixes => {gml => NS_GML_301, smil => NS_SMIL_20} , schemas => [ 'gml3.0.1/*/*.xsd' ] } , '3.1.0' => { prefixes => {gml => NS_GML_310, smil => NS_SMIL_20} , schemas => [ 'gml3.1.0/*/*.xsd' ] } , '3.1.1' => { prefixes => {gml => NS_GML_311, smil => NS_SMIL_20 ,gmlsf => NS_GML_311_SF} , schemas => [ 'gml3.1.1/{base,smil,xlink}/*.xsd' , 'gml3.1.1/profile/*/*/*.xsd' ] } , '3.2.1' => { prefixes => {gml => NS_GML_321, smil => NS_SMIL_20 } , schemas => [ 'gml3.2.1/*.xsd', 'gml3.1.1/smil/*.xsd' ] } ); # This list must be extended, but I do not know what people need. my @declare_always = qw/gml:TopoSurface/; # for Geo::EOP and other stripped-down GML versions sub _register_gml_version($$) { $info{$_[1]} = $_[2] } sub new($@) { my ($class, $dir) = (shift, shift); $class->SUPER::new(direction => $dir, @_); } sub init($) { my ($self, $args) = @_; $args->{allow_undeclared} = 1 unless exists $args->{allow_undeclared}; $args->{opts_rw} = { @{$args->{opts_rw}} } if ref $args->{opts_rw} eq 'ARRAY'; $args->{opts_rw}{key_rewrite} = 'PREFIXED'; $args->{opts_rw}{mixed_elements} = 'STRUCTURAL'; $args->{any_element} ||= 'ATTEMPT'; $self->SUPER::init($args); $self->{GG_dir} = $args->{direction} or panic "no direction"; my $version = $args->{version} or error __x"GML object requires an explicit version"; unless(exists $info{$version}) { exists $ns2version{$version} or error __x"GML version {v} not recognized", v => $version; $version = $ns2version{$version}; } $self->{GG_version} = $version; my $info = $info{$version}; $self->prefixes(xlink => NS_XLINK_1999, %{$info->{prefixes}}); (my $xsd = __FILE__) =~ s!\.pm!/xsd!; my @xsds = map {glob "$xsd/$_"} @{$info->{schemas} || []}, 'xlink1.0.0/*.xsd'; $self->importDefinitions(\@xsds); $self; } sub declare(@) { my $self = shift; my $direction = $self->direction; $self->declare($direction, $_) for @_, @declare_always; $self; } sub from($@) { my ($class, $data, %args) = @_; my $xml = XML::Compile->dataToXML($data); my $top = type_of_node $xml; my $ns = (unpack_type $top)[0]; my $version = $ns2version{$ns} or error __x"unknown GML version with namespace {ns}", ns => $ns; my $self = $class->new('READER', version => $version); my $r = $self->reader($top, %args) or error __x"root node `{top}' not recognized", top => $top; ($top, $r->($xml)); } #--------------------------------- sub version() {shift->{GG_version}} sub direction() {shift->{GG_dir}} #--------------------------------- # just added as example, implemented in super-class #------------------ sub printIndex(@) { my $self = shift; my $fh = @_ % 2 ? shift : select; $self->SUPER::printIndex($fh , kinds => 'element', list_abstract => 0, @_); } our $AUTOLOAD; sub AUTOLOAD(@) { my $self = shift; my $call = $AUTOLOAD; return if $call =~ m/::DESTROY$/; my ($pkg, $method) = $call =~ m/(.+)\:\:([^:]+)$/; $method eq 'GPtoGML' or error __x"method {name} not implemented", name => $call; eval "require Geo::GML::GeoPoint"; panic $@ if $@; $self->$call(@_); } 1;