Move EFA logic to ::EFA, just set URL in ::VRR (d64f9834) · Commits · derf / Travel-Status-DE-EFA

lib/Travel/Status/DE/EFA.pm

0 → 100644

+476 −0

Original line number	Diff line number	Diff line
		package Travel::Status::DE::EFA;

		use strict;
		use warnings;
		use 5.010;

		no if $] >= 5.018, warnings => "experimental::smartmatch";

		our $VERSION = '1.05';

		use Carp qw(confess cluck);
		use Encode qw(encode decode);
		use Travel::Status::DE::EFA::Line;
		use Travel::Status::DE::EFA::Result;
		use LWP::UserAgent;
		use XML::LibXML;

		sub new {
		my ( $class, %opt ) = @_;

		my $ua = LWP::UserAgent->new(%opt);
		my @now = localtime( time() );

		my @time = @now[ 2, 1 ];
		my @date = ( $now[3], $now[4] + 1, $now[5] + 1900 );

		if ( not( $opt{place} and $opt{name} ) ) {
		confess('You need to specify a place and a name');
		}
		if ( $opt{type} and not( $opt{type} ~~ [qw[stop address poi]] ) ) {
		confess('type must be stop, address or poi');
		}

		if ( not $opt{efa_url} ) {
		confess('efa_url is mandatory');
		}

		## no critic (RegularExpressions::ProhibitUnusedCapture)
		## no critic (Variables::ProhibitPunctuationVars)

		if ( $opt{time}
		and $opt{time} =~ m{ ^ (?<hour> \d\d? ) : (?<minute> \d\d ) $ }x )
		{
		@time = @+{qw{hour minute}};
		}
		elsif ( $opt{time} ) {
		confess('Invalid time specified');
		}

		if (
		$opt{date}
		and $opt{date} =~ m{ ^ (?<day> \d\d? ) [.] (?<month> \d\d? ) [.]
		(?<year> \d{4} )? $ }x
		)
		{
		if ( $+{year} ) {
		@date = @+{qw{day month year}};
		}
		else {
		@date[ 0, 1 ] = @+{qw{day month}};
		}
		}
		elsif ( $opt{date} ) {
		confess('Invalid date specified');
		}

		my $self = {
		post => {
		command => q{},
		deleteAssignedStops_dm => '1',
		help => 'Hilfe',
		itdDateDay => $date[0],
		itdDateMonth => $date[1],
		itdDateYear => $date[2],
		itdLPxx_id_dm => ':dm',
		itdLPxx_mapState_dm => q{},
		itdLPxx_mdvMap2_dm => q{},
		itdLPxx_mdvMap_dm => '3406199:401077:NAV3',
		itdLPxx_transpCompany => 'vrr',
		itdLPxx_view => q{},
		itdTimeHour => $time[0],
		itdTimeMinute => $time[1],
		language => 'de',
		mode => 'direct',
		nameInfo_dm => 'invalid',
		nameState_dm => 'empty',
		name_dm => $opt{name},
		outputFormat => 'XML',
		placeInfo_dm => 'invalid',
		placeState_dm => 'empty',
		place_dm => $opt{place},
		ptOptionsActive => '1',
		requestID => '0',
		reset => 'neue Anfrage',
		sessionID => '0',
		submitButton => 'anfordern',
		typeInfo_dm => 'invalid',
		type_dm => $opt{type} // 'stop',
		useProxFootSearch => '0',
		useRealtime => '1',
		},
		};

		bless( $self, $class );

		$ua->env_proxy;

		my $response = $ua->post( $opt{efa_url}, $self->{post} );

		if ( $response->is_error ) {
		$self->{errstr} = $response->status_line;
		return $self;
		}

		$self->{xml} = $response->decoded_content;

		$self->{tree} = XML::LibXML->load_xml( string => $self->{xml}, );

		# say $self->{tree}->toString(1);

		$self->check_for_ambiguous();

		return $self;
		}

		sub new_from_xml {
		my ( $class, %opt ) = @_;

		my $self = { xml => $opt{xml}, };

		$self->{tree} = XML::LibXML->load_xml( string => $self->{xml}, );

		return bless( $self, $class );
		}

		sub errstr {
		my ($self) = @_;

		return $self->{errstr};
		}

		sub sprintf_date {
		my ($e) = @_;

		return sprintf( '%02d.%02d.%d',
		$e->getAttribute('day'),
		$e->getAttribute('month'),
		$e->getAttribute('year'),
		);
		}

		sub sprintf_time {
		my ($e) = @_;

		return sprintf( '%02d:%02d',
		$e->getAttribute('hour'),
		$e->getAttribute('minute'),
		);
		}

		sub check_for_ambiguous {
		my ($self) = @_;

		my $xml = $self->{tree};

		my $xp_place = XML::LibXML::XPathExpression->new('//itdOdv/itdOdvPlace');
		my $xp_name = XML::LibXML::XPathExpression->new('//itdOdv/itdOdvName');
		my $xp_mesg
		= XML::LibXML::XPathExpression->new('//itdMessage[@type="error"]');

		my $xp_place_elem = XML::LibXML::XPathExpression->new('./odvPlaceElem');
		my $xp_name_elem = XML::LibXML::XPathExpression->new('./odvNameElem');

		my $e_place = ( $xml->findnodes($xp_place) )[0];
		my $e_name = ( $xml->findnodes($xp_name) )[0];
		my @e_mesg = $xml->findnodes($xp_mesg);

		if ( not( $e_place and $e_name ) ) {

		# this should not happen[tm]
		cluck('skipping ambiguity check- itdOdvPlace/itdOdvName missing');
		return;
		}

		my $s_place = $e_place->getAttribute('state');
		my $s_name = $e_name->getAttribute('state');

		if ( $s_place eq 'list' ) {
		$self->{errstr} = sprintf(
		'Ambiguous place input: %s',
		join( q{ \| },
		map { decode( 'UTF-8', $_->textContent ) }
		@{ $e_place->findnodes($xp_place_elem) } )
		);
		return;
		}
		if ( $s_name eq 'list' ) {
		$self->{errstr} = sprintf(
		'Ambiguous name input: %s',
		join( q{ \| },
		map { decode( 'UTF-8', $_->textContent ) }
		@{ $e_name->findnodes($xp_name_elem) } )
		);
		return;
		}
		if ( $s_place eq 'notidentified' ) {
		$self->{errstr} = 'invalid place parameter';
		return;
		}
		if ( $s_name eq 'notidentified' ) {
		$self->{errstr} = 'invalid name parameter';
		return;
		}
		if (@e_mesg) {
		$self->{errstr} = join( q{; }, map { $_->textContent } @e_mesg );
		return;
		}

		return;
		}

		sub lines {
		my ($self) = @_;
		my @lines;

		my $xp_element
		= XML::LibXML::XPathExpression->new('//itdServingLines/itdServingLine');

		my $xp_info = XML::LibXML::XPathExpression->new('./itdNoTrain');
		my $xp_route = XML::LibXML::XPathExpression->new('./itdRouteDescText');
		my $xp_oper = XML::LibXML::XPathExpression->new('./itdOperator/name');

		if ( $self->{lines} ) {
		return @{ $self->{lines} };
		}

		for my $e ( $self->{tree}->findnodes($xp_element) ) {

		my $e_info = ( $e->findnodes($xp_info) )[0];
		my $e_route = ( $e->findnodes($xp_route) )[0];
		my $e_oper = ( $e->findnodes($xp_oper) )[0];

		if ( not($e_info) ) {
		cluck( 'node with insufficient data. This should not happen. '
		. $e->getAttribute('number') );
		next;
		}

		my $line = $e->getAttribute('number');
		my $direction = $e->getAttribute('direction');
		my $valid = $e->getAttribute('valid');
		my $type = $e_info->getAttribute('name');
		my $route = ( $e_route ? $e_route->textContent : undef );
		my $operator = ( $e_oper ? $e_oper->textContent : undef );
		my $identifier = $e->getAttribute('stateless');

		push(
		@lines,
		Travel::Status::DE::EFA::Line->new(
		name => $line,
		direction => decode( 'UTF-8', $direction ),
		valid => $valid,
		type => decode( 'UTF-8', $type ),
		route => decode( 'UTF-8', $route ),
		operator => decode( 'UTF-8', $operator ),
		identifier => $identifier,
		)
		);
		}

		$self->{lines} = \@lines;

		return @lines;
		}

		sub results {
		my ($self) = @_;
		my @results;

		my $xp_element = XML::LibXML::XPathExpression->new('//itdDeparture');

		my $xp_date = XML::LibXML::XPathExpression->new('./itdDateTime/itdDate');
		my $xp_time = XML::LibXML::XPathExpression->new('./itdDateTime/itdTime');
		my $xp_rdate = XML::LibXML::XPathExpression->new('./itdRTDateTime/itdDate');
		my $xp_rtime = XML::LibXML::XPathExpression->new('./itdRTDateTime/itdTime');
		my $xp_line = XML::LibXML::XPathExpression->new('./itdServingLine');
		my $xp_info
		= XML::LibXML::XPathExpression->new('./itdServingLine/itdNoTrain');

		if ( $self->{results} ) {
		return @{ $self->{results} };
		}

		$self->lines;

		for my $e ( $self->{tree}->findnodes($xp_element) ) {

		my $e_date = ( $e->findnodes($xp_date) )[0];
		my $e_time = ( $e->findnodes($xp_time) )[0];
		my $e_line = ( $e->findnodes($xp_line) )[0];
		my $e_info = ( $e->findnodes($xp_info) )[0];

		my $e_rdate = ( $e->findnodes($xp_rdate) )[0];
		my $e_rtime = ( $e->findnodes($xp_rtime) )[0];

		if ( not( $e_date and $e_time and $e_line ) ) {
		cluck('node with insufficient data. This should not happen');
		next;
		}

		my $date = sprintf_date($e_date);
		my $time = sprintf_time($e_time);

		my $rdate = $e_rdate ? sprintf_date($e_rdate) : $date;
		my $rtime = $e_rtime ? sprintf_time($e_rtime) : $time;

		my $platform = $e->getAttribute('platform');
		my $line = $e_line->getAttribute('number');
		my $dest = $e_line->getAttribute('direction');
		my $info = $e_info->textContent;
		my $key = $e_line->getAttribute('key');
		my $countdown = $e->getAttribute('countdown');
		my $delay = $e_info->getAttribute('delay') // 0;
		my $type = $e_info->getAttribute('name');

		my $platform_is_db = 0;

		my @line_obj
		= grep { $_->{identifier} eq $e_line->getAttribute('stateless') }
		@{ $self->{lines} };

		if ( $platform =~ s{ ^ \# }{}ox ) {
		$platform_is_db = 1;
		}

		push(
		@results,
		Travel::Status::DE::EFA::Result->new(
		date => $rdate,
		time => $rtime,
		platform => $platform,
		platform_db => $platform_is_db,
		key => $key,
		lineref => $line_obj[0] // undef,
		line => $line,
		destination => decode( 'UTF-8', $dest ),
		countdown => $countdown,
		info => decode( 'UTF-8', $info ),
		delay => $delay,
		sched_date => $date,
		sched_time => $time,
		type => $type,
		)
		);
		}

		@results = map { $_->[0] }
		sort { $a->[1] <=> $b->[1] }
		map { [ $_, $_->countdown ] } @results;

		$self->{results} = \@results;

		return @results;
		}

		1;

		__END__

		=head1 NAME

		Travel::Status::DE::EFA - unofficial EFA departure monitor

		=head1 SYNOPSIS

		use Travel::Status::DE::EFA;

		my $status = Travel::Status::DE::EFA->new(
		efa_url => 'http://efa.vrr.de/vrr/XSLT_DM_REQUEST',
		place => 'Essen', name => 'Helenenstr'
		);

		for my $d ($status->results) {
		printf(
		"%s %d %-5s %s\n",
		$d->time, $d->platform, $d->line, $d->destination
		);
		}

		=head1 VERSION

		version 1.05

		=head1 DESCRIPTION

		Travel::Status::DE::EFA is an unofficial interface to EFA-based departure
		monitors.

		It reports all upcoming tram/bus/train departures at a given place.

		=head1 METHODS

		=over

		=item my $status = Travel::Status::DE::EFA->new(I<%opt>)

		Requests the departures as specified by I<opts> and returns a new
		Travel::Status::DE::EFA object. Dies if the wrong I<opts> were passed.

		Arguments:

		=over

		=item B<place> => I<place>

		Name of the place/city

		=item B<type> => B<address>\|B<poi>\|B<stop>

		Type of the following I<name>. B<poi> means "point of interest". Defaults to
		B<stop> (stop/station name).

		=item B<name> => I<name>

		address / poi / stop name to list departures for.

		=back

		=item $status->errstr

		In case of en HTTP request or EFA error, returns a string describing it. If
		none occured, returns undef.

		=item $status->lines

		Returns a list of Travel::Status::DE::EFA::Line(3pm) objects, each one
		describing one line servicing the selected station.

		=item $status->results

		Returns a list of Travel::Status::DE::EFA::Result(3pm) objects, each one describing
		one departure.

		=back

		=head1 DIAGNOSTICS

		None.

		=head1 DEPENDENCIES

		=over

		=item * Class::Accessor(3pm)

		=item * LWP::UserAgent(3pm)

		=item * XML::LibXML(3pm)

		=back

		=head1 BUGS AND LIMITATIONS

		Not all features of the web interface are supported.

		=head1 SEE ALSO

		efa-m(1), Travel::Status::DE::EFA::Result(3pm).

		=head1 AUTHOR

		Copyright (C) 2011 by Daniel Friesel E<lt>derf@finalrewind.orgE<gt>

		=head1 LICENSE

		This module is licensed under the same terms as Perl itself.

lib/Travel/Status/DE/VRR/Line.pm→lib/Travel/Status/DE/EFA/Line.pm

+10 −10

Original line number	Diff line number	Diff line
		package Travel::Status::DE::VRR::Line;
		package Travel::Status::DE::EFA::Line;

		use strict;
		use warnings;
		@@ -8,7 +8,7 @@ use parent 'Class::Accessor';

		our $VERSION = '1.05';

		Travel::Status::DE::VRR::Line->mk_ro_accessors(
		Travel::Status::DE::EFA::Line->mk_ro_accessors(
		qw(direction name operator route type valid));

		sub new {
		@@ -31,7 +31,7 @@ __END__

		=head1 NAME

		Travel::Status::DE::VRR::Line - Information about a line departing at the
		Travel::Status::DE::EFA::Line - Information about a line departing at the
		requested station

		=head1 SYNOPSIS
		@@ -50,9 +50,9 @@ version 1.05

		=head1 DESCRIPTION

		Travel::Status::DE::VRR::Line describes a tram/bus/train line departing at the
		stop requested by Travel::Status::DE::VRR. Note that it only covers one
		direction, so in most cases, you get two Travel::Status::DE::VRR::Line objects
		Travel::Status::DE::EFA::Line describes a tram/bus/train line departing at the
		stop requested by Travel::Status::DE::EFA. Note that it only covers one
		direction, so in most cases, you get two Travel::Status::DE::EFA::Line objects
		per actual line.

		=head1 METHODS
		@@ -80,7 +80,7 @@ Partial route of the line (as string), usually start and destination with two
		stops in between. May be undefined.

		Note that start means the actual start of the line, the stop requested by
		Travel::Status::DE::VRR::Line may not even be included in this listing.
		Travel::Status::DE::EFA::Line may not even be included in this listing.

		=item $line->type

		@@ -97,9 +97,9 @@ When / how long above information is valid.

		=over

		=item $line = Travel::Status::DE::VRR::Line->new(I<%data>)
		=item $line = Travel::Status::DE::EFA::Line->new(I<%data>)

		Returns a new Travel::Status::DE::VRR::Line object. You should not need to
		Returns a new Travel::Status::DE::EFA::Line object. You should not need to
		call this.

		=item $line->TO_JSON
		@@ -126,7 +126,7 @@ The B<route> accessor returns a simple string, an array might be better suited.

		=head1 SEE ALSO

		Travel::Status::DE::VRR(3pm).
		Travel::Status::DE::EFA(3pm).

		=head1 AUTHOR

lib/Travel/Status/DE/VRR/Result.pm→lib/Travel/Status/DE/EFA/Result.pm

+10 −10

Original line number	Diff line number	Diff line
		package Travel::Status::DE::VRR::Result;
		package Travel::Status::DE::EFA::Result;

		use strict;
		use warnings;
		@@ -8,7 +8,7 @@ use parent 'Class::Accessor';

		our $VERSION = '1.05';

		Travel::Status::DE::VRR::Result->mk_ro_accessors(
		Travel::Status::DE::EFA::Result->mk_ro_accessors(
		qw(countdown date delay destination is_cancelled info key line lineref platform
		platform_db sched_date sched_time time type)
		);
		@@ -41,8 +41,8 @@ __END__

		=head1 NAME

		Travel::Status::DE::VRR::Result - Information about a single
		departure received by Travel::Status::DE::VRR
		Travel::Status::DE::EFA::Result - Information about a single
		departure received by Travel::Status::DE::EFA

		=head1 SYNOPSIS

		@@ -60,8 +60,8 @@ version 1.05

		=head1 DESCRIPTION

		Travel::Status::DE::VRR::Result describes a single departure as obtained by
		Travel::Status::DE::VRR. It contains information about the time, platform,
		Travel::Status::DE::EFA::Result describes a single departure as obtained by
		Travel::Status::DE::EFA. It contains information about the time, platform,
		line number and destination.

		=head1 METHODS
		@@ -116,7 +116,7 @@ The name/number of the line.

		=item $departure->lineref

		Travel::Status::DE::VRR::Line(3pm) object describing the departing line in
		Travel::Status::DE::EFA::Line(3pm) object describing the departing line in
		detail.

		=item $departure->platform
		@@ -154,9 +154,9 @@ field. See L</DEPARTURE TYPES>.

		=over

		=item $departure = Travel::Status::DE::VRR::Result->new(I<%data>)
		=item $departure = Travel::Status::DE::EFA::Result->new(I<%data>)

		Returns a new Travel::Status::DE::VRR::Result object. You should not need to
		Returns a new Travel::Status::DE::EFA::Result object. You should not need to
		call this.

		=item $departure->TO_JSON
		@@ -214,7 +214,7 @@ interface.

		=head1 SEE ALSO

		Travel::Status::DE::VRR(3pm).
		Travel::Status::DE::EFA(3pm).

		=head1 AUTHOR

lib/Travel/Status/DE/VRR.pm

+18 −388

File changed.

Preview size limit exceeded, changes collapsed.

t/20-vrr.t

+2 −2

Original line number	Diff line number	Diff line
		@@ -17,13 +17,13 @@ my $xml = slurp('t/in/essen_hb.xml');

		my $status = Travel::Status::DE::VRR->new_from_xml(xml => $xml);

		isa_ok($status, 'Travel::Status::DE::VRR');
		isa_ok($status, 'Travel::Status::DE::EFA');
		can_ok($status, qw(errstr results));

		my @results = $status->results;

		for my $result (@results) {
		isa_ok($result, 'Travel::Status::DE::VRR::Result');
		isa_ok($result, 'Travel::Status::DE::EFA::Result');
		can_ok($result, qw(date destination info line time type platform));
		}

Admin message