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

As of today, bahn.de sends gzip-compressed replies

parent 6141430b

Build.PL

+1 −0
Original line number Diff line number Diff line
@@ -26,6 +26,7 @@ Module::Build->new( 
		'DateTime::Duration'                  => 0,

		'DateTime::Format::Strptime'          => 0,

		'Getopt::Long'                        => 0,

		'IO::Uncompress::Gunzip'              => 0,

		'JSON'                                => 0,

		'List::Util'                          => 0,

		'LWP::UserAgent'                      => 0,

lib/Travel/Routing/DE/DBRIS.pm

+9 −7
Original line number Diff line number Diff line
@@ -14,6 +14,7 @@ use DateTime::Format::Strptime; 
use Encode qw(decode encode);

use JSON;

use LWP::UserAgent;

use IO::Uncompress::Gunzip;

use Travel::Status::DE::DBRIS;

use Travel::Routing::DE::DBRIS::Connection;

use Travel::Routing::DE::DBRIS::Offer;
@@ -203,23 +204,23 @@ sub new { 
			say "requesting $req_str";

		}



		my ( $content, $error ) = $self->post_with_cache( $req_url, $req_str );

		my ( $raw_content, $error )

		  = $self->post_with_cache( $req_url, $req_str );



		if ($error) {

			$self->{errstr} = $error;

			return $self;

		}



		my $gunzip  = IO::Uncompress::Gunzip->new( \$raw_content, Append => 1 );

		my $content = q{};



		while ( $gunzip->read($content) ) { }



		if ( $self->{developer_mode} ) {

			say decode( 'utf-8', $content );

		}



		# Sometimes, bahn.de adds garbage at the end

		if ( $content =~ m/^[^{]/ or $content =~ m/[^}]$/ ) {

			$content =~ s/^[^{]+//;

			$content =~ s/[^}]+$//;

		}



		$self->{raw_json} = $json->decode($content);

		if ( $conf{from} and $conf{to} ) {

			$self->parse_connections;
@@ -294,6 +295,7 @@ sub post_with_cache { 
	my $reply = $self->{ua}->post(

		$url,

		Accept            => 'application/json',

		'Accept-Encoding' => 'gzip',

		'Accept-Language' => $self->{language},

		'Content-Type'    => 'application/json; charset=utf-8',

		Content           => $req,