File Coverage

blib/lib/XML/RSS/Tools.pm

Criterion	Covered	Total	%
statement	19	21	90.4
branch			n/a
condition			n/a
subroutine	7	7	100.0
pod			n/a
total	26	28	92.8

# --------------------------------------------------
#
# XML::RSS::Tools
# Version 0.34
# $Id: Tools.pm 101 2014-05-27 14:25:39Z adam $
#
# Copyright iredale Consulting, all rights reserved
# http://www.iredale.net/
#
# OSI Certified Open Source Software
#
# --------------------------------------------------

package XML::RSS::Tools;

use 5.010;                 # No longer been tested on anything earlier
use utf8;
use strict;                # Naturally
use warnings;              # Naturally
use warnings::register;    # So users can "use warnings 'XML::RSS::Tools'"
use Carp;                  # We're a nice module
use XML::RSS;              # Handle the RSS/RDF files
use XML::LibXML;           # Hand the XML file for XSLT
use XML::LibXSLT;          # Hand the XSL file and do the XSLT
use URI;                   # Deal with URIs nicely
use FileHandle;            # Allow the use of File Handle Objects

our $VERSION = '0.34';

#
#   Tools Constructor
#

sub new {
    my $class = shift;
    my %args   = @_;

    my $object = bless {
        _rss_version    => 0.91,            # We convert all feeds to this version
        _xml_string     => q{},             # Where we hold the input RSS/RDF
        _xsl_string     => q{},             # Where we hold the XSL Template
        _output_string  => q{},             # Where the output string goes
        _transformed    => 0,               # Flag for transformation
        _error_message  => q{},             # Error message
        _uri_url        => q{},             # URI URL
        _uri_file       => q{},             # URI File
        _uri_scheme     => q{},             # URI Scheme
        _xml_catalog    => q{},             # XML Catalog file
        _http_client    => 'auto',          # Which HTTP Client to use
        _proxy_server   => q{},             # A Proxy Server
        _proxy_user     => q{},             # Username on the proxy server
        _proxy_password => q{},             # Password for user on the proxy server
        _debug          => $args{debug} || 0,       # Debug flag
        _auto_wash      => $args{auto_wash} || 1,   # Flag for auto_washing input RSS/RDF
    },
    ref $class || $class;

    if ( $args{version} ) {
        croak "No such version of RSS $args{version}"
            unless set_version( $object, $args{version} );
    }

    if ( $args{http_client} ) {
        croak "Not configured for HTTP Client $args{http_client}"
            unless set_http_client( $object, $args{http_client} );
    }

    if ( $args{xml_catalog} ) {
        croak 'XML Catalog Support not enabled in your version of XML::LibXML'
            if $XML::LibXML::VERSION < 1.53;
        croak "Unable to read XML catalog $args{xml_catalog}"
            unless set_xml_catalog( $object, $args{xml_catalog} );
    }

    return $object;
}

#
#   Output what we have as a string
#
sub as_string {
    my $self = shift;
    my $mode = shift || q{};

    if ($mode) {
        if ( $mode =~ /rss/mxi ) {
            carp 'No RSS File to output'
                if !$self->{_rss_string} && $self->{_debug};
            return $self->{_rss_string};
        }
        elsif ( $mode =~ /xsl/mxi ) {
            carp 'No XSL Template to output'
                if !$self->{_xsl_string} && $self->{_debug};
            return $self->{_xsl_string};
        }
        elsif ( $mode =~ /error/mxi ) {
            if ( $self->{_error_message} ) {
                my $message = $self->{_error_message};
                $self->{_error_message} = q{};
                return $message;
            }
        }
        else {
            croak "Unknown mode: $mode";
        }
    }
    else {
        carp 'Nothing To Output Yet'
            if !$self->{_transformed} && $self->{_debug};
        return $self->{_output_string};
    }
    return;
}

#
#   Set/Read the debug level
#
sub debug {
    my $self  = shift;
    my $debug = shift;
    $self->{_debug} = $debug if defined $debug;
    return $self->{_debug};
}

#
#   Read the auto_wash level
#
sub get_auto_wash {
    my $self = shift;
    return $self->{_auto_wash};
}

#
#   Set the auto_wash level
#
sub set_auto_wash {
    my $self = shift;
    my $wash = shift;
    $self->{_auto_wash} = $wash if defined $wash;
    return $self->{_auto_wash};
}

#
#   Read the HTTP client mode
#
sub get_http_client {
    my $self = shift;
    return $self->{_http_client};
}

