File Coverage

blib/lib/WWW/EFA.pm

Criterion	Covered	Total	%
statement	22	24	91.6
branch			n/a
condition			n/a
subroutine	8	8	100.0
pod			n/a
total	30	32	93.7

package WWW::EFA;
use Moose;
use MooseX::Params::Validate;

# CPAN modules
use LWP::UserAgent;
use YAML;
use Carp;
use Try::Tiny;
use File::Spec::Functions;
use XML::LibXML;
use Class::Date qw/now/;

### Local modules
# Objects
use WWW::EFA::Departure;
use WWW::EFA::Line;
use WWW::EFA::Location;
use WWW::EFA::Place;
use WWW::EFA::Station;
use WWW::EFA::ResultHeader;

# Factories
use WWW::EFA::DepartureFactory;
use WWW::EFA::LineFactory;
use WWW::EFA::LocationFactory;
use WWW::EFA::PlaceFactory;
use WWW::EFA::HeaderFactory;
use WWW::EFA::RouteFactory;

use WWW::EFA::Request;
use WWW::EFA::DeparturesResult;
use WWW::EFA::ConnectionsResult;


=head1 NAME

WWW::EFA - Interface to EFA sites (Elektronische Fahrplanauskunft)

=head1 VERSION

    Version 0.04

=cut

our $VERSION = '0.04';


=head1 SYNOPSIS

Get location of public transport stops and connection details.

    use WWW::EFA;

    my $efa = WWW::EFA->new();
    ...

=head1 PARAMS/ACCESSORS

TODO: RCL 2012-01-22 document params/accessors

=cut

has 'base_url'      => ( is => 'ro', isa => 'Str', required => 1,   );
has 'cache_dir'     => ( is => 'ro', isa => 'Str',                  );

has 'agent' => (
    is          => 'ro',
    isa         => 'LWP::UserAgent',
    required    => 1,
    lazy        => 1,
    default     => sub{ LWP::UserAgent->new() },
);


has 'place_factory' => (
    is          => 'ro',
    isa         => 'WWW::EFA::PlaceFactory',
    required    => 1,
    lazy        => 1,
    default     => sub{ WWW::EFA::PlaceFactory->new() },
    );

has 'line_factory' => (
    is          => 'ro',
    isa         => 'WWW::EFA::LineFactory',
    required    => 1,
    lazy        => 1,
    default     => sub{ WWW::EFA::LineFactory->new() },
    );

has 'location_factory' => (
    is          => 'ro',
    isa         => 'WWW::EFA::LocationFactory',
    required    => 1,
    lazy        => 1,
    default     => sub{ WWW::EFA::LocationFactory->new() },
    );

has 'departure_factory' => (
    is          => 'ro',
    isa         => 'WWW::EFA::DepartureFactory',
    required    => 1,
    lazy        => 1,
    default     => sub{ WWW::EFA::DepartureFactory->new() },
    );

has 'route_factory' => (
    is          => 'ro',
    isa         => 'WWW::EFA::RouteFactory',
    required    => 1,
    lazy        => 1,
    default     => sub{ WWW::EFA::RouteFactory->new() },
    );

has 'header_factory' => (
    is          => 'ro',
    isa         => 'WWW::EFA::HeaderFactory',
    required    => 1,
    lazy        => 1,
    default     => sub{ WWW::EFA::HeaderFactory->new() },
    );

# Requests per minute
has 'sleep_between_requests' => (
    is          => 'ro',
    isa         => 'Int',
    required    => 1,
    default     => 0,
);

has 'last_request_time' => (
    is          => 'rw',
    isa         => 'Int',
);

=head1 METHODS

=head2 departures

Queries the XSLT_DM_REQUEST method from the EFA server.

=head3 Params

=over 4

=item location => L<WWW::EFA::Location> (which must have the id (stopID) defined)

=back

