"Fossies" - the Fresh Open Source Software Archive

Member "navit-0.5.4/navit/script/osm/Geo/OSM/APIClientV5.pm" (18 Jan 2020, 7533 Bytes) of package /linux/privat/navit-0.5.4.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "APIClientV5.pm" see the Fossies "Dox" file reference documentation.

    1 ##################################################################
    2 ## APIClientV5.pm - General Perl client for the API             ##
    3 ## By Martijn van Oosterhout <kleptog@svana.org>                ##
    4 ##                                                              ##
    5 ## Currently only supports uploading. Note the package actually ##
    6 ## creates a package named Geo::OSM::APIClient so upgrades to   ##
    7 ## later versions will be easier.                               ##
    8 ## Licence: LGPL                                                ##
    9 ##################################################################
   10 
   11 use LWP::UserAgent;
   12 use strict;
   13 
   14 package Geo::OSM::APIClient;
   15 use Geo::OSM::OsmReaderV5;
   16 use MIME::Base64;
   17 use HTTP::Request;
   18 use Carp;
   19 use Encode;
   20 use POSIX qw(sigprocmask);
   21 use URI;
   22 use Socket qw(inet_ntoa);
   23 
   24 sub new
   25 {
   26   my( $class, %attr ) = @_;
   27 
   28   my $obj = bless {}, $class;
   29 
   30   my $url = $attr{api};
   31   if( not defined $url )
   32   {
   33     croak "Did not specify api url";
   34   }
   35 
   36   $url =~ s,/$,,;   # Strip trailing slash
   37   $obj->{url} = URI->new($url);
   38   $obj->{client} = new LWP::UserAgent(agent => 'Geo::OSM::APIClientV5', timeout => 1200);
   39 
   40   if( defined $attr{username} and defined $attr{password} )
   41   {
   42     my $encoded = MIME::Base64::encode_base64("$attr{username}:$attr{password}","");
   43     $obj->{client}->default_header( "Authorization", "Basic $encoded" );
   44   }
   45 
   46   # We had the problem of the client doing a DNS lookup each request. To
   47   # solve this we do a gethostbyname now and store that in the URI.
   48   {
   49     my $addr;
   50     (undef, undef, undef, undef, $addr) = gethostbyname($obj->{url}->host);
   51     if( defined $addr )
   52     {
   53       $obj->{client}->default_header( "Host", $obj->{url}->host );
   54       $obj->{url}->host( inet_ntoa($addr) );
   55       print STDERR "Using address: ".$obj->{url}->as_string()."\n";
   56     }
   57   }
   58   # Hack to avoid protocol lookups each time
   59   @LWP::Protocol::http::EXTRA_SOCK_OPTS = ( 'Proto' => 6 );
   60 
   61   $obj->{reader} = init Geo::OSM::OsmReader( sub { _process($obj,@_) } );
   62   return $obj;
   63 }
   64 
   65 # This is the callback from the parser. If checks if the buffer is defined.
   66 # If the buffer is an array, append the new object. If the buffer is a proc,
   67 # call it.
   68 sub _process
   69 {
   70   my($obj,$ent) = @_;
   71   if( not defined $obj->{buffer} )
   72   { die "Internal error: Received object with buffer" }
   73   if( ref $obj->{buffer} eq "ARRAY" )
   74   { push @{$obj->{buffer}}, $ent; return }
   75   if( ref $obj->{buffer} eq "CODE" )
   76   { $obj->{buffer}->($ent); return }
   77   die "Internal error: don't know what to do with buffer $obj->{buffer}";
   78 }
   79 
   80 # Utility function to handle the temporary blocking of signals in a way that
   81 # works with exception handling.
   82 sub _with_blocked_sigs(&)
   83 {
   84   my $ss = new POSIX::SigSet( &POSIX::SIGINT );
   85   my $func = shift;
   86   my $os = new POSIX::SigSet;
   87   sigprocmask( &POSIX::SIG_BLOCK, $ss, $os );
   88   my $ret = eval { &$func };
   89   sigprocmask( &POSIX::SIG_SETMASK, $os );
   90   die $@ if $@;
   91   return $ret;
   92 }
   93 
   94 sub _request
   95 {
   96   my $self = shift;
   97   my $req = shift;
   98   return _with_blocked_sigs { $self->{client}->request($req) };
   99 }
  100 
  101 sub last_error_code
  102 {
  103   my $self=shift;
  104   croak "No last error" unless defined $self->{last_error};
  105   return $self->{last_error}->code;
  106 }
  107 
  108 sub last_error_message
  109 {
  110   my $self=shift;
  111   croak "No last error" unless defined $self->{last_error};
  112   return $self->{last_error}->message;
  113 }
  114 
  115 sub create($)
  116 {
  117   my( $self, $ent ) = @_;
  118   my $oldid = $ent->id;
  119   $ent->set_id(0);
  120   my $content = encode("utf-8", $ent->full_xml);
  121   $ent->set_id($oldid);
  122   my $req = new HTTP::Request PUT => $self->{url}."/".$ent->type()."/create";
  123   $req->content($content);
  124 
  125 #  print $req->as_string;
  126 
  127   my $res = $self->_request($req);
  128 
  129 #  print $res->as_string;
  130 
  131   if( $res->code == 200 )
  132   {
  133     return $res->content
  134   }
  135 
  136   $self->{last_error} = $res;
  137   return undef;
  138 }
  139 
  140 sub modify($)
  141 {
  142   my( $self, $ent ) = @_;
  143   my $content = encode("utf-8", $ent->full_xml);
  144   my $req = new HTTP::Request PUT => $self->{url}."/".$ent->type()."/".$ent->id();
  145   $req->content($content);
  146 
  147 #  print $req->as_string;
  148 
  149   my $res = $self->_request($req);
  150 
  151   return $ent->id() if $res->code == 200;
  152   $self->{last_error} = $res;
  153   return undef;
  154 }
  155 
  156 sub delete($)
  157 {
  158   my( $self, $ent ) = @_;
  159   my $content = encode("utf-8", $ent->full_xml);
  160   my $req = new HTTP::Request DELETE => $self->{url}."/".$ent->type()."/".$ent->id();
  161 #  $req->content($content);
  162 
  163 #  print $req->as_string;
  164 
  165   my $res = $self->_request($req);
  166 
  167   return $ent->id() if $res->code == 200;
  168   $self->{last_error} = $res;
  169   return undef;
  170 }
  171 
  172 sub get($$)
  173 {
  174   my $self = shift;
  175   my $type = shift;
  176   my $id = shift;
  177   my $extra = shift;
  178 
  179   $extra = "/".$extra if (defined $extra);
  180   $extra = "" if not defined $extra;
  181 
  182   my $req = new HTTP::Request GET => $self->{url}."/$type/$id$extra";
  183 
  184   my $res = $self->_request($req);
  185 
  186   if( $res->code != 200 )
  187   {
  188     $self->{last_error} = $res;
  189     return undef;
  190   }
  191 
  192   my @res;
  193   $self->{buffer} = \@res;
  194   $self->{reader}->parse($res->content);
  195   undef $self->{buffer};
  196   if($extra =~ /history/)
  197   {
  198     return @res;
  199   }
  200   if(scalar(@res) != 1 )
  201   {
  202     die "Unexpected response for get_$type [".$res->content()."]\n";
  203   }
  204 
  205   return $res[0];
  206 }
  207 
  208 sub resurrect($$)
  209 {
  210   my $self = shift;
  211   my $type = shift;
  212   my $id = shift;
  213 
  214   my $ret = $self->get($type, $id);
  215   if (defined $ret || !defined $self->{last_error} || ($self->{last_error}->code != 410)) {
  216     return $ret;
  217   }
  218 
  219   my @ents = $self->get($type, $id, 'history');
  220   # we want the last _visible_ one
  221   my $ent = $ents[-2];
  222   if ($ent->type eq 'way') {
  223     printf("resurrecting way, checking all member nodes...\n");
  224     foreach my $node_id (@{$ent->nodes()}) {
  225         printf("checking node: $node_id...");
  226         my $node_ent = $self->get('node', $node_id);
  227         if (defined $node_ent) {
  228             printf("good\n");
  229             next;
  230         }
  231         printf("attempting to resurrect node: $node_id...");
  232         $node_ent = $self->resurrect('node', $node_id);
  233         if (!defined $node_ent) {
  234             die "failed";
  235         }
  236         printf("success!\n");
  237     }
  238     printf("all way nodes are OK, ");
  239   }
  240   printf("attempting to resurrect %s...", $ent->type);
  241   $ret = $self->modify($ent);
  242   if ($ret == $ent->id) {
  243     printf("ok\n");
  244     return $ret;
  245   }
  246   die sprintf("unable to resurrect $type $id: %s\n", $self->last_error_message);
  247 }
  248 
  249 sub get_node($)
  250 {
  251   my $self = shift;
  252   return $self->get("node",shift);
  253 }
  254 
  255 sub get_way($)
  256 {
  257   my $self = shift;
  258   return $self->get("way",shift);
  259 }
  260 
  261 sub get_relation($)
  262 {
  263   my $self = shift;
  264   return $self->get("relation",shift);
  265 }
  266 
  267 sub get_subtype($$)
  268 {
  269   my $self = shift;
  270   my $type = shift;
  271   my $id = shift;
  272   my $subtype = shift;
  273 
  274   my $req = new HTTP::Request GET => $self->{url}."/$type/$id/$subtype";
  275 
  276   my $res = $self->_request($req);
  277 
  278   if( $res->code != 200 )
  279   {
  280     $self->{last_error} = $res;
  281     return undef;
  282   }
  283 
  284   my @res;
  285   $self->{buffer} = \@res;
  286   $self->{reader}->parse($res->content);
  287   undef $self->{buffer};
  288   if( scalar(@res) < 1 )
  289   {
  290     die "Unexpected response for get_subtype($type,$id,$subtype) [".$res->content()."]\n";
  291   }
  292 
  293   return \@res;
  294 }
  295 
  296 sub get_node_ways($)
  297 {
  298   my $self = shift;
  299   my $id = shift;
  300 
  301   return $self->get_subtype("node",$id,"ways");
  302 }
  303 
  304 sub map($$$$)
  305 {
  306   my $self = shift;
  307   my @bbox = @_;
  308 
  309   my $req = new HTTP::Request GET => $self->{url}."/map?bbox=$bbox[0],$bbox[1],$bbox[2],$bbox[3]";
  310 
  311   my $res = $self->_request($req);
  312 
  313   if( $res->code != 200 )
  314   {
  315     $self->{last_error} = $res;
  316     return undef;
  317   }
  318 
  319   my @res;
  320   $self->{buffer} = \@res;
  321   $self->{reader}->parse($res->content);
  322   undef $self->{buffer};
  323 
  324   return \@res;
  325 }
  326 
  327 1;