File Coverage

blib/lib/FlashVideo/Downloader.pm
Criterion Covered Total %
statement 17 161 10.5
branch 0 96 0.0
condition 0 20 0.0
subroutine 5 15 33.3
pod 0 9 0.0
total 22 301 7.3


line stmt bran cond sub pod time code
1             # Part of get-flash-videos. See get_flash_videos for copyright.
2             package FlashVideo::Downloader;
3              
4 3     3   32933 use strict;
  3         5  
  3         98  
5 3     3   1059 use FlashVideo::Utils;
  3         12  
  3         448  
6              
7 3     3   23 use base "FlashVideo::Site";
  3         6  
  3         2042  
8              
9             sub new {
10 1     1 0 19 my $class = shift;
11              
12             my $self = {
13 1         3 has_readkey => scalar eval { require Term::ReadKey }
  1         409  
14             };
15              
16 1         6 bless $self, $class;
17 1         4 return $self;
18             }
19              
20             sub play {
21 0     0 0 0 my ($self, $url, $file, $browser) = @_;
22              
23             $self->{stream} = sub {
24 0     0   0 $self->{stream} = undef;
25              
26 0 0 0     0 if ($^O =~ /MSWin/i and $self->player eq "VLC") {
27             # mplayer is the default - but most Windows users won't have it. If no
28             # other player is specified, check to see if VLC is installed, and if so,
29             # use it. In future perhaps this should use Win32::FileOp's
30             # ShellExecute (possibly with SW_SHOWMAXIMIZED depending on video
31             # resolution) to open in the default media player. However, this
32             # isn't ideal as media players tend to pinch each other's file
33             # associations.
34 0 0       0 if (my $vlc_binary = FlashVideo::Utils::get_vlc_exe_from_registry()) {
35 0         0 require Win32::Process;
36 0         0 require File::Basename;
37 0         0 require File::Spec;
38 0         0 $file = File::Spec->rel2abs($file);
39              
40             # For absolutely no valid reason, Win32::Process::Create requires
41             # *just* the EXE filename (for example vlc.exe) and then any
42             # subsequent parameters as the "commandline parameters". Since
43             # when is the EXE filename (which, of course, has already been
44             # supplied) a commandline parameter?!
45 0         0 my $binary_no_path = File::Basename::basename $vlc_binary;
46              
47 0         0 my $binary_just_path = File::Basename::dirname $vlc_binary;
48              
49             # Note info() is used because the player is launched when >=n% of
50             # the video is complete (so the user doesn't have to wait until
51             # it's all downloaded). die() wouldn't be good as we then wouldn't
52             # download the remainder of the video.
53 0         0 my $process;
54 0 0       0 Win32::Process::Create(
55             $process,
56             $vlc_binary,
57             "$binary_no_path $file",
58             1,
59             32, # NORMAL_PRIORITY_CLASS
60             $binary_just_path,
61             ) or info "Couldn't launch VLC ($vlc_binary): " . Win32::GetLastError();
62             }
63             }
64             else {
65             # *nix
66 0         0 my $pid = fork;
67 0 0       0 die "Fork failed" unless defined $pid;
68 0 0       0 if(!$pid) {
69 0         0 exec $self->replace_filename($self->player, $file);
70 0         0 die "Exec failed\n";
71             }
72             }
73 0         0 };
74              
75 0         0 $self->download($url, $file, $browser);
76             }
77              
78             sub download {
79 0     0 0 0 my ($self, $url, $file, $browser) = @_;
80              
81 0         0 $self->{printable_filename} = $file;
82              
83 0         0 $file = $self->get_filename($file);
84              
85             # Support resuming
86 0 0       0 my $mode = (-e $file) ? '>>' : '>';
87 0         0 my $offset;
88 0 0 0     0 if ($file ne '-' && -e $file) {
89 0         0 $offset = -s $file;
90              
91 0         0 my $response = $browser->head($url);
92              
93             # File might be fully downloaded, in which case there's nothing to
94             # resume.
95 0 0       0 if ($offset == $response->header('Content-Length')) {
96 0         0 error "File $self->{printable_filename} has been fully downloaded.";
97 0 0       0 $self->{stream}->() if defined $self->{stream};
98 0         0 return;
99             }
100              
101 0         0 info "File $self->{printable_filename} already exists, seeing if resuming is supported.";
102 0 0       0 if (!$response->header('Accept-Ranges')) {
103 0 0       0 if(!$self->yes) {
104 0         0 error "This server doesn't explicitly support resuming.\n" .
105             "Do you want to try resuming anyway (y/n)?";
106 0         0 chomp(my $answer = );
107 0 0 0     0 if (!$answer or lc($answer) eq 'n') {
108 0         0 undef $offset;
109 0         0 $mode = '>';
110             }
111             }
112             }
113             else {
114 0         0 info "Server supports resuming, attempting to resume.";
115             }
116             }
117              
118 0         0 my $video_fh;
119 0 0       0 if($file eq '-') {
120 0         0 $video_fh = \*STDOUT;
121             } else {
122 0 0       0 open $video_fh, $mode, $file or die $!;
123             }
124              
125 0         0 binmode $video_fh;
126 0         0 $self->{fh} = $video_fh;
127              
128 0         0 info "Downloading $url...";
129 0 0       0 if ($offset) {
130 0         0 $browser->add_header("Range", "bytes=$offset-");
131             }
132             my $response = $browser->get($url,
133             ':content_cb' => sub {
134 0     0   0 my ($data, $response) = @_;
135              
136             # If we're resuming, Content-Length will just be the length of the
137             # range the server is sending back, so add on the offset to make %
138             # completed accurate.
139 0 0       0 if (!$self->{content_length}) {
140 0         0 $self->{content_length} = $response->header('Content-Length')
141             + $offset;
142              
143 0 0       0 if($response->header('Content-encoding') =~ /gzip/i) {
144 0 0       0 eval { require Compress::Zlib; } or do {
  0         0  
145 0         0 error "Must have Compress::Zlib installed to download from this site.\n";
146 0         0 exit 1;
147             };
148              
149 0         0 my($inflate, $status) = Compress::Zlib::inflateInit(
150             -WindowBits => -Compress::Zlib::MAX_WBITS());
151 0 0       0 error "inflateInit failed: $status" if $status;
152              
153             $self->{filter} = sub {
154 0         0 my($data) = @_;
155              
156 0 0       0 if(!$self->{downloaded}) {
157 0         0 Compress::Zlib::_removeGzipHeader(\$data);
158             }
159              
160 0         0 my($output, $status) = $inflate->inflate($data);
161 0         0 return $output;
162             }
163 0         0 }
164             }
165              
166 0 0 0     0 if ($offset and !$response->header('Content-Range')) {
167 0         0 error "Resuming failed - please delete $self->{printable_filename} and restart.";
168 0         0 exit 1;
169             }
170             else {
171 0 0       0 $self->{downloaded} = $offset unless $self->{downloaded};
172             }
173              
174 0         0 my $len = length $data;
175              
176 0 0       0 if($self->{filter}) {
177 0         0 $data = $self->{filter}->($data);
178             }
179              
180 0 0       0 return unless $data;
181              
182 0         0 my $fh = $self->{fh};
183 0   0     0 print $fh $data || die "Unable to write to '$self->{printable_filename}': $!\n";
184              
185 0 0       0 if(defined $self->{stream}) {
186 0 0       0 if($self->{downloaded} > 300_000) {
187 0         0 $self->{stream}->();
188             }
189             }
190              
191 0 0 0     0 if(!$self->{downloaded} && length $data > 16) {
192 0 0       0 if(!$self->check_magic($data)) {
193 0         0 error "Sorry, file does not look like a media file, aborting.";
194 0         0 exit 1;
195             }
196             }
197              
198 0         0 $self->{downloaded} += $len;
199 0         0 $self->progress;
200 0         0 }, ':read_size_hint' => 16384);
201              
202 0 0       0 if($browser->response->header("X-Died")) {
203 0         0 error $browser->response->header("X-Died");
204             }
205              
206 0 0       0 close $self->{fh} || die "Unable to write to '$self->{printable_filename}': $!";
207              
208 0 0       0 if ($browser->success) {
209 0         0 return $self->{downloaded} - $offset;
210             } else {
211 0 0       0 unlink $file unless -s $file;
212 0         0 error "Couldn't download $url: " . $browser->response->status_line;
213 0         0 return 0;
214             }
215             }
216              
217             sub progress {
218 0     0 0 0 my($self) = @_;
219              
220 0 0       0 return unless -t STDERR;
221 0 0       0 return if $self->quiet;
222              
223 0         0 my $progress_text;
224              
225 0 0       0 if ($self->{content_length}) {
226 0         0 my $percent = int(
227             ($self->{downloaded} / $self->{content_length}) * 100
228             );
229 0 0 0     0 if ($percent != $self->{percent} || time != $self->{last_time}) {
230 0         0 my $downloaded_kib = _bytes_to_kib($self->{downloaded});
231 0         0 my $total_kib = _bytes_to_kib($self->{content_length});
232 0         0 $progress_text = ": $percent% ($downloaded_kib / $total_kib KiB)";
233 0         0 $self->{last_time} = time;
234 0         0 $self->{percent} = $percent;
235             }
236             } else {
237             # Handle lame servers that don't tell us how big the file is
238 0         0 my $data_transferred = _bytes_to_kib($self->{downloaded});
239 0 0       0 if ($data_transferred != $self->{data_transferred}) {
240 0         0 $progress_text = ": $data_transferred KiB";
241             }
242             }
243              
244 0 0       0 if($progress_text) {
245 0         0 my $width = get_terminal_width();
246              
247 0         0 my $filename = $self->{printable_filename};
248 0         0 my $filename_len = $width - length($progress_text);
249              
250 0 0       0 if($filename_len < length $filename) {
251             # 3 for "..."
252 0         0 my $rem = 3 + length($filename) - $filename_len;
253             # Try and chop off somewhere near the end, but not the very end..
254 0         0 my $pos = length($filename) - $rem - 12;
255 0 0       0 $pos = 0 if $pos < 0;
256 0         0 substr($filename, $pos, $rem) = "...";
257             }
258              
259 0         0 syswrite STDERR, "\r$filename$progress_text";
260             }
261             }
262              
263             sub _bytes_to_kib {
264 0     0   0 return sprintf '%0.2f', ($_[0] / 1024)
265             }
266              
267             sub replace_filename {
268 0     0 0 0 my($self, $string, $filename) = @_;
269 0 0       0 $string .= " %s" unless $string =~ /%s/;
270 0         0 my $esc = $self->shell_escape($filename);
271 0         0 $string =~ s/['"]?%s['"]?/$esc/g;
272 0         0 return $string;
273             }
274              
275             sub shell_escape {
276 3     3 0 35 my($self, $file) = @_;
277              
278             # Shell escape the given filename
279 3         12 $file =~ s/'/'\\''/g;
280 3         25 return "'$file'";
281             }
282              
283             sub check_file {
284 0     0 0   my($self, $file) = @_;
285              
286 0           open my $fh, "<", $file;
287 0           binmode $fh;
288 0           my $data;
289 0           read $fh, $data, 16;
290              
291 0           return $self->check_magic($data);
292             }
293              
294             sub check_magic {
295 0     0 0   my($self, $data) = @_;
296              
297             # This is a very simple check to ensure we have a media file.
298             # The aim is to avoid downloading HTML, Flash, etc and claiming to have
299             # succeeded.
300              
301             # FLV
302 0 0         if(substr($data, 0, 3) eq 'FLV') {
    0          
    0          
    0          
    0          
    0          
303 0           return 1;
304             # MP3
305             } elsif(substr($data, 0, 3) eq 'ID3') {
306 0           return 1;
307             # ASF
308             } elsif(substr($data, 0, 4) eq "\x30\x26\xb2\x75") {
309 0           return 1;
310             # ISO
311             } elsif(substr($data, 4, 4) eq 'ftyp') {
312 0           return 1;
313             # Other QuickTime
314             } elsif(substr($data, 4, 4) =~ /moov|mdat|wide|free|pnot|skip/) {
315 0           return 1;
316             # AVI / WAV
317             } elsif(substr($data, 0, 4) eq 'RIFF') {
318 0           return 1;
319             }
320              
321 0           return 0;
322             }
323              
324             sub get_filename {
325 0     0 0   my($self, $file) = @_;
326              
327             # On windows the filename needs to be in the codepage of the system..
328 0 0         if($^O =~ /MSWin/i) {
329 0           $file = Encode::encode(get_win_codepage(), $file);
330             # This may have added '?' as subsition characters, replace with '_'
331 0           $file =~ s/\?/_/g;
332             }
333              
334 0           return $file;
335             }
336              
337             1;
338