File Coverage

blib/lib/CSS/Tiny/Style.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

package CSS::Tiny::Style;

use version; $VERSION = qv('0.0.3');

use warnings;
use strict;
use Carp;

use CSS::Tiny;
use HTML::Element;

package CSS::Tiny;

sub selectors {
    my $self = shift;
    return keys %{ $self };
}

sub styles {
    my $self = shift;
    my @styles = $self->_sorted_styles;

    return @styles;
}

sub _sorted_styles {
    return sort { $a->specificity <=> $b->specificity } shift->_all_styles
}

sub _all_styles {
    my $self = shift;
    my @res;
    while (my ($selector, $properties) = each %{ $self }) {
	push @res, CSS::Tiny::Style->new($selector, $properties);
    }
    return @res;
}

our $AUTOLOAD;

sub AUTOLOAD {
    my $self = shift;

    my $attr = $AUTOLOAD;
    $attr =~ s/.*:://;

    return unless exists $self->{$attr};
    return CSS::Tiny::Style->new($attr, $self->{$attr});
}


sub style {
    my $self = shift;
    my $style = shift;

    return unless exists $self->{$style};
    return CSS::Tiny::Style->new($style, $self->{$style});
}

package CSS::Tiny::Style;

use warnings;
use strict;
no warnings qw/uninitialized/;

use Carp;
use overload
    '""' => \&stringify;

sub new {
    my $class = shift;
    $class = ref $class || $class;

    my $selector = shift || croak "Need a selector";
    my $properties = shift || {};

    my $self = $properties;
    $self->{_selector} = $selector;
    $self->{_selarr}   = undef;    # set later to [];

    bless $self, $class;
}

sub stringify {
    my $self = shift;
    my @fields = grep { !/^_/ } keys %{ $self };
    for (@fields) { $_ = join ":", $_, $self->{$_} };
    return join ';', @fields;
}

##################################################################################################################
# from css spec at http://www.w3.org/TR/REC-CSS2/selector.html#q1
##################################################################################################################
#
#  *			Matches any element.	Universal selector
#
#  E			Matches any E element (i.e., an element of type E).
#
#  E F			Matches any F element that is a descendant of an E element.
#
#  E > F		Matches any F element that is a child of an element E.
#
#  E:first-child	Matches element E when E is the first child of its parent.
#
#  E + F		Matches any F element immediately preceded by a sibling element E.
#
#  E[foo]		Matches any E element with the "foo" attribute set (whatever the value).
#
#  E[foo="warning"]	Matches any E element whose "foo" attribute value is exactly equal to "warning".
#
#  E[foo~="warning"]	Matches any E element whose "foo" attribute value is a list of space-separated values,
# 			one of which is exactly equal to "warning".
#
#  E[lang|="en"]	Matches any E element whose "lang" attribute has a hyphen-separated list of values
# 			beginning (from the left) with "en".
#
#  DIV.warning		Language specific. (In HTML, the same as DIV[class~="warning"].)
#
#  E#myid		Matches any E element with ID equal to "myid".	ID selectors
#
##################################################################################################################

sub element_match {
    my $self = shift;
    my $el = shift || croak "No element to match";

    return if lc $el->tag eq 'html';
    return if lc $el->tag eq 'head';
    return if $el->look_up("_tag", "head");

    my @sel = @_;

    @sel = $self->selector_array unless @sel;


    no strict 'refs';

    my $sel = shift @sel;
    for (qw/tag id class/) {
	my $sub = "_$_";

	next unless (my $val = &$sub($sel));  # skip test if no value in selector

	my $att = /tag/ ? '_tag' : $_;        # HTML::Element behaviour
	$val = $val eq '*' ? $el->tag : $val; # always matches


	return unless ($val && ((lc $val) eq (lc $el->attr($att))));
    }
    use strict 'refs';
    return 1;
}