#
#   Set which HTTP client to use
#
sub set_http_client {
    my $self   = shift;
    my $client = shift;

    return $self->_raise_error( 'No HTTP Client requested' )
        unless defined $client;
    return $self->_raise_error( "Not configured for HTTP Client $client" )
        unless ( grep {/$client/mx} qw(auto ghttp lwp lite curl) );

    $self->{_http_client} = lc $client;
    return $self->{_http_client};
}

#
#   Get the HTTP proxy
#
sub get_http_proxy {
    my $self = shift;
    my $proxy;

    if ( $self->{_proxy_server} ) {
        $proxy = $self->{_proxy_user} . q{:} . $self->{_proxy_password} . q{@}
            if ( $self->{_proxy_user} && $self->{_proxy_password} );
        $proxy .= $self->{_proxy_server};
        return $proxy;
    }
}

#
#   Set the HTTP proxy
#
sub set_http_proxy {
    my $self = shift;
    my %args = @_;

    $self->{_proxy_server}   = $args{proxy_server};
    $self->{_proxy_user}     = $args{proxy_user};
    $self->{_proxy_password} = $args{proxy_pass};

    return $self;
}

#
#   Get the RSS Version
#
sub get_version {
    my $self = shift;
    return $self->{_rss_version};
}

#
#   Set the RSS Version
#
sub set_version {
    my $self    = shift;
    my $version = shift;

    return $self->_raise_error( 'No RSS version supplied' )
        unless defined $version;
    return $self->_raise_error("No such version of RSS $version")
        unless ( grep {/$version/mx} qw(0 0.9 0.91 0.92 0.93 0.94 1.0 2.0) );

    $self->{_rss_version} = $version;
    if ($version) {
        return $self->{_rss_version};
    }
    else {
        return '0.0';
    }
}

#
#   Get XML Catalog File
#
sub get_xml_catalog {
    my $self = shift;
    return $self->{_xml_catalog};
}

#
#   Set XML catalog file
#
sub set_xml_catalog {
    my $self         = shift;
    my $catalog_file = shift;

    croak 'XML Catalog Support not enabled in your version of XML::LibXML'
        if $XML::LibXML::VERSION < 1.53;

    if ( $self->_check_file( $catalog_file ) ) {
        $self->{_xml_catalog} = $catalog_file;
        return $self;
    }
    else {
        return;
    }
}

#
#   Load an RSS file, and call RSS conversion to standard RSS format
#
sub rss_file {
    my $self      = shift;
    my $file_name = shift;

    if ( $self->_check_file( $file_name ) ) {
        my $fh = FileHandle->new( $file_name, 'r' )
            or croak "Unable to open $file_name for reading";
        $self->{_rss_string} = $self->_load_filehandle( $fh );
        undef $fh;
        $self->_parse_rss_string;
        $self->{_transformed} = 0;
        return $self;
    }
    else {
        return;
    }
}

#
#   Load an XSL file
#
sub xsl_file {
    my $self      = shift;
    my $file_name = shift;

    if ( $self->_check_file( $file_name ) ) {
        my $fh = FileHandle->new( $file_name, 'r' )
            or croak "Unable to open $file_name for reading";
        $self->{_xsl_string} = $self->_load_filehandle( $fh );
        undef $fh;
        $self->{_transformed} = 0;
        return $self;
    }
    else {
        return;
    }
}

#
#   Load an RSS file from a FH, and call RSS conversion to standard RSS format
#
sub rss_fh {
    my $self      = shift;
    my $file_name = shift;

    if ( ref $file_name  eq 'FileHandle' ) {
        $self->{_rss_string} = $self->_load_filehandle( $file_name );
        _parse_rss_string($self);
        $self->{_transformed} = 0;
        return $self;
    }
    else {
        return $self->_raise_error(
            'FileHandle error: No FileHandle Object Passed' );
    }
}

#
#   Load an XSL file from a FH
#
sub xsl_fh {
    my $self      = shift;
    my $file_name = shift;

    if ( ref $file_name eq 'FileHandle' ) {
        $self->{_xsl_string}  = $self->_load_filehandle( $file_name );
        $self->{_transformed} = 0;
        return $self;
    }
    else {
        return $self->_raise_error(
            'FileHandle error: No FileHandle Object Passed' );
    }
}

#
#   Load an RSS file via HTTP and call RSS conversion to standard RSS format
#
sub rss_uri {
    my $self = shift;
    my $uri  = shift;

    $uri = $self->_process_uri( $uri );
    return unless $uri;

    return $self->rss_file( $self->{_uri_file} )
        if ( $self->{_uri_scheme} eq 'file' );

    my $xml = $self->_http_get( $uri );
    return unless $xml;
    $self->{_rss_string} = $xml;
    _parse_rss_string( $self );
    $self->{_transformed} = 0;
    return $self;
}

