File Coverage

blib/lib/WWW/PTV/Route.pm
Criterion Covered Total %
statement 21 84 25.0
branch 0 28 0.0
condition 0 13 0.0
subroutine 7 14 50.0
pod 3 4 75.0
total 31 143 21.6


line stmt bran cond sub pod time code
1             package WWW::PTV::Route;
2              
3 1     1   7 use strict;
  1         2  
  1         38  
4 1     1   5 use warnings;
  1         2  
  1         24  
5              
6 1     1   896 use WWW::PTV::TimeTable;
  1         4  
  1         33  
7 1     1   8 use HTML::TreeBuilder;
  1         2  
  1         13  
8 1     1   33 use Scalar::Util qw(weaken);
  1         3  
  1         61  
9 1     1   7 use Carp qw(croak);
  1         2  
  1         121  
10              
11             our $STOP = {};
12             our $VERSION = '0.05';
13             our @ATTR = qw( id direction_out direction_in direction_out_link direction_in_link
14             description_out description_in name operator operator_ph );
15              
16             foreach my $attr ( @ATTR ) {
17             {
18 1     1   6 no strict 'refs';
  1         3  
  1         2764  
19             *{ __PACKAGE__ .'::'. $attr } = sub {
20 0     0     my( $self, $val ) = @_;
21 0 0         $self->{$attr} = $val if $val;
22 0           return $self->{$attr}
23             }
24             }
25             }
26              
27             sub new {
28 0     0 0   my( $class, %args ) = @_;
29 0           my $self = bless {}, $class;
30 0 0         $args{id} or croak 'Constructor failed: mandatory id argument not supplied';
31              
32 0           foreach my $attr ( @ATTR ) { $self->{$attr} = $args{$attr} }
  0            
33              
34 0           $self->{uri} = $args{uri};
35 0 0         $args{ua} ? weaken( $self->{ua} = $args{ua} ) : croak 'Mandatory argument ua not supplied';
36              
37 0           return $self
38             }
39              
40 0     0 1   sub get_inbound_tt { $_[0]->__get_tt( 'in' ) }
41              
42 0     0 1   sub get_outbound_tt { $_[0]->__get_tt( 'out' ) }
43              
44             sub __get_tt {
45 0     0     my( $self, $direction ) = @_;
46 0 0         return unless $direction =~ /(in|out)/;
47              
48 0 0         my $tt = $self->__request( ( $direction eq 'out' ? $self->{direction_out_link} : $self->{direction_in} ) );
49 0           my $t = HTML::TreeBuilder->new_from_content( $tt );
50             #my $tt = HTML::TreeBuilder->new_from_file( './metro_bus_route_235_tt_out_full' );
51 0           my $t = $tt;
52              
53 0           for ( $t->look_down( _tag => 'meta' ) ) {
54 0 0 0       if( ( defined $_->attr( 'http-equiv' ) ) and ( $_->attr( 'http-equiv' ) eq 'refresh' ) ) {
55 0           ( my $url = $_->attr( 'content' ) ) =~ s/^.*url=//;
56 0           $url .= '&itdLPxx_scrollOffset=118';
57 0           print "Getting: $url\n";
58 0           $t = HTML::TreeBuilder->new_from_content( $self->__request( $self->{uri}.'/tt/'.$url ) );
59             last
60 0           }
61             }
62              
63 0           $tt = $t->look_down( _tag => 'img', title => 'Expand' );
64              
65 0 0 0       if ( $tt && $tt->attr( 'onclick' ) && $tt->attr( 'onclick' ) =~ /TTB_REQUEST/ ) {
      0        
66 0           ( $tt = $tt->attr( 'onclick' ) ) =~ s/^.*\('//;
67 0           $tt =~ s/'.*$//;
68 0           $t = HTML::TreeBuilder->new_from_content( $self->__request( "http://tt.ptv.vic.gov.au/tt/$tt" ) )
69             }
70              
71 0           $t = $t->look_down( _tag => 'div', id => qr/tt(Bus|Tram|Train)/ );
72 0           my @stops = $t->look_down( _tag => 'div', class => qr/^ma_stop/ );
73 0           my @stop_names = map { $_->as_text } @stops;
  0            
74 0           my @stop_links = map { my ($r) = $_->look_down( _tag => 'a' )->attr( 'href' ) =~ /.*\/(\d*$)/ } @stops;
  0            
75 0           my $stop_times;
76 0           my $c = 0;
77              
78 0           foreach my $t ( $t->look_down( _tag => 'div', class => qr/^ttBodyN?TP$/ ) ) {
79             #my @s = map { $_->as_text } $t->look_down( _tag => 'span' );
80 0           my $s;
81              
82 0           foreach my $t ( $t->look_down( _tag => 'span' ) ) {
83 0           my ( $h, $m ) = split /:/, $t->as_text;
84 0 0 0       push @{ $s }, $h and next if $h !~ /\d/;
  0            
85 0           my $is_pm = $t->look_down( _tag => 'b' );
86              
87 0 0         push @{ $s }, ( $h == 12
  0 0          
    0          
88             ? ( $is_pm ? "$h:$m" : "00:$m" )
89             : ( $is_pm ? $h + 12 .":$m" : "$h:$m" )
90             );
91             }
92              
93 0           $self->{ STOP }->{ $stop_links[$c] }->{ $direction } = $s;
94 0           $self->{ STOP }->{ $stop_links[$c] }->{ name } = $stop_names[$c];
95 0           $c++;
96 0           push @{ $stop_times }, $s
  0            
97             }
98              
99 0           my $ret = WWW::PTV::TimeTable->new( \@stop_names, \@stop_links, $stop_times );
100 0           $self->{timetable}->{$direction} = $ret;
101 0           return $ret;
102             }
103              
104             sub __request {
105 0     0     my($self,$uri) = @_;
106 0 0         my $res = ( $uri !~ /^http:/
107             ? $self->{ua}->get( $self->{uri} . $uri )
108             : $self->{ua}->get( $uri ) );
109              
110 0 0         return $res->content if $res->is_success;
111 0           croak 'Unable to retrieve content: ' . $res->status_line
112             }
113              
114             sub get_stop_names_and_ids {
115 0     0 1   my ($self, $direction) = @_;
116 0   0       $direction ||= 'out';
117 0 0         $self->{timetable}->{$direction} || $self->__get_tt($direction);
118 0           return $self->{timetable}->{$direction}->stop_names_and_ids;
119             }
120              
121             1;
122              
123             __END__