From c2190255f0c25118c118583c8555a9f5cecd948d Mon Sep 17 00:00:00 2001 From: Daniel Friesel Date: Mon, 23 May 2011 09:12:12 +0200 Subject: Code cleanup, remove WWW::Efa::Error stuff for now (to be reimplemented) --- lib/WWW/Efa.pm | 787 ++++++++++++++++++++++++++++----------------------------- 1 file changed, 388 insertions(+), 399 deletions(-) (limited to 'lib/WWW/Efa.pm') diff --git a/lib/WWW/Efa.pm b/lib/WWW/Efa.pm index 417fd6b..99c3181 100644 --- a/lib/WWW/Efa.pm +++ b/lib/WWW/Efa.pm @@ -1,313 +1,269 @@ package WWW::Efa; -=head1 NAME - -WWW::Efa - inofficial interface to the efa.vrr.de German itinerary service - -=head1 SYNOPSIS - - use WWW::Efa; - - my $efa = WWW::Efa->new( - from => ['Essen', 'HBf'], - to => ['Duisburg', 'HBf'], - ); - - $efa->submit(); - $efa->parse(); - - for my $con ($efa->connections()) { - for my $c (@{$con}) { - printf( - "%-5s ab %-30s %-20s %s\n%-5s an %-30s\n\n",, - @{$c}{'dep_time', 'dep_stop', 'train_line', 'train_dest'}, - @{$c}{'arr_time', 'arr_stop'}, - ); - } - print "\n\n"; - } - -=head1 DESCRIPTION - -B is a client for the efa.vrr.de web interface. -You pass it the start/stop of your journey, maybe a time and a date and more -details, and it returns the up-to-date scheduled connections between those two -stops. - -It uses B and B for this. - -=cut - use strict; use warnings; use 5.010; -use base 'Exporter'; - +use Carp qw(confess); use LWP::UserAgent; use XML::LibXML; -use WWW::Efa::Error::Ambiguous; -use WWW::Efa::Error::Backend; -use WWW::Efa::Error::NoData; -use WWW::Efa::Error::Setup; -our @EXPORT_OK = (); -my $VERSION = '1.3+git'; +our $VERSION = '1.3'; sub post_time { - my ($post, $conf) = @_; + my ( $post, $conf ) = @_; + my $time; - if ($conf->{'depart'}) { - $post->{'itdTripDateTimeDepArr'} = 'dep'; - $time = $conf->{'depart'} || $conf->{'time'}; + if ( $conf->{depart} ) { + $post->{itdTripDateTimeDepArr} = 'dep'; + $time = $conf->{depart} || $conf->{time}; } else { - $post->{'itdTripDateTimeDepArr'} = 'arr'; - $time = $conf->{'arrive'}; + $post->{itdTripDateTimeDepArr} = 'arr'; + $time = $conf->{arrive}; } - if ($time !~ / ^ [0-2]? \d : [0-5]? \d $ /x) { - die WWW::Efa::Error::Setup->new( - ($conf->{'depart'} ? 'depart' : 'arrive'), - $time, 'Must match HH:MM' - ); + if ( $time !~ / ^ [0-2]? \d : [0-5]? \d $ /x ) { + confess("time: must match HH:MM - '${time}'"); } - @{$post}{'itdTimeHour', 'itdTimeMinute'} = split(/:/, $time); + + @{$post}{ 'itdTimeHour', 'itdTimeMinute' } = split( /:/, $time ); + + return; } sub post_date { - my ($post, $date) = @_; - my ($day, $month, $year) = split(/\./, $date); + my ( $post, $date ) = @_; + + my ( $day, $month, $year ) = split( /[.]/, $date ); - if (not defined $day or not length($day) or $day < 1 or $day > 31) { - die WWW::Efa::Error::Setup->new( - 'date', $date, 'Invalid day' - ); + if ( not defined $day or not length($day) or $day < 1 or $day > 31 ) { + confess("date: invalid day, must match DD.MM[.[YYYY]] - '${date}'"); } - if (not defined $month or not length($month) or $month < 1 or $month > 12) { - die WWW::Efa::Error::Setup->new( - 'date', $date, 'Invalid month' - ); + if ( not defined $month or not length($month) or $month < 1 or $month > 12 ) + { + confess("date: invalid month, must match DD.MM[.[YYYY]] - '${date}'"); } - if (not defined $year or not length($year)) { - $year = (localtime(time))[5] + 1900; + if ( not defined $year or not length($year) ) { + $year = ( localtime(time) )[5] + 1900; } - @{$post}{'itdDateDay', 'itdDateMonth', 'itdDateYear'} = ($day, $month, $year); + @{$post}{ 'itdDateDay', 'itdDateMonth', 'itdDateYear' } + = ( $day, $month, $year ); + + return; } sub post_exclude { - my ($post, @exclude) = @_; + my ( $post, @exclude ) = @_; + my @mapping = qw{ - zug s-bahn u-bahn stadtbahn tram stadtbus regionalbus - schnellbus seilbahn schiff ast sonstige + zug s-bahn u-bahn stadtbahn tram stadtbus regionalbus + schnellbus seilbahn schiff ast sonstige }; foreach my $exclude_type (@exclude) { my $ok = 0; - for my $map_id (0 .. $#mapping) { - if ($exclude_type eq $mapping[$map_id]) { + for my $map_id ( 0 .. $#mapping ) { + if ( $exclude_type eq $mapping[$map_id] ) { $post->{"inclMOT_${map_id}"} = undef; $ok = 1; } } - if (not $ok) { - die WWW::Efa::Error::Setup->new( - 'exclude', - join(q{ }, @exclude), - 'Must consist of ' . join(q{ }, @mapping) - ); + if ( not $ok ) { + confess("exclude: Unsupported type '${exclude_type}'"); } } + + return; } sub post_prefer { - my ($post, $prefer) = @_; + my ( $post, $prefer ) = @_; given ($prefer) { - when ('speed') { $post->{'routeType'} = 'LEASTTIME' } - when ('nowait') { $post->{'routeType'} = 'LEASTINTERCHANGE' } - when ('nowalk') { $post->{'routeType'} = 'LEASTWALKING' } + when ('speed') { $post->{routeType} = 'LEASTTIME' } + when ('nowait') { $post->{routeType} = 'LEASTINTERCHANGE' } + when ('nowalk') { $post->{routeType} = 'LEASTWALKING' } default { - die WWW::Efa::Error::Setup->new( - 'prefer', $prefer, 'Must be either speed, nowait or nowalk' - ); + confess("prefer: Must be speed/nowait/nowalk: '${prefer}'"); } } + + return; } sub post_include { - my ($post, $include) = @_; + my ( $post, $include ) = @_; given ($include) { - when ('local') { $post->{'lineRestriction'} = 403 } - when ('ic') { $post->{'lineRestriction'} = 401 } - when ('ice') { $post->{'lineRestriction'} = 400 } + when ('local') { $post->{lineRestriction} = 403 } + when ('ic') { $post->{lineRestriction} = 401 } + when ('ice') { $post->{lineRestriction} = 400 } default { - die WWW::Efa::Error::Setup->new( - 'include', $include, 'Must be one of local/ic/ice' - ); + confess("include: Must be local/ic/ice: '${include}'"); } } + + return; } sub post_walk_speed { - my ($post, $walk_speed) = @_; + my ( $post, $walk_speed ) = @_; - if ($walk_speed ~~ ['normal', 'fast', 'slow']) { - $post->{'changeSpeed'} = $walk_speed; + if ( $walk_speed ~~ [ 'normal', 'fast', 'slow' ] ) { + $post->{changeSpeed} = $walk_speed; } else { - die WWW::Efa::Error::Setup->new( - 'walk_speed', $walk_speed, 'Must be normal, fast or slow' - ); + confess("walk_speed: Must be normal/fast/slow: '${walk_speed}'"); } + + return; } sub post_place { - my ($post, $which, $place, $stop, $type) = @_; + my ( $post, $which, $place, $stop, $type ) = @_; - if (not ($place and $stop)) { - die WWW::Efa::Error::Setup->new( - 'place', $which, 'Need at least two elements' - ); + if ( not( $place and $stop ) ) { + confess('place: Need two elements'); } $type //= 'stop'; - @{$post}{"place_${which}", "name_${which}"} = ($place, $stop); + @{$post}{ "place_${which}", "name_${which}" } = ( $place, $stop ); - if ($type ~~ [qw[address poi stop]]) { + if ( $type ~~ [qw[address poi stop]] ) { $post->{"type_${which}"} = $type; } + + return; } sub create_post { my ($conf) = @_; - my @now = localtime(time()); - my $post = { - changeSpeed => "normal", - command => "", - execInst => "", - imparedOptionsActive => 1, - inclMOT_0 => "on", - inclMOT_1 => "on", - inclMOT_10 => "on", - inclMOT_11 => "on", - inclMOT_2 => "on", - inclMOT_3 => "on", - inclMOT_4 => "on", - inclMOT_5 => "on", - inclMOT_6 => "on", - inclMOT_7 => "on", - inclMOT_8 => "on", - inclMOT_9 => "on", - includedMeans => "checkbox", - itOptionsActive => 1, - itdDateDay => $now[3], - itdDateMonth => $now[4] + 1, - itdDateYear => $now[5] + 1900, - itdLPxx_ShowFare => " ", - itdLPxx_command => "", - itdLPxx_enableMobilityRestrictionOptionsWithButton => "", - itdLPxx_id_destination => ":destination", - itdLPxx_id_origin => ":origin", - itdLPxx_id_via => ":via", - itdLPxx_mapState_destination => "", - itdLPxx_mapState_origin => "", - itdLPxx_mapState_via => "", - itdLPxx_mdvMap2_destination => "", - itdLPxx_mdvMap2_origin => "", - itdLPxx_mdvMap2_via => "", - itdLPxx_mdvMap_destination => "::", - itdLPxx_mdvMap_origin => "::", - itdLPxx_mdvMap_via => "::", - itdLPxx_priceCalculator => "", - itdLPxx_transpCompany => "vrr", - itdLPxx_view => "", - itdTimeHour => $now[2], - itdTimeMinute => $now[1], - itdTripDateTimeDepArr => "dep", - language => "de", - lineRestriction => 403, - maxChanges => 9, - nameInfo_destination => "invalid", - nameInfo_origin => "invalid", - nameInfo_via => "invalid", - nameState_destination => "empty", - nameState_origin => "empty", - nameState_via => "empty", - name_destination => "", - name_origin => "", - name_via => "", - placeInfo_destination => "invalid", - placeInfo_origin => "invalid", - placeInfo_via => "invalid", - placeState_destination => "empty", - placeState_origin => "empty", - placeState_via => "empty", - place_destination => "", - place_origin => "", - place_via => "", - ptOptionsActive => 1, - requestID => 0, - routeType => "LEASTTIME", - sessionID => 0, - text => 1993, - trITArrMOT => 100, - trITArrMOTvalue100 => 8, - trITArrMOTvalue101 => 10, - trITArrMOTvalue104 => 10, - trITArrMOTvalue105 => 10, - trITDepMOT => 100, - trITDepMOTvalue100 => 8, - trITDepMOTvalue101 => 10, - trITDepMOTvalue104 => 10, - trITDepMOTvalue105 => 10, - typeInfo_destination => "invalid", - typeInfo_origin => "invalid", - typeInfo_via => "invalid", - type_destination => "stop", - type_origin => "stop", - type_via => "stop", - useRealtime => 1 + my @now = localtime( time() ); + my $post = { + changeSpeed => 'normal', + command => q{}, + execInst => q{}, + imparedOptionsActive => 1, + inclMOT_0 => 'on', + inclMOT_1 => 'on', + inclMOT_10 => 'on', + inclMOT_11 => 'on', + inclMOT_2 => 'on', + inclMOT_3 => 'on', + inclMOT_4 => 'on', + inclMOT_5 => 'on', + inclMOT_6 => 'on', + inclMOT_7 => 'on', + inclMOT_8 => 'on', + inclMOT_9 => 'on', + includedMeans => 'checkbox', + itOptionsActive => 1, + itdDateDay => $now[3], + itdDateMonth => $now[4] + 1, + itdDateYear => $now[5] + 1900, + itdLPxx_ShowFare => q{ }, + itdLPxx_command => q{}, + itdLPxx_enableMobilityRestrictionOptionsWithButton => q{}, + itdLPxx_id_destination => ':destination', + itdLPxx_id_origin => ':origin', + itdLPxx_id_via => ':via', + itdLPxx_mapState_destination => q{}, + itdLPxx_mapState_origin => q{}, + itdLPxx_mapState_via => q{}, + itdLPxx_mdvMap2_destination => q{}, + itdLPxx_mdvMap2_origin => q{}, + itdLPxx_mdvMap2_via => q{}, + itdLPxx_mdvMap_destination => q{::}, + itdLPxx_mdvMap_origin => q{::}, + itdLPxx_mdvMap_via => q{::}, + itdLPxx_priceCalculator => q{}, + itdLPxx_transpCompany => 'vrr', + itdLPxx_view => q{}, + itdTimeHour => $now[2], + itdTimeMinute => $now[1], + itdTripDateTimeDepArr => 'dep', + language => 'de', + lineRestriction => 403, + maxChanges => 9, + nameInfo_destination => 'invalid', + nameInfo_origin => 'invalid', + nameInfo_via => 'invalid', + nameState_destination => 'empty', + nameState_origin => 'empty', + nameState_via => 'empty', + name_destination => q{}, + name_origin => q{}, + name_via => q{}, + placeInfo_destination => 'invalid', + placeInfo_origin => 'invalid', + placeInfo_via => 'invalid', + placeState_destination => 'empty', + placeState_origin => 'empty', + placeState_via => 'empty', + place_destination => q{}, + place_origin => q{}, + place_via => q{}, + ptOptionsActive => 1, + requestID => 0, + routeType => 'LEASTTIME', + sessionID => 0, + text => 1993, + trITArrMOT => 100, + trITArrMOTvalue100 => 8, + trITArrMOTvalue101 => 10, + trITArrMOTvalue104 => 10, + trITArrMOTvalue105 => 10, + trITDepMOT => 100, + trITDepMOTvalue100 => 8, + trITDepMOTvalue101 => 10, + trITDepMOTvalue104 => 10, + trITDepMOTvalue105 => 10, + typeInfo_destination => 'invalid', + typeInfo_origin => 'invalid', + typeInfo_via => 'invalid', + type_destination => 'stop', + type_origin => 'stop', + type_via => 'stop', + useRealtime => 1 }; + post_place( $post, 'origin', @{ $conf->{from} } ); + post_place( $post, 'destination', @{ $conf->{to} } ); - post_place($post, 'origin', @{$conf->{'from'}}); - post_place($post, 'destination', @{$conf->{'to'}}); - - if ($conf->{'via'}) { - post_place($post, 'via', @{$conf->{'via'}}); + if ( $conf->{via} ) { + post_place( $post, 'via', @{ $conf->{via} } ); } - if ($conf->{'arrive'} || $conf->{'depart'}) { - post_time($post, $conf); + if ( $conf->{arrive} || $conf->{depart} ) { + post_time( $post, $conf ); } - if ($conf->{'date'}) { - post_date($post, $conf->{'date'}); + if ( $conf->{date} ) { + post_date( $post, $conf->{date} ); } - if ($conf->{'exclude'}) { - post_exclude($post, @{$conf->{'exclude'}}); + if ( $conf->{exclude} ) { + post_exclude( $post, @{ $conf->{exclude} } ); } - if ($conf->{'max_interchanges'}) { - $post->{'maxChanges'} = $conf->{'max_interchanges'}; + if ( $conf->{max_interchanges} ) { + $post->{maxChanges} = $conf->{max_interchanges}; } - if ($conf->{'prefer'}) { - post_prefer($post, $conf->{'prefer'}); + if ( $conf->{prefer} ) { + post_prefer( $post, $conf->{prefer} ); } - if ($conf->{'proximity'}) { - $post->{'useProxFootSearch'} = 1; + if ( $conf->{proximity} ) { + $post->{useProxFootSearch} = 1; } - if ($conf->{'include'}) { - post_include($post, $conf->{'include'}); + if ( $conf->{include} ) { + post_include( $post, $conf->{include} ); } - if ($conf->{'walk_speed'}) { - post_walk_speed($post, $conf->{'walk_speed'}); + if ( $conf->{walk_speed} ) { + post_walk_speed( $post, $conf->{walk_speed} ); } - if ($conf->{'bike'}) { - $post->{'bikeTakeAlong'} = 1; + if ( $conf->{bike} ) { + $post->{bikeTakeAlong} = 1; } return $post; @@ -320,10 +276,10 @@ sub parse_initial { my $con_no; my $cons = []; - my $xp_td = XML::LibXML::XPathExpression->new('//table//table/tr/td'); + my $xp_td = XML::LibXML::XPathExpression->new('//table//table/tr/td'); my $xp_img = XML::LibXML::XPathExpression->new('./img'); - foreach my $td (@{$tree->findnodes($xp_td)}) { + foreach my $td ( @{ $tree->findnodes($xp_td) } ) { my $colspan = $td->getAttribute('colspan') // 0; my $class = $td->getAttribute('class') // q{}; @@ -332,29 +288,28 @@ sub parse_initial { next; } - if ($colspan == 8) { - if ($td->textContent() =~ / (? \d+ ) \. .+ Fahrt /x) { - $con_no = $+{'no'} - 1; + if ( $colspan == 8 ) { + if ( $td->textContent() =~ m{ (? \d+ ) [.] .+ Fahrt }x ) { + $con_no = $+{no} - 1; $con_part = 0; next; } } - if ($class =~ /^bgColor2?$/) { - if ($class eq 'bgColor' and ($con_part % 2) == 1) { + if ( $class =~ /^bgColor2?$/ ) { + if ( $class eq 'bgColor' and ( $con_part % 2 ) == 1 ) { $con_part++; } - elsif ($class eq 'bgColor2' and ($con_part % 2) == 0) { + elsif ( $class eq 'bgColor2' and ( $con_part % 2 ) == 0 ) { $con_part++; } } - if ( - defined $con_no and not $td->exists($xp_img) - and $td->textContent() !~ /^\s*$/ - ) + if ( defined $con_no + and not $td->exists($xp_img) + and $td->textContent() !~ /^\s*$/ ) { - push(@{$cons->[$con_no]->[$con_part]}, $td->textContent()); + push( @{ $cons->[$con_no]->[$con_part] }, $td->textContent() ); } } @@ -363,21 +318,22 @@ sub parse_initial { sub parse_pretty { my ($con_parts) = @_; + my $elements; my @next_extra; - for my $con (@{$con_parts}) { + for my $con ( @{$con_parts} ) { my $hash; # Note: Changes @{$con} elements - foreach my $str (@{$con}) { + foreach my $str ( @{$con} ) { $str =~ s/[\s\n\t]+/ /gs; $str =~ s/^ //; $str =~ s/ $//; } - if (@{$con} < 5) { + if ( @{$con} < 5 ) { @next_extra = @{$con}; next; } @@ -385,41 +341,190 @@ sub parse_pretty { # @extra may contain undef values foreach my $extra (@next_extra) { if ($extra) { - push(@{$hash->{'extra'}}, $extra); + push( @{ $hash->{extra} }, $extra ); } } @next_extra = undef; - if ($con->[0] !~ / \d{2} : \d{2} /ox) { - splice(@{$con}, 0, 0, q{}); - splice(@{$con}, 4, 0, q{}); + if ( $con->[0] !~ / \d{2} : \d{2} /ox ) { + splice( @{$con}, 0, 0, q{} ); + splice( @{$con}, 4, 0, q{} ); $con->[7] = q{}; } - elsif ($con->[4] =~ / Plan: \s ab /ox) { - push(@{$hash->{'extra'}}, splice(@{$con}, 4, 1)); + elsif ( $con->[4] =~ / Plan: \s ab /ox ) { + push( @{ $hash->{extra} }, splice( @{$con}, 4, 1 ) ); } - foreach my $extra (splice(@{$con}, 8, -1)) { - push (@{$hash->{'extra'}}, $extra); + foreach my $extra ( splice( @{$con}, 8, -1 ) ) { + push( @{ $hash->{extra} }, $extra ); } - $hash->{'dep_time'} = $con->[0]; + $hash->{dep_time} = $con->[0]; + # always "ab" $con->[1]; - $hash->{'dep_stop'} = $con->[2]; - $hash->{'train_line'} = $con->[3]; - $hash->{'arr_time'} = $con->[4]; + $hash->{dep_stop} = $con->[2]; + $hash->{train_line} = $con->[3]; + $hash->{arr_time} = $con->[4]; + # always "an" $con->[5]; - $hash->{'arr_stop'} = $con->[6]; - $hash->{'train_dest'} = $con->[7]; + $hash->{arr_stop} = $con->[6]; + $hash->{train_dest} = $con->[7]; + + push( @{$elements}, $hash ); + } + + return $elements; +} + +sub new { + my ( $obj, %conf ) = @_; + + my $ref = {}; + + $ref->{config} = \%conf; + + $ref->{post} = create_post( \%conf ); + + return bless( $ref, $obj ); +} + +sub submit { + my ( $self, %conf ) = @_; + + $conf{autocheck} = 1; + + $self->{ua} = LWP::UserAgent->new(%conf); - push(@{$elements}, $hash); + my $response = $self->{ua} + ->post( 'http://efa.vrr.de/vrr/XSLT_TRIP_REQUEST2', $self->{post} ); + + # XXX (workaround) + # The content actually is iso-8859-1. But HTML::Message doesn't actually + # decode character strings when they have that encoding. However, it + # doesn't check for latin-1, which is an alias for iso-8859-1. + + $self->{html_reply} = $response->decoded_content( charset => 'latin-1' ); + + return; +} + +sub parse { + my ($self) = @_; + + my $tree = XML::LibXML->load_html( string => $self->{html_reply}, ); + + my $raw_cons = parse_initial($tree); + + for my $raw_con ( @{$raw_cons} ) { + push( @{ $self->{connections} }, parse_pretty($raw_con) ); + } + $self->{tree} = $tree; + + $self->check_ambiguous(); + $self->check_no_connections(); + + if ( @{$raw_cons} == 0 ) { + confess('Got no data to parse'); + } + + return 1; +} + +sub check_ambiguous { + my ($self) = @_; + my $tree = $self->{tree}; + + my $xp_select = XML::LibXML::XPathExpression->new('//select'); + my $xp_option = XML::LibXML::XPathExpression->new('./option'); + + foreach my $select ( @{ $tree->findnodes($xp_select) } ) { + + my $post_key = $select->getAttribute('name'); + my @possible; + + foreach my $val ( $select->findnodes($xp_option) ) { + push( @possible, $val->textContent() ); + } + my $err_text = join( q{, }, @possible ); + + confess("Ambiguous input for '${post_key}': '${err_text}'"); } - return($elements); + + return; } +sub check_no_connections { + my ($self) = @_; + my $tree = $self->{tree}; + + my $xp_err_img = XML::LibXML::XPathExpression->new( + '//td/img[@src="images/ausrufezeichen.jpg"]'); + + my $err_node = $tree->findnodes($xp_err_img)->[0]; + + if ($err_node) { + my $text = $err_node->parentNode()->parentNode()->textContent(); + confess("Got no connections: '${text}'"); + } + + return; +} + +sub connections { + my ($self) = @_; + + return @{ $self->{connections} }; +} + +1; + +__END__ + +=head1 NAME + +WWW::Efa - inofficial interface to the efa.vrr.de German itinerary service + +=head1 SYNOPSIS + + use WWW::Efa; + + my $efa = WWW::Efa->new( + from => ['Essen', 'HBf'], + to => ['Duisburg', 'HBf'], + ); + + $efa->submit(); + $efa->parse(); + + for my $con ($efa->connections()) { + for my $c (@{$con}) { + printf( + "%-5s ab %-30s %-20s %s\n%-5s an %-30s\n\n",, + @{$c}{'dep_time', 'dep_stop', 'train_line', 'train_dest'}, + @{$c}{'arr_time', 'arr_stop'}, + ); + } + print "\n\n"; + } + +=head1 VERSION + +version 1.3 + +=head1 DESCRIPTION + +B is a client for the efa.vrr.de web interface. +You pass it the start/stop of your journey, maybe a time and a date and more +details, and it returns the up-to-date scheduled connections between those two +stops. + +It uses B and B for this. + =head1 METHODS -=head2 new(%conf) +=over + +=item $efa = WWW::Efa->new(I<%conf>) Returns a new WWW::Efa object and sets up its POST data via %conf. @@ -487,153 +592,17 @@ If true: Prefer connections allowing to take a bike along =back -When encountering invalid hash keys, a WWW::Efa::Error object is stored to be -retrieved by $efa->error(); - -=cut - -sub new { - my ($obj, %conf) = @_; - my $ref = {}; - - $ref->{'config'} = \%conf; - - eval { - $ref->{'post'} = create_post(\%conf); - }; - if ($@ and ref($@) eq 'WWW::Efa::Error::Setup') { - $ref->{'error'} = $@; - } - - return bless($ref, $obj); -} - -=head2 $efa->error() - -In case a WWW::Efa operation encountered an error, this returns a -B object related to the exact error. Otherwise, returns -undef. - -=cut - -sub error { - my ($self) = @_; - - if ($self->{'error'}) { - return $self->{'error'}; - } - return; -} - -=head2 $efa->submit(%opts) +=item $efa->submit(I<%opts>) Submit the query to B. -B<%opts> is passed on to LWP::UserAgent->new(%opts). +I<%opts> is passed on to LWP::UserAgent->new(%opts). -=cut - -sub submit { - my ($self, %conf) = @_; - - $conf{'autocheck'} = 1; - - $self->{'ua'} = LWP::UserAgent->new(%conf); - - my $response - = $self->{'ua'}->post('http://efa.vrr.de/vrr/XSLT_TRIP_REQUEST2', - $self->{post}); - - # XXX (workaround) - # The content actually is iso-8859-1. But HTML::Message doesn't actually - # decode character strings when they have that encoding. However, it - # doesn't check for latin-1, which is an alias for iso-8859-1. - - $self->{'html_reply'} = $response->decoded_content( - charset => 'latin-1' - ); -} - -=head2 $efa->parse() +=item $efa->parse() Parse the B reply. -returns a true value on success. Upon failure, returns undef and sets -$efa->error() to a WWW::Efa::Error object. - -=cut - -sub parse { - my ($self) = @_; - my $err; - - my $tree = XML::LibXML->load_html( - string => $self->{'html_reply'}, - ); - - my $raw_cons = parse_initial($tree); - - if (@{$raw_cons} == 0) { - $self->{'error'} = WWW::Efa::Error::NoData->new(); - } - - for my $raw_con (@{$raw_cons}) { - push(@{$self->{'connections'}}, parse_pretty($raw_con)); - } - $self->{'tree'} = $tree; - - if ($err = $self->check_ambiguous()) { - $self->{'error'} = $err; - } - elsif ($err = $self->check_no_connections()) { - $self->{'error'} = $err; - } - - if ($self->{'error'}) { - return; - } - - return 1; -} - -sub check_ambiguous { - my ($self) = @_; - my $tree = $self->{'tree'}; - - my $xp_select = XML::LibXML::XPathExpression->new('//select'); - my $xp_option = XML::LibXML::XPathExpression->new('./option'); - - foreach my $select (@{$tree->findnodes($xp_select)}) { - - my $post_key = $select->getAttribute('name'); - my @possible; - - foreach my $val ($select->findnodes($xp_option)) { - push(@possible, $val->textContent()); - } - - return WWW::Efa::Error::Ambiguous->new( - $post_key, - @possible, - ); - } -} - -sub check_no_connections { - my ($self) = @_; - my $tree = $self->{'tree'}; - - my $xp_err_img = XML::LibXML::XPathExpression->new( - '//td/img[@src="images/ausrufezeichen.jpg"]'); - - my $err_node = $tree->findnodes($xp_err_img)->[0]; - - if ($err_node) { - return WWW::Efa::Error::Backend->new( - $err_node->parentNode()->parentNode()->textContent() - ); - } -} +returns a true value on success. -=head2 $efa->connections() +=item $efa->connections() Returns an array of connection elements. Each connection element is an arrayref of connection part, and each connecton part is a hash containing the @@ -663,12 +632,32 @@ Arrival stop, e.g. "Berlin HBf" =back -=cut +=back -sub connections { - my ($self) = @_; +=head1 DIAGNOSTICS - return(@{$self->{'connections'}}); -} +Dies with a backtrace when anything goes wrong. -1; +=head1 DEPENDENCIES + +=over + +=item * LWP::UserAgent(3pm) + +=item * XML::LibXML(3pm) + +=back + +=head1 BUGS AND LIMITATIONS + +The parser is still somewhat fragile and has no proper error handling. + +It is best not to pass Unicode characters to B. + +=head1 AUTHOR + +Copyright (C) 2009-2011 by Daniel Friesel Ederf@finalrewind.orgE + +=head1 LICENSE + + 0. You just DO WHAT THE FUCK YOU WANT TO. -- cgit v1.2.3