#
#   Load an XSL file via HTTP
#
sub xsl_uri {
    my $self = shift;
    my $uri  = shift;

    $uri = $self->_process_uri( $uri );
    return unless $uri;

    return $self->xsl_file( $self->{_uri_file} )
        if ( $self->{_uri_scheme} eq 'file' );

    my $xml = $self->_http_get( $uri );
    return unless $xml;
    $self->{_xsl_string}  = $xml;
    $self->{_transformed} = 0;
    return $self;
}

#
#   Parse a string and convert to standard RSS
#
sub rss_string {
    my $self = shift;
    my $xml  = shift;

    return unless $xml;
    $self->{_rss_string} = $xml;
    _parse_rss_string($self);
    $self->{_transformed} = 0;
    return $self;
}

#
#   Import an XSL from string
#
sub xsl_string {
    my $self = shift;
    my $xml  = shift;

    return unless $xml;
    $self->{_xsl_string}  = $xml;
    $self->{_transformed} = 0;
    return $self;
}

#
#   Do the transformation
#
sub transform {
    my $self = shift;

    croak 'No XSLT loaded' unless $self->{_xsl_string};
    croak 'No RSS loaded'  unless $self->{_rss_string};
    croak q{Can't transform twice without a change} if $self->{_transformed};

    my $xslt       = XML::LibXSLT->new;
    my $xml_parser = XML::LibXML->new;
    if ( $self->{_xml_catalog} ) {
        $xml_parser->load_catalog( $self->{_xml_catalog} );                 # Load the catalogue
    }
    else {
        $xml_parser->expand_entities( 0 );                                  # Otherwise don't touch entities
    }
    $xml_parser->keep_blanks( 0 );
    $xml_parser->validation( 0 );
    $xml_parser->complete_attributes( 0 );
    my $source_xml = $xml_parser->parse_string( $self->{_rss_string} );     # Parse the source XML
    my $style_xsl  = $xml_parser->parse_string( $self->{_xsl_string} );     # and Template XSL files
    my $stylesheet = $xslt->parse_stylesheet( $style_xsl );                 # Load the parsed XSL into XSLT
    my $result_xml = $stylesheet->transform( $source_xml );                 # Transform the source XML
    $self->{_output_string}
        = $stylesheet->output_string( $result_xml );                          # Store the result
    $self->{_transformed} = 1;
    return $self;
}

#   ---------------
#   Private Methods
#   ---------------

#
#   Parse the RSS string
#
sub _parse_rss_string {
    my $self = shift;
    my $xml  = $self->{_rss_string};

    $xml = _wash_xml( $xml ) if $self->{_auto_wash};

    if ( $self->{_rss_version} ) {    # Only normalise if version is true
        my $rss = XML::RSS->new;
        $rss->parse( $xml );
        if ( $rss->{version} != $self->{_rss_version} ) {
            $rss->{output} = $self->{_rss_version};
            $xml = $rss->as_string;
            $xml = _wash_xml( $xml ) if $self->{_auto_wash};
        }
        $self->{_xml_rss} = $rss;
    }
    $self->{_rss_string} = $xml;
    return $self;
}

#
#   Load file from File Handle
#
sub _load_filehandle {
    my $self   = shift;
    my $handle = shift;
    my $content;

    while ( my $line = $handle->getline ) {
        $content .= $line;
    }
    return $content;
}

#
#   Wash the XML File of known nasties
#
sub _wash_xml {
    my $xml = shift;

    $xml = _clean_entities( $xml );
    $xml =~ s/\s+/ /gsmx;
    $xml =~ s/> />/gmx;
    $xml =~ s/^.*(<\?xml)/$1/gsmx;    # Remove bogus content before
    return $xml;
}

#
#   Check that the requested file is there and readable
#
sub _check_file {
    my $self      = shift;
    my $file_name = shift;

    return $self->_raise_error( 'File error: No file name supplied' )
        unless $file_name;
    return $self->_raise_error( "File error: Cannot find $file_name" )
        unless -e $file_name;
    return $self->_raise_error( "File error: $file_name isn't a real file" )
        unless -f _;
    return $self->_raise_error( "File error: Cannot read file $file_name" )
        unless -r _;
    return $self->_raise_error( "File error: $file_name is zero bytes long" )
        if -z _;
    return $self;
}

#
#   Process a URI ready for HTTP getting
#
sub _process_uri {
    my $self = shift;
    my $uri  = shift;

    return $self->_raise_error( 'No URI provided.' ) unless $uri;
    my $uri_object = URI->new( $uri )->canonical;
    return $self->_raise_error( "URI provided ($uri) is not valid." )
        unless $uri_object;

    $self->{_uri_scheme} = $uri_object->scheme;
    return $self->_raise_error(
        'No URI Scheme in ' . $uri_object->as_string . q{.} )
        unless $self->{_uri_scheme};
    return $self->_raise_error(
        'Unsupported URI Scheme (' . $self->{_uri_scheme} . q{).} )
        unless $self->{_uri_scheme} =~ /http|file/mx;

    $self->{_uri_file} = $uri_object->file if $self->{_uri_scheme} eq 'file';

    return $uri_object->as_string;
}

