Initial commit

3 files changed, 217 insertions, 0 deletions

diff --git a/bin/dbwagenreihung b/bin/dbwagenreihung
new file mode 100644
index 0000000..0c5b2fe
--- /dev/null
+++ b/bin/dbwagenreihung
@@ -0,0 +1,36 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use 5.020;
+use utf8;
+
+our $VERSION = '0.00';
+
+use Travel::Status::DE::IRIS;
+use Travel::Status::DE::DBWagenreihung;
+
+my ($station, $train_number) = @ARGV;
+
+my $res = Travel::Status::DE::IRIS->new(station => $station, with_related => 1);
+
+if ($res->errstr) {
+	say STDERR $res->errstr;
+	exit 1;
+}
+
+my @trains = grep { $_->train_no eq $train_number } $res->results;
+
+if (@trains != 1) {
+	say STDERR "Unable to find train in reported departures";
+	exit 1;
+}
+
+my $wr = Travel::Status::DE::DBWagenreihung->new(
+	departure => $trains[0]->sched_departure,
+	developer_mode => 1,
+	train_number => $train_number,
+);
+
+for my $wagon ($wr->wagons) {
+	printf("%s %s\n", $wagon->number, $wagon->section);
+}
diff --git a/lib/Travel/Status/DE/DBWagenreihung.pm b/lib/Travel/Status/DE/DBWagenreihung.pm
new file mode 100644
index 0000000..68dbd69
--- /dev/null
+++ b/lib/Travel/Status/DE/DBWagenreihung.pm
@@ -0,0 +1,140 @@
+package Travel::Status::DE::DBWagenreihung;
+
+use strict;
+use warnings;
+use 5.020;
+
+our $VERSION = '0.00';
+
+use Carp qw(cluck confess);
+use JSON;
+use LWP::UserAgent;
+use Travel::Status::DE::DBWagenreihung::Wagon;
+
+sub new {
+	my ( $class, %opt ) = @_;
+
+	if ( not $opt{train_number} ) {
+		confess('train_number option must be set');
+	}
+
+	if ( not $opt{departure} ) {
+		confess('departure option must be set');
+	}
+
+	my $self = {
+		api_base      => $opt{api_base}
+		  // 'https://www.apps-bahn.de/wr/wagenreihung/1.0',
+		developer_mode => $opt{developer_mode},
+		cache => $opt{cache},
+		departure       => $opt{departure},
+		json => JSON->new,
+		serializable    => $opt{serializable},
+		train_number    => $opt{train_number},
+		user_agent      => $opt{user_agent},
+	};
+
+	bless( $self, $class );
+
+	if ( not $self->{user_agent} ) {
+		my %lwp_options = %{ $opt{lwp_options} // { timeout => 10 } };
+		$self->{user_agent} = LWP::UserAgent->new(%lwp_options);
+		$self->{user_agent}->env_proxy;
+	}
+
+	$self->get_wagonorder;
+
+	return $self;
+}
+
+sub get_wagonorder {
+	my ($self) = @_;
+
+	my $api_base = $self->{api_base};
+	my $cache = $self->{cache};
+	my $train_number = $self->{train_number};
+
+	my $datetime = $self->{departure};
+
+	if (ref($datetime) eq 'DateTime') {
+		$datetime = $datetime->strftime('%Y%m%d%H%M');
+	}
+
+	my ($content, $err) = $self->get_with_cache($cache, "${api_base}/${train_number}/${datetime}");
+
+	if ($err) {
+		$self->{errstr} = "Failed to fetch station data: $err";
+		return;
+	}
+	my $json = $self->{json}->decode($content);
+	if ($self->{developer_mode}) {
+		say $self->{json}->pretty->encode($json);
+	}
+
+	if (exists $json->{error}) {
+		$self->{errstr} = 'Backend error: ' . $json->{error}{msg};
+		return;
+	}
+
+	$self->{data} = $json->{data};
+	$self->{meta} = $json->{meta};
+}
+
+sub error {
+	my ($self) = @_;
+
+	return $self->{errstr};
+}
+
+sub wagons {
+	my ($self) = @_;
+
+	if (exists $self->{wagons}) {
+		return @{$self->{wagons}};
+	}
+
+	for my $group (@{$self->{data}{istformation}{allFahrzeuggruppe}}) {
+		for my $wagon (@{$group->{allFahrzeug}}) {
+			push(@{$self->{wagons}}, Travel::Status::DE::DBWagenreihung::Wagon->new(%{$wagon}));
+		}
+	}
+	return @{$self->{wagons} // []};
+}
+
+sub get_with_cache {
+	my ( $self, $cache, $url ) = @_;
+
+	if ( $self->{developer_mode} ) {
+		say "GET $url";
+	}
+
+	if ($cache) {
+		my $content = $cache->thaw($url);
+		if ($content) {
+			if ( $self->{developer_mode} ) {
+				say '  cache hit';
+			}
+			return ( ${$content}, undef );
+		}
+	}
+
+	if ( $self->{developer_mode} ) {
+		say '  cache miss';
+	}
+
+	my $ua  = $self->{user_agent};
+	my $res = $ua->get($url);
+
+	if ( $res->is_error ) {
+		return ( undef, $res->status_line );
+	}
+	my $content = $res->decoded_content;
+
+	if ($cache) {
+		$cache->freeze( $url, \$content );
+	}
+
+	return ( $content, undef );
+}
+
+1;
diff --git a/lib/Travel/Status/DE/DBWagenreihung/Wagon.pm b/lib/Travel/Status/DE/DBWagenreihung/Wagon.pm
new file mode 100644
index 0000000..f3569c3
--- /dev/null
+++ b/lib/Travel/Status/DE/DBWagenreihung/Wagon.pm
@@ -0,0 +1,41 @@
+package Travel::Status::DE::DBWagenreihung::Wagon;
+
+use strict;
+use warnings;
+use 5.020;
+use utf8;
+
+use parent 'Class::Accessor';
+use Carp qw(cluck);
+
+our $VERSION = '1.21';
+
+Travel::Status::DE::DBWagenreihung::Wagon->mk_ro_accessors(
+	qw(number section)
+);
+
+sub new {
+	my ( $obj, %opt ) = @_;
+	my $ref = \%opt;
+
+	$ref->{number} = $ref->{wagenordnungsnummer};
+	$ref->{section} = $ref->{fahrzeugsektor};
+
+	return bless( $ref, $obj );
+}
+
+sub sections {
+	my ($self) = @_;
+
+	return @{$self->{sections}};
+}
+
+sub TO_JSON {
+	my ($self) = @_;
+
+	my %copy = %{$self};
+
+	return {%copy};
+}
+
+1;