=cut
sub departures {
    my ( $self, %params ) = validated_hash(
        \@_,
        location => { isa => 'WWW::EFA::Location'    },
        equivs   => { isa => 'Bool', default  => '0' },
        limit    => { isa => 'Int' , optional => 1   },
    );
    if( not $params{location}->id ){
        croak( "Need a location with an id (stopID) to get departures" );
    }

    # Build the request for the stopfinder request
    # The suffix '_sf' in many arguments is for the 'stop finder' requst
    my $req = WWW::EFA::Request->new(
        base_url        => $self->base_url,
        service         => 'XSLT_DM_REQUEST'
    );

    $req->set_argument( 'type_dm'                       , 'stop'                  );
    $req->set_argument( 'useRealtime'                   , 1                       );
    $req->set_argument( 'mode'                          , 'direct'                );
    $req->set_argument( 'name_dm'                       , $params{location}->id   );
    $req->set_argument( 'deleteAssignedStops_dm'        , $params{equivs}         );
    $req->set_argument( 'limit'                         , $params{limit}          ) if $params{limit};

    # Get the reader
    my $doc = $self->_get_doc( request => $req );

    # Move into the itdDepartureMonitorRequest element
    ( $doc ) = $doc->findnodes( 'itdDepartureMonitorRequest' );

    # Sanity checks
    my( $odv_elem ) = $doc->findnodes( "itdOdv" );
    if( not $odv_elem or $odv_elem->getAttribute( 'usage' ) ne 'dm' ){
        croak( "Could not find itdOdv/attribute::usage = 'dm'" );
    }

    # This is the result we will return
    my $result = WWW::EFA::DeparturesResult->new();

    my( $name_elem ) = $odv_elem->findnodes( 'itdOdvName' );
    if( not $name_elem or not $name_elem->hasAttribute( 'state' ) or $name_elem->getAttribute( 'state' ) ne 'identified' ){
        # TODO: RCL 2011-11-14 Deal with list or other error options better
        return $result;
    }

    my $departure_location = $self->location_factory->location_from_odvNameElem( $odv_elem->findnodes( 'itdOdvName/odvNameElem' ) );
    if( not $departure_location ){
        return $result;
    }

    # If the Location does not have a name, get it from the place
    if( not $departure_location->name ){
        my $place = $self->place_factory->place_from_itdOdvPlace( $odv_elem->findnodes( 'itdOdvPlace' ) );
        $departure_location->name( $place->name );
    }

    $result->add_departure_station( WWW::EFA::Station->new( location => $departure_location ) );

    # Alternative (further away) departure stations
    foreach my $alt_station_element ( $odv_elem->findnodes( 'itdOdvAssignedStops/itdOdvAssignedStop' ) ){
        # TODO: RCL 2011-11-06 This hasn't been tested yet - I have never seen an example with more stops...
        my $location = $self->location_factory->location_from_itdOdvAssignedStop( $alt_station_element );
        $result->add_departure_station( WWW::EFA::Station->new( location => $location ) );
    }

    # Get the lines
    foreach my $line_elem ( $doc->findnodes( 'itdServingLines/itdServingLine' ) ) {
        my $line = $self->line_factory->line_from_itdServingLine( $line_elem );
        $result->add_line( $line );
    }

    # Get the departures
    foreach my $dep_elem ( $doc->findnodes( 'itdDepartureList/itdDeparture' ) ){
        my $departure = $self->departure_factory->departure_from_itdDeparture( $dep_elem );
        $result->add_departure( $departure );
    }

    return $result;
}

=head2 trips

Queries the XSLT_TRIP_REQUEST2 method from the EFA server.

=head3 Required Params

=over 4

=item I<from> => L<WWW::EFA::Location>

=item I<to> => L<WWW::EFA::Location>

=item I<date> => L<Class::Date> of the time to be searched

=back

=head3 Optional Params

=over 4

=item I<via> => L<WWW::EFA::Location> (default undef)

=item I<is_departure> => $boolean (set to true if the date is the departure time)

=item I<language> => $string (language to return results in. Default 'de')

=item I<walk_speed> => $number (override default walk speed.)
    TODO: RCL 2011-08-23 What is walk speed? km/h? m/s?

=back