#
#   Grab something via HTTP
#
sub _http_get {
    my $self = shift;
    my $uri  = shift;

    my $user_agent = "XML::RSS::Tools/$VERSION";

    if ( $self->{_http_client} eq 'auto' ) {
        my @modules = qw "WWW::Curl::Easy HTTP::GHTTP HTTP::Lite LWP";
        foreach my $module (@modules) {
            eval { require $module; };
            if ( ! $@ ) {
                $self->{_http_client} = lc $module ;
                $self->{_http_client} =~ s/.*:://mx;
                last;
            }
        }
        return $self->_raise_error(
            'HTTP error: No HTTP client library installed')
            if $self->{_http_client} eq 'auto';
    }

    if ( $self->{_http_client} eq 'lite' ) {
        require HTTP::Lite;
        my $ua = HTTP::Lite->new;
        $ua->add_req_header( 'User-Agent',
            "$user_agent HTTP::Lite/$HTTP::Lite::VERSION ($^O)"
        );
        $ua->proxy( $self->{_proxy_server} ) if $self->{_proxy_server};
        my $r = $ua->request($uri)
            or return $self->_raise_error( "Unable to get document: $!" );
        return $self->_raise_error( "HTTP error: $r, " . $ua->status_message )
            unless $r == 200;
        return $ua->body;
    }

    if (   $self->{_http_client} eq 'lwp'
        || $self->{_http_client} eq 'useragent' )
    {
        require LWP::UserAgent;
        my $ua = LWP::UserAgent->new;
        $ua->agent( $user_agent . ' ' . $ua->agent . " ($^O)" );
        $ua->proxy( [ 'http', 'ftp' ], $self->{_proxy_server} )
            if $self->{_proxy_server};
        my $response = $ua->request( HTTP::Request->new( 'GET', $uri ) );
        return $self->_raise_error( 'HTTP error: ' . $response->status_line )
            if $response->is_error;
        return $response->content( );
    }

    if ( $self->{_http_client} eq 'ghttp' ) {
        require HTTP::GHTTP;
        my $ua = HTTP::GHTTP->new($uri);
        $ua->set_header( 'User-Agent',
            "$user_agent HTTP::GHTTP/$HTTP::GHTTP::VERSION ($^O)" );
        if ( $self->{_proxy_server} ) {
            $ua->set_proxy( $self->{_proxy_server} );
            $ua->set_proxy_authinfo( $self->{_proxy_user},
                $self->{_proxy_password} )
                if ( $self->{_proxy_user} && $self->{_proxy_password} );
        }
        $ua->process_request;
        my $xml = $ua->get_body;
        if ( $xml ) {
            my ( $status, $message ) = $ua->get_status;
            return $self->_raise_error("HTTP error: $status, $message")
                unless $status == 200;
            return $xml;
        }
        else {
            return $self->_raise_error(
                "HTTP error: Unable to connect to server: $uri");
        }
    }

    if ($self->{_http_client} eq 'curl' ) {
        require WWW::Curl::Easy;
        my ($curl, $response_body, $file_b, $response_head,
            $file_h, $response, $response_code);

        $curl = WWW::Curl::Easy->new;

        open $file_b, '>', \$response_body;
        open $file_h, '>', \$response_head;

        $curl->setopt( WWW::Curl::Easy->CURLOPT_USERAGENT,
            "$user_agent WWW::Curl::Easy/$WWW::Curl::Easy::VERSION ($^O)" );
        $curl->setopt( WWW::Curl::Easy->CURLOPT_HEADER, 0 );
        $curl->setopt( WWW::Curl::Easy->CURLOPT_NOPROGRESS, 1 );
        $curl->setopt( WWW::Curl::Easy->CURLOPT_URL, $uri );
        $curl->setopt( WWW::Curl::Easy->CURLOPT_WRITEDATA, $file_b );
        $curl->setopt( WWW::Curl::Easy->CURLOPT_WRITEHEADER, $file_h );

        $response = $curl->perform;

        close $file_b;
        close $file_h;

        if ($response == 0) {
            $response_code = $curl->getinfo(
                WWW::Curl::Easy->CURLINFO_HTTP_CODE );
            return $self->_raise_error( "HTTP error: $response_code" )
                unless $response_code == 200;
            return $response_body
        }
        else {
            return $self->_raise_error( "HTTP error : " .
                $curl->strerror( $response ) . " ($response)" );
        }

    }
}

