package Travel::Status::DE::DBWagenreihung::Carriage; use strict; use warnings; use 5.020; use utf8; use parent 'Class::Accessor'; use Carp qw(cluck); our $VERSION = '0.17'; Travel::Status::DE::DBWagenreihung::Carriage->mk_ro_accessors( qw(class_type is_closed is_dosto is_locomotive is_powercar number model section uic_id type start_meters end_meters length_meters start_percent end_percent length_percent has_priority_seats has_ac has_quiet_zone has_bahn_comfort has_wheelchair_space has_wheelchair_toilet has_family_zone has_infant_cabin has_info has_bistro has_first_class has_second_class ) ); my %type_map = ( SEATS_SEVERELY_DISABLE => 'priority_seats', AIR_CONDITION => 'ac', ZONE_QUIET => 'quiet_zone', SEATS_BAHN_COMFORT => 'bahn_comfort', INFO => 'info', TOILET_WHEELCHAIR => 'wheelchair_toilet', WHEELCHAIR_SPACE => 'wheelchair_space', ZONE_FAMILY => 'family_zone', CABIN_INFANT => 'infant_cabin', ); sub new { my ( $obj, %opt ) = @_; my $ref = {}; my %json = %{ $opt{json} }; my $platform = $opt{platform}; $ref->{class_type} = 0; $ref->{has_bistro} = 0; $ref->{is_locomotive} = 0; $ref->{is_powercar} = 0; $ref->{is_closed} = 0; $ref->{number} = $json{wagonIdentificationNumber}; $ref->{model} = $json{vehicleID}; $ref->{uic_id} = $json{vehicleID}; $ref->{section} = $json{platformPosition}{sector}; $ref->{type} = $json{type}{constructionType}; $ref->{model} =~ s{^.....(...)....(?:-.)?$}{$1} or $ref->{model} = undef; my $self = bless( $ref, $obj ); $self->parse_type; for my $amenity ( @{ $json{amenities} // [] } ) { my $type = $amenity->{type}; if ( $type_map{$type} ) { my $key = 'has_' . $type_map{$type}; $self->{$key} = 1; } } if ( $json{status} and $json{status} eq 'CLOSED' ) { $ref->{is_closed} = 1; } if ( $json{type}{category} =~ m{DININGCAR} ) { $ref->{has_bistro} = 1; } elsif ( $json{type}{category} eq 'LOCOMOTIVE' ) { $ref->{is_locomotive} = 1; } elsif ( $json{type}{category} eq 'POWERCAR' ) { $ref->{is_powercar} = 1; } $ref->{has_first_class} = $json{type}{hasFirstClass}; $ref->{has_second_class} = $json{type}{hasEconomyClass}; if ( $ref->{type} =~ m{AB} ) { $ref->{class_type} = 12; } elsif ( $ref->{type} =~ m{A} ) { $ref->{class_type} = 1; } elsif ( $ref->{type} =~ m{B|WR} ) { $ref->{class_type} = 2; } my $pos = $json{platformPosition}; my $platform_length = $platform->{end} - $platform->{start}; $ref->{start_meters} = $pos->{start}; $ref->{end_meters} = $pos->{end}; $ref->{start_percent} = ( $pos->{start} - $platform->{start} ) * 100 / $platform_length, $ref->{end_percent} = ( $pos->{end} - $platform->{start} ) * 100 / $platform_length, $ref->{length_meters} = $pos->{start} - $pos->{end}; $ref->{length_percent} = $ref->{end_percent} - $ref->{start_percent}; if ( $pos->{start} eq '' or $pos->{end} eq '' ) { $ref->{position}{valid} = 0; } else { $ref->{position}{valid} = 1; } return $self; } sub attributes { my ($self) = @_; return @{ $self->{attributes} // [] }; } # See also: # https://de.wikipedia.org/wiki/UIC-Bauart-Bezeichnungssystem_f%C3%BCr_Reisezugwagen#Kennbuchstaben # https://www.deutsche-reisezugwagen.de/lexikon/erklarung-der-gattungszeichen/ sub parse_type { my ($self) = @_; my $type = $self->{type}; my @desc; if ( $type =~ m{^D} ) { $self->{is_dosto} = 1; push( @desc, 'Doppelstock' ); } if ( $type =~ m{b} ) { $self->{has_accessibility} = 1; push( @desc, 'Behindertengerechte Ausstattung' ); } if ( $type =~ m{d} ) { $self->{multipurpose} = 1; push( @desc, 'Mehrzweck' ); } if ( $type =~ m{f} ) { push( @desc, 'Steuerabteil' ); } if ( $type =~ m{i} ) { push( @desc, 'Interregio' ); } if ( $type =~ m{mm} ) { push( @desc, 'modernisiert' ); } if ( $type =~ m{p} ) { $self->{has_ac} = 1; push( @desc, 'Großraum' ); } if ( $type =~ m{s} ) { push( @desc, 'Sonderabteil' ); } if ( $type =~ m{v} ) { $self->{has_ac} = 1; $self->{has_compartments} = 1; push( @desc, 'Abteil' ); } if ( $type =~ m{w} ) { $self->{has_ac} = 1; $self->{has_compartments} = 1; push( @desc, 'Abteil' ); } $self->{attributes} = \@desc; } sub is_first_class { my ($self) = @_; if ( $self->{type} =~ m{^D?A} ) { return 1; } return 0; } sub is_second_class { my ($self) = @_; if ( $self->{type} =~ m{^D?A?B} ) { return 1; } return 0; } sub sections { my ($self) = @_; return @{ $self->{sections} }; } sub TO_JSON { my ($self) = @_; my %copy = %{$self}; return {%copy}; } 1;