Unverified Commit f56bb307 authored by Birte Kristina Friesel's avatar Birte Kristina Friesel
Browse files

remove hafas/get_xml_p helper (not required for mgate.exe API)

parent 61d2de43
Loading
Loading
Loading
Loading
+0 −138
Original line number Diff line number Diff line
@@ -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="... &gt; ..."> 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&amp;R};
			$body =~ s{& }{&amp; }g;

			# <Attribute [...] text="[...]"[...]"" /> is invalid XML.
			# Work around it.
			$body
			  =~ s{<Attribute([^>]+)text="([^"]*)"([^"=>]*)""}{<Attribute$1text="$2&#042;$3&#042;"}s;

			# Same for <HIMMessage lead="[...]"[...]"[...]" />
			$body
			  =~ s{<HIMMessage([^>]+)lead="([^"]*)"([^"=>]*)"([^"]*)"}{<Attribute$1text="$2&#042;$3&#042;$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&#11020;$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 ) = @_;