source: josm/trunk/scripts/TestHTTPS.pl

Last change on this file was 14920, checked in by stoecker, 7 months ago

see #16123 - use port 443 for tests always, not a specified non-standard port - last variant failed with {switch:...} statements

  • Property svn:executable set to *
File size: 4.1 KB
Line 
1#! /usr/bin/perl -w
2
3use strict;
4use utf8;
5use open qw/:std :encoding(utf8)/;
6use Net::HTTPS;
7use XML::LibXML;
8
9my %urls;
10my %known;
11
12sub getignores
13{
14  open FILE,"<:encoding(utf-8)","josm_httpsignores.txt" or die;
15  for my $line (<FILE>)
16  {
17    if($line =~ /\|\| TestHTTPS \|\| \{\{\{(.*)\}\}\} \|\|/)
18    {
19      $known{$1} = 1;
20    }
21  }
22  close FILE;
23}
24
25sub getmaps
26{
27  my $dom = XML::LibXML->load_xml(location => "imagery_josm.imagery.xml");
28  my $xpc = XML::LibXML::XPathContext->new($dom);
29  $xpc->registerNs('j',  'http://josm.openstreetmap.de/maps-1.0');
30  foreach my $entry ($xpc->findnodes("//j:entry"))
31  {
32    my $name = $xpc->findvalue("./j:name", $entry);
33    for my $e ($xpc->findnodes(".//j:*", $entry))
34    {
35      if($e->textContent =~ /^http:\/\/(.*?)(:\d+)?[\/]/)
36      {
37        my $u = $1;
38        if($u =~ /^(.*)\{switch:(.*)\}(.*)$/)
39        {
40          my ($f,$switch,$e) = ($1, $2, $3);
41          for my $s (split(",", $switch))
42          {
43            $urls{"$f$s$e"}{"MAP:$name"}++;
44          }
45        }
46        else
47        {
48          $urls{$u}{"MAP:$name"}++;
49        }
50      }
51    }
52  }
53}
54
55sub getfile($$)
56{
57  my ($type, $file) = @_;
58  open FILE,"<:encoding(utf-8)",$file or die;
59  my $name;
60  for my $line (<FILE>)
61  {
62    if($line =~ /^([^ \t].*);(.*)/)
63    {
64      my ($n, $url) = ($1, $2);
65      if($url =~ /josm\.openstreetmap\.de/)
66      {
67        $name = "WIKI$type:$n";
68      }
69      else
70      {
71        $name = "$type:$n";
72      }
73    }
74    if($line =~ /http:\/\/(.*?)(:\d+)?[\/]/)
75    {
76      $urls{$1}{$name}++;
77    }
78  }
79  close FILE;
80}
81
82sub getdump()
83{
84  open FILE,"<:encoding(utf-8)","josm_dump.txt" or die;
85  local $/;
86  undef $/;
87  my $file = <FILE>;
88  close FILE;
89  eval $file;
90}
91
92print "Options: \n PLUGIN STYLE RULE PRESET MAP DUMP\n GETPLUGIN GETSTYLE GETRULE GETPRESET GETMAP GETDUMP\n LOCAL\n IGNORES GETIGNORES\n ALL GETALL\n" if !@ARGV;
93
94open OUTFILE,">","josm_https.txt" or die "Could not open output file";
95open OUTFILENH,">","josm_no_https.txt" or die "Could not open no-https output file";
96
97sub doprint($)
98{
99  my $t = $_[0];
100  for my $k (sort keys %known)
101  {
102    $known{$k}++ if($t =~ s/(\Q$k\E)/~~$1~~/g);
103  }
104  print OUTFILE $t;
105  print $t;
106}
107
108my $local = 0;
109for my $ARG (@ARGV)
110{
111  if($ARG eq "ALL") {push(@ARGV, "PLUGIN", "STYLE", "RULE", "PRESET", "MAP", "DUMP", "IGNORES");}
112  if($ARG eq "GETALL") {push(@ARGV, "GETPLUGIN", "GETSTYLE", "GETRULE", "GETPRESET", "GETMAP", "GETDUMP", "GETIGNORES");}
113}
114my %ARGS = map {$_ => 1} @ARGV; # prevent double arguments by passing through a hash
115for my $ARG (sort keys %ARGS)
116{
117  if($ARG eq "GETIGNORES") { system "curl https://josm.openstreetmap.de/wiki/IntegrationTestIgnores?format=txt -o josm_httpsignores.txt"; getignores();}
118  if($ARG eq "IGNORES") { getignores(); }
119  if($ARG eq "LOCAL") {$local = 1; }
120  if($ARG eq "GETDUMP") { system "scp josm\@josm.openstreetmap.de:auto/httpinfo.dump josm_dump.txt"; getdump();}
121  if($ARG eq "DUMP") { getdump(); }
122  if($ARG eq "GETMAP") { system "curl https://josm.openstreetmap.de/maps -o imagery_josm.imagery.xml"; getmaps();}
123  if($ARG eq "MAP") { getmaps(); }
124  for my $x ("PLUGIN", "STYLE", "RULE", "PRESET")
125  {
126    my $t = lc($x);
127    my $url = $x eq "PLUGIN" ? $t : "${t}s";
128    my $file = "josm_$t.xml";
129    if($ARG eq "GET$x") { system "curl https://josm.openstreetmap.de/$url -o $file"; getfile($x, $file);}
130    if($ARG eq $x) { getfile($x, $file); }
131  }
132}
133
134for my $url (sort keys %urls)
135{
136  my $i = join(" # ", sort keys %{$urls{$url}});
137  if($local) # skip test
138  {
139    doprint "* $url:$i\n";
140    next;
141  }
142  eval
143  {
144    local $SIG{ALRM} = sub {die "--Alarm--"};
145
146    alarm(5);
147    my $s = Net::HTTPS->new(Host => $url) || die $@;
148    $s->write_request(GET => "/", 'User-Agent' => "TestHTTPS/1.0");
149    my($code, $mess, %h) = $s->read_response_headers;
150    alarm(0);
151    doprint "* $url [$code $mess]: $i\n";
152  };
153  if($@)
154  {
155    my $e = $@||"";
156    $e =~ s/[\r\n]//g;
157    $e =~ s/ at scripts\/TestHTTPS.pl .*//;
158    if($@ !~ "(--Alarm--|Connection refused)")
159    {
160      doprint "* $url [Error $e] :$i\n";
161    }
162    elsif($@)
163    {
164      print OUTFILENH "* $url [$e] :$i\n";
165    }
166  }
167}
168
169for my $k (sort keys %known)
170{
171  print "Unused ignores $k\n" if $known{$k} == 1;
172}
Note: See TracBrowser for help on using the repository browser.