package Travel::Status::DE::URA; use strict; use warnings; use 5.010; no if $] >= 5.018, warnings => 'experimental::smartmatch'; our $VERSION = '1.00'; # create CONSTANTS for different Return Types use constant { TYPE_STOP => 0, TYPE_PREDICTION => 1, TYPE_MESSAGE => 2, TYPE_BASE => 3, TYPE_URA => 4, }; use Carp qw(confess cluck); use DateTime; use Encode qw(encode decode); use List::MoreUtils qw(firstval none uniq); use LWP::UserAgent; use Text::CSV; use Travel::Status::DE::URA::Result; use Travel::Status::DE::URA::Stop; sub new { my ( $class, %opt ) = @_; my %lwp_options = %{ $opt{lwp_options} // { timeout => 10 } }; my $ua = LWP::UserAgent->new(%lwp_options); my $response; if ( not( $opt{ura_base} and $opt{ura_version} ) ) { confess('ura_base and ura_version are mandatory'); } my $self = { datetime => $opt{datetime} // DateTime->now( time_zone => 'Europe/Berlin' ), developer_mode => $opt{developer_mode}, ura_base => $opt{ura_base}, ura_version => $opt{ura_version}, full_routes => $opt{calculate_routes} // 0, hide_past => $opt{hide_past} // 1, stop => $opt{stop}, via => $opt{via}, viaID => $opt{viaID}, stopID => $opt{stopID}, lineID => $opt{lineID}, circle => $opt{circle}, post => { # show all stops StopAlso => 'True', # for easier debugging ordered in the returned order ReturnList => 'stoppointname,stopid,latitude,longitude,lineid,' . 'linename,directionid,destinationtext,vehicleid,tripid,' . 'estimatedtime' }, }; $self->{ura_instant_url} = $self->{ura_base} . '/instant_V' . $self->{ura_version}; bless( $self, $class ); $ua->env_proxy; if ( substr( $self->{ura_instant_url}, 0, 5 ) ne 'file:' ) { # filter by stopID only if full_routes is not set if ( not $self->{full_routes} and $self->{stopID} ) { $self->{post}{StopID} = $self->{stopID}; # filter for via as well to make via work $self->{post}{StopID} .= ',' . $self->{viaID} if $self->{viaID}; } # filter by line if ( $self->{lineID} ) { $self->{post}{LineID} = $self->{lineID}; } # filter for Stops in circle (lon,lat,dist) if ( $self->{circle} ) { $self->{post}{Circle} = $self->{circle}; } $response = $ua->post( $self->{ura_instant_url}, $self->{post} ); } else { $response = $ua->get( $self->{ura_instant_url} ); } if ( $response->is_error ) { $self->{errstr} = $response->status_line; return $self; } my $raw_str = $response->decoded_content; if ( $self->{developer_mode} ) { say $raw_str; } # Fix encoding in case we're running through test files if ( substr( $self->{ura_instant_url}, 0, 5 ) eq 'file:' ) { $raw_str = encode( 'UTF-8', $raw_str ); } $self->parse_raw_data($raw_str); return $self; } sub parse_raw_data { my ( $self, $raw_str ) = @_; my $csv = Text::CSV->new( { binary => 1 } ); for my $dep ( split( /\r\n/, $raw_str ) ) { $dep =~ s{^\[}{}; $dep =~ s{\]$}{}; $csv->parse($dep); my @fields = $csv->fields; # encode all fields for my $i ( 1, 11 ) { $fields[$i] = encode( 'UTF-8', $fields[$i] ); } push( @{ $self->{raw_list} }, \@fields ); my $type = $fields[0]; if ( $type == TYPE_STOP ) { my $stop_name = $fields[1]; my $stop_id = $fields[2]; my $longitude = $fields[3]; my $latitude = $fields[4]; # create Stop Dict if ( !$self->{stops}{$stop_id} ) { $self->{stops}{$stop_id} = Travel::Status::DE::URA::Stop->new( name => decode( 'UTF-8', $stop_name ), id => $stop_id, longitude => $longitude, latitude => $latitude, ); } } if ( $type == TYPE_PREDICTION ) { push( @{ $self->{stop_names} }, $fields[1] ); } } @{ $self->{stop_names} } = uniq @{ $self->{stop_names} }; return $self; } sub get_stop_by_name { my ( $self, $name ) = @_; my $nname = lc($name); my $actual_match = firstval { $nname eq lc($_) } @{ $self->{stop_names} }; if ($actual_match) { return $actual_match; } return ( grep { $_ =~ m{$name}i } @{ $self->{stop_names} } ); } sub get_stops { my ($self) = @_; return $self->{stops}; } sub errstr { my ($self) = @_; return $self->{errstr}; } sub results { my ( $self, %opt ) = @_; my @results; my $full_routes = $opt{calculate_routes} // $self->{full_routes} // 0; my $hide_past = $opt{hide_past} // $self->{hide_past} // 1; my $stop = $opt{stop} // $self->{stop}; my $stop_id = $opt{stopID} // $self->{stopID}; my $via = $opt{via} // $self->{via}; my $via_id = $opt{viaID} // $self->{viaID}; my $dt_now = $self->{datetime}; my $ts_now = $dt_now->epoch; if ( $via or $via_id ) { $full_routes = 1; } for my $dep ( @{ $self->{raw_list} } ) { my ( $type, $stopname, $stopid, $longitude, $latitude, $lineid, $linename, $directionid, $dest, $vehicleid, $tripid, $timestamp ) = @{$dep}; my ( @route_pre, @route_post ); # only work on Prediction informations next unless $type == TYPE_PREDICTION; if ( $stop and not( $stopname eq $stop ) ) { next; } if ( $stop_id and not( $stopid eq $stop_id ) ) { next; } if ( not $timestamp ) { cluck("departure element without timestamp: $dep"); next; } $timestamp /= 1000; if ( $hide_past and $ts_now > $timestamp ) { next; } my $dt_dep = DateTime->from_epoch( epoch => $timestamp, time_zone => 'Europe/Berlin' ); my $ts_dep = $dt_dep->epoch; if ($full_routes) { my @route = map { [ $_->[11] / 1000, $_->[1], $_->[2], $_->[3], $_->[4] ] } grep { $_->[10] == $tripid } grep { $_->[0] == 1 } @{ $self->{raw_list} }; @route_pre = grep { $_->[0] < $ts_dep } @route; @route_post = grep { $_->[0] > $ts_dep } @route; if ( $via and none { $_->[1] eq $via } @route_post ) { next; } if ( $via_id and none { $_->[2] eq $via_id } @route_post ) { next; } if ($hide_past) { @route_pre = grep { $_->[0] >= $ts_now } @route_pre; } @route_pre = map { $_->[0] } sort { $a->[1] <=> $b->[1] } map { [ $_, $_->[0] ] } @route_pre; @route_post = map { $_->[0] } sort { $a->[1] <=> $b->[1] } map { [ $_, $_->[0] ] } @route_post; @route_pre = map { Travel::Status::DE::URA::Stop->new( datetime => DateTime->from_epoch( epoch => $_->[0], time_zone => 'Europe/Berlin' ), name => decode( 'UTF-8', $_->[1] ), id => $_->[2], longitude => $_->[3], latitude => $_->[4], ) } @route_pre; @route_post = map { Travel::Status::DE::URA::Stop->new( datetime => DateTime->from_epoch( epoch => $_->[0], time_zone => 'Europe/Berlin' ), name => decode( 'UTF-8', $_->[1] ), id => $_->[2], longitude => $_->[3], latitude => $_->[4], ) } @route_post; } push( @results, Travel::Status::DE::URA::Result->new( datetime => $dt_dep, dt_now => $dt_now, line => $linename, line_id => $lineid, destination => $dest, route_pre => [@route_pre], route_post => [@route_post], stop => $stopname, stop_id => $stopid, ) ); } @results = map { $_->[0] } sort { $a->[1] <=> $b->[1] } map { [ $_, $_->datetime->epoch ] } @results; return @results; } 1; __END__ =head1 NAME Travel::Status::DE::URA - unofficial departure monitor for "Unified Realtime API" data providers (e.g. ASEAG) =head1 SYNOPSIS use Travel::Status::DE::URA; my $status = Travel::Status::DE::URA->new( ura_base => 'http://ivu.aseag.de/interfaces/ura', ura_version => '1', stop => 'Aachen Bushof' ); for my $d ($status->results) { printf( "%s %-5s %25s (in %d min)\n", $d->time, $d->line, $d->destination, $d->countdown ); } =head1 VERSION version 1.00 =head1 DESCRIPTION Travel::Status::DE::URA is an unofficial interface to URA-based realtime departure monitors (as used e.g. by the ASEAG). It reports all upcoming departures at a given place in real-time. Schedule information is not included. =head1 METHODS =over =item my $status = Travel::Status::DE::URA->new(I<%opt>) Requests the departures as specified by I and returns a new Travel::Status::DE::URA object. The following two parameters are mandatory: =over =item B => I The URA base url. =item B => I The version, may be any string. =back The request URL is I/instant_VI, so for C<< http://ivu.aseag.de/interfaces/ura >>, C<< 1 >> this module will send requests to C<< http://ivu.aseag.de/interfaces/ura/instant_V1 >>. The following parameter is optional: =over =item B => I<\%hashref> Passed on to C<< LWP::UserAgent->new >>. Defaults to C<< { timeout => 10 } >>, you can use an empty hashref to override it. =back Additionally, all options supported by C<< $status->results >> may be specified here, causing them to be used as defaults. Note that while they can be overridden later, they may limit the set of departures requested from the server. =item $status->errstr In case of an HTTP request error, returns a string describing it. If none occured, returns undef. =item $status->get_stop_by_name(I<$stopname>) Returns a list of stops matching I<$stopname>. For instance, if the stops "Aachen Bushof", "Eupen Bushof", "Brand" and "Brandweiher" exist, the parameter "bushof" will return "Aachen Bushof" and "Eupen Bushof", while "brand" will only return "Brand". =item $status->results(I<%opt>) Returns a list of Travel::Status::DE::URA::Result(3pm) objects, each describing one departure. Accepted parameters (all are optional): =item $status->get_stops() Returns a list of all Stops returned by the Request. This is usefull for circle requests, to find nearby Stops. =over =item B => I (default 0) When set to a true value: Compute routes for all results, enabling use of their B accessors. Otherwise, those will just return nothing (undef / empty list, depending on context). =item B => I (default 1) Do not include past departures in the result list and the computed timetables. =item B => I Only return departures at stop I. =item B => I Only return departures containing I in their route after their corresponding stop. Implies B=1. =back =back =head1 DIAGNOSTICS None. =head1 DEPENDENCIES =over =item * Class::Accessor(3pm) =item * DateTime(3pm) =item * List::MoreUtils(3pm) =item * LWP::UserAgent(3pm) =item * Text::CSV(3pm) =back =head1 BUGS AND LIMITATIONS Many. =head1 SEE ALSO Travel::Status::DE::URA::Result(3pm). =head1 AUTHOR Copyright (C) 2013-2015 by Daniel Friesel Ederf@finalrewind.orgE =head1 LICENSE This module is licensed under the same terms as Perl itself.