File Coverage

blib/lib/WebService/Validator/CSS/W3C.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

package WebService::Validator::CSS::W3C;
use strict;
use warnings;

use SOAP::Lite 0.65;
use LWP::UserAgent qw//;
use URI qw//;
use URI::QueryParam qw//;
use Carp qw//;
use base qw/Class::Accessor/;

our $VERSION = "0.3";

# profiles currently supported by the W3C CSS Validator
our %PROFILES = map { $_ => 1 } qw/none css1 css2 css21 css3 svg svgbasic
                                   svgtiny mobile atsc-tv tv/;

# user media currently supported by the W3C CSS Validator
our %MEDIA    = map { $_ => 1 } qw/all aural braille embossed handheld
                                   print screen tty tv presentation/;

# warnings level currently supported by the W3C CSS Validator
our %WARNINGS = map { $_ => 1 } qw/0 1 2 no/;

__PACKAGE__->mk_accessors    (qw/user_agent validator_uri/);
__PACKAGE__->mk_ro_accessors (qw/response request_uri som success/);

sub new
{
    my $proto = shift;
    my $class = ref $proto || $proto;
    my $self = bless {}, $class;
    my $ua = shift;
    my $uri = shift;

    if (defined $ua) {

        # check whether it really is
        Carp::croak "$ua is not a LWP::UserAgent"
          unless UNIVERSAL::isa($ua, 'LWP::UserAgent');

        $self->user_agent($ua);
    } else {
        my $ua = LWP::UserAgent->new(agent => __PACKAGE__."/".$VERSION);
        $self->user_agent($ua);
    }

    if (defined $uri) {
        $self->validator_uri($uri);
    } else {
        $self->validator_uri("http://jigsaw.w3.org/css-validator/validator");
    }

    return $self;
}

sub _handle_response
{
    my $self = shift;
    my $res = shift;

    # internal or server errors...
    return 0 unless $res->is_success;

    local $_ = $res->content;

    my $som;
    eval { $som = SOAP::Deserializer->new->deserialize($_); };

    # Deserialization might fail if the response is not a legal
    # SOAP response, e.g., if the response is ill-formed... Not
    # sure how to make the reason for failure available to the
    # application, suggestions welcome.
    if ($@) {
        # Carp::carp $@;
        return 0;
    }

    # memorize the SOAP object model object
    $self->{'som'} = $som;

    # check whether this is really the CSS Validator responding
    if ($som->match("/Envelope/Body/cssvalidationresponse")) {
        $self->{'success'} = 1;
    }
    # if the response was a SOAP fault
    elsif ($som->match("/Envelope/Body/Fault")) {
        $self->{'success'} = 0;
    }

    # return whether the response was successfully processed
    return $self->{'success'};
}

sub validate
{
    my $self = shift;
    my %parm = @_;
    my $uri = URI->new($self->validator_uri);
    my $ua = $self->user_agent;

    $self->{'success'} = 0;

    #
    if (defined $parm{string}) {
        $uri->query_param(text => $parm{string});
    } elsif (defined $parm{uri}) {
        $uri->query_param(uri => $parm{uri});
    } else {
        Carp::croak "you must supply a string/uri parameter\n";
    }

    if (defined $parm{medium}) {
        # check whether the medium is supported
        Carp::croak "$parm{medium} is not a legal medium\n"
          unless $MEDIA{$parm{medium}};

        $uri->query_param(medium => $parm{medium});
    }

    if (defined $parm{profile}) {
        # check whether the profile is supported
        Carp::croak "$parm{profile} is not a legal profile\n"
          unless $PROFILES{$parm{profile}};

        $uri->query_param(profile => $parm{profile});
    }

    if (defined $parm{warnings}) {
        Carp::croak "warnings must be either \"no\" or an integer from 0 to 2\n"
          unless $WARNINGS{$parm{warnings}};
        $uri->query_param(warning => $parm{warnings});
    }

    # request SOAP 1.2 output
    $uri->query_param(output => "soap12");

    # memorize request uri
    $self->{'request_uri'} = $uri;

    # generate new HTTP::Request object
    my $req = HTTP::Request->new(GET => $uri);

    # add an Accept-Language header if desired
    if (defined $parm{language}) {
        $req->header(Accept_Language => $parm{language});
    }

    my $res = $ua->simple_request($req);

    # memorize response
    $self->{'response'} = $res;

    return $self->_handle_response($res);
}

sub is_valid
{
    my $self = shift;
    my $som = $self->som;

    # previous failure means the style sheet is invalid
    return 0 unless $self->success and defined $som;

    # fetch validity field in reponse
    my $validity = $som->valueof("/Envelope/Body/cssvalidationresponse/validity");

    # valid if m:validity is true
    return 1 if defined $validity and $validity eq "true";

    # else invalid
    return 0;
}

sub errors
{
    my $self = shift;
    my $som = $self->som;

    return () unless defined $som;
    return $som->valueof("//error");
}

sub warnings
{
    my $self = shift;
    my $som = $self->som;

    return () unless defined $som;
    return $som->valueof("//warning");
}

sub errorcount
{
    my $self = shift;
    my $som = $self->som;

    return () unless defined $som;
    return $som->valueof("//errorcount");
}

sub warningcount
{
    my $self = shift;
    my $som = $self->som;

    return () unless defined $som;
    return $som->valueof("//warningcount");
}

1;

__END__