Loading lib/DBInfoscreen/Helper/HAFAS.pm +0 −138 Original line number Diff line number Diff line Loading @@ -86,144 +86,6 @@ sub get_json_p { return $promise; } sub get_xml_p { my ( $self, $cache, $url ) = @_; my $promise = Mojo::Promise->new; if ( my $content = $cache->thaw($url) ) { return $promise->resolve($content); } $self->{log}->debug("get_xml_p($url)"); $self->{user_agent}->request_timeout(5)->get_p( $url => $self->{header} ) ->then( sub { my ($tx) = @_; if ( my $err = $tx->error ) { $cache->freeze( $url, {} ); $self->{log}->warn( "hafas->get_xml_p($url): HTTP $err->{code} $err->{message}" ); $promise->reject( "GET $url returned HTTP $err->{code} $err->{message}"); return; } my $body = decode( 'ISO-8859-15', $tx->res->body ); # <SDay text="... > ..."> is invalid XML, but present # regardless. As it is the last tag, we just throw it away. $body =~ s{<SDay [^>]*/>}{}s; # More fixes for invalid XML $body =~ s{P&R}{P&R}; $body =~ s{& }{& }g; # <Attribute [...] text="[...]"[...]"" /> is invalid XML. # Work around it. $body =~ s{<Attribute([^>]+)text="([^"]*)"([^"=>]*)""}{<Attribute$1text="$2*$3*"}s; # Same for <HIMMessage lead="[...]"[...]"[...]" /> $body =~ s{<HIMMessage([^>]+)lead="([^"]*)"([^"=>]*)"([^"]*)"}{<Attribute$1text="$2*$3*$4"}s; # Dito for <HIMMessage [...] lead="[...]<br>[...]"> # (replace line breaks with space) while ( $body =~ s{<HIMMessage([^>]+)lead="([^"]*)<br/?>([^"=]*)"}{<HIMMessage$1lead="$2 $3"}gis ) { } # ... and <HIMMessage [...] lead="[...]<>[...]"> # (replace <> with t$t) while ( $body =~ s{<HIMMessage([^>]+)lead="([^"]*)<>([^"=]*)"}{<HIMMessage$1lead="$2⬌$3"}gis ) { } # ... and any other HTML tag inside an XML attribute # (remove them entirely) while ( $body =~ s{<HIMMessage([^>]+)lead="([^"]*)<[^>]+>([^"=]*)"}{<HIMMessage$1lead="$2$3"}gis ) { } my $tree; eval { $tree = XML::LibXML->load_xml( string => $body ) }; if ($@) { $self->{log}->debug("hafas->get_xml_p($url): $@"); $cache->freeze( $url, {} ); $promise->reject; return; } my $ret = { station => {}, stations => [], messages => [], }; for my $station ( $tree->findnodes('/Journey/St') ) { my $name = $station->getAttribute('name'); my $adelay = $station->getAttribute('adelay'); my $ddelay = $station->getAttribute('ddelay'); push( @{ $ret->{stations} }, $name ); $ret->{station}{$name} = { adelay => $adelay, ddelay => $ddelay, }; } for my $message ( $tree->findnodes('/Journey/HIMMessage') ) { my $header = $message->getAttribute('header'); my $lead = $message->getAttribute('lead'); my $display = $message->getAttribute('display'); # "something is wrong, but we're not telling what" is not helpful. # Observed on RRX lines in NRW if ( $header =~ m{ : \s St..?rung. \s \(Quelle: \s zuginfo.nrw \) $ }x and not $lead ) { next; } push( @{ $ret->{messages} }, { header => $header, lead => $lead, display => $display } ); } $cache->freeze( $url, $ret ); $promise->resolve($ret); return; } )->catch( sub { my ($err) = @_; $self->{log}->warn("hafas->get_xml_p($url): $err"); $promise->reject($err); return; } )->wait; return $promise; } sub trainsearch_p { my ( $self, %opt ) = @_; Loading Loading
lib/DBInfoscreen/Helper/HAFAS.pm +0 −138 Original line number Diff line number Diff line Loading @@ -86,144 +86,6 @@ sub get_json_p { return $promise; } sub get_xml_p { my ( $self, $cache, $url ) = @_; my $promise = Mojo::Promise->new; if ( my $content = $cache->thaw($url) ) { return $promise->resolve($content); } $self->{log}->debug("get_xml_p($url)"); $self->{user_agent}->request_timeout(5)->get_p( $url => $self->{header} ) ->then( sub { my ($tx) = @_; if ( my $err = $tx->error ) { $cache->freeze( $url, {} ); $self->{log}->warn( "hafas->get_xml_p($url): HTTP $err->{code} $err->{message}" ); $promise->reject( "GET $url returned HTTP $err->{code} $err->{message}"); return; } my $body = decode( 'ISO-8859-15', $tx->res->body ); # <SDay text="... > ..."> is invalid XML, but present # regardless. As it is the last tag, we just throw it away. $body =~ s{<SDay [^>]*/>}{}s; # More fixes for invalid XML $body =~ s{P&R}{P&R}; $body =~ s{& }{& }g; # <Attribute [...] text="[...]"[...]"" /> is invalid XML. # Work around it. $body =~ s{<Attribute([^>]+)text="([^"]*)"([^"=>]*)""}{<Attribute$1text="$2*$3*"}s; # Same for <HIMMessage lead="[...]"[...]"[...]" /> $body =~ s{<HIMMessage([^>]+)lead="([^"]*)"([^"=>]*)"([^"]*)"}{<Attribute$1text="$2*$3*$4"}s; # Dito for <HIMMessage [...] lead="[...]<br>[...]"> # (replace line breaks with space) while ( $body =~ s{<HIMMessage([^>]+)lead="([^"]*)<br/?>([^"=]*)"}{<HIMMessage$1lead="$2 $3"}gis ) { } # ... and <HIMMessage [...] lead="[...]<>[...]"> # (replace <> with t$t) while ( $body =~ s{<HIMMessage([^>]+)lead="([^"]*)<>([^"=]*)"}{<HIMMessage$1lead="$2⬌$3"}gis ) { } # ... and any other HTML tag inside an XML attribute # (remove them entirely) while ( $body =~ s{<HIMMessage([^>]+)lead="([^"]*)<[^>]+>([^"=]*)"}{<HIMMessage$1lead="$2$3"}gis ) { } my $tree; eval { $tree = XML::LibXML->load_xml( string => $body ) }; if ($@) { $self->{log}->debug("hafas->get_xml_p($url): $@"); $cache->freeze( $url, {} ); $promise->reject; return; } my $ret = { station => {}, stations => [], messages => [], }; for my $station ( $tree->findnodes('/Journey/St') ) { my $name = $station->getAttribute('name'); my $adelay = $station->getAttribute('adelay'); my $ddelay = $station->getAttribute('ddelay'); push( @{ $ret->{stations} }, $name ); $ret->{station}{$name} = { adelay => $adelay, ddelay => $ddelay, }; } for my $message ( $tree->findnodes('/Journey/HIMMessage') ) { my $header = $message->getAttribute('header'); my $lead = $message->getAttribute('lead'); my $display = $message->getAttribute('display'); # "something is wrong, but we're not telling what" is not helpful. # Observed on RRX lines in NRW if ( $header =~ m{ : \s St..?rung. \s \(Quelle: \s zuginfo.nrw \) $ }x and not $lead ) { next; } push( @{ $ret->{messages} }, { header => $header, lead => $lead, display => $display } ); } $cache->freeze( $url, $ret ); $promise->resolve($ret); return; } )->catch( sub { my ($err) = @_; $self->{log}->warn("hafas->get_xml_p($url): $err"); $promise->reject($err); return; } )->wait; return $promise; } sub trainsearch_p { my ( $self, %opt ) = @_; Loading