source: subversion/applications/rendering/tahNG/development/tahlib.pm @ 29350

Last change on this file since 29350 was 7689, checked in by deelkar, 11 years ago

add lines2curces beziercurvehinting

File size: 20.6 KB
Line 
1use strict; 
2
3# =====================================================================
4# The following is duplicated from tilesGen.pl
5# =====================================================================
6
7my $lastmsglen = 0;
8
9my $idleFor = 0;
10my $idleSeconds = 0;
11
12my %faults; #variable to track non transient errors
13
14# hash for MagicMkdir
15my %madeDir;
16
17#-----------------------------------------------------------------------------
18# Prints status message without newline, overwrites previous message
19# (if $newline set, starts new line after message)
20#-----------------------------------------------------------------------------
21sub statusMessage 
22{
23    my ($msg, $currentSubTask, $progressJobs, $progressPercent, $newline) = @_;
24    my $Config = $main::Config;
25   
26    my $toprint = sprintf("[#%d %3d%% %s] %s%s ", $progressJobs, $progressPercent+.5, $currentSubTask, $msg, ($newline) ? "" : "...");
27
28    if ($Config->get("Verbose"))
29    {
30        print STDERR "$toprint\n";
31        return;
32    }
33
34    my $curmsglen = length($toprint);
35    print STDERR "\r$toprint";
36    print STDERR " " x ($lastmsglen-$curmsglen);
37    if ($newline)
38    {
39        $lastmsglen = 0;
40        print STDERR "\n";
41    }
42    else
43    {
44        $lastmsglen = $curmsglen;
45    }
46
47}
48
49#-----------------------------------------------------------------------------
50# Used to display task completion. Only for verbose mode.
51#-----------------------------------------------------------------------------
52sub doneMessage
53{
54    my $msg = shift();
55    my $Config = $main::Config;
56
57    $msg = "done" if ($msg eq "");
58
59    if ($Config->get("Verbose"))
60    {
61        print STDERR "$msg\n";
62        return;
63    }
64}
65
66#-----------------------------------------------------------------------------
67# A sleep function with visible countdown
68#-----------------------------------------------------------------------------
69sub talkInSleep
70{
71    my ($message, $duration,$progstart) = @_;
72    my $Config = $main::Config;
73    if ($Config->get("Verbose"))
74    {
75        print STDERR "$message: sleeping $duration seconds\n";
76        sleep $duration;
77        return;
78    }
79
80    for (my $i = 0; $i< $duration; $i++)
81    {
82        my $totalseconds = time() - $progstart;
83        statusMessage(sprintf("%s. Idle for %d:%02d (%d%% idle) ", 
84                $message,
85                $idleFor/60, $idleFor%60,
86                $totalseconds ? $idleSeconds * 100 / $totalseconds : 100));
87        sleep 1;
88        $idleFor++;
89        $idleSeconds++;
90    }
91}
92
93sub setIdle
94{
95    my ($idle,$setTotal) = @_;
96    if ($setTotal)
97    {
98        $idleSeconds = $idle;
99    }
100    else
101    {
102        $idleFor = $idle;
103    }
104}
105
106sub getIdle
107{
108    my $getTotal = @_;
109    if ($getTotal)
110    {
111      return $idleSeconds;
112    }
113    else
114    {
115      return $idleFor;
116    }
117}
118
119
120#-----------------------------------------------------------------------------
121# fault handling
122#-----------------------------------------------------------------------------
123sub addFault
124{
125    my ($faulttype,$diff) = @_;
126    $diff = 1 if (not $diff);
127    $faults{$faulttype} += $diff;
128    return $faults{$faulttype};
129}
130
131sub getFault
132{
133    my ($faulttype) = @_;
134    return $faults{$faulttype};
135}
136
137sub resetFault
138{
139    my ($faulttype) = @_;
140    $faults{$faulttype} = 0;
141    return "0 but true";
142}
143
144#-----------------------------------------------------------------------------
145# Run a shell command. Suppress command's stderr output unless it terminates
146# with an error code.
147#
148# Return 1 if ok, 0 on error.
149#-----------------------------------------------------------------------------
150sub runCommand
151{
152    my ($cmd,$mainPID) = @_;
153    my $Config = $main::Config;
154
155    # $message is deprecated, issue statusmessage prior to exec.
156    # statusMessage($message, $Config{Verbose}, $currentSubTask, $progressJobs, $progressPercent,0);
157
158
159    if ($Config->get("Verbose"))
160    {
161        my $retval = system($cmd);
162        return $retval == 0;
163    }
164
165    my $ErrorFile = $Config->get("WorkingDirectory")."/".$mainPID.".stderr";
166    my $retval = system("$cmd 2> $ErrorFile");
167    my $ok = 0;
168    my $ExtraInfo = "\nAdditional info about the Error(s):\n";
169
170    # <0 means that the process could not start
171    if ($retval < 0)
172    {
173        print STDERR "ERROR:\n";
174        print STDERR "  Could not run the following command:\n";
175        print STDERR "  $cmd\n";
176        print STDERR "  Please check your installation.\n";
177    } 
178    else
179    {
180        # Technically the return value is ($retval >> 8) but if we only look
181        # at that we will miss the situations where the program died due to
182        # a signal. In that case $retval will be the signal that killed it.
183        # So any non-zero value is an error.
184       
185        if ($retval)
186        {
187            print STDERR "ERROR\n";
188            print STDERR "  The following command produced an error message:\n";
189            print STDERR "  $cmd\n";
190            print STDERR "  Debug output follows:\n";
191            open(ERR, $ErrorFile);
192            while(<ERR>)
193            {
194                print STDERR "  | $_";
195                if (grep(/preferences.xml/,$_))
196                {
197                    $ExtraInfo=$ExtraInfo."\n * Inkscape preference file corrupt. Delete ~/.inkscape/preferences.xml to continue";
198                    if ($Config->get("AutoResetInkscapePrefs") == 1)
199                    {
200                        $ExtraInfo=$ExtraInfo."\n   AutoResetInkscapePrefs set, trying to reset ~/.inkscape/preferences.xml";
201                        unlink (glob("~/.inkscape/preferences.xml")) or addFault("fatal",1);
202                    }
203                    else
204                    {
205                        addFault("fatal",1); ## this error is fatal because it needs human intervention before processing can continue
206                    }
207                }
208                elsif (grep(/infinite template recursion/,$_))
209                {
210                    $ExtraInfo=$ExtraInfo."\n * Tile too complex for Xmlstarlet, possibly an excessively long way, or too many maplint errors";
211                }
212            }
213            close(ERR);
214            print STDERR $ExtraInfo."\n\n";
215        }
216        else
217        {
218            $ok = 1;
219        }
220    }
221   
222    killafile($ErrorFile);
223    return $ok;
224}
225
226#-----------------------------------------------------------------------------
227# Delete a file if it exists
228#-----------------------------------------------------------------------------
229sub killafile($){
230  my $file = shift();
231  unlink $file if(-f $file);
232}
233
234#-----------------------------------------------------------------------------
235# Create a directory and all its parent directories
236# (equivalent to a "mkdir -p" on Unix, but stores already-created dirs
237# in a hash to avoid unnecessary system calls)
238#-----------------------------------------------------------------------------
239sub MagicMkdir
240{
241    my $file = shift;
242    my @paths = split("/", $file);
243    pop(@paths);
244    my $dir = (substr($file,0,1) eq "/") ? "/" : "";
245    foreach my $path(@paths)
246    {
247        if ($dir eq "")
248        {
249            $dir .= $path; # how are paths with leading "/" handled now?
250        }
251        else
252        {
253            $dir .= "/".$path;
254        }
255
256        if (!defined($madeDir{$dir}))
257        {
258            mkdir $dir;
259            $madeDir{$dir}=1;
260        }
261    }
262}
263
264#-----------------------------------------------------------------------------
265# GET a URL and save contents to file
266#-----------------------------------------------------------------------------
267sub DownloadFile 
268{
269    my ($URL, $File, $UseExisting) = @_;
270    my $Config = $main::Config;
271
272    my $ua = LWP::UserAgent->new(keep_alive => 1, timeout => $Config->get("DownloadTimeout"));
273    $ua->agent("tilesAtHome");
274    $ua->env_proxy();
275
276    if(!$UseExisting) 
277    {
278        killafile($File);
279    }
280
281    # Note: mirror sets the time on the file to match the server time. This
282    # is important for the handling of JobTime later.
283    $ua->mirror($URL, $File);
284
285    doneMessage(sprintf("done, %d bytes", -s $File));
286}
287
288#-----------------------------------------------------------------------------
289# Merge multiple OSM files into one, making sure that elements are present in
290# the destination file only once even if present in more than one of the input
291# files.
292#
293# This has become necessary in the course of supporting maplint, which would
294# get upset about duplicate objects created by combining downloaded stripes.
295#-----------------------------------------------------------------------------
296sub mergeOsmFiles
297{
298    my ($destFile, $sourceFiles) = @_;
299    my $Config = $main::Config;
300    my $existing = {};
301
302    # If there's only one file, just copy the input to the output
303    if( scalar(@$sourceFiles) == 1 )
304    {
305      copy $sourceFiles->[0], $destFile;
306      killafile ($sourceFiles->[0]) if (! $Config->get("Debug"));
307      return;
308    }
309   
310    open (DEST, "> $destFile");
311
312    print DEST qq(<?xml version="1.0" encoding="UTF-8"?>\n);
313    my $header = 0;
314
315    foreach my $sourceFile(@{$sourceFiles})
316    {
317        open(SOURCE, $sourceFile);
318        while(<SOURCE>)
319        {
320            next if /^\s*<\?xml/;
321            # We want to copy the version number, but only the first time (obviously)
322            # Handle where the input doesn't have a version
323            if (/^\s*<osm.*(?:version=([\d.'"]+))?/)
324            {
325                if( not $header )
326                {
327                    my $version = $1 || "'".$Config->get("OSMVersion")."'";
328                    print DEST qq(<osm version=$version generator="tahlib.pm mergeOsmFiles" xmlns:osmxapi="http://www.informationfreeway.org/osmxapi/0.5">\n);
329                    $header = 1;
330                }
331                next;
332            }
333            last if (/^\s*<\/osm>/);
334            if (/^\s*<(node|segment|way|relation) id=['"](\d+)['"].*(.)>/)
335            {
336                my ($what, $id, $slash) = ($1, $2, $3);
337                my $key = substr($what, 0, 1) . $id;
338                if (defined($existing->{$key}))
339                {
340                    # object exists already. skip!
341                    next if ($slash eq "/");
342                    while(<SOURCE>)
343                    {
344                        last if (/^\s*<\/$what>/);
345                    }
346                    next;
347                }
348                else
349                {
350                    # object didn't exist, note
351                    $existing->{$key} = 1;
352                }
353            }
354            print DEST;
355        }
356        close(SOURCE);
357        killafile ($sourceFile) if (!$Config->get("Debug"));
358    }
359    print DEST "</osm>\n";
360    close(DEST);
361}
362
363#-----------------------------------------------------------------------------
364# cut out a bbox from OSM data, keeping tagged nodes and area types outside
365# the bbox, throw away all other entities that are irrelevant to the bbox.
366#-----------------------------------------------------------------------------
367sub cropDataToBBox # TODO: Get area types to stick
368{
369    my ($bllon, $bllat, $trlon, $trlat, $sourceFile, $destFile) = @_;
370    my $Config = $main::Config;
371    open (SOURCE, $sourceFile) or die("unable to read file $sourceFile");
372    my $KeepNode = {};
373    my $KeepWay = {};
374    my $KeepRelation = {};
375    my ($what, $id, $lat, $lon, $slash);
376    while (<SOURCE>)
377    {
378        if (/^\s*<(node).*id=['"](\d+)['"].*lat=["']([0-9.Ee-]+)["'].*lon=["']([0-9.Ee-]+)["'][^\/>]*(\/?)>/)
379        {
380            ($what, $id, $lat, $lon, $slash)=($1,$2,$3,$4,$5);
381            print "*** $what   id=$id lat=$lat lon=$lon slash=$slash \n" if ($Config->get("Debug") >= 5);
382            die "wrong bbox $bllat, $bllon, $trlat, $trlon" if ($bllat > $trlat or $bllon > $trlon);
383            if ($lat >= $bllat and $lat <= $trlat and $lon >= $bllon and $lon <= $trlon)
384            {
385                $KeepNode->{$id}=10;
386                print " ** Keep node $id for it is in bbox\n" if ($Config->get("Debug") >= 5);
387            }
388            else
389            {
390                print " ** node $id lat=$lat lon=$lon is not in bbox $bllat, $bllon, $trlat, $trlon\n" if ($Config->get("Debug") >= 5);
391                next if ( $slash eq "/" );
392                while(<SOURCE>)
393                {
394                    last if (/^\s*<\/$what>/);
395                    if (/^\s*<tag.*k=['"](.+)['"].*v=['"](.+)['"].*(\/?)>/)
396                    {
397                        my ($key,$value,$subslash) = ($1,$2,$3);# TODO: check for slash not there
398                        if ($key eq "name") #assume label relevant to tile if "name" present
399                        {
400                            print " ** KeepNode before: $KeepNode->{$id} \n" if ($Config->get("Debug") >= 5 and defined($KeepNode->{$id}));
401                            $KeepNode->{$id}=1 unless ($KeepNode->{$id}); #don't overwrite nodes that are already selected by bbox with a "lower" value
402                            print " ** Keep node $id for it has a name\n" if ($Config->get("Debug") >= 5);
403                        }
404                    }
405                }
406            }
407        }
408        elsif (/^\s*<(way|relation).*id=['"](\d+)['"].*(\/?)>/)
409        {
410            ($what, $id, $slash)=($1,$2,$3);
411            ($lat, $lon) = (undef,undef);
412            print "*** $what   id=$id slash=$slash \n" if ($Config->get("Debug") >= 5);
413            next if ( $slash eq "/" );
414            while (<SOURCE>)
415            {
416                last if (/^\s*<\/$what>/);
417                if ($what eq "way") 
418                {
419                    if (/^\s*<nd.*ref=['"](\d+)['"].*(\/?)>/)
420                    {
421                        my ($ref,$subslash) = ($1,$2);# TODO: check for slash not there
422                        $KeepWay->{$id} = 1  if (defined $KeepNode->{$ref} and $KeepNode->{$ref} == 10); # only select way if node is in bbox
423                        print " ** way ".$id." node ".$ref."  KeepNode: ".$KeepNode->{$ref}." \n" if ($Config->get("Debug") >= 5 and defined($KeepNode->{$ref}));
424                    }
425                    elsif (/^\s*<tag k=['"](.*)['"].*v=['"](.*)['"].*/)
426                    {
427                        my ($key,$value) = ($1,$2);
428                        $KeepWay->{$id} = 1  if (keepWayByTag($key,$value));
429                    }
430                }
431                elsif ($what eq "relation") 
432                { 
433                    if (/^\s*<member.*type=['"](way|node|relation)['"].*ref=['"](\d+)['"].*(\/?)>/)
434                    {
435                        my ($type,$ref,$subslash) = ($1,$2,$3);# TODO: check for slash not there
436                        if ($type eq "node")
437                        {
438                            $KeepRelation->{$id} = 1  if ($KeepNode->{$ref} == 10); #only select relation if node is in bbox
439                        }
440                        elsif ($type eq "way")
441                        {
442                            $KeepRelation->{$id} = 1  if ($KeepWay->{$ref});
443                        }
444                        elsif ($type eq "relation")
445                        {
446                            $KeepRelation->{$id} = 1  if ($KeepRelation->{$ref}); # FIXME this only works if the relation referenced has already been checked
447                            # TODO: keep relation if multipolygon or otherwise relevant for rendering relating to bbox.
448                        }
449                    }
450                }
451            }
452        }
453    }
454    seek(SOURCE,0,0); # restart at the beginning and mark all nodes, ways and relations "to keep" that are referenced by already kept relations
455    while(<SOURCE>)
456    {
457        if (/^\s*<(relation).*id=['"](\d+)['"].*(\/?)>/)
458        {
459            ($what,$id,$slash)=($1,$2,$3);
460            if ($KeepRelation->{$id})
461            {
462                next if ( $slash eq "/" );
463                while(<SOURCE>)
464                {
465                    last if (/^\s*<\/$what>/);
466                    if (/^\s*<member.*type=['"](way|node|relation)['"].*ref=['"](\d+)['"].*(\/?)>/)
467                    {
468                        my ($type,$ref,$subslash) = ($1,$2,$3);# TODO: check for slash not there
469                        if ($type eq "node")
470                        {
471                            $KeepNode->{$ref} = 1 if (not $KeepNode->{$ref});
472                        }
473                        elsif ($type eq "way")
474                        { 
475                            $KeepWay->{$ref} = 1;
476                        }
477                        elsif ($type eq "relation")
478                        { 
479                            $KeepRelation->{$ref} = 1; # FIXME this only works correctly if the relation referenced has not already been checked
480                        }
481                    }
482                }
483            }
484        }
485    }
486
487    seek(SOURCE,0,0); # restart at the beginning and mark all nodes "to keep" that are referenced by already kept ways
488    while(<SOURCE>)
489    {
490        if (/^\s*<(way).*id=['"](\d+)['"].*(\/?)>/)
491        {
492            ($what,$id,$slash)=($1,$2,$3);
493            if ($KeepWay->{$id})
494            {
495                next if ( $slash eq "/" );
496                while(<SOURCE>)
497                {
498                    last if (/^\s*<\/$what>/);
499                    if (/^\s*<nd.*ref=['"](\d+)['"].*(\/?)>/)
500                    {
501                        my ($ref,$subslash) = ($1,$2); # TODO: check for slash not there
502                        $KeepNode->{$ref} = 1 if (not $KeepNode->{$ref});
503                    }
504                }
505            }
506        }
507    }
508    seek(SOURCE,0,0);#reset a last time to actually copy data
509    open (DEST, "> $destFile") or die("can't open file $destFile for writing");
510    while (<SOURCE>)
511    {
512        if (/^\s*<(node|way|relation).*id=['"](\d+)['"].*(\/?)>/)
513        {
514            ($what, $id, $slash)=($1,$2,$3);
515            if (($what eq "node" and $KeepNode->{$id}) or ($what eq "way" and $KeepWay->{$id}) or ($what eq "relation" and $KeepRelation->{$id}))
516            {
517                print DEST;
518                next if ( $slash eq "/" );
519                while (<SOURCE>)
520                {
521                    print DEST;
522                    last if (/^\s*<\/$what>/);
523                }
524            }
525        }
526        elsif (/^\s*<(\/?)(osm)[^\/>]*(\/?)(>?)/) # .* matches too greedily so we have to use [^\/>]*
527        {
528            my ($endslash,$what,$slash,$angbr) = ($1,$2,$3,$4);
529            print DEST;
530            print if ($Config->get("Debug") >=5);
531            print "endslash: ".$endslash.", what: ".$what.", slash: ".$slash.", angbr: ".$angbr." -- " if ($Config->get("Debug") > 2);
532            last if (($slash eq "/" and $angbr eq ">") or $endslash eq "/");
533            next if ($angbr eq ">");
534            while (<SOURCE>)
535            {
536                print if ($Config->get("Debug") > 1);
537                print DEST;
538                last if (/>/);
539            }
540        }
541        elsif (/^\s*<\?xml.*\?>/)
542        {
543            print if ($Config->get("Debug") > 1);
544            print DEST;
545        }
546    }
547    close(SOURCE);
548    close(DEST);
549}
550
551#-----------------------------------------------------------------------------
552# check for tags that make us keep this way, i.e. area running around the bbox,
553# TODO: area-names that run into the bbox, etc.
554# area tags: area, leisure, landuse, military, natural,
555#            building*, historic*, ruins*, sport*, tourism*
556#   * =usually small areas. TODO: fix for those.
557#-----------------------------------------------------------------------------
558sub keepWayByTag
559{
560    my ($key,$value) = @_;
561    if ($key =~ /(area|leisure|landuse|military|natural)/) # Landuse and natural should be the main focus.
562    {
563        return 1;
564    }
565    elsif ($key eq "sport" and $value =~ /(soccer|football|tennis|yes)/) # FIXME: get better tag list
566    {
567        return 1;
568    }
569    else
570    {
571        return 0;
572    }
573}
574#-----------------------------------------------------------------------------
575# Clean up temporary files before exit, then exit or return with error
576# depending on mode (loop, xy, ...)
577#-----------------------------------------------------------------------------
578sub cleanUpAndDie
579{
580    my ($Reason,$Mode,$Severity,$mainPID) = @_;
581    my $Config = $main::Config;
582
583    ## TODO: clean up *.tempdir too
584
585    print STDERR "\n$Reason\n" if ($Config->get("Verbose"));
586
587    if (! $Config->get("Debug")) 
588    {
589        opendir (TEMPDIR, $Config->get("WorkingDirectory"));
590        my @files = grep { /$mainPID/ } readdir(TEMPDIR); # FIXME: this will get files from other processes using the same Working Directory for low pids because the numbers will collide with tile coordinates
591        closedir (TEMPDIR);
592        while (my $file = shift @files)
593        {
594             print STDERR "deleting ".$Config->get("WorkingDirectory")."/".$file."\n" if ($Config->get("Verbose"));
595             killafile($Config->get("WorkingDirectory")."/".$file);
596        }
597       
598    }
599   
600    return 0 if ($Mode eq "loop");
601    print STDERR "\n$Reason\n" if (! $Config->get("Verbose")); #print error only once, and only if fatal.
602    exit($Severity);
603}
604
605
6061;
607
Note: See TracBrowser for help on using the repository browser.