diff options
author | Daniel Friesel <derf@finalrewind.org> | 2011-09-08 17:11:10 +0200 |
---|---|---|
committer | Daniel Friesel <derf@finalrewind.org> | 2011-09-08 17:11:10 +0200 |
commit | a785413d46ea064d7bc6dff1c2c86d1392557dda (patch) | |
tree | 993061d827e144e75cdb12eb4ac6599215c1ac68 |
initial commit
-rw-r--r-- | .gitignore | 10 | ||||
-rw-r--r-- | Build.PL | 22 | ||||
-rw-r--r-- | README | 24 | ||||
-rwxr-xr-x | bin/efa-m | 139 | ||||
-rw-r--r-- | lib/Travel/Status/DE/VRR.pm | 155 | ||||
-rw-r--r-- | lib/Travel/Status/DE/VRR/Result.pm | 74 |
6 files changed, 424 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..189304f --- /dev/null +++ b/.gitignore @@ -0,0 +1,10 @@ +/_build +/Build +/blib +/cover_db +/MANIFEST +/MANIFEST.bak +/MANIFEST.SKIP +/MANIFEST.SKIP.bak +/MYMETA.yml +/MYMETA.json diff --git a/Build.PL b/Build.PL new file mode 100644 index 0000000..094b2d3 --- /dev/null +++ b/Build.PL @@ -0,0 +1,22 @@ +#!/usr/bin/env perl + +use strict; +use warnings; +use Module::Build; + +Module::Build->new( + + build_requires => { + 'Test::More' => 0, + 'Test::Pod' => 0, + }, + module_name => 'Travel::Status::DE::VRR', + license => 'unrestricted', + requires => { + 'perl' => '5.10.1', + 'Getopt::Long' => 0, + 'XML::LibXML' => 0, + }, + sign => 1, + +)->create_build_script(); @@ -0,0 +1,24 @@ +Travel::Status::DE::VRR - ?? +----------------------------------------------- + +* <http://finalrewind.org/projects/Travel-Status-DE-VRR/> + + +Dependencies +------------ + + * perl version 5.10.1 or newer + * XML::LibXML + + +Installation +------------ + +$ perl Build.PL +$ ./Build +$ sudo ./Build install + +See also the Module::Build documentation. + +You can then run 'man Travel::Status::DE::VRR'. +This distribution also ships the script 'efa-m', see 'man efa-m'. diff --git a/bin/efa-m b/bin/efa-m new file mode 100755 index 0000000..f031e81 --- /dev/null +++ b/bin/efa-m @@ -0,0 +1,139 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use 5.010; + +our $VERSION = '0.00'; + +use Getopt::Long qw(:config no_ignore_case); +use List::Util qw(max); +use Travel::Status::DE::VRR; + +my ( $date, $time ); +my @output; + +binmode( STDOUT, ':encoding(utf-8)' ); + +GetOptions( + 'd|date=s' => \$date, + 'h|help' => sub { show_help(0) }, + 't|time=s' => \$time, + 'V|version' => \&show_version, + +) or show_help(1); + +if (@ARGV != 2) { + show_help(1); +} + +my ($place, $station) = @ARGV; + +my $status = Travel::Status::DE::VRR->new( + date => $date, + place => $place, + name => $station, + time => $time, +); + +sub show_help { + my ($code) = @_; + + print "Usage: efa-m [-d <dd.mm.yyyy>] [-t <hh:mm>] <city> <station>\n" + . "See also: man efa-m\n"; + + exit $code; +} + +sub show_version { + say "efa-m version ${VERSION}"; + + exit 0; +} + +sub display_result { + my (@lines) = @_; + + my @line_length; + + if ( not @lines ) { + die("Nothing to show\n"); + } + + for my $i ( 0 .. 3 ) { + $line_length[$i] = max map { length( $_->[$i] ) } @lines; + } + + for my $line (@lines) { + printf( + join( q{ }, ( map { "%-${_}s" } @line_length ) ) . "\n", + @{$line}[ 0 .. 3 ] + ); + } + + return; +} + +for my $d ( $status->results ) { + + push( + @output, + [ + $d->time, + $d->platform, + $d->line, + $d->destination, + ] + ); +} + +display_result(@output); + +__END__ + +=head1 NAME + +=head1 SYNOPSIS + +=head1 VERSION + +version 0.00 + +=head1 DESCRIPTION + +=head1 OPTIONS + +=over + +=item B<-V>, B<--version> + +Show version information. + +=back + +=head1 EXIT STATUS + +=head1 CONFIGURATION + +None. + +=head1 DEPENDENCIES + +=over + +=item * Class::Accessor(3pm) + +=item * XML::LibXML(3pm) + +=item * WWW::Mechanize(3pm) + +=back + +=head1 BUGS AND LIMITATIONS + +=head1 AUTHOR + +Copyright (C) 2011 by Daniel Friesel E<lt>derf@finalrewind.orgE<gt> + +=head1 LICENSE + +This program is licensed under the same terms as Perl itself. diff --git a/lib/Travel/Status/DE/VRR.pm b/lib/Travel/Status/DE/VRR.pm new file mode 100644 index 0000000..8bb1f6d --- /dev/null +++ b/lib/Travel/Status/DE/VRR.pm @@ -0,0 +1,155 @@ +package Travel::Status::DE::VRR; + +use strict; +use warnings; +use 5.010; + +our $VERSION = '0.00'; + +use Travel::Status::DE::VRR::Result; +use WWW::Mechanize; +use XML::LibXML; + +sub new { + my ( $class, %opt ) = @_; + + my $mech = WWW::Mechanize->new(); + my @now = localtime( time() ); + + my $self = { + post => { + command => q{}, + deleteAssignedStops_dm => '1', + help => 'Hilfe', + itdDateDay => $now[3], + itdDateMonth => $now[4] + 1, + itdDateYear => $now[5] + 1900, + 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 => $now[2], + itdTimeMinute => $now[1], + language => 'de', + nameInfo_dm => 'invalid', + nameState_dm => 'empty', + name_dm => $opt{name}, + 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 => 'stop', + useProxFootSearch => '0', + useRealtime => '1', + }, + }; + + $mech->post( 'http://efa.vrr.de/vrr/XSLT_DM_REQUEST', $self->{post} ); + + if ( $mech->response->is_error ) { + die( $mech->response->status_line ); + } + + my $form = $mech->form_number(1); + + for my $input ( $form->find_input( 'dmLineSelection', 'option' ) ) { + $input->check(); + } + + $mech->click('submitButton'); + + if ( $mech->response->is_error ) { + die( $mech->response->status_line ); + } + + $self->{html} = $mech->response->decoded_content; + + $self->{tree} = XML::LibXML->load_html( + string => $self->{html}, + recover => 2, + suppress_errors => 1, + suppress_warnings => 1, + ); + + return bless( $self, $class ); +} + +sub results { + my ($self) = @_; + my @results; + + my $xp_element = XML::LibXML::XPathExpression->new( + '//td[@colspan="3"]/table/tr[starts-with(@class,"bgColor")]'); + + my @parts = ( + ['time', './td[2]'], + ['platform', './td[3]'], + ['line', './td[5]'], + ['dest', './td[7]'], + ); + + @parts = map { [ $_->[0], XML::LibXML::XPathExpression->new($_->[1]) ] } + @parts; + + for my $tr ($self->{tree}->findnodes($xp_element) ) { + my ($time, $platform, $line, $dest) = map { ($tr->findnodes($_->[1]))[0]->textContent } @parts; + $platform =~ s{ ^ \S+ \s }{}x; + push(@results, Travel::Status::DE::VRR::Result->new( + time => $time, + platform => $platform, + line => $line, + destination => $dest, + )); + } + + return @results; +} + +1; + +__END__ + +=head1 NAME + +Travel::Status::DE::VRR - inofficial VRR departure monitor + +=head1 SYNOPSIS + +=head1 VERSION + +version + +=head1 DESCRIPTION + +=head1 METHODS + +=over + +=back + +=head1 DIAGNOSTICS + +=head1 DEPENDENCIES + +=over + +=back + +=head1 BUGS AND LIMITATIONS + +=head1 SEE ALSO + +=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. diff --git a/lib/Travel/Status/DE/VRR/Result.pm b/lib/Travel/Status/DE/VRR/Result.pm new file mode 100644 index 0000000..a61a9d2 --- /dev/null +++ b/lib/Travel/Status/DE/VRR/Result.pm @@ -0,0 +1,74 @@ +package Travel::Status::DE::VRR::Result; + +use strict; +use warnings; +use 5.010; + +use parent 'Class::Accessor'; + +our $VERSION = '0.00'; + +Travel::Status::DE::VRR::Result->mk_ro_accessors( + qw(destination time platform line)); + +sub new { + my ( $obj, %conf ) = @_; + + my $ref = \%conf; + + return bless( $ref, $obj ); +} +1; + +__END__ + +=head1 NAME + +Travel::Status::DE::VRR::Result - Information about a single +departure received by Travel::Status::DE::VRR + +=head1 SYNOPSIS + +=head1 VERSION + +version 0.00 + +=head1 DESCRIPTION + +=head1 METHODS + +=head2 ACCESSORS + +=over + +=back + +=head2 INTERNAL + +=over + +=back + +=head1 DIAGNOSTICS + +None. + +=head1 DEPENDENCIES + +=over + +=item Class::Accessor(3pm) + +=back + +=head1 BUGS AND LIMITATIONS + +=head1 SEE ALSO + +=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. |