view release on metacpan or  search on metacpan

lib/Daizu/Preview.pm  view on Meta::CPAN

Exactly which attributes are adjusted depends on the contents of
L<%HTML_URL_ATTR|/%HTML_URL_ATTR>.

In addition, inline CSS code in C<style> elements is filtered though
the CSS filtering function described below, so that CSS links are
adjusted as well.

=cut

sub adjust_preview_links_html
{
    my ($cms, $wc_id, $base_url, $html, $fh) = @_;
    $base_url = URI->new($base_url);

    # TODO - SSI processing should be optional, probably off by default.
    # TODO - this should be done in output_preview, for the right MIME types,
    # whether or not there's a preview function for them.
    _process_ssi($cms, $wc_id, $base_url, \$html);

    # When in <style> elements filter CSS to adjust links.
    my $in_style = 0;

    my $parser = HTML::Parser->new(
        api_version => 3,
        start_h => [
            sub { _start_h($cms, $wc_id, $base_url, $fh, \$in_style, @_) },
            'tagname, attr',
        ],
        end_h => [
            sub {
                my ($tagname) = @_;
                --$in_style if $tagname eq 'style';
                print $fh "</$tagname>";
            },
            'tagname',
        ],
        default_h => [
            sub {
                my ($css) = @_;
                if ($in_style) {
                    adjust_preview_links_css($cms, $wc_id, $base_url,
                                             $css, $fh);
                }
                else {
                    print $fh $css;
                }
            },
            'text',
        ],
    );
    $parser->parse($html);
    $parser->eof;
}

sub _start_h
{
    my ($cms, $wc_id, $base_url, $fh, $in_style, $tagname, $attr) = @_;

    ++$$in_style if $tagname eq 'style';

    delete $attr->{'/'};      # to cope with XHTML empty elements

    # The keys are sorted to allow for testing.
    my $attrtext = join ' ', map {
        "$_=\"" . html_escape_attr(exists $HTML_URL_ATTR{"$tagname:$_"}
            ? adjust_link_for_preview($cms, $wc_id, $base_url, $attr->{$_},
                                       $HTML_URL_ATTR{"$tagname:$_"})
            : $attr->{$_}) . '"';
    } sort keys %$attr;

    print $fh ($attrtext ? "<$tagname $attrtext>" : "<$tagname>");
}

sub _process_ssi
{
    my ($cms, $wc_id, $base_url, $html) = @_;
    my $output = '';

    LOOP: {
        # TODO - recognize other SSI directives and signal error
        if ($$html =~ m{\G<!--\#include \s+
                                virtual \s* = \s* ( "[^"]*" |
                                                    '[^']*' |
                                                    `[^`]*` )
                        \s+ -->}cgx)
        {
            my $url = $1;
            $url =~ s/\A"(.*)"\z/$1/ or
                    s/\A'(.*)'\z/$1/ or
                    s/\A`(.*)`\z/$1/;
            $url = URI->new($url);
            $output .= "[SSI error: only path allowed]", redo LOOP
                if $url->scheme;
            $url = $url->abs($base_url);
            my ($type, $fragment) = _load_ssi($cms, $wc_id, $url);
            $output .= "[SSI error: $fragment]", redo LOOP
                unless defined $type;
            _process_ssi($cms, $wc_id, $url, $fragment)
                if exists $ENABLE_SSI{$type};
            $output .= $$fragment;
            redo LOOP;
        }
        elsif ($$html =~ /\G([^<]+)/cg || $$html =~ /\G(.)/cgs) {
            $output .= $1;
            redo LOOP;
        }
    }

    $$html = $output;
}

# Returns either:
#   MIME type and reference to content - if URL is active
#   undef and error string - if URL is not active
sub _load_ssi
{
    my ($cms, $wc_id, $url) = @_;
    my $db = $cms->db;

    my ($guid_id, $gen_class, $method, $argument, $type, $status) =
        db_select($db,