source: subversion/sites/other/trapi/ptdb.pm @ 31161

Last change on this file since 31161 was 14350, checked in by blarson, 11 years ago

Workaround one case of corrupt relations.
Better stats for waycache (forgot to mention adding waycache previously)
dumptile is less picky about arguments, can take multiple tiles
fetchtile is nasty hack to fetch all objects that appear to be in a tile

File size: 27.1 KB
Line 
1#!/usr/bin/perl
2# Copyright 2008, 2009 Blars Blarson. 
3# Distributed under GPL version 2, see GPL-2
4
5use strict;
6use warnings;
7
8use Math::Trig;
9use File::Path;
10
11use constant MAXZOOM => 14;             # magic number with current ptn scheme
12use constant NOPTN => "\0\0\0\0";       # toptn(0,0,0)
13use constant MAXLAT => 85.051128;       # deliberatly slightly less than the thoretical value
14use constant MINLAT => -(MAXLAT);
15use constant CONV => 10000000;          # conversion from lat/lon to int
16use constant {NONE => 0, NODE => 1, WAY => 2, RELATION => 3, ROLE => 4};
17use constant MEMBER => { 'node' => NODE, 'way' => WAY, 'relation' => RELATION, 'role' => ROLE };
18use constant MEMBERTYPE => ( '', 'node', 'way', 'relation', 'role' );
19use constant PZ => pack("N", 0);
20
21our $devnull;
22our @comtags;
23our %tagsversion;
24
25sub ptdbinit($) {
26    our ($mode) = @_;
27    open NODES, $mode, DBDIR."nodes.db"
28        or die "Could not open nodes.db: $!";
29    open WAYS, $mode, DBDIR."ways.db"
30        or die "Could not open ways.db: $!";
31    open RELATIONS, $mode, DBDIR."relations.db"
32        or die "Could not open relations.db: $!";
33    open ZOOMS, $mode, DBDIR."zooms.db"
34        or die "Could not open zooms.db: $!";
35    open $devnull, "<", "/dev/null"
36        or die "Could not open /dev/null: $!";
37    our $wch = 0;
38    our $wcm = 0;
39}
40
41# tags are encoded in a variable-length code.
42# first byte 0 means no more tags, 1 means string follows.
43# >=192 means 2 more bytes, >=128 means 1 more byte
44# vals and roles are the same except 0 means string follows.
45#
46# commontags reads the tags file and creates the hashes for encoding
47# and arrays for decoding
48sub commontags($) {
49    my ($ctn) = @_;
50    return unless($ctn);
51    print "processing tags.$ctn\n" if (VERBOSE > 30);
52    my ($v, $t, $vv, $tn, $vn, $va, $ta, $vva, $tag);
53    our ($mode);
54    my $ro = 0; # $mode eq '<';
55    open TAGS, "<", DBDIR."tags.$ctn" or die "Could not open tags.$ctn: $!";
56    $comtags[$ctn] = [
57        undef,
58        [ {}, [], {}, [], ],
59        [ {}, [], {}, [], ],
60        [ {}, [], {}, [], ],
61        [ {}, [], ],
62    ];
63
64    while ($_ = <TAGS>) {
65        chomp;
66        if (/^\t\t([^\t]*)\t(\d+)$/) {
67            my $val = $1;
68            unless (defined $vva) {
69                unless ($ro) {
70                    $vv = {};
71                    $v->{$tag} = $vv;
72                }
73                $vva = [];
74                $va->[$tn] = $vva;
75                $vn = 0;
76            }
77            $vv->{$val} = ++$vn unless($ro);
78            $vva->[$vn] = $val;
79        } elsif (/^\t([^\t]*)\t(\d+)$/) {
80            $tag = $1;
81            $ta->[++$tn] = $tag;
82            $t->{$tag} = $tn unless($ro);
83            $vva = undef;
84        } elsif (/^(\w+)s$/) {
85            my $m = MEMBER->{$1};
86            die "Malformed line in tags.$ctn: $_" unless($m);
87            ($t, $ta, $v, $va) = @{$comtags[$ctn]->[$m]};
88            $tn = ($m != ROLE);
89        } else {
90            die "Malformed line in tags.$ctn: $_";
91        }
92    }
93    close TAGS;
94    print "tags.$ctn processed\n" if (VERBOSE > 10);
95}
96
97# pack 4-bit z, 14-bit x and y into 4-byte ptn (packed tile number)
98sub toptn($$$) {
99    my ($z, $x, $y) = @_;
100    return pack "b32", sprintf "%0.4b%0.14b%0.14b", $z, $x, $y;
101}
102
103# given MAXZOOM xy, return ptn
104sub etoptn($$) {
105    my ($x, $y) = @_;
106    # ZOOMS is stored for MAXZOOM-1
107    seek ZOOMS, (($x>>1)<<(MAXZOOM-1)) | ($y>>1), 0;
108    my $z;
109    if (read ZOOMS, $z, 1) {
110        $z = unpack "C", $z;
111    }
112    $z = MINZOOM unless($z);
113    return toptn($z, $x >> (MAXZOOM-$z), $y >> (MAXZOOM-$z));
114}
115
116# unpack 4-bit z, 14-bit x and y from 4-byte ptn (packed tile number)
117sub fromptn($) {
118    if (unpack("b32", $_[0]) =~ /^(.{4,4})(.{14,14})(.{14,14})$/) {
119        return (oct "0b".$1, oct "0b".$2, oct "0b".$3);
120    }
121    return 0, 0, 0;
122}
123
124# lat, lon, zoom to xy
125# based on wiki.openstreetmap.org/index.php/Slippy_map_tilenames
126sub getTileNumber($$$) {
127    my ($lat,$lon,$z) = @_;
128    # use closest tile near poles
129    $lat = MAXLAT if ($lat > MAXLAT);
130    $lat = MINLAT if ($lat < MINLAT);
131    my $xtile = int( ($lon+180)/360 * (1<<$z) ) ;
132    my $ytile = int( (1 - log(tan($lat*pi/180) + sec($lat*pi/180))/pi)/2 * (1<<$z) ) ;
133    return(($xtile, $ytile));
134}
135
136# open file from ptn, and name
137#   name is "data", "nodes", "ways", or "relations"
138# if file doesn't exist, return /dev/null if read only or create it
139# we keep a cache of file handles
140sub openptn($$) {
141    my ($ptn, $name) = @_;
142    my $f;
143    my $ptnname = $ptn.$name;
144    our ($opened, $hits, $misses, $cachecount, $mode);
145    our (%filecache);
146    if (defined $filecache{$ptnname}) {
147        $hits++;
148        $filecache{$ptnname}->[1] = ++$cachecount;
149        return $filecache{$ptnname}->[0];
150    }
151    my ($z, $x, $y) = fromptn($ptn);
152    print "opening z$z/$x/$y/$name\n" if (VERBOSE > 34);
153    unless (open $f, $mode, "z$z/$x/$y/$name") {
154        my $err = $!;
155        return $devnull if ($mode eq "<");
156        open $f, "+>", "z$z/$x/$y/$name" or $f = undef();
157        unless (defined $f) {
158            unless (mkdir "z$z/$x/$y") {
159                unless (mkdir "z$z/$x") {
160                    mkdir "z$z" or die "Could not mkdir z$z for z$z/$x/$y/$name: $!\nopen err: $err";
161                    mkdir "z$z/$x" or die "Could not mkdir z$z/$x for z$z/$x/$y/$name: $!";
162                }
163                mkdir "z$z/$x/$y" or die "Could not mkdir z$z/$x/$y for z$z/$x/$y/$name: $!";
164            }
165            open $f, "+>",  "z$z/$x/$y/$name"
166                or die "Could not open z$z/$x/$y/$name: $!";
167        }
168        if ($name eq "data") {
169            printvnum($f, TAGSVERSION);
170            $tagsversion{$f} = TAGSVERSION;
171            commontags(TAGSVERSION) unless (defined($comtags[TAGSVERSION]));
172        }
173    } elsif ($name eq "data") {
174        my $tv = getvnum($f);
175        unless (defined $tv) {
176            if ($mode eq '<') {
177                $tv = 0;
178            } else {
179                $tv = TAGSVERSION;
180                printvnum($f, $tv);
181                commontags(TAGSVERSION) unless (defined($comtags[TAGSVERSION]));
182            }
183        } elsif ($tv > TAGSVERSION) {
184            my ($vz, $vx, $vy) = fromptn($ptn);
185            print "!!! broken tile z$vz $vx,$vy\n";
186            $tv = 0;
187        }
188        $tagsversion{$f} = $tv;
189        commontags($tv) if ($tv && !defined($comtags[$tv]));
190        our %togc;
191        $togc{$ptn} = $cachecount unless($tv == TAGSVERSION || $mode eq '<');
192    }
193    # keep a cache of the most recently opened 500 files
194    if ($opened++ > MAXOPEN) {
195        print "Cache full after $hits hits and $misses misses\n"
196            if (VERBOSE > 10);
197        my @toclose =
198            sort {${$filecache{$a}}[1] <=> ${$filecache{$b}}[1]} keys %filecache;
199        while ($opened > KEEPOPEN) {
200            my $toclose = shift @toclose;
201#           if ($toclose =~ /data$/) {
202#               delete $tagsversion{$filecache{$toclose}->[0]};
203#           }
204            delete $filecache{$toclose};
205            $opened--;
206        }
207    }
208    $misses++;
209    $filecache{$ptnname} = [$f, ++$cachecount];
210    return $f;
211}
212
213# print openptn cache statistics
214sub cachestat {
215    our ($hits, $misses);
216    my $c = $hits/($hits + $misses) * 100;
217    print "Hits: $hits Misses: $misses  Cache: $c\%\n";
218}
219
220# get rid of cache associated with ptn
221sub flushptn($) {
222    my ($ptn) = @_;
223    our (%filecache, $opened);
224    foreach my $name ("data", "nodes", "ways", "relations") {
225        my $ptnname = $ptn.$name;
226        if (exists $filecache{$ptnname}) {
227            delete $tagsversion{$filecache{$ptnname}->[0]}
228                if ($name eq "data");
229            delete $filecache{$ptnname};
230            $opened--;
231        }
232    }
233}
234
235# force the file buffers to be written to disk
236sub writecache() {
237    our (%filecache);
238    my $select = select;
239    while (my ($k, $f) = each %filecache) {
240        select ${$f}[0];
241        $| = 1;
242        $| = 0;
243    }
244    select NODES;
245    $| = 1;
246    $| = 0;
247    select WAYS;
248    $| = 1;
249    $| = 0;
250    select RELATIONS;
251    $| = 1;
252    $| = 0;
253    select ZOOMS;
254    $| = 1;
255    $| = 0;
256    select $select;
257}
258
259# close all files
260sub closeall {
261    our (%filecache, $opened);
262    while (my $ptn = each %filecache) {
263        delete $filecache{$ptn};
264    }
265    $opened = 0;
266    close NODES;
267    close WAYS;
268    close RELATIONS;
269    close ZOOMS;
270}
271
272# get a null-terminated string from a file
273sub gets($) {
274    my ($f) = @_;
275    my $s = "";
276    my $c;
277    while (defined($c = getc($f))) {
278        if ($c eq "\0") {
279            return $s;
280        }
281        $s .= $c;
282    }
283    return $s;
284}
285
286# return or set ptn of a node
287sub nodeptn {
288    my ($node, $ptn) = @_;
289    seek NODES, $node * 4, 0;
290    if (defined $ptn) {
291        print NODES $ptn;
292    } else {
293        $ptn = NOPTN unless(read NODES, $ptn, 4);
294    }
295    return $ptn;
296}
297
298# return or set ptn of a way
299sub wayptn {
300    my ($way, $ptn) = @_;
301    seek WAYS, $way * 4, 0;
302    if (defined $ptn) {
303        print WAYS $ptn;
304    } else {
305        $ptn = NOPTN unless(read WAYS, $ptn, 4);
306    }
307    return $ptn;
308}
309
310# return or set ptn of a relation
311sub relationptn {
312    my ($relation, $ptn) = @_;
313    seek RELATIONS, $relation * 4, 0;
314    if (defined $ptn) {
315        print RELATIONS $ptn;
316    } else {
317        $ptn = NOPTN unless(read RELATIONS, $ptn, 4);
318    }
319    return $ptn;
320}
321
322
323# get lat and lon of the corners of a tile
324# based on wiki.openstreetmap.org/index.php/Slippy_map_tilenames
325sub Project {
326    my ($X,$Y, $Zoom) = @_;
327    my $Unit = 1 / (1 << $Zoom);
328    my $relY1 = $Y * $Unit;
329    my $relY2 = $relY1 + $Unit;
330   
331    # note: $LimitY = ProjectF(degrees(atan(sinh(pi)))) = log(sinh(pi)+cosh(pi)) = pi
332    # note: degrees(atan(sinh(pi))) = 85.051128..
333    #my $LimitY = ProjectF(85.0511);
334   
335    # so stay simple and more accurate
336    my $LimitY = pi;
337    my $RangeY = 2 * $LimitY;
338    $relY1 = $LimitY - $RangeY * $relY1;
339    $relY2 = $LimitY - $RangeY * $relY2;
340    my $Lat1 = ProjectMercToLat($relY1);
341    my $Lat2 = ProjectMercToLat($relY2);
342    $Unit = 360 / (1 << $Zoom);
343    my $Long1 = -180 + $X * $Unit;
344    return(($Lat2, $Long1, $Lat1, $Long1 + $Unit)); # S,W,N,E
345}
346sub ProjectMercToLat($){
347    my $MercY = shift();
348    return( 180/pi* atan(sinh($MercY)));
349}
350sub ProjectF
351{
352    my $Lat = shift;
353    $Lat = deg2rad($Lat);
354    my $Y = log(tan($Lat) + (1/cos($Lat)));
355    return($Y);
356}
357
358# find the tiles this relation is in
359sub reltiles($) {
360    my @members = @{shift @_};
361    our (%waycache, $wch, $wcm);
362    my (%tiles, %wtodo, %rdone, %rtodo);
363    foreach my $m (@members) {
364        my ($type, $id, $role) = @$m;
365        if ($type == NODE) {
366            $tiles{nodeptn($id)}++;
367        } elsif ($type == WAY) {
368            my $t = wayptn($id);
369            if (exists $wtodo{$t}) {
370                ${$wtodo{$t}}{$id}++;
371            } else {
372                $wtodo{$t} = {$id => 1};
373            }
374        } elsif ($type == RELATION) {
375            my $t = relationptn($id);
376            $rtodo{$t} //= {};
377            $rtodo{$t}->{$id}++;
378        } else {
379            die "Unknown relation $id type $type";
380        }
381    }
382    # can't use foreach because %rtodo can change
383    while (my @rt = keys %rtodo) {
384        while (my $t = shift @rt) {
385            my %rthis = %{$rtodo{$t}};
386            delete $rtodo{$t};
387            my $rf = openptn($t, "relations");
388            my $df = openptn($t, "data");
389            seek $rf, 0, 0;
390            while (my ($r, $off) = readrel($rf)) {
391                last unless (defined $r);
392                next unless ($r && exists $rthis{$r});
393                print "  relation $r\n" if (VERBOSE > 200);
394                $rdone{$r}++;
395                unless ($off) {
396                    my ($uz, $ux, $uy) = fromptn($t);
397                    print "!!! relation $r not in tile $uz $ux,$uy\n" if (VERBOSE > 4);
398                    next;
399                }
400                seek $df, $off, 0;
401                my @mm = readmemb($df);
402                foreach my $mi (@mm) {
403                    my ($type, $n, $role) = @$mi;
404                    if ($type == NODE) {
405                        $tiles{nodeptn($n)}++;
406                    } elsif ($type == WAY) {
407                        if (exists $waycache{$n}) {
408                            print "    Way cache hit: $n\n" if (VERBOSE > 999);
409                            $wch++;
410                            if (ref($waycache{$n})) {
411                                foreach my $p (@{$waycache{$n}}) {
412                                    $tiles{$p}++;
413                                }
414                            } else {
415                                $tiles{$waycache{$n}}++;
416                            }
417                        } else {
418                            $wcm++;
419                            my $wp = wayptn($n);
420                            $wtodo{$wp} //= {};
421                            $wtodo{$wp}->{$n}++;
422                        }
423                    } elsif ($type == RELATION) {
424                        next if(exists $rdone{$n});
425                        my $rrp = relationptn($n);
426                        $rtodo{$rrp} //= {};
427                        $rtodo{$rrp}->{$n}++;
428                    } else {
429                        die "Unknown relation $r type $type";
430                    }
431                }
432            }
433        }
434    }
435    foreach my $t (keys %wtodo) {
436        $tiles{$t}++;
437        my %wthis = %{$wtodo{$t}};
438        my $wf = openptn($t, "ways");
439        my $df = openptn($t, "data");
440        seek $wf, 0, 0;
441        while (my ($w, $off) = readway($wf)) {
442            last unless (defined $w);
443            next unless ($w && $off && exists $wthis{$w});
444            seek $df, $off, 0;
445            my @nodes = readwaynodes($df);
446            my %wt;
447            foreach my $n (@nodes) {
448                my $p = nodeptn($n);
449                $wt{$p}++;
450                $tiles{$p}++;
451            }
452            my @k = keys %wt;
453            if (scalar(@k) > 1) {
454                $waycache{$w} = [@k];
455            } else {
456                $waycache{$w} = $k[0];
457            }
458        }
459    }
460    print "      waycache hits: $wch misses: $wcm\n" if (VERBOSE > 10);
461    return %tiles;
462}
463
464# split a tile into 4 of next zoom level
465sub splitptn($) {
466    my ($ptn) = @_;
467    my ($ez, $ex, $ey) = fromptn($ptn);
468    return(0) if ($ez >= MAXZOOM);
469    our %waycache;
470    writecache();
471    print "Splitting z$ez $ex,$ey\n" if (VERBOSE > 2);
472    my $nd = openptn($ptn, "data");
473    my $nz = $ez + 1;
474    my $fz = 1 << (MAXZOOM - $nz);
475    my $bx = $ex << (MAXZOOM - $nz);
476    my $bxx = $bx + $fz;
477    my $by = $ey << (MAXZOOM - $nz);
478    for (my $xx = $bx; $xx < $bxx; $xx++) {
479        seek ZOOMS, ($xx << (MAXZOOM-1)) | $by, 0;
480        print ZOOMS pack("C", $nz) x $fz;
481    }
482    my ($nf, $nnf, %nf, $nnd, %nd, %n, %wf, %w, $n);
483    $nf = openptn($ptn, "nodes");
484    seek $nf, 0, 0;
485    while (my ($nid, $nlat, $nlon, $noff) = readnode($nf)) {
486        last unless(defined $nid);
487        next unless($nid);
488        my ($nx, $ny) = getTileNumber($nlat/CONV, $nlon/CONV, $nz);
489        print "moving node $nid to z$nz $nx,$ny\n" if (VERBOSE > 30);
490        my $p = toptn($nz, $nx, $ny);
491        unless ($nnf = $nf{$p}) {
492            $nnf = openptn($p, "nodes");
493            seek $nnf, 0, 2;
494            $nf{$p} = $nnf;
495        }
496        my ($nnoff);
497        if ($noff) {
498            unless ($nnd = $nd{$p}) {
499                $nnd = openptn($p, "data");
500                seek $nnd, 0, 2;
501                $nd{$p} = $nnd;
502            }
503            $nnoff = tell($nnd);
504            seek $nd, $noff, 0;
505            my @tv = readtags($nd, NODE);
506            printtags($nnd, \@tv, NODE);
507        } else {
508            $nnoff = 0;
509        }
510        printnode($nnf, $nid, $nlat, $nlon, $nnoff);
511        nodeptn($nid,$p);
512        $n{$nid} = $p;
513    }
514    my $wf = openptn($ptn, "ways");
515    seek $wf, 0, 0;
516    my $w;
517    while (my ($wid, $woff) = readway($wf)) {
518        last unless (defined $wid);
519        next unless($wid);
520        delete $waycache{$wid};
521        print "Way $wid\n" if (VERBOSE > 4);
522        if ($woff) {
523            my %w;
524            seek $nd, $woff, 0;
525            my @nodes = readwaynodes($nd);
526            foreach my $nn (@nodes) {
527                if ($n{$nn}) {
528                    $w{$n{$nn}} = 1;
529                }
530            }
531            my $first = 1;
532            foreach my $p (keys %w) {
533                my $nnoff;
534                if ($first) {
535                    if (VERBOSE > 4) {
536                        my ($uz, $ux, $uy) = fromptn($p);
537                        print " moved to z$uz $ux,$uy\n";
538                    }
539                    unless ($nnd = $nd{$p}) {
540                        $nnd = openptn($p, "data");
541                        seek $nnd, 0, 2;
542                    }
543                    $nnoff = tell $nnd;
544                    printwaynodes($nnd, \@nodes);
545                    my @tv = readtags($nd, WAY);
546                    printtags($nnd, \@tv, WAY);
547                    wayptn($wid,$p);
548                    $first = 0;
549                } else {
550                    if (VERBOSE > 4) {
551                        my ($uz, $ux, $uy) = fromptn($p);
552                        print "  also in z$uz $ux,$uy\n";
553                    }
554                    $nnoff = 0;
555                }
556                my $nwf;
557                unless ($nwf = $wf{$p}) {
558                    $nwf = openptn($p, "ways");
559                    $wf{$p} = $nwf;
560                }
561                seek $nwf, 0, 2;
562                printway($nwf, $wid, $nnoff);
563            }
564            if ($first) {
565                my $p = nodeptn($nodes[0]);
566                $p = toptn(0,1,1) if ($p eq NOPTN);
567                if (VERBOSE > 4) {
568                    my ($uz, $ux, $uy) = fromptn($p);
569                    print " moved to z$uz $ux,$uy\n";
570                }
571                $nnd = openptn($p, "data");
572                seek $nnd, 0, 2;
573                my $nnoff = tell $nnd;
574                printwaynodes($nnd, \@nodes);
575                my @tv = readtags($nd, WAY);
576                printtags($nnd, \@tv, WAY);
577                my $nwf = openptn($p, "ways");
578                seek $nwf, 0, 0;
579                my $mt;
580                while (my ($w, $woff) = readway($nwf)) {
581                    last unless(defined $w);
582                    $mt //= tell($nwf) unless($w);
583                    next unless ($w == $wid);
584                    $mt = tell($nwf);
585                    last;
586                }
587                seek $nwf, $mt-8, 0 if ($mt);
588                printway($nwf, $wid, $nnoff);
589                wayptn($wid,$p);
590            }
591        } else {
592            my $wptn = wayptn($wid);
593            my $nwf = openptn($wptn, "ways");
594            seek $nwf, 0, 0;
595            while (my ($ww, $wwoff) = readway($nwf)) {
596                last unless (defined $ww);
597                next unless ($ww == $wid);
598                my $nwd = openptn($wptn, "data");
599                seek $nwd, $wwoff, 0;
600                my @nodes = readwaynodes($nwd);
601                foreach my $nn (@nodes) {
602                    if ($n{$nn}) {
603                        $w{$n{$nn}} = 1;
604                    }
605                }
606                my $nwf;
607                foreach my $p (keys %w) {
608                    if (VERBOSE > 4) {
609                        my ($uz, $ux, $uy) = fromptn($p);
610                        print "  in z$uz $ux,$uy\n";
611                    }
612                    unless ($nwf = $wf{$p}) {
613                        $nwf = openptn($p, "ways");
614                        $wf{$p} = $nwf;
615                    }
616                    seek $nwf, 0, 2;
617                    printway($nwf, $wid, 0);
618                }
619                last;
620            }
621        }
622    }
623    my $rf = openptn($ptn, "relations");
624    my $rfp = 0;
625    my $nx = $ex << 1;
626    my $ny = $ey << 1;
627    my (%t, %rf);
628    $t{toptn($nz,$nx,$ny)} = 1;
629    $t{toptn($nz,$nx+1,$ny)} = 1;
630    $t{toptn($nz,$nx,$ny+1)} = 1;
631    $t{toptn($nz,$nx+1,$ny+1)} = 1;
632    for(;;) {
633        seek $rf, $rfp, 0;      # reltiles may have moved the file pointer
634        my ($rid, $roff);
635        last unless ((($rid, $roff) = readrel($rf)) && defined($rid));
636        $rfp = tell $rf;
637        next unless($rid);
638        print "relation $rid\n" if (VERBOSE > 4);
639        my %tiles = reltiles([[RELATION, $rid]]);
640        my (@members, @tv);
641        my $first = ($roff != 0);
642        if ($first) {
643            seek $nd, $roff, 0;
644            @members = readmemb($nd);
645            @tv = readtags($nd, RELATION);
646        }
647        foreach my $t (keys %t) {
648            next unless (exists $tiles{$t});
649            my ($nnoff);
650            if ($first) {
651                unless ($nnd = $nd{$t}) {
652                    $nnd = openptn($t, "data");
653                    seek $nnd, 0, 2;
654                }
655                seek $nnd, 0, 2;
656                $nnoff = tell $nnd;
657                printmemb($nnd, \@members);
658                printtags($nnd, \@tv, RELATION);
659                relationptn($rid,$t);
660                $first = 0;
661            } else {
662                $nnoff = 0;
663            }
664            my $nrf;
665            unless ($nrf = $rf{$t}) {
666                $nrf = openptn($t, "relations");
667                $rf{$t} = $nrf;
668            }
669            if (VERBOSE > 4) {
670                my ($uz, $ux, $uy) = fromptn($t);
671                if ($nnoff) {
672                    print "  moved to z$uz $ux,$uy\n";
673                } else {
674                    print "  in z$uz $ux,$uy\n";
675                }
676            }
677            seek $nrf, 0, 2;
678            printrel($nrf, $rid, $nnoff);
679        }
680        if ($first) {
681            my $t = each %tiles;
682            unless (defined $t) {
683                print "missing relation $rid\n" if (VERBOSE > 1);
684                next;
685            }
686            $nnd = openptn($t, "data");
687            seek $nnd, 0, 2;
688            my $nnoff = tell $nnd;
689            printmemb($nnd, \@members);
690            printtags($nnd, \@tv, RELATION);
691            my $nrf = openptn($t, "relations");
692            if (VERBOSE > 4) {
693                my ($uz, $ux, $uy) = fromptn($t);
694                print "  moved to z$uz $ux,$uy\n";
695            }
696            seek $nrf, 0, 0;
697            my ($mt);
698            while (my ($r, $roff) = readrel($nrf)) {
699                last unless (defined $r);
700                $mt //= tell($nrf) unless ($r);
701                next unless ($r == $rid);
702                $mt = tell($nrf);
703                last;
704            }
705            seek $nrf, $mt-8, 0 if($mt);
706            printrel($nrf, $rid, $nnoff);
707            relationptn($rid,$t);
708        }
709    }
710    flushptn($ptn);
711    rmtree("z$ez/$ex/$ey",{});
712    return 1;
713}
714
715# vnum are variable-length numbers.  1 byte is up to 127, 2 up to 16511,
716# 3 up to 2113663, 4 up to 270549119
717sub printvnum($$) {
718    my ($f, $v) = @_;
719#    print " printvnum($v)\n" if (VERBOSE > 995);
720    if ($v >= 128) {
721        $v -= 128;
722        if ($v >= 16384) {
723            $v -= 16384;
724            if ($v >= 2097152) {
725                $v -= 2097152;
726                print $f pack "C4", (224 + ($v>>24)), (($v>>16) & 0xff),
727                    (($v>>8) & 0xff, $v & 0xff);
728            } else {
729                print $f pack "C3", (192 + ($v>>16)), (($v>>8) & 0xff),
730                    ($v & 0xff);
731            }
732        } else {
733            print $f pack "C2", (128 + ($v>>8)), ($v & 0xff);
734        }
735    } else {
736        print $f pack "C", $v;
737    }
738}
739
740sub getvnum($) {
741    my ($f) = @_;
742    my $c = getc($f);
743    return undef unless(defined $c);
744    my $v = unpack "C", $c;
745    if ($v >= 128) {
746        if ($v >= 192) {
747            if ($v >= 224) {
748                $v -= 224;
749                $v <<= 8;
750                $v += unpack "C", getc($f);
751                $v <<= 8;
752                $v += unpack "C", getc($f);
753                $v <<= 8;
754                $v += unpack("C", getc($f)) + 2097152 + 16384 + 128;
755                return $v;
756            }
757            $v -= 192;
758            $v <<= 8;
759            $v += unpack "C", getc($f);
760            $v <<= 8;
761            $v += unpack("C", getc($f)) + 16384 + 128;
762            return $v;
763        }
764        $v -= 128;
765        $v <<= 8;
766        $v += unpack("C", getc($f)) + 128;
767    }
768    return $v;
769}
770   
771       
772
773sub printtags($$$) {
774    my ($f, $tags, $t) = @_;
775    my @tags = @$tags;
776    my $tagsver = tv_check($f);
777    my $h = $tagsver ? $comtags[$tagsver]->[$t] : undef;
778    while (my $tag = shift @tags) {
779        my $val = shift @tags;
780        print "  k=$tag v=$val tagsver=$tagsver\n" if (VERBOSE > 99);
781        if ($tagsver) {
782            my $tn = $h->[0]->{$tag};
783            if ($tn) {
784                printvnum($f, $tn);
785                my $vn;
786                if (defined $h->[2]->{$tag}) {
787                    $vn = $h->[2]->{$tag}->{$val} // 0;
788                    if ($vn) {
789                        printvnum($f, $vn);
790                    } else {
791                        print $f pack("C",0)."$val\0";
792                    }
793                } else {
794                    $vn = '';
795                    print $f "$val\0";
796                }
797                print "    tn=$tn vn=$vn\n" if (VERBOSE > 99);
798            } else {
799                print $f pack("C",1)."$tag\0$val\0";
800            }
801        } else {
802            print $f "$tag\0$val\0";
803        }
804    }
805    print $f "\0";
806    print "  next off ".tell($f)."\n" if (VERBOSE > 99);
807}
808
809sub readtags($$) {
810    my ($f, $t) = @_;
811    my @tags;
812    my $tagsver = tv_check($f);
813    if ($tagsver) {
814        my $a = $comtags[$tagsver]->[$t];
815        while (my $c = getvnum($f)) {
816            if ($c == 1) {
817                my $tag = gets($f);
818                my $val = gets($f);
819                push @tags, $tag, $val;
820            } else {
821                push @tags, $a->[1]->[$c];
822                if (defined $a->[3]->[$c]) {
823                    my $i = getvnum($f);
824                    print "  tn=$c vn=$i\n" if (VERBOSE > 990);
825                    if ($i) {
826                        push @tags, $a->[3]->[$c]->[$i];
827                    } else {
828                        push @tags, gets($f);
829                    }
830                } else {
831                    push @tags, gets($f);
832                }
833            }
834        }
835    } else {
836        my $tag;
837        while (defined($tag = gets($f))) {
838            last if ($tag eq "");
839            my $val = gets($f);
840            push @tags, $tag, $val;
841        }
842    }
843    return @tags;
844}
845
846sub printmemb($$) {
847    my ($f, $memb) = @_;
848    my @members = @$memb;
849    my $tagsver = tv_check($f);
850    my $h = $tagsver ? $comtags[$tagsver]->[ROLE]->[0] : undef;
851    while (my $m = shift @members) {
852        print $f pack("CN", $m->[0], $m->[1]);
853        my $role = $m->[2];
854        if ($tagsver) {
855            if (exists $h->{$role}) {
856                printvnum($f, $h->{$role});
857            } else {
858                print $f pack("C", 0).$role."\0";
859            }
860        } else {
861            print $f "$role\0";
862        }
863    }
864    print $f pack "C", NONE;
865}
866
867sub readmemb($) {
868    my ($f) = @_;
869    my @members;
870    my ($b, $role);
871    my $tagsver = tv_check($f);
872    my $a = $tagsver ? $comtags[$tagsver]->[ROLE]->[1] : undef;
873    while (defined($b = getc($f))) {
874        my ($type) = unpack "C", $b;
875        last unless($type);
876        last unless(read $f, $b, 4);
877        my ($id) = unpack "N", $b;
878        my $r = $tagsver ? getvnum($f) : 0;
879        if ($r) {
880            $role = $a->[$r];
881        } else {
882            $role = gets($f);
883        }
884        push @members, [$type, $id, $role];
885    }
886    return @members;
887}
888
889sub readnode($) {
890    my ($f) = @_;
891    my $b;
892    read $f, $b, 16 or return undef;
893    return unpack "NN!N!N", $b;
894}
895
896sub readway($) {
897    my ($f) = @_;
898    my $b;
899    read $f, $b, 8 or return undef;
900    return unpack "NN", $b;
901}
902
903sub readrel($) {
904    my ($f) = @_;
905    my $b;
906    read $f, $b, 8 or return undef;
907    return unpack "NN", $b;
908}
909
910sub readwaynodes($) {
911    my ($f) = @_;
912    my ($b);
913    if (tv_check($f)) {
914        my $nodes = getvnum($f) // 0;
915        print "reading $nodes nodes\n" if (VERBOSE > 99);
916        read $f, $b, (4 * $nodes);
917        return unpack("N$nodes", $b);
918    } else {
919        my @nodes;
920        while (read $f, $b, 4) {
921            my $n = unpack "N", $b;
922            last unless ($n);
923            push @nodes, $n;
924        }
925        return @nodes;
926    }
927}
928
929sub printnode($$$$$) {
930    my ($f, $id, $lat, $lon, $off) = @_;
931    print $f pack "NN!N!N", $id, $lat, $lon, $off;
932}
933
934sub printway($$$) {
935    my ($f, $id, $off) = @_;
936    print $f pack "NN", $id, $off;
937}
938
939sub printrel($$$) {
940    my ($f, $id, $off) = @_;
941    print $f pack "NN", $id, $off;
942}
943
944sub printwaynodes($$) {
945    my ($f, $n) = @_;
946    my $nodes = scalar(@$n);
947    print "saving $nodes nodes\n" if (VERBOSE > 99);
948    if (tv_check($f)) {
949        printvnum($f, $nodes);
950        print $f pack "N$nodes", @$n;
951    } else {
952        print $f pack "N$nodes", @$n;
953        print $f PZ;
954    }
955    print " tags at ".tell($f)."\n" if (VERBOSE > 99);
956}
957
958sub tv_check($) {
959    my ($f) = @_;
960    my $tv = $tagsversion{$f};
961    return $tv if (defined $tv);
962    print "!!! undefined tagsversion\n" if (VERBOSE > 4);
963    my $loc = tell $f;
964    seek $f, 0, 0;
965    $tv = getvnum($f) // 0;
966    $tagsversion{$f} = $tv;
967    seek $f, $loc, 0;
968    return $tv;
969}
970
971# garbagecollect a single tile
972sub gcptn($) {
973    my ($ptn) = @_;
974    flushptn($ptn);
975    my ($z, $x, $y) = fromptn($ptn);
976    print "Garbagecollect: z$z $x,$y\n" if (VERBOSE > 4);
977    my ($df, $ndf, $nf, $nnf, $wf, $nwf, $rf, $nrf, $b);
978    if (open $df, "<", "z$z/$x/$y/data") {
979        $tagsversion{$df} = getvnum($df);
980        open $ndf, ">", "z$z/$x/$y/data.new";
981        printvnum($ndf, TAGSVERSION);
982        $tagsversion{$ndf} = TAGSVERSION;
983        commontags(TAGSVERSION) unless (defined $comtags[TAGSVERSION]);
984    } else {
985        $df = $devnull;
986        $ndf = undef;
987    }
988    if (open $nf, "<", "z$z/$x/$y/nodes") {
989        open $nnf, ">", "z$z/$x/$y/nodes.new";
990    } else {
991        $nf = $devnull;
992        $nnf = undef;
993    }
994    if (open $wf, "<", "z$z/$x/$y/ways") {
995        open $nwf, ">", "z$z/$x/$y/ways.new";
996    } else {
997        $wf = $devnull;
998        $nwf = undef;
999    }
1000    if (open $rf, "<", "z$z/$x/$y/relations") {
1001        open $nrf, ">", "z$z/$x/$y/relations.new";
1002    } else {
1003        $rf = $devnull;
1004        $nrf = undef;
1005    }
1006    my %seen;
1007    while (my ($n, $lat, $lon, $off) = readnode($nf)) {
1008        last unless (defined $n);
1009        next unless ($n);
1010        if (exists $seen{$n}) {
1011            print "Duplicate node $n in tile z$z $x,$y\n";
1012            next;
1013        }
1014        my $noff = 0;
1015        if ($off) {
1016            seek $df, $off, 0;
1017            $noff = tell $ndf;
1018            my @tags = readtags($df, NODE);
1019            printtags($ndf, \@tags, NODE);
1020        }
1021        printnode($nnf, $n, $lat, $lon, $noff);
1022        $seen{$n} = 1;
1023        my $oldptn = nodeptn($n);
1024        if (defined $oldptn && $oldptn ne NOPTN) {
1025            if ($oldptn ne $ptn) {
1026                my ($uz, $ux, $uy) = fromptn($oldptn);
1027                print "  node $n is actually in tile z$z $x,$y not z$uz $ux,$uy\n";
1028#                   nodeptn($n, $ptn);
1029            }
1030        } else {
1031            print "  node $n is in tile z$z $x,$y not deleted\n";
1032#               nodeptn($n, $ptn);
1033        }
1034    }
1035    %seen = ();
1036    while (my ($w, $off) = readway($wf)) {
1037        last unless (defined $w);
1038        next unless ($w);
1039        if (exists $seen{$w}) {
1040            print "Duplicate way $w\n";
1041            next;
1042        }
1043        my $noff = 0;
1044        if ($off) {
1045            seek $df, $off, 0;
1046            $noff = tell $ndf;
1047            my @nodes = readwaynodes($df);
1048            my @tags = readtags($df, WAY);
1049            printwaynodes($ndf, \@nodes);
1050            printtags($ndf, \@tags, WAY);
1051        }
1052        $seen{$w} = 1;
1053        my $oldptn = wayptn($w);
1054        if (defined $oldptn) {
1055            if ($off && ($ptn ne $oldptn)) {
1056                my ($ux, $uy, $uz) = fromptn($oldptn);
1057                print "  way $w is actually in z$z $x,$y not z$uz $ux,$uy\n";
1058#                   wayptn($w, $ptn);
1059            }
1060            printway($nwf, $w, $noff);
1061        } else {
1062            if ($off) {
1063                print "  way $w is actually in z$z $x,$y not deleted\n";
1064#                   wayptn($w, $ptn);
1065#                   printway($nwf, $w, $noff);
1066            } else {
1067                print "  way $w is deleted, not in z$z $x,$y\n";
1068            }
1069        }
1070    }
1071    %seen = ();
1072    while (my ($r, $off) = readrel($rf)) {
1073        last unless (defined $r);
1074        next unless ($r);
1075        if (exists $seen{$r}) {
1076            print "Duplicate relation $r\n";
1077            next;
1078        }
1079        my $noff = 0;
1080        if ($off) {
1081            seek $df, $off, 0;
1082            $noff = tell $ndf;
1083            my @members = readmemb($df);
1084            printmemb($ndf, \@members);
1085            my @tags = readtags($df, RELATION);
1086            printtags($ndf, \@tags, RELATION);
1087        }
1088        my $oldptn = relationptn($r);
1089        if (defined $oldptn && $oldptn ne NOPTN) {
1090            if ($off && ($ptn ne $oldptn)) {
1091                my ($uz, $ux, $uy) = fromptn($oldptn);
1092                print "  relation $r is actually in z$z $x,$y not z$uz $ux,$uy\n";
1093#                   relationptn($r, $ptn);
1094            } else {
1095                printrel($nrf, $r, $noff);
1096            }
1097        } else {
1098            if ($off && $z != 0) {
1099                print "  relation $r is actually in z$z $x,$y not deleted\n";
1100#                   relationptn($r, $ptn);
1101#                   printrel($nrf, $r, $noff);
1102            } else {
1103                print "  relation $r is deleted, not in z$z $x,$y\n";
1104            }
1105        }
1106    }
1107    if (defined $ndf) {
1108        delete $tagsversion{$df};
1109        close $df;
1110        delete $tagsversion{$ndf};
1111        close $ndf;
1112        rename "z$z/$x/$y/data.new","z$z/$x/$y/data";
1113    }
1114    if (defined $nnf) {
1115        close $nf;
1116        close $nnf;
1117        rename "z$z/$x/$y/nodes.new","z$z/$x/$y/nodes";
1118    }
1119    if (defined $nwf) {
1120        close $wf;
1121        close $nwf;
1122        rename "z$z/$x/$y/ways.new","z$z/$x/$y/ways";
1123    }
1124    if (defined $nrf) {
1125        close $rf;
1126        close $nrf;
1127        rename "z$z/$x/$y/relations.new","z$z/$x/$y/relations";
1128    }
1129}
1130
11311;
1132
Note: See TracBrowser for help on using the repository browser.