diff options
Diffstat (limited to 'lib/WWW')
| -rwxr-xr-x | lib/WWW/Efa.pm | 197 |
1 files changed, 170 insertions, 27 deletions
diff --git a/lib/WWW/Efa.pm b/lib/WWW/Efa.pm index 3ec8443..da0bb05 100755 --- a/lib/WWW/Efa.pm +++ b/lib/WWW/Efa.pm @@ -10,43 +10,149 @@ use WWW::Mechanize; my $VERSION = '1.3+git'; -sub new { - my ($obj, $post) = @_; - my $ref = {}; +sub post_time { + my ($post, $conf) = @_; + my $time; - my $firsturl - = 'http://efa.vrr.de/vrr/XSLT_TRIP_REQUEST2?language=de&itdLPxx_transpCompany=vrr'; - my $posturl = 'http://efa.vrr.de/vrr/XSLT_TRIP_REQUEST2'; + if ($conf->{'depart'} || $conf->{'time'}) { + $post->{'itdTripDateTimeDepArr'} = 'dep'; + $time = $conf->{'depart'} || $conf->{'time'}; + } + else { + $post->{'itdTripDateTimeDepArr'} = 'arr'; + $time = $conf->{'arrive'}; + } - $ref->{'mech'} = WWW::Mechanize->new( - autocheck => 1, - ); + if ($time !~ / ^ [0-2]? \d : [0-5]? \d $ /x) { + confess('conf: time invalid. Use HH:MM'); + } + @{$post}{'itdTimeHour', 'itdTimeMinute'} = split(/:/, $time); +} - $ref->{'mech'}->get($firsturl); - $ref->{'mech'}->submit_form( - form_name => 'jp', - fields => $post, - ); +sub post_date { + my ($post, $date) = @_; - # 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. + if ($date !~ /^ [0-3]? \d \. [01]? \d \. (?: \d{4} )? $/x) { + confess('conf: date invalid DD.MM.[YYYY]'); + } + @{$post}{'itdDateDay', 'itdDateMonth', 'itdDateYear'} = split(/\./, $date); + $post->{'itdDateYear'} //= (localtime(time))[5] + 1900; +} - $ref->{'html_reply'} = $ref->{'mech'}->response()->decoded_content( - charset => 'latin-1' - ); +sub post_exclude { + my ($post, @exclude) = @_; + my @mapping = qw{ + 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]) { + $post->{"inclMOT_${map_id}"} = undef; + $ok = 1; + } + } + if (not $ok) { + confess("conf: exclude: Invalid element $exclude_type"); + } + } +} - return bless($ref, $obj); +sub post_prefer { + my ($post, $prefer) = (@_); + + given($prefer) { + when('speed') { $post->{'routeType'} = 'LEASTTIME' } + when('nowait') { $post->{'routeType'} = 'LEASTINTERCHANGE' } + when('nowalk') { $post->{'routeType'} = 'LEASTWALKING' } + default { + confess("conf: prefer: Invalid argument $prefer"); + } + } } -sub new_from_html { - my ($obj, $html) = @_; - my $ref = {}; +sub post_include { + my ($post, $include) = @_; + + given ($include) { + when ('local') { $post->{'lineRestriction'} = 403 } + when ('ic') { $post->{'lineRestriction'} = 401 } + when ('ice') { $post->{'lineRestriction'} = 400 } + default { + confess('conf: invalid include'); + } + } +} - $ref->{'html_reply'} = $html; +sub post_walk_speed { + my ($post, $walk_speed) = @_; - return bless($ref, $obj); + if ($walk_speed ~~ ['normal', 'fast', 'slow']) { + $post->{'changeSpeed'} = $walk_speed; + } + else { + confess('conf: walk_speed invalid'); + } +} + +sub post_place { + my ($post, $which, $place, $stop, $type) = @_; + + if (not ($place and $stop)) { + confess("conf: ${which}: Need at least two elements"); + } + + $type //= 'stop'; + + @{$post}{"place_${which}", "name_${which}"} = ($place, $stop); + + if ($type ~~ [qw[address poi stop]]) { + $post->{"type_${which}"} = $type; + } +} + +sub create_post { + my ($conf) = @_; + my $post = {}; + + post_place($post, 'origin', @{$conf->{'from'}}); + + post_place($post, 'destination', @{$conf->{'to'}}); + + if ($conf->{'via'}) { + post_place($post, 'via', @{$conf->{'via'}}); + } + if ($conf->{'arrive'} || $conf->{'depart'} || $conf->{'time'}) { + post_time($post, $conf); + } + if ($conf->{'date'}) { + post_date($post, $conf->{'date'}); + } + if ($conf->{'exclude'}) { + post_exclude($post, @{$conf->{'exclude'}}); + } + if ($conf->{'max_interchanges'}) { + $post->{'maxChanges'} = $conf->{'max_interchanges'}; + } + if ($conf->{'prefer'}) { + post_prefer($post, $conf->{'prefer'}); + } + if ($conf->{'proximity'}) { + $post->{'useProxFootSearch'} = 1; + } + if ($conf->{'include'}) { + post_include($post, $conf->{'include'}); + } + if ($conf->{'walk_speed'}) { + post_walk_speed($post, $conf->{'walk_speed'}); + } + if ($conf->{'bike'}) { + $post->{'bikeTakeAlong'} = 1; + } + + return $post; } sub parse_initial { @@ -158,6 +264,43 @@ sub parse_pretty { 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) = @_; + + my $firsturl + = 'http://efa.vrr.de/vrr/XSLT_TRIP_REQUEST2?language=de&itdLPxx_transpCompany=vrr'; + + $self->{'mech'} = WWW::Mechanize->new( + autocheck => 1, + timeout => $conf{'timeout'} // 10, + ); + + $self->{'mech'}->get($firsturl); + $self->{'mech'}->submit_form( + form_name => 'jp', + fields => $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'} = $self->{'mech'}->response()->decoded_content( + charset => 'latin-1' + ); +} + sub parse { my ($self) = @_; |