File Coverage

blib/lib/WWW/PTV.pm
Criterion Covered Total %
statement 27 168 16.0
branch 0 32 0.0
condition 0 12 0.0
subroutine 9 25 36.0
pod 13 13 100.0
total 49 250 19.6


line stmt bran cond sub pod time code
1             package WWW::PTV;
2              
3 2     2   30622 use warnings;
  2         4  
  2         64  
4 2     2   10 use strict;
  2         4  
  2         43  
5              
6 2     2   6951 use LWP;
  2         114945  
  2         69  
7 2     2   2392 use WWW::Mechanize;
  2         238944  
  2         82  
8 2     2   2381 use HTML::TreeBuilder;
  2         51569  
  2         20  
9 2     2   76 use Carp qw(croak);
  2         4  
  2         127  
10 2     2   1400 use WWW::PTV::Area;
  2         6  
  2         55  
11 2     2   1144 use WWW::PTV::Stop;
  2         5  
  2         60  
12 2     2   1065 use WWW::PTV::Route;
  2         6  
  2         5174  
13              
14             our $VERSION = '0.07';
15             our $CACHE;
16              
17             sub new {
18 0     0 1   my ( $class, %args ) = @_;
19              
20 0           my $self = bless {}, $class;
21 0 0         $self->{uri} = 'http://' . ( defined $args{uri} ? $args{uri} : 'ptv.vic.gov.au' ) . '/';
22 0           $self->{ua} = LWP::UserAgent->new;
23 0           $self->{tree} = HTML::TreeBuilder->new;
24 0 0         $self->{cache}++ if $args{cache};
25              
26 0           return $self
27             }
28              
29             sub __request {
30 0     0     my ( $self, $uri ) = @_;
31              
32             my $res = ( $uri !~ /^http:/
33             ? $self->{ua}->get( $self->{uri} . $uri )
34 0 0         : $self->{ua}->get( $uri ) );
35              
36 0 0         $res->is_success and return $res->content;
37              
38 0           croak 'Unable to retrieve content: ' . $res->status_line
39             }
40              
41             sub __tl_request {
42 0     0     my ( $self, $tag_id ) = @_;
43              
44             my $r = ( ( $self->{cache} and $CACHE->{timetables}->{master} )
45             ? $CACHE->{timetables}->{master}
46 0 0 0       : $self->__request( 'http://ptv.vic.gov.au/timetables' )
47             );
48              
49 0 0         $CACHE->{timetables}->{master} = $r if $self->{cache};
50              
51 0           my $t = HTML::TreeBuilder->new_from_content( $r );
52 0           $t = $t->look_down( _tag => 'select', id => $tag_id );
53 0           my @routes = $t->look_down( _tag => 'option' );
54              
55 0           return my %routes = map { $_->attr( 'value' ) => $_->as_text } grep { $_->attr( 'value' ) ne '' } @routes
  0            
  0            
56             }
57              
58 0     0 1   sub cache { $_[0]->{cache}++ }
59              
60 0     0 1   sub nocache { $_[0]->{cache} = 0 }
61              
62             sub get_metropolitan_bus_routes {
63 0     0 1   return $_[0]->__tl_request( 'RouteForm1_RouteUrl' );
64             }
65              
66             sub get_metropolitan_train_routes {
67 0     0 1   return $_[0]->__tl_request( 'RouteForm2_RouteUrl' )
68             }
69              
70             sub get_metropolitan_tram_routes {
71 0     0 1   return $_[0]->__tl_request( 'RouteForm3_RouteUrl' );
72             }
73              
74             sub get_vline_bus_routes {
75 0     0 1   return $_[0]->__tl_request( 'RouteForm4_RouteUrl' )
76             }
77              
78             sub get_vline_train_routes {
79 0     0 1   return $_[0]->__tl_request( 'RouteForm5_RouteUrl' )
80             }
81              
82             sub get_regional_bus_routes {
83 0     0 1   return $_[0]->__tl_request( 'RouteForm6_RouteUrl' )
84             }
85              
86             sub get_route_by_id {
87 0     0 1   my ( $self, $id ) = @_;
88              
89 0 0         $id or return "Mandatory parameter id not given";
90              
91 0 0 0       return $CACHE->{ROUTE}->{$id} if ( $self->{cache} and $CACHE->{ROUTE}->{$id} );
92              
93 0           my $r = $self->__request( "/route/view/$id" );
94 0           my $t = HTML::TreeBuilder->new_from_content( $r );
95 0           my %route = (id => $id);
96 0           my $r_link = $t->look_down( _tag => 'div', id => 'content' );
97 0           $route{name} = $t->look_down( _tag => 'h1' )->as_text;
98              
99             ( $route{direction_in}, $route{direction_out} )
100 0           = $r_link->look_down( _tag => 'ul' )->look_down( _tag => "a" );
101              
102             ( $route{direction_in_link}, $route{direction_out_link} )
103 0           = map { $_->attr( 'href' ) } $r_link->look_down( _tag => 'ul' )->look_down( _tag => "a" );
  0            
104              
105             ( $route{direction_in}, $route{direction_out} )
106 0           = map { $_->as_text } ( $route{direction_in}, $route{direction_out} );
  0            
107              
108             ( $route{description_in}, $route{description_out} )
109 0           = map { $_->as_text } $r_link->look_down( _tag => 'p' );
  0            
110              
111 0           my $operator = $t->look_down( _tag => 'div', class => 'operator' )->as_text;
112 0           $operator =~ s/(Contact|Website|:)/,/g;
113 0           $operator =~ s/\s//g;
114 0           ( $route{operator} ,$route{operator_ph} ) = ( split /,/, $operator )[0,2];
115 0           $route{ua} = $self->{ua};
116 0           $route{uri} = $self->{uri};
117 0           my $route = WWW::PTV::Route->new( %route );
118 0 0         $CACHE->{ROUTE}->{$id} = $route if ( $self->{cache} );
119              
120 0           return $route
121             }
122              
123              
124              
125             sub get_stop_by_id {
126 0     0 1   my ( $self, $id ) = @_;
127              
128 0 0         $id or return "Mandatory parameter id not given";
129              
130 0 0 0       return $CACHE->{STOP}->{$id} if ( $self->{cache} and $CACHE->{STOP}->{$id} );
131              
132 0           my $r = $self->__request( "/stop/view/$id" );
133 0           my $t = HTML::TreeBuilder->new_from_content( $r );
134 0           my %stop = (id => $id );
135 0           my $s_type = $t->look_down( _tag => 'img', class => 'stopModeImage' );
136 0           $stop{address} = $t->look_down( _tag => 'div', id => 'container' )
137             ->look_down( _tag => 'p' )
138             ->as_text;
139              
140 0           $stop{transport_type} = $s_type->attr('src');
141 0           $stop{transport_type} =~ s|themes/transport-site/images/jp/icons/icon||;
142 0           $stop{transport_type} =~ s|\.png||;
143 0           ( $stop{street}, $stop{locality} ) = ( split /,/, $stop{address} );
144 0           ( $stop{postcode} ) = $stop{locality} =~ /\b(\d{4})\b/;
145 0           $stop{municipiality} = $t->look_down( _tag => 'table', class => 'stationSummary' )
146             ->look_down( _tag => 'a' )
147             ->as_text;
148              
149 0           ( $stop{municipiality_id} ) = $t->look_down( _tag => 'table', class => 'stationSummary' )
150             ->look_down( _tag => 'a' )
151             ->attr( 'href' );
152 0           ( $stop{municipiality_id} ) = $stop{municipiality_id} =~ /\/(\d.*)$/;
153              
154 0           $stop{zone} = ( $t->look_down( _tag => 'table', class => 'stationSummary' )
155             ->look_down( _tag => 'td' )
156             )[2]->as_text;
157              
158 0           $stop{map_ref} = $t->look_down( _tag => 'div', class => 'aside' )
159             ->look_down( _tag => 'a' )
160             ->attr( 'href' );
161              
162 0           ( $stop{latitude} ) = $stop{map_ref} =~ /=(-?\d.*),/;
163              
164 0           ( $stop{longitude} ) = $stop{map_ref} =~ /,(-?\d.*)$/;
165              
166             ( $stop{phone_feedback}, $stop{phone_station} )
167 0           = map { $_->as_text } $t->look_down( _tag => 'div', class => 'expander phone-numbers' )
  0            
168             ->look_down( _tag => 'dd' );
169              
170 0           $stop{staff_hours} = $t->look_down( _tag => 'div', 'data-cookie' => 'stop-staff' )
171             ->look_down( _tag => 'dd' )->as_text;
172              
173             ( $stop{myki_machines}, $stop{myki_checks}, $stop{vline_bookings} )
174 0           = map { $_->as_text } $t->look_down( _tag => 'div', 'data-cookie' => 'stop-ticketing' )
  0            
175             ->look_down( _tag => 'dd' );
176              
177             ( $stop{car_parking}, $stop{_bicycles}, $stop{taxi_rank} )
178 0           = map { $_->as_text } $t->look_down( _tag => 'div', 'data-cookie' => 'stop-other-transport-links' )
  0            
179             ->look_down( _tag => 'dd' );
180              
181             ( $stop{bicycle_racks}, $stop{bicycle_lockers}, $stop{bicycle_cage} )
182 0           = map { s/.*://; $_ } split /,/, $stop{_bicycles};
  0            
  0            
183              
184             ( $stop{wheelchair_accessible}, $stop{stairs}, $stop{escalator}, $stop{lift}, $stop{tactile_paths}, $stop{hearing_loop} )
185 0           = map { $_->as_text } $t->look_down( _tag => 'div', 'data-cookie' => 'stop-accessibility' )
  0            
186             ->look_down( _tag => 'dd' );
187              
188             ( $stop{seating}, $stop{lighting}, $stop{lockers}, $stop{public_phone}, $stop{public_toilet}, $stop{_waiting_area} )
189 0           = map { $_->as_text } $t->look_down( _tag => 'div', 'data-cookie' => 'stop-general-facilities' )
  0            
190             ->look_down( _tag => 'dd' );
191              
192             ( $stop{waiting_area_indoor}, $stop{waiting_area_sheltered} )
193 0           = map { s/.*://; $_ } split /,/, $stop{_waiting_area};
  0            
  0            
194              
195 0           foreach my $line ( $t->look_down( _tag => 'div', 'data-cookie' => 'stop-line-timetables' )
196             ->look_down( _tag => 'div', class => 'timetable-row' ) ) {
197 0           my $ref = { id => $line->look_down( _tag => 'a' )->attr( 'href' ) =~ /^.*\/(.*)/ };
198 0           $ref->{ name } = $line->look_down( _tag => 'a' )->as_text;
199 0           $ref->{ type } = _get_line_type( $line->look_down( _tag => 'img' )->attr( 'src' ) );
200 0           push @{ $stop{routes} }, $ref
  0            
201             }
202              
203 0           $stop{ua} = $self->{ua};
204              
205 0           my $stop = WWW::PTV::Stop->new( %stop );
206 0 0         $CACHE->{STOP}->{$id} = $stop if ( $self->{cache} );
207              
208 0           return $stop
209             }
210              
211             sub get_area_by_id {
212 0     0 1   my ( $self, $id ) = @_;
213              
214 0 0         $id or return "Mandatory parameter id not given";
215              
216 0 0 0       return $CACHE->{AREA}->{$id} if ( $self->{cache} and $CACHE->{AREA}->{$id} );
217              
218 0           my $r = $self->__request( "/location/view/$id" );
219 0           my $t = HTML::TreeBuilder->new_from_content( $r );
220 0           my %area = ( id => $id );
221 0           $area{name} = $t->look_down( _tag => 'h1' )->as_text;
222 0           @{ $area{suburbs}} = split /, /, $t->look_down( _tag => 'p' )->as_text;
  0            
223 0           my $t_type;
224              
225 0           foreach my $service ( $t->look_down( _tag => 'div', id => 'content' )->look_down( _tag => 'div' ) ) {
226 0           my $type = $service->look_down( _tag => 'h3' );
227              
228 0 0         if ( $type->as_text ne '' ) { $t_type = $type->as_text }
  0            
229              
230 0           @{ $area{service}{names}{$t_type} }
231 0           = map { $_->as_text } $service->look_down( _tag => 'li' );
  0            
232              
233 0           @{ $area{service}{links}{$t_type} }
234 0           = map { $_->attr( 'href' ) } $service->look_down( _tag => 'a' );
  0            
235             }
236              
237 0           my $area = WWW::PTV::Area->new( %area );
238 0 0         $CACHE->{AREA}->{$id} = $area if ( $self->{cache} );
239              
240 0           return $area
241             }
242              
243             sub get_local_areas {
244 0     0 1   my $self = shift;
245              
246 0           my $r = $self->__request( '/getting-around/local-areas/' );
247 0           my $t = HTML::TreeBuilder->new_from_content( $r );
248 0           $t = $t->look_down( _tag => 'div', id => 'content' );
249              
250 0           @{ $self->{local_areas}{names} }
251 0           = map { $_->as_text } $t->look_down( _tag => 'li' );
  0            
252              
253 0           @{ $self->{local_areas}{links} }
254 0           = map { $_->attr( 'href' ) } $t->look_down( _tag => 'a' );
  0            
255              
256 0           my %res;
257 0           @res{ @{ $self->{local_areas}{names} } } = @{ $self->{local_areas}{links} };
  0            
  0            
258              
259 0           return %res
260             }
261              
262             sub _get_line_type {
263 0     0     my $obj = shift;
264              
265 0           $obj =~ s/^.*\/icon//;
266 0           $obj =~ s/\..*$//;
267              
268 0           return lc $obj
269             }
270              
271             1;
272              
273             __END__