=cut
sub trips {
    my ( $self, %params ) = validated_hash(
        \@_,
        from         => { isa => 'WWW::EFA::Location'                     },
        via          => { isa => 'WWW::EFA::Location' , optional => 1     },
        to           => { isa => 'WWW::EFA::Location'                     },
        date         => { isa => 'Class::Date'        , default  => now() },
        is_departure => { isa => 'Bool'               , default  => 1     },
        language     => { isa => 'Str'                , default  => 'de'  },
        walk_speed   => { isa => 'Num',               , optional => 1     },
        products     => { isa => 'ArrayRef'           , optional => 1     },
    );

    # Build the request for the stopfinder request
    # The suffix '_sf' in many arguments is for the 'stop finder' requst
    my $req = WWW::EFA::Request->new(
        base_url  => $self->base_url,
        service   => 'XSLT_TRIP_REQUEST2',
    );

    $req->set_argument( 'sessionID'                     , '0'                                   );
    $req->set_argument( 'requestID'                     , '0'                                   );
    $req->set_argument( 'ptOptionsActive'               , '1'                                   );
    $req->set_argument( 'useRealtime'                   , '1'                                   );
    $req->set_argument( 'useProxyFootSearch'            , '1'                                   );
    $req->set_argument( 'language'                      , $params{language}                     );
    $req->set_argument( 'itdTripDateTimeDepArr'         , $params{is_departure} ? 'dep' : 'arr' );
    $req->set_argument( 'changeSpeed'                   , $params{walk_speed}                   ) if $params{walk_speed};

    $req->set_argument( 'itdDate'                       , $params{date}->strftime( '%Y%m%d' ) );
    $req->set_argument( 'itdTime'                       , $params{date}->strftime( '%H%M' ) );

    # Add the locations
    $req->add_location( 'origin'        , $params{from} );
    $req->add_location( 'destination'   , $params{to}   );
    $req->add_location( 'via'           , $params{via}  ) if( $params{via} );

    # TODO: RCL 2011-11-10 make mapping homogeneous with DepartureFactory for mot_type
    if ( $params{products} ){
        $req->set_argument( 'includedMeans'             , 'checkbox'    );

        my %products =
            map{ $_ => 1 }
            @{ $params{products} };

	if ( $products{I} or $products{R} ){
            $req->set_argument( 'inclMOT_0',    'on' );
        }
	if( $products{S} ){
	    $req->set_argument( 'inclMOT_1',    'on' );
        }
        if( $products{U} ){
            $req->set_argument( 'inclMOT_2',    'on' );
        }
        if( $products{T} ){
            $req->set_argument( 'inclMOT_3',    'on' );
            $req->set_argument( 'inclMOT_4',    'on' );
        }
        if( $products{B} ){
            $req->set_argument( 'inclMOT_5',    'on' );
            $req->set_argument( 'inclMOT_6',    'on' );
            $req->set_argement( 'inclMOT_7',    'on' );
        }
        if( $products{P} ){
	    $req->set_argument( 'inclMOT_10',   'on' );
        }

	if( $products{F} ){
	    $req->set_argument( 'inclMOT_9',    'on' );
        }
        if( $products{C} ){
            $req->set_argument( 'inclMOT_8',    'on' );
        }

	$req->set_argument( 'inclMOT_11',   'on' ); # 11 == 'others'. Always on for now

	# workaround for highspeed trains: fails when you want highspeed, but not regional
	if ( $products{I} ){
	    $req->set_argument( 'lineRestriction',  403 ); # means: all but ice
	}
    }

    # Get the data
    my $doc = $self->_get_doc( request => $req );
    my $header = $self->header_factory->header_from_result( $doc );

    my $result = WWW::EFA::ConnectionsResult->new(
        request     => $req,
        );

    # Sanity checks
    # Valid date?
    # TODO: RCL 2011-11-11 Check for valid date
    # my( $date_elem ) = $doc->findnodes( 'itdTripdateTime/itdDateTime/itdDate/itdMessage' );

    # Get the requestID
    my( $request_elem ) = $doc->findnodes( 'itdTripRequest' );
    if( $request_elem and $request_elem->hasAttribute( 'requestID' ) ){
        $result->request_id( $request_elem->getAttribute( 'requestID' ) );
    }

    # Get the to/from/via/...
    STOP:
    foreach my $stop_elem ( $request_elem->findnodes( 'itdOdv' ) ){
        my $usage = $stop_elem->getAttribute( 'usage' );
        my( $state_elem ) = $stop_elem->findnodes( 'itdOdvPlace' );
        if( not $state_elem or not $state_elem->hasAttribute( 'state' )
            or $state_elem->getAttribute( 'state' ) ne 'identified' ){
            # TODO: RCL 2011-11-11 Deal with ambiguous (not identified) results here.
            next STOP;
        }

        my( $name_elem ) = $stop_elem->findnodes( 'itdOdvName/odvNameElem' );
        if( not $name_elem ){
            #carp( "No odvNameElem inside itdOdv:\n" . $stop_elem->toString( 2 ) );
            next STOP;
        }
        my $location = $self->location_factory->location_from_odvNameElem( $name_elem );

        # If there was no location (e.g. no via), then just jump to next STOP
        if( not $location ){
            #carp( "Could not get a location from:\n" . $name_elem->toString( 2 ) );
            next STOP;
        }

        my $location_attribute = $usage . '_location';

        $result->$location_attribute( $location );
    }

    foreach my $route_elem( $request_elem->findnodes( 'itdItinerary/itdRouteList/itdRoute' ) ){
        my $route = $self->route_factory->route_from_itdRoute( $route_elem );
        $result->add_route( $route );
    }

    return $result;
}

