1# Copyrights 2008-2015 by [Mark Overmeer]. 2# For other contributors see ChangeLog. 3# See the manual pages for details on the licensing terms. 4# Pod stripped from pm file by OODoc 2.01. 5use warnings; 6use strict; 7 8package Geo::EOP; 9use vars '$VERSION'; 10$VERSION = '0.50'; 11 12use base 'Geo::GML'; 13 14use Geo::EOP::Util; # all 15use Geo::GML::Util qw/:gml311/; 16 17use Log::Report 'geo-eop', syntax => 'SHORT'; 18use XML::Compile::Util qw/unpack_type pack_type type_of_node/; 19use Math::Trig qw/rad2deg deg2rad/; 20 21# map namespace always to the newest implementation of the protocol 22my %ns2version = 23 ( &NS_HMA_ESA => '1.0' 24 , &NS_EOP_ESA => '1.2.1' 25 ); 26 27# list all available versions 28# It is a pity that not all schema use the same prefixes... sometimes, 29# the dafault prefix is used... therefore, we have to configure all that 30# manually. 31 32my @stdprefs = # will be different in the future 33 ( sar => NS_SAR_ESA 34 , atm => NS_ATM_ESA 35 , gml => NS_GML_311 36 ); 37 38my %info = 39 ( '1.0' => 40 { prefixes => {hma => NS_HMA_ESA, ohr => NS_OHR_ESA, @stdprefs} 41 , eop_schemas => [ 'hma1.0/{eop,sar,opt,atm}.xsd' ] 42 , gml_schemas => [ 'eop1.1/gmlSubset.xsd' ] 43 , gml_version => '3.1.1eop' 44 } 45 46 , '1.1' => 47 { prefixes => {eop => NS_EOP_ESA, opt => NS_OPT_ESA, @stdprefs} 48 , eop_schemas => [ 'eop1.1/{eop,sar,opt,atm}.xsd' ] 49 , gml_schemas => [ 'eop1.1/gmlSubset.xsd' ] 50 , gml_version => '3.1.1eop' 51 } 52 53 , '1.2beta' => 54 { prefixes => {eop => NS_EOP_ESA, opt => NS_OPT_ESA, @stdprefs} 55 , eop_schemas => [ 'eop1.2beta/{eop,sar,opt,atm}.xsd' ] 56 , gml_schemas => [ 'eop1.1/gmlSubset.xsd' ] 57 , gml_version => '3.1.1eop' 58 } 59 60 , '1.2.1' => 61 { prefixes => {eop => NS_EOP_ESA, opt => NS_OPT_ESA, @stdprefs} 62 , eop_schemas => [ 'eop1.2.1/{eop,sar,opt,atm}.xsd' ] 63 , gml_schemas => [ 'eop1.2.1/gmlSubset.xsd' ] 64 , gml_version => '3.1.1eop' 65 } 66 67# , '2.0' => 68# { eop_schemas => [ 'eop2.0/*.xsd' ] 69# , gml_version => '3.2.1' 70# } 71 72 ); 73 74my %measure = 75 ( rad_deg => sub { rad2deg $_[0] } 76 , deg_rad => sub { deg2rad $_[0] } 77 , '%_float' => sub { $_[0] / 100 } 78 , 'float_%' => sub { sprintf "%.2f", $_[0] / 100 } 79 ); 80sub _convert_measure($@); 81 82# This list must be extended, but I do not know what people need. 83my @declare_always = (); 84 85 86sub new($@) { my $class = shift; $class->SUPER::new('RW', @_) } 87 88sub init($) 89{ my ($self, $args) = @_; 90 $args->{allow_undeclared} = 1 91 unless exists $args->{allow_undeclared}; 92 93 my $version = $args->{eop_version} 94 or error __x"EOP object requires an explicit eop_version"; 95 96 unless(exists $info{$version}) 97 { exists $ns2version{$version} 98 or error __x"EOP version {v} not recognized", v => $version; 99 $version = $ns2version{$version}; 100 } 101 $self->{GE_version} = $version; 102 my $info = $info{$version}; 103 104 $args->{version} = $info->{gml_version}; 105 if($info->{gml_schemas}) # using own GML 3.1.1 subset 106 { $self->_register_gml_version($info->{gml_version} => {}); 107 } 108 109 $self->SUPER::init($args); 110 111 $self->addPrefixes($info->{prefixes}); 112 113 (my $xsd = __FILE__) =~ s!\.pm!/xsd!; 114 my @xsds = map {glob "$xsd/$_"} 115 @{$info->{eop_schemas} || []}, @{$info->{gml_schemas} || []}; 116 117 $self->importDefinitions(\@xsds); 118 119 my $units = delete $args->{units}; 120 if($units) 121 { if(my $a = $units->{angle}) 122 { $self->addHook(type => 'gml:AngleType' 123 , after => sub { _convert_measure $a, @_} ); 124 } 125 if(my $d = $units->{distance}) 126 { $self->addHook(type => 'gml:MeasureType' 127 , after => sub { _convert_measure $d, @_} ); 128 } 129 if(my $p = $units->{percentage}) 130 { $self->addHook(path => qr/Percentage/ 131 , after => sub { _convert_measure $p, @_} ); 132 } 133 } 134 135 $self; 136} 137 138sub declare(@) 139{ my $self = shift; 140 141 my $direction = $self->direction; 142 143 $self->declare($direction, $_) 144 for @_, @declare_always; 145 146 $self; 147} 148 149 150sub from($@) 151{ my ($thing, $data, %args) = @_; 152 my $xml = XML::Compile->dataToXML($data); 153 154 my $product = type_of_node $xml; 155 my $version = $xml->getAttribute('version'); 156 defined $version 157 or error __x"no version attribute in root element"; 158 159 my $self; 160 if(ref $thing) # instance method 161 { $self = $thing; 162 } 163 else # class method 164 { exists $info{$version} 165 or error __x"EOP version {version} not (yet) supported. Upgrade Geo::EOP or inform author" 166 , version => $version; 167 168 $self = $thing->new(eop_version => $version); 169 } 170 171 my $r = $self->reader($product, %args); 172 defined $r 173 or error __x"do not understand root node {type}", type => $product; 174 175 ($product, $r->($xml)); 176} 177 178#--------------------------------- 179 180 181sub eopVersion() {shift->{GE_version}} 182 183#-------------- 184 185 186sub printIndex(@) 187{ my $self = shift; 188 my $fh = @_ % 2 ? shift : select; 189 $self->SUPER::printIndex($fh 190 , kinds => 'element', list_abstract => 0, @_); 191} 192 193# This code will probaby move to Geo::GML 194sub _convert_measure($@) # not $$$$ for right context 195{ my ($to, $node, $data, $path) = @_; 196 ref $data eq 'HASH' or return $data; 197 my ($val, $from) = @$data{'_', 'uom'}; 198 defined $val && $from or return $data; 199 200 return $val if $from eq $to; 201 my $code = $measure{$from.'_'.$to} or return $data; 202 $code->($val); 203} 204 205#---------------------- 206 207 2081; 209