File Coverage

blib/lib/FlashVideo/URLFinder.pm
Criterion Covered Total %
statement 4 6 66.6
branch n/a
condition n/a
subroutine 2 2 100.0
pod n/a
total 6 8 75.0


line stmt bran cond sub pod time code
1             # Part of get-flash-videos. See get_flash_videos for copyright.
2             package FlashVideo::URLFinder;
3              
4 1     1   1885 use strict;
  1         2  
  1         35  
5 1     1   44 use FlashVideo::Mechanize;
  0            
  0            
6             use FlashVideo::Generic;
7             use FlashVideo::Site;
8             use FlashVideo::Utils;
9             use URI;
10              
11             # The main issue is getting a URL for the actual video, so we handle this
12             # here - a different package for each site, as well as a generic fallback.
13             # Each package has a find_video method, which should return a URL, and a
14             # suggested filename.
15              
16             # In some cases there isn't an obvious URL to find, so the following will be loaded and their 'can_handle'
17             # method called.
18             my @extra_can_handle = qw(Brightcove Mtvnservices Gawker);
19              
20             sub find_package {
21             my($class, $url, $browser) = @_;
22             my $package = _find_package_url($url, $browser);
23              
24             if(!defined $package) {
25             # Fairly lame heuristic, look for the first URL outside the
26             # element (avoids grabbing things like codebase attribute).
27             # Also look at embedded scripts for sites which embed their content that way.
28             # TODO: extract all SWF URLs from the page and check to see if we've
29             # got a package for those.
30              
31             for my $possible_url($browser->content =~
32             m!(?:]+>.*?|<(?:script|embed|iframe|param) [^>]*(?:src=["']?|name=["']src["']\ value=["']))(http://[^"'> ]+)!gixs) {
33             $package = _find_package_url($possible_url, $browser);
34              
35             return _found($package, $possible_url) if defined $package;
36             }
37             }
38              
39             if(!defined $package) {
40             for(@extra_can_handle) {
41             my $possible_package = _load($_);
42              
43             my $r = $possible_package->can_handle($browser, $url);
44             if($r) {
45             $package = $possible_package;
46             last;
47             }
48             }
49             }
50              
51             if(!defined $package) {
52             $package = "FlashVideo::Generic";
53             }
54              
55             return _found($package, $url);
56             }
57              
58             # Split the URLs into parts and see if we have a package with this name.
59              
60             sub _find_package_url {
61             my($url, $browser) = @_;
62             my $package;
63              
64             foreach my $host_part (split /\./, URI->new($url)->host) {
65             $host_part = lc $host_part;
66             $host_part =~ s/[^a-z0-9]//i;
67              
68             my $possible_package = _load($host_part);
69              
70             if($possible_package->can("find_video")) {
71              
72             if($possible_package->can("can_handle")) {
73             next unless $possible_package->can_handle($browser, $url);
74             }
75              
76             $package = $possible_package;
77             last;
78             }
79             }
80              
81             return $package;
82             }
83              
84             sub _found {
85             my($package, $url) = @_;
86             info "Using method '" . lc((split /::/, $package)[-1]) . "' for $url";
87             return $package, $url;
88             }
89              
90             sub _load {
91             my($site) = @_;
92              
93             my $package = "FlashVideo::Site::" . ucfirst lc $site;
94              
95             if(eval "require $package") {
96             no strict 'refs';
97             push @{$package . "::ISA"}, "FlashVideo::Site";
98             }
99             return $package;
100             }
101              
102             1;