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

DBWagenreihung: sort functions by visibility

parent 6840f2eb

lib/Travel/Status/DE/DBWagenreihung.pm

+180 −167
Original line number Diff line number Diff line
@@ -19,6 +19,8 @@ our $VERSION = '0.12'; 
Travel::Status::DE::DBWagenreihung->mk_ro_accessors(

	qw(direction platform station train_no train_type));



# {{{ Rolling Stock Models



my %is_redesign = (

	"02" => 1,

	"03" => 1,
@@ -103,6 +105,9 @@ my %power_desc = ( 
	99 => 'Sonderfahrzeug',

);



# }}}

# {{{ Constructors



sub new {

	my ( $class, %opt ) = @_;
@@ -184,69 +189,94 @@ sub get_wagonorder { 
	return $self->parse_wagonorder;

}



sub parse_wagonorder {

	my ($self) = @_;

# }}}

# {{{ Internal Helpers



	$self->{platform} = $self->{data}{istformation}{halt}{gleisbezeichnung};

sub get_with_cache {

	my ( $self, $cache, $url ) = @_;



	$self->{station} = {

		ds100 => $self->{data}{istformation}{halt}{rl100},

		eva   => $self->{data}{istformation}{halt}{evanummer},

		name  => $self->{data}{istformation}{halt}{bahnhofsname},

	};

	if ( $self->{developer_mode} ) {

		say "GET $url";

	}



	$self->{train_type} = $self->{data}{istformation}{zuggattung};

	$self->{train_no}   = $self->{data}{istformation}{zugnummer};

	if ($cache) {

		my $content = $cache->thaw($url);

		if ($content) {

			if ( $self->{developer_mode} ) {

				say '  cache hit';

			}

			return ( ${$content}, undef );

		}

	}



	$self->parse_wagons;

	$self->{origins}      = $self->parse_wings('startbetriebsstellename');

	$self->{destinations} = $self->parse_wings('zielbetriebsstellename');

	if ( $self->{developer_mode} ) {

		say '  cache miss';

	}



sub errstr {

	my ($self) = @_;

	my $ua  = $self->{user_agent};

	my $res = $ua->get($url);



	return $self->{errstr};

	if ( $res->is_error ) {

		return ( undef, $res->status_line );

	}

	my $content = $res->decoded_content;



sub TO_JSON {

	my ($self) = @_;



	# ensure that all objects are available

	$self->origins;

	$self->destinations;

	$self->train_numbers;

	$self->train_descriptions;

	$self->sections;

	if ($cache) {

		$cache->freeze( $url, \$content );

	}



	my %copy = %{$self};

	return ( $content, undef );

}



	delete $copy{from_json};

sub wagongroup_powertype {

	my ( $self, @wagons ) = @_;



	return {%copy};

	if ( not @wagons ) {

		@wagons = $self->wagons;

	}



sub has_bad_wagons {

	my ($self) = @_;

	my %ml = map { $_ => 0 } ( 90 .. 99 );



	if ( defined $self->{has_bad_wagons} ) {

		return $self->{has_bad_wagons};

	for my $wagon (@wagons) {



		if ( not $wagon->uic_id or length( $wagon->uic_id ) != 12 ) {

			next;

		}



	for my $group ( @{ $self->{data}{istformation}{allFahrzeuggruppe} } ) {

		for my $wagon ( @{ $group->{allFahrzeug} } ) {

			my $pos = $wagon->{positionamhalt};

			if (   $pos->{startprozent} eq ''

				or $pos->{endeprozent} eq ''

				or $pos->{startmeter} eq ''

				or $pos->{endemeter} eq '' )

			{

				return $self->{has_bad_wagons} = 1;

		my $wagon_type = substr( $wagon->uic_id, 0, 2 );

		if ( $wagon_type < 90 ) {

			next;

		}



		$ml{$wagon_type}++;

	}



	my @likelihood = reverse sort { $ml{$a} <=> $ml{$b} } keys %ml;



	if ( $ml{ $likelihood[0] } == 0 ) {

		return undef;

	}



	return $self->{has_bad_wagons} = 0;

	return $likelihood[0];

}



sub parse_wagonorder {

	my ($self) = @_;



	$self->{platform} = $self->{data}{istformation}{halt}{gleisbezeichnung};



	$self->{station} = {

		ds100 => $self->{data}{istformation}{halt}{rl100},

		eva   => $self->{data}{istformation}{halt}{evanummer},

		name  => $self->{data}{istformation}{halt}{bahnhofsname},

	};



	$self->{train_type} = $self->{data}{istformation}{zuggattung};

	$self->{train_no}   = $self->{data}{istformation}{zugnummer};



	$self->parse_wagons;

	$self->{origins}      = $self->parse_wings('startbetriebsstellename');

	$self->{destinations} = $self->parse_wings('zielbetriebsstellename');

}



sub parse_wings {
@@ -270,6 +300,63 @@ sub parse_wings { 
	return \@names;

}



sub parse_wagons {

	my ($self) = @_;



	my @wagon_groups;



	for my $group ( @{ $self->{data}{istformation}{allFahrzeuggruppe} } ) {

		my @group;

		for my $wagon ( @{ $group->{allFahrzeug} } ) {

			my $wagon_object

			  = Travel::Status::DE::DBWagenreihung::Wagon->new( %{$wagon},

				train_no => $group->{verkehrlichezugnummer} );

			push( @{ $self->{wagons} }, $wagon_object );

			push( @group,               $wagon_object );

			if ( not $wagon_object->{position}{valid} ) {

				$self->{has_bad_wagons} = 1;

			}

		}

		push( @wagon_groups, [@group] );

	}

	if ( @{ $self->{wagons} // [] } > 1 and not $self->has_bad_wagons ) {

		if ( $self->{wagons}[0]->{position}{start_percent}

			> $self->{wagons}[-1]->{position}{start_percent} )

		{

			$self->{direction} = 100;

		}

		else {

			$self->{direction} = 0;

		}

	}

	if ( not $self->has_bad_wagons ) {

		@{ $self->{wagons} } = sort {

			$a->{position}->{start_percent} <=> $b->{position}->{start_percent}

		} @{ $self->{wagons} };

	}



	for my $i ( 0 .. $#wagon_groups ) {

		my $group = $wagon_groups[$i];

		my $tt    = $self->wagongroup_subtype( @{$group} );

		if ($tt) {

			for my $wagon ( @{$group} ) {

				$wagon->set_traintype( $i, $tt );

			}

		}

	}



	$self->{wagongroups} = [@wagon_groups];

}



# }}}

# {{{ Public Functions



sub errstr {

	my ($self) = @_;



	return $self->{errstr};

}



sub destinations {

	my ($self) = @_;
@@ -309,80 +396,71 @@ sub sections { 
	return @{ $self->{sections} // [] };

}



sub train_numbers {

sub train_descriptions {

	my ($self) = @_;



	if ( exists $self->{train_numbers} ) {

		return @{ $self->{train_numbers} };

	if ( exists $self->{train_descriptions} ) {

		return @{ $self->{train_descriptions} };

	}



	my @numbers;

	for my $wagons ( @{ $self->{wagongroups} } ) {

		my ( $short, $desc ) = $self->wagongroup_description( @{$wagons} );

		my @sections = uniq map { $_->section } @{$wagons};



	for my $group ( @{ $self->{data}{istformation}{allFahrzeuggruppe} } ) {

		push( @numbers, $group->{verkehrlichezugnummer} );

		push(

			@{ $self->{train_descriptions} },

			{

				sections => [@sections],

				short    => $short,

				text     => $desc,

			}



	@numbers = uniq @numbers;



	$self->{train_numbers} = \@numbers;



	return @numbers;

		);

	}



sub wagongroup_powertype {

	my ( $self, @wagons ) = @_;



	if ( not @wagons ) {

		@wagons = $self->wagons;

	return @{ $self->{train_descriptions} };

}



	my %ml = map { $_ => 0 } ( 90 .. 99 );



	for my $wagon (@wagons) {

sub train_numbers {

	my ($self) = @_;



		if ( not $wagon->uic_id or length( $wagon->uic_id ) != 12 ) {

			next;

	if ( exists $self->{train_numbers} ) {

		return @{ $self->{train_numbers} };

	}



		my $wagon_type = substr( $wagon->uic_id, 0, 2 );

		if ( $wagon_type < 90 ) {

			next;

		}

	my @numbers;



		$ml{$wagon_type}++;

	for my $group ( @{ $self->{data}{istformation}{allFahrzeuggruppe} } ) {

		push( @numbers, $group->{verkehrlichezugnummer} );

	}



	my @likelihood = reverse sort { $ml{$a} <=> $ml{$b} } keys %ml;

	@numbers = uniq @numbers;



	if ( $ml{ $likelihood[0] } == 0 ) {

		return undef;

	}

	$self->{train_numbers} = \@numbers;



	return $likelihood[0];

	return @numbers;

}



sub train_descriptions {

sub has_bad_wagons {

	my ($self) = @_;



	if ( exists $self->{train_descriptions} ) {

		return @{ $self->{train_descriptions} };

	if ( defined $self->{has_bad_wagons} ) {

		return $self->{has_bad_wagons};

	}



	for my $wagons ( @{ $self->{wagongroups} } ) {

		my ( $short, $desc ) = $self->wagongroup_description( @{$wagons} );

		my @sections = uniq map { $_->section } @{$wagons};



		push(

			@{ $self->{train_descriptions} },

	for my $group ( @{ $self->{data}{istformation}{allFahrzeuggruppe} } ) {

		for my $wagon ( @{ $group->{allFahrzeug} } ) {

			my $pos = $wagon->{positionamhalt};

			if (   $pos->{startprozent} eq ''

				or $pos->{endeprozent} eq ''

				or $pos->{startmeter} eq ''

				or $pos->{endemeter} eq '' )

			{

				sections => [@sections],

				short    => $short,

				text     => $desc,

				return $self->{has_bad_wagons} = 1;

			}

		}

		);

	}



	return @{ $self->{train_descriptions} };

	return $self->{has_bad_wagons} = 0;

}



sub wagongroup_description {
@@ -635,89 +713,24 @@ sub wagons { 
	return @{ $self->{wagons} // [] };

}



sub parse_wagons {

sub TO_JSON {

	my ($self) = @_;



	my @wagon_groups;



	for my $group ( @{ $self->{data}{istformation}{allFahrzeuggruppe} } ) {

		my @group;

		for my $wagon ( @{ $group->{allFahrzeug} } ) {

			my $wagon_object

			  = Travel::Status::DE::DBWagenreihung::Wagon->new( %{$wagon},

				train_no => $group->{verkehrlichezugnummer} );

			push( @{ $self->{wagons} }, $wagon_object );

			push( @group,               $wagon_object );

			if ( not $wagon_object->{position}{valid} ) {

				$self->{has_bad_wagons} = 1;

			}

		}

		push( @wagon_groups, [@group] );

	}

	if ( @{ $self->{wagons} // [] } > 1 and not $self->has_bad_wagons ) {

		if ( $self->{wagons}[0]->{position}{start_percent}

			> $self->{wagons}[-1]->{position}{start_percent} )

		{

			$self->{direction} = 100;

		}

		else {

			$self->{direction} = 0;

		}

	}

	if ( not $self->has_bad_wagons ) {

		@{ $self->{wagons} } = sort {

			$a->{position}->{start_percent} <=> $b->{position}->{start_percent}

		} @{ $self->{wagons} };

	}



	for my $i ( 0 .. $#wagon_groups ) {

		my $group = $wagon_groups[$i];

		my $tt    = $self->wagongroup_subtype( @{$group} );

		if ($tt) {

			for my $wagon ( @{$group} ) {

				$wagon->set_traintype( $i, $tt );

			}

		}

	}



	$self->{wagongroups} = [@wagon_groups];

}



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';

	}

	# ensure that all objects are available

	$self->origins;

	$self->destinations;

	$self->train_numbers;

	$self->train_descriptions;

	$self->sections;



	my $ua  = $self->{user_agent};

	my $res = $ua->get($url);

	my %copy = %{$self};



	if ( $res->is_error ) {

		return ( undef, $res->status_line );

	}

	my $content = $res->decoded_content;

	delete $copy{from_json};



	if ($cache) {

		$cache->freeze( $url, \$content );

	return {%copy};

}



	return ( $content, undef );

}

# }}}



1;