=head2 stop_finder

Queries the XML_STOPFINDER_REQUEST method from the EFA server.

Used to get an address from coordinates

Returns an ArrayRef of L<WWW::EFA::Location>.

=head3 Usage


my $location = WWW::EFA::Location->new(
    coordinates => WWW::EFA::Coordinates->new(
        lat => 12.12345,
        lon => 48.12345,
    );

my( $address ) = $efa->stop_finder(
    location    => $location,
    );


=head3 Params

=over 4

=item location  => L<WWW::EFA::Location>

=back

=cut
sub stop_finder {
    my ( $self, %params ) = validated_hash(
        \@_,
        location => { isa => 'WWW::EFA::Location' },
    );

    # Build the request for the stopfinder request
    # The suffix '_sf' in many arguments is for the 'stop finder' requst
    my $req = WWW::EFA::Request->new(
        base_url        => $self->base_url,
        service         => 'XML_STOPFINDER_REQUEST',
    );

    # 1=place 2=stop 4=street 8=address 16=crossing 32=poi 64=postcode
    $req->set_argument( 'anyObjFilter_sf'                , 126      );

    $req->set_argument( 'reducedAnyPostcodeObjFilter_sf' , 64       );
    $req->set_argument( 'reducedAnyTooManyObjFilter_sf'  , 2        );
    $req->set_argument( 'useHouseNumberList'             , 'true'   );
    $req->set_argument( 'regionID_sf'                    , 1        );
    $req->add_location( 'sf'                             , $params{location} );

    # Get the doc
    my $doc = $self->_get_doc( request => $req );

    # Make sure the state is defined and a known value.
    # if not, then the XML was not the way we expect it...
    my( $place_elem ) = $doc->findnodes( 'itdStopFinderRequest/itdOdv/itdOdvPlace' );
    if( not $place_elem or not $place_elem->hasAttribute( 'state' ) ){
        croak( "state not found in itdOdvPlace" );
    }
    my $state = $place_elem->getAttribute( 'state' );
    if( $state !~ m/^(identified|list|notidentified)$/ ){
        croak( "Unknown state: $state" );
    }

    # If the location could not be identified, return empty arrayref
    return [] if( $state eq 'notidentified' );

    # Usually there will only be one match, but there could be more (see state 'list' above)
    my @locations;
    foreach my $name_elem( $doc->findnodes( 'itdStopFinderRequest/itdOdv/itdOdvName/odvNameElem' ) ){
        my $location = $self->location_factory->location_from_odvNameElem( $name_elem );
        push( @locations, $location ) if $location->id;
    }

    # nearby stops
    foreach my $alt_station_element ( $doc->findnodes( 'itdStopFinderRequest/itdOdv/itdOdvAssignedStops/itdOdvAssignedStop' ) ){
        # TODO: RCL 2011-11-06 This hasn't been tested yet - I have never seen an example with more stops...
        my $location = $self->location_factory->location_from_itdOdvAssignedStop( $alt_station_element );
        push( @locations, $location );
    }

    # TODO: RCL 2011-11-10 This request also returns a list of itdOdvAssignedStops - it is also suitable
    # for finding the closest stop.  What is the difference to coord request? Maybe this method is
    # superfluous legacy?

    return @locations;
}

=head2 coord_request

Queries the XML_COORD_REQUEST method from the EFA server.
Returns an array reference of L<WWW::EFA::Location> objects.


=head3 Params

=over 4

=item I<location> => L<WWW::EFA::Location>
Must have either id or lon/lat defined

=item I<max_results> => $integer
Maximum number of results to return

=item I<max_distance> => $integer
Maximum distance (meters) around the given location to search

=back

=cut
sub coord_request {
    my ( $self, %params ) = validated_hash(
        \@_,
        location      => { isa => 'WWW::EFA::Location'   },
        max_results   => { isa => 'Int', default => 50   },
        max_distance  => { isa => 'Int', default => 1320 },
    );

    # Build the request
    my $req = WWW::EFA::Request->new(
        base_url        => $self->base_url,
        service         => 'XML_COORD_REQUEST',
    );

    $req->set_argument( 'coordListOutputFormat' , 'STRING'              );
    $req->set_argument( 'type_1'                , 'STOP'                );
    $req->set_argument( 'inclFilter'            , 1                     );
    $req->set_argument( 'max'                   , $params{max_results}  );
    $req->set_argument( 'radius_1'              , $params{max_distance} );
    # Cannot use the $req->add_location method here because it would add the location by id
    $req->set_argument( 'coord'                 , sprintf( "%.6f:%.6f:WGS84",
            $params{location}->coordinates->longitude,
            $params{location}->coordinates->latitude,
            ) );
    my $doc = $self->_get_doc( request => $req );

    # Move into the itdDepartureMonitorRequest element
    ( $doc ) = $doc->findnodes( 'itdCoordInfoRequest' );

    my @locations;
    foreach my $coord_elem( $doc->findnodes( 'itdCoordInfo/coordInfoItemList/coordInfoItem' ) ){
        my $location = $self->location_factory->location_from_coordInfoItem( $coord_elem );
        push( @locations, $location );
    }
    return @locations;
}

=head2 complete_location_from_anything

Give any valid combination from which a Location object may be completed (id, lat/lon, latitude/longitude, or location) and it will return a complete L<WWW::EFA::Location>.

This can be handy in some contexts when you don't have a complete location object...

=head3 Params

=over 4

=item I<id> => $integer

=item I<lat> / I<latitude> => $number

=item I<lon> / I<longitude> => $number

=item I<location> => L<WWW::EFA::Location>

=back

=cut
sub complete_location_from_anything {
    my ( $self, %params ) = validated_hash(
        \@_,
        id          => { isa => 'Int', optional => 1 },
        lat         => { isa => 'Num', optional => 1 },
        lon         => { isa => 'Num', optional => 1 },
        latitude    => { isa => 'Num', optional => 1 },
        longitude   => { isa => 'Num', optional => 1 },
        location    => { isa => 'WWW::EFA::Location', optional => 1 },
      );

    if( $params{lat} ){
        $params{latitude} = $params{lat};
        delete( $params{lat} );
    }
    if( $params{lon} ){
        $params{longitude} = $params{lon};
        delete( $params{lon} );
    }

    if( not $params{location} and $params{id} ){
        $params{location} = $self->get_location( $params{id} );
    }

    # We don't have a location, but hopefully lat/lon
    if( not $params{location}  ){
        # Can't go on if no coords
        if( not $params{longitude} or not $params{latitude} ){
            croak( "Cannot set an origin without latitude, longitude or location!\n" );
        }
        $params{location} = WWW::EFA::Location->new(
            coordinates => WWW::EFA::Coordinates->new(
                latitude    => $params{latitude},
                longitude   => $params{longitude},
                ),
            );
    }

    # We have a rough location, without ID - see if we can make it one with an ID
    if( not $params{location}->id or not $params{location}->coordinates ){
        my @stops = $self->stop_finder(
            location    => $params{location},
        );
        if( scalar( @stops ) < 1 ){
            croak( "No stops found near location:\n" . $params{location}->string );
        }
        $params{location} = $stops[0];
    }
    if( not $params{location}->id ){
        croak( "I still don't have an ID for your location, even after searching for it...\n" );
    }
    return $params{location};
}

# Private method to wrap around:
#  * the http request to the EFA server
#  * parse the XML content
#  * error handling if any of the above fail or are unexpected
# Returns the XML as got from the EFA server
sub _get_xml {
    my ( $self, %params ) = validated_hash(
        \@_,
        request      => { isa => 'WWW::EFA::Request'   },
    );


    my $xml;
    # If the XML source is defined, use it rather than a live request
    my $cache_file = ( $self->cache_dir
        ? catfile( $self->cache_dir, $params{request}->digest )
        : undef );

    if( $cache_file and -f $cache_file ){
        # TODO: RCL 2011-11-20 add debug
        # printf "#RCL reading from: %s\n", $cache_file;
        open( my $fh_in, '<:encoding(ISO-8859-1)', $cache_file ) or die( $! );
        while( my $line = readline( $fh_in ) ){
            $xml .= $line;
        }
        close $fh_in;
    }else{
        # Don't hammer the server - sleep if need be...
        if( $self->sleep_between_requests and $self->last_request_time ){
            my $sleep = $self->sleep_between_requests - ( time() - $self->last_request_time );
            if( $sleep > 0 ){
                sleep( $sleep );
            }
        }

        # Use post - it is more robust than GET, and we don't have to encode parameters
        my $result = $self->agent->post( $params{request}->url, $params{request}->arguments );
        $self->last_request_time( time() );

        # If response code is not 2xx, something went wrong...
        if( not $result->is_success ){
            croak( "Response from posting request for stop_finder was not a success:\n" . Dump( {
                    URL       => $result->request->uri,
                    Status    => $result->code,
                    Content   => $result->decoded_content,
                    } ) );
        }
        $xml = $result->decoded_content;

        if( $cache_file ){
            # TODO: RCL 2011-11-13 Do all operators send in ISO-8859-1 encoding?
            open( my $fh_out, '>:encoding(ISO-8859-1)', $cache_file ) or die( $! );
            print $fh_out $xml;
            close $fh_out;
        }
    }

    return $xml;
}

# Private method to wrap around:
#  * get_xml
#  * make L<XML::LibXML> parser
#  * move to the /itdRequest element in the document
# Returns a L<XML::LibXML> document
sub _get_doc {
    my( $self, %params ) = validated_hash(
        \@_,
        request => { isa => 'WWW::EFA::Request' },
        );
    my $xml = $self->_get_xml( %params );

    my $parser = XML::LibXML->new();
    my $doc = $parser->parse_string( $xml, ) or croak( "Could not read XML" );

    # We always want to be in the itdRequest section
    ( $doc ) = $doc->findnodes( '/itdRequest' );

    return $doc;
}



=head1 AUTHOR

Robin Clarke, C<< <perl at robinclarke.net> >>

=head1 BUGS

Please report any bugs or feature requests to C<bug-www-efa at rt.cpan.org>, or through
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=WWW-EFA>.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.


=head1 SUPPORT

You can find documentation for this module with the perldoc command.

perldoc WWW::EFA


You can also look for information at:

=over 4

=item * Github - this is my preferred path to receive input on the project!

L<https://github.com/robin13/WWW-EFA>

=item * RT: CPAN's request tracker (report bugs here)

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=WWW-EFA>

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/WWW-EFA>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/WWW-EFA>

=item * Search CPAN

L<http://search.cpan.org/dist/WWW-EFA/>

=back


=head1 ACKNOWLEDGEMENTS


=head1 LICENSE AND COPYRIGHT

Copyright 2011 Robin Clarke.

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.


=cut

1; # End of WWW::EFA