#
#   Fix Entities
#   This subroutine is a mix of Matt Sergent's rss-mirror script
#   And chunks of the HTML::Entites module if you have Perl 5.8 or
#   later you don't need this code.
#
sub _clean_entities {
    my $xml = shift;

    my %entity = (
        trade   => '™',
        euro    => '€',
        quot    => q{"},
        apos    => q{'},
        AElig   => q{Æ},
        Aacute  => q{Á},
        Acirc   => q{Â},
        Agrave  => q{À},
        Aring   => q{Å},
        Atilde  => q{Ã},
        Auml    => q{Ä},
        Ccedil  => q{Ç},
        ETH     => q{Ð},
        Eacute  => q{É},
        Ecirc   => q{Ê},
        Egrave  => q{È},
        Euml    => q{Ë},
        Iacute  => q{Í},
        Icirc   => q{Î},
        Igrave  => q{Ì},
        Iuml    => q{Ï},
        Ntilde  => q{Ñ},
        Oacute  => q{Ó},
        Ocirc   => q{Ô},
        Ograve  => q{Ò},
        Oslash  => q{Ø},
        Otilde  => q{Õ},
        Ouml    => q{Ö},
        THORN   => q{Þ},
        Uacute  => q{Ú},
        Ucirc   => q{Û},
        Ugrave  => q{Ù},
        Uuml    => q{Ü},
        Yacute  => q{Ý},
        aacute  => q{á},
        acirc   => q{â},
        aelig   => q{æ},
        agrave  => q{à},
        aring   => q{å},
        atilde  => q{ã},
        auml    => q{ä},
        ccedil  => q{ç},
        eacute  => q{é},
        ecirc   => q{ê},
        egrave  => q{è},
        eth     => q{ð},
        euml    => q{ë},
        iacute  => q{í},
        icirc   => q{î},
        igrave  => q{ì},
        iuml    => q{ï},
        ntilde  => q{ñ},
        oacute  => q{ó},
        ocirc   => q{ô},
        ograve  => q{ò},
        oslash  => q{ø},
        otilde  => q{õ},
        ouml    => q{ö},
        szlig   => q{ß},
        thorn   => q{þ},
        uacute  => q{ú},
        ucirc   => q{û},
        ugrave  => q{ù},
        uuml    => q{ü},
        yacute  => q{ý},
        yuml    => q{ÿ},
        copy    => q{©},
        reg     => q{®},
        nbsp    => q{\240},
        iexcl   => q{¡},
        cent    => q{¢},
        pound   => q{£},
        curren  => q{¤},
        yen     => q{¥},
        brvbar  => q{¦},
        sect    => q{§},
        uml     => q{¨},
        ordf    => q{ª},
        laquo   => q{«},
        'not'   => q{¬},
        shy     => q{­},
        macr    => q{¯},
        deg     => q{°},
        plusmn  => q{±},
        sup1    => q{¹},
        sup2    => q{²},
        sup3    => q{³},
        acute   => q{´},
        micro   => q{µ},
        para    => q{¶},
        middot  => q{·},
        cedil   => q{¸},
        ordm    => q{º},
        raquo   => q{»},
        frac14  => q{¼},
        frac12  => q{½},
        frac34  => q{¾},
        iquest  => q{¿},
        'times' => q{×},
        divide  => q{÷},
    );
    my $entities = join q{|}, keys %entity;
    $xml =~ s/&(?!(#[0-9]+|#x[0-9a-fA-F]+|\w+);)/&/gm;       # Matt's ampersand entity fixer
    $xml =~ s/&($entities);/$entity{$1}/gimx;                    # Deal with odd entities
    return $xml;
}

#
#   Raise error condition
#
sub _raise_error {
    my $self    = shift;
    my $message = shift;

    $self->{_error_message} = $message;
    carp $message if $self->{_debug};
    return;
}

1;

__END__