HTML::Encapsulate - rewrites an HTML page as a self-contained set of files

    use HTML::Encapsulate qw(download);

    # This will download the page at the URL given in the first
    # argument into a folder named in the second, here called
    # C<bar.html>.  The folder will contain all the images and other
    # components required to view the page.  The page itself will be
    # saved as C<index.html>
    download "http://foo.com/bar" => "bar.html";

    # It also has an OO interface, allows various defaults to be
    # adjusted via the %options hash.
    my $he = HTML::Encapsulate->new(%options);
    $he->download("http://foo.com/bar" => "bar.html");




    # HTTP::Requests can also be passed.  This enables the result of
    # form posts to be captured.
    my $request = HTTP::Request->new(GET => 'http://somewhere.com/something.html');
    my $download_dir = 'some/directory/path';

    $he->download($request, $download_dir);

    wget -kp http://foo.com/bar 

package HTML::Encapsulate;
use warnings;
use strict;
use Carp;
use PerlIO;
use File::Path qw(mkpath);
use File::Spec;
use File::Spec::Unix;
use Carp qw(croak carp cluck confess);
use Exporter;
use LWP::UserAgent;
use HTML::TreeBuilder::XPath;
use Scalar::Util qw(blessed);
use URI;
use HTML::Entities qw(decode_entities encode_entities);
use HTML::Tidy;
use HTTP::Response::Encoding;
use HTML::HeadParser;
use HTTP::Headers::Util;

use version; our $VERSION = qv('0.3');

 
# We don't want to inherit Exporter, we can't always import the import
# method, so this is a workaround.
sub import { goto &Exporter::import }



our @EXPORT_OK = qw(download);

our %TIDY_OPTIONS = (lower_literals => 1,
                     show_errors => 0,
                     show_warnings => 0,
                     tidy_mark => 0);


# url(blah) or url( 'blah' ) etc.
my $QUOTED_STR = qr/ " ([^"]*) " | ' ([^']*) ' /x;

my $URL_RE = qr/ url \s* \( 
                                                          \s* (?: $QUOTED_STR | (.*?) ) \s*
                                                  \) 
/ix; 

my $IMPORT_RE = qr/ 
    \@import (?:
                            \s+ $URL_RE     | # @import url(blah) with optional quotes
                            \s* $QUOTED_STR | # @import "blah" or @import 'blah'
                            \s+ (\S+)         # @import  blah
                      )
/xi;

sub _inner_html
{
    my $node = shift;
    join "", map { ref $_? $_->as_HTML : $_ } $node->content_list;
}

sub _slurp
{
    my $path = shift;
    my $encoding = defined $_[0]?
        "encoding($_[0])" : "";

    local $/;
    confess "failed to open file '$path': $!" 
        unless open my $fh, "<$encoding", $path;
    my $content = <$fh>;
    close $fh;
    return $content;
}

sub _spit
{
    my $path = shift;
    my $content = shift;
    confess "failed to open file '$path': $!" unless open my $fh, ">", $path;
    print $fh $content;
    close $fh;
}

# This parses the charset from a HTML doc's HEAD section, if present, 
#
# The code here is adapted from Tatsuhiko Miyagawa's here:
# http://svn.bulknews.net/repos/public/HTTP-Response-Charset/trunk/lib/HTTP/Response/Charset.pm
#
# See also http://use.perl.org/~miyagawa/journal/31250
# HTTP::Response::Charset seems not to be on CPAN, however.
{

    my $boms = [
        'UTF-8'    => "\x{ef}\x{bb}\x{bf}",
        'UTF-32BE' => "\x{0}\x{0}\x{fe}\x{ff}",
        'UTF-32LE' => "\x{ff}\x{fe}\x{0}\x{0}",
        'UTF-16BE' => "\x{fe}\x{ff}",
        'UTF-16LE' => "\x{ff}\x{fe}",
    ];


    sub _detect_encoding
    {
        my $filename = shift;
        
        # 1) We assume the content has been identified as HTML, 
        # and the Content-Type header already checked.

        # Read in a max 4k chunk from the content;
        my $chunk;
        {
            open my $fh, "<", $filename 
                or Carp::confess "Failed to read file '$filename': $!";
            read $fh, $chunk, 4096; # read up to 4k
            close $fh;
        }

        # 2) Look for META head tags
        {
            my $head_parser = HTML::HeadParser->new;              
            $head_parser->parse($chunk);            
            $head_parser->eof;
            
            my $content_type = $head_parser->header('Content-Type');            
            return unless $content_type;
            my ($words) = HTTP::Headers::Util::split_header_words($content_type);
            my %param = @$words;
            return $param{charset};
        }

        # 3) If there's a UTF BOM set, look for it
        my $count = 0;
        while (my ($enc, $bom) = $boms->[$count++, $count++])
        {
            return $enc 
                if $bom eq substr($chunk, 0, length $bom);
        }
    
        # 4) If it looks like an XML document, look for XML declaration
        if ($chunk =~ m!^<\?xml\s+version="1.0"\s+encoding="([\w\-]+)"\?>!) {
            return $1;
        }

        # 5) If there's Encode::Detect module installed, try it
        if ( eval "use Encode::Detect::Detector" ) {
            my $charset = Encode::Detect::Detector::detect($chunk);
            return $charset if $charset;
        }
        
        return;
    }
}