sub match {
    my $self = shift;

    # the next argument is an element or a listref of elements
    my @el = shift; if (ref $el[0] eq 'ARRAY') { @el = @{$el[0]} };

    my ($sel, $rel, @sel);
    if (@_) {
	(
	 $sel,	# the first selector
	 $rel, 	# the relationship, i.e.: '>' or '+' or ' '
	 @sel	# the remaining selector
	) = @_;
    } else {
	($sel, $rel, @sel) = $self->selector_array;
    }


    #+++++++++++++++++++++++++++++++++++++++++++++++++++++
    # 1) loop through elements
    # 2) check if one matches
    # 3) if it matches, loop through his relatives
    # 4) return true if one matches
    #+++++++++++++++++++++++++++++++++++++++++++++++++++++

    my $match = 0;
    for (@el) {
	if ($self->element_match($_, $sel)) {
	    # if element matches, check his relatives
	    if ($rel) {
		my $rellist = $_->$rel;
		$match = $self->match($rellist, @sel)
	    } else {
		$match = 1;
	    }
	}
	last if $match;
    };
    return $match;
}

sub selector {
    my $self = shift;
    $self->{'_selector'};
}


*selarr = *selector_array;
sub selector_array {
    my $self = shift;
    unless (defined $self->{_selarr}) {
	my $selector = $self->selector;
	my @sel = _sel_arr($selector);
	$self->{_selarr} = [@sel];
    }
    return @{ $self->{_selarr} };
}

sub add_to {
    my $self = shift;
    my $element = shift;

    my $style = $element->attr('style');
    $style = $style eq "" ? $self->stringify : (join ";", ($style, $self->stringify));
    #$style =~ s/^;//; # why why why?
    $element->attr('style', $style)
}

###########################################################################################################
# from CSS spec at http://www.w3.org/TR/CSS21/cascade.html#specificity
###########################################################################################################
# A selector's specificity is calculated as follows:
#
#     * count the number of ID attributes in the selector (= a)
#     * count the number of other attributes and pseudo-classes in the selector (= b)
#     * count the number of element names in the selector (= c)
#     * ignore pseudo-elements.
#
# Concatenating the three numbers a-b-c (in a number system with a large base) gives the specificity.
#
# Example(s):
#
# Some examples:
#
# *             {}  /* a=0 b=0 c=0 -> specificity =   0 */
# LI            {}  /* a=0 b=0 c=1 -> specificity =   1 */
# UL LI         {}  /* a=0 b=0 c=2 -> specificity =   2 */
# UL OL+LI      {}  /* a=0 b=0 c=3 -> specificity =   3 */
# H1 + *[REL=up]{}  /* a=0 b=1 c=1 -> specificity =  11 */
# UL OL LI.red  {}  /* a=0 b=1 c=3 -> specificity =  13 */
# LI.red.level  {}  /* a=0 b=2 c=1 -> specificity =  21 */
# #x34y         {}  /* a=1 b=0 c=0 -> specificity = 100 */
###########################################################################################################

sub specificity {
    my $self = shift;
    return 0 if $self->selector eq '*';
    return (
	    $self->count_ids * 100 +
	    $self->count_attributes * 10 +
	    $self->count_tags
	    );
}

sub tag { _tag(shift->selector) }

sub id { _id(shift->selector) }

sub class { _class(shift->selector) }

sub count_ids {
    my @sel = shift->selarr;
    return scalar grep { /\#/ } @sel
}

sub count_attributes {
    my @sel = shift->selarr;
    return scalar grep { /\./ || /\[/ } @sel
}

sub count_tags {
    my @sel = shift->selarr;
    return int (((scalar grep { !/\*/ } @sel) / 2) + 1)
}

sub _sel_arr {
    local $_ = shift;
    my @d;

    while ($_) {
	my ($tag, $op);


	s/([a-zA-Z0-9.\#\*]+)\s*$//; $tag = $1;
	$op  = $1 if (s/(\s*[+>]*\s*)$//);


	push @d, $tag if $tag;

	for ($op) {
	    /\+/    && do { push @d, 'left';    last; };
	    /\>/    && do { push @d, 'parent';  last; };
	    /^\s+$/ && do { push @d, 'lineage';	last; };
	}
    }
    return @d;
}

sub _tag {
    local $_ = shift;

    return '*' if (/^\./ || /^\#/);
    /^(\w+)[\#\.]*/;
    return $1;
}

sub _id {
    local $_ = shift;
    /\#(\w+)\W*/;
    return $1;
}

sub _class {
    local $_ = shift;
    /\.(\w+)\W*/;
    return $1;
}


1;
__END__