The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.

NAME

Net::Curl::Simple::examples - sample modules for Net::Curl::Simple

Download accelerator

Extracted from examples/download-accelerator.pl

Simple downloader capable to download a file using multiple connections.

 #!/usr/bin/perl
 #
 use strict;
 use warnings;
 use Net::Curl::Simple::UserAgent;
 use IO::Handle; # for STDOUT->flush

 my $width = 80;
 my $uri = shift @ARGV or die "Usage: $0 URI [num connections]\n";
 my $threads = shift @ARGV || 0;
 $threads = $threads >= 1 ? int $threads : 3;

 # we'll disguise as chrome
 my $chrome = Net::Curl::Simple::UserAgent->new(
     useragent => 'Mozilla/5.0 (Windows NT 5.1) AppleWebKit/534.24 (KHTML, like Gecko) Chrome/11.0.696.60 Safari/534.24',
     httpheader => [
         'Connection: keep-alive',
         'Cache-Control: max-age=0',
         'Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8',
         'Accept-Language: en-US,en;q=0.8',
         'Accept-Charset: ISO-8859-1,utf-8;q=0.7,*;q=0.3',
     ],
     connecttimeout => 30,
 );


 # get some basic information about the download
 my $size;
 my $fulluri;
 my $filename;
 {
     # test this uri
     my $curl = $chrome->curl->head( $uri,
         # check whether server supports resume
         resume_from_large => 1,
         # no callback here so it will block
         undef );

     # make sure there were no errors
     die "HEAD failed: ${ \$curl->code }: ${ \$curl->error }\n"
         if $curl->code;

     ( $size, $fulluri, my $code ) = $curl->getinfos(
         'content_length_download',
         'effective_url',
         'response_code',
     );

     # 206 -- partial content (http)
     # 350 -- Restarting at (ftp)
     die "Cannot download, code $code\n"
         unless $code == 206 or $code == 350;

     # we started at 1, so the reported size is wrong
     $size += 1;

     # extract output file name
     # decoding Content-Disposition to complicated to bother
     $fulluri =~ m#.*/(.*)#;
     $filename = $1;
 }

 # align sizes, optional
 my $alignsize = 1024;
 my $maxthreads = 1 + int ( $size / $alignsize / 4 );
 $threads = $maxthreads if $threads > $maxthreads;
 my $partsize = $alignsize * int ( $size / ( $alignsize * $threads ) );

 # progress display information
 my $partwidth = int ( $width / $threads );
 my @display = ( 0 ) x $threads;
 my $lastupdate = 0;


 print "Downloading $filename ($size bytes, $threads connections):\n";
 die "ERROR: File exists\n" if -f $filename;

 foreach my $part ( 0 .. ( $threads - 1 ) ) {
     my $resume_from = $part * $partsize;

     open my $fout, '+>', $filename
         or die "Cannot save to $filename: $!\n";
     seek $fout, $resume_from, 0;

     my $easy = $chrome->curl;
     $easy->{file} = $fout;
     $easy->{part} = $part;
     # last part may be larger
     $easy->{partsize} = $part != $threads - 1 ?
         $partsize : $size - $resume_from;

     $easy->get( $uri,
         # where we want to resume
         resume_from_large => $resume_from,
         # header will tell us where we really have to resume
         headerfunction => \&cb_header,
         # write to file handle directly
         writedata => $fout,
         # enable progress callback
         noprogress => 0,
         progressfunction => \&cb_progress,
         sub { update_display( $_[0]->{part}, 1 ) }
     );
 }

 # start download and wait for all threads to finish
 1 while Net::Curl::Simple->join;

 # update display one last time
 $lastupdate = 0;
 update_display( 0, 1 );
 print "\nFinished\n";

 exit 0;

 sub cb_header
 {
     my ( $easy, $data, $uservar ) = @_;
     push @{ $easy->{headers} }, $data;
     if ( $data =~ /^Content-Range:\s*bytes\s+(\d+)/ ) { # HTTP
         seek $easy->{file}, $1, 0;
     } elsif ( $data =~ /^350 Restarting at (\d+)/ ) { # FTP
         seek $easy->{file}, $1, 0;
     }
     return length $data;
 }

 sub update_display
 {
     $display[ $_[0] ] = $_[1];
     my $time = time;
     return if $time == $lastupdate;
     $lastupdate = $time;

     print join '', "\r", map { $_ >= $partwidth ? "*" x $partwidth
         : "#" x $_ . "_" x ($partwidth - $_) }
         map { int $_ * $partwidth } @display;
     STDOUT->flush;
 }

 sub cb_progress
 {
     my $curl = $_[0];
     update_display( $curl->{part}, $_[2] / $curl->{partsize} );
     # abort if we've got what we wanted
     return 1 if $_[2] > $curl->{partsize};

     return 0;
 }

 # vim: ts=4:sw=4

Irssi CPAN search

Extracted from examples/irssi-cpan-search.pl

This example searches modules on CPAN.

 use strict;
 use warnings;
 use Irssi;
 use URI::Escape;
 use Net::Curl::Simple;

 my $max_pages = 5;

 sub got_body
 {
     my ( $window, $easy ) = @_;
     if ( my $result = $easy->code ) {
         warn "Could not download $easy->{uri}: $result\n";
         return;
     }

     my @found;
     while ( $easy->{body} =~ s#<h2 class=sr><a href="(.*?)"><b>(.*?)</b></a></h2>## ) {
         my $uri = $1;
         $_ = $2;
         s/&#(\d+);/chr $1/eg;
         chomp;
         push @found, $_;
     }
     @found = "no results" unless @found;
     my $msg = "CPAN search %9$easy->{args}%n $easy->{page}%9:%n "
         . (join "%9;%n ", @found);
     if ( $window ) {
         $window->print( $msg );
     } else {
         Irssi::print( $msg );
     }

     return if ++$easy->{page} > $max_pages;
     $easy->{body} =~ m#<a href="(.*?)">Next &gt;&gt;</a>#;
     return unless $1;
     $easy->get( $1, sub { got_body( $window, @_ ) } );
 }

 sub cpan_search
 {
     my ( $args, $server, $window ) = @_;

     my $query = uri_escape( $args );
     my $uri = "http://search.cpan.org/search?query=${query}&mode=all&n=20";
     my $easy = Net::Curl::Simple->new();
     $easy->{args} = $args;
     $easy->{page} = 1;
     $easy->get( $uri, sub { got_body( $window, @_ ) } );
 }

 Irssi::command_bind( 'cpan', \&cpan_search );

 # vim: ts=4:sw=4