# Constructor

sub new
{
    my $class = shift;
    croak "You must supply a matched set of key => value paramters"
        if @_ % 2;

    my %options = @_;

    unless (defined $options{ua}) 
    {
        # the default user agent should follow redirects
        my $ua = LWP::UserAgent->new(
            requests_redirectable => [qw(GET POST HEAD)]
        );
        $options{ua} = $ua;
    }

    my $self = bless \%options, $class;
    
    return $self;
}

sub ua { @_>1 ? shift->{ua} = shift : shift->{ua} }

our $DEFAULT_INSTANCE; # lazily assigned within download

sub download
{
    my $self = shift;

    # An URI or HTTP::Request for the page we want
    my $request = shift;

    # Where to save things. A directory - the main file will be called
    # 'index.html'
    my $content_dir = shift; 

    # A specialised UserAgent to use
    my $ua = shift;

    if (!blessed($self) 
        || !$self->isa(__PACKAGE__))
    { # we're a function, readjust the paramters accordingly
        ($self, $request, $content_dir, $ua) 
            = ( ($DEFAULT_INSTANCE ||= __PACKAGE__->new), $self, $request, $content_dir, shift);
    }

   
    # If no user agent supplied, use the instance's
    $ua ||= $self->{ua};

    croak "please supply an URL or HTTP::Request to download" 
        unless $request;

    $request = HTTP::Request->new(GET => $request)
        if (blessed $request && $request->isa('URI'))
        || ref \$request eq 'SCALAR';

    croak "first argument must be an URL or HTTP::Request instance" 
        unless blessed $request and $request->isa('HTTP::Request');

    croak "please supply a directory to copy into" 
        unless $content_dir;

    carp "warning, path '$content_dir' already exists, we may overwrite content" 
        if -e $content_dir;

    # All seems in order, now proceed....
    mkpath $content_dir;


    # First get the main document
    my $file = File::Spec->catdir($content_dir, "index.html");
    my $response = $ua->request($request, $file);

    unless ($response and $response->is_success) 
    {
        croak "HTTP request failed: ". $response->status_line;
    }
    
    # If it's not HTML, we can't understand it, so just leave it
    # unchanged.
    return unless $response->content_type =~ /html$/;


    # Otherwise, "localise" it....

    # This will parse the HTML so we can get the links
    my $parser = HTML::TreeBuilder::XPath->new;

    # Get the encoding, if we can
    my $encoding = $response->encoding || _detect_encoding($file);

    # HTML::Tidy does a better job of interpreting bad html than
    # HTML::TreeBuilder alone, so we pass it through that first.  If
    # we don't, the resulting HTML obtained after HTML::TreeBuilder
    # has parsed it can be broken.
    {
        my $tidy = HTML::Tidy->new(\%TIDY_OPTIONS);
        $tidy->ignore( text => qr/./ );        


        my $content = _slurp($file, $encoding);

        {
            no warnings 'redefine';

            # HTML::Tidy insists on calling this function.... silence
            # it, locally
            local *Carp::carp = sub {}; 
            
            $content = $tidy->clean($content);
        }

        $parser->parse($content);
    }
    
    my %seen; # We store URLs we've already processed in here

    # This will both download an URL's target and rewrite the URL to
    # point to the downloaded copy - here we refer to that process as
    # "localising" an url.
    my $localise_url = sub
    {
        my $url = shift || croak "no url parameter supplied";
        $url = URI->new_abs(decode_entities($url), $response->base) 
            unless blessed $url;

        my $local_url = $seen{$url};

        unless ($local_url)
        {
            # FIXME check for inline URL images? (i.e. data:// urls)
            my ($ext) = $url->path =~ m![.]([^./]+)$!;
            my $index = keys(%seen)+1;
            my $filename = $index;
            $filename .= ".$ext" 
                if defined $ext;
            my $file = File::Spec->catfile($content_dir, $filename); 


            # clean up things like '/../foo' which will cause an error 
            # if passed to $ua->get
            my $url_path = File::Spec::Unix->canonpath($url->path);
            $url->path($url_path);

            $local_url = $seen{$url} = $filename;
            
#            print "downloading $url -> $file\n";  DEBUG
            my $response2 = $ua->get($url, ':content_file' => $file);

            carp "failed to download $url: ". $response2->status_line
                unless $response2->is_success 
                    && -f $file;
        }

        return $local_url;
        
    };

    # This will localise URLs in tag attributes
    my $process_attr = sub 
    {
        my ($attr) = @_;

        my $url = $attr->getValue;
        return unless $url ne "";

        my $local_url = $localise_url->($url);
#        warn "url $url -> $local_url"; # DEBUG
        # rewrite the attribute
        $attr->getParentNode->attr($attr->getName, $local_url);
    };

    # This will localise a stylesheet link
    my $localise_style_url = sub
    {
        # note, CSS defines URLs to be relative to the stylesheet.
        my $base = shift || croak "you must supply a base url";
        my $url = URI->new_abs(shift, $base);

        my $local_url = $localise_url->($url);

        $local_url = encode_entities($local_url);

#        warn "localising $url-> $local_url\n"; # DEBUG
        return "url($local_url)";
    };

    my $process_stylesheet; # defined later

    # This will localise a stylesheet @import link
    my $localise_import = sub
    {
        my $base = shift;
        my $url = shift;

        my $local_url = $localise_url->($url);
        my $stylesheet_file = File::Spec->catdir($content_dir, $local_url);

        my $content = _slurp $stylesheet_file;
        $process_stylesheet->($base, $content);
        _spit $stylesheet_file, $content;        

        # Note, we don't convert the url, since that will be done later
        return "\@import url($url)"; 
    };

    # This function will localise an entire stylesheet's links.  It
    # returns the number of things downloaded.
    $process_stylesheet = sub
    {
        my $base = shift || croak "you must supply a base url";

        # First, convert all '@import' statements to the '@import url()' form,
        # then localise all url() references. Return true if either has been applied.
        my @stylesheets = $_[0] =~ s/$IMPORT_RE/$localise_import->($base, $+)/ige;
        my @urls = $_[0] =~ s/$URL_RE/$localise_style_url->($base, $+)/ige;

        return @stylesheets + @urls;
    };

    # This localises a <style> element
    my $process_style_node = sub 
    {
        my $style = shift || croak "you must supply a node";
        my $content = _inner_html $style;
        return unless $process_stylesheet->($response->base, $content);

        $style->delete_content;
        $style->push_content($content);
    };


    # A look-up table defining how to localise different things
    my @targets = 
        (images => '//img/@src', $process_attr,
         inputs => '//input/@src', $process_attr,
         # the XPath1 tranlsate() function is necessary to make a case-insensitive match of 'stylesheet'
         stylesheets => '/html/head/link[translate(@rel, "STYLHE","stylhe")="stylesheet"]/@href', sub { 
             my $attr = shift;
#             warn "node has value ".$attr->getValue;

             my $url = URI->new_abs($attr->getValue, $response->base);
             my $local_url = $localise_url->($url);
             my $file = File::Spec->catdir($content_dir, $local_url);
#             warn "file is $file $local_url";

             my $content = _slurp $file;
             $process_stylesheet->($url, $content);
             _spit $file, $content;

             $process_attr->($attr);
         },
         scripts => '//script/@src', $process_attr,
         styles => '//style', $process_style_node,
        );



    # Now localise each type of thing in turn
    while (@targets)
    {
        my ($type, $xpath, $process) = splice @targets, 0, 3;

        # FIXME unescape urls

        my @nodes = $parser->findnodes($xpath);

        foreach my $node (@nodes) 
        {
            eval { $process->($node) };
            next unless $@;

            $node = $node->getParentNode 
                while $node->getParentNode && !$node->can('as_HTML');
            warn "Failed to process node matching $xpath:\n    ". 
                $node->as_HTML ."\n...because: $@\n";
        }

    }


    # Now write the localised result back into the final index.html
    confess "failed to write to $file: $!" 
        unless open my $fh, ">", $file;
    print $fh $parser->as_HTML;
    close $fh;

    $parser->delete;
    
}

1;
__END__