CSS-Prepare/lib/CSS/Prepare.pm
package CSS::Prepare;
use Modern::Perl;
use CSS::Prepare::CSSGrammar;
use CSS::Prepare::Property::Background;
use CSS::Prepare::Property::Border;
use CSS::Prepare::Property::BorderRadius;
use CSS::Prepare::Property::Color;
use CSS::Prepare::Property::Effects;
use CSS::Prepare::Property::Font;
use CSS::Prepare::Property::Formatting;
use CSS::Prepare::Property::Generated;
use CSS::Prepare::Property::Hacks;
use CSS::Prepare::Property::Margin;
use CSS::Prepare::Property::Padding;
use CSS::Prepare::Property::Tables;
use CSS::Prepare::Property::Text;
use CSS::Prepare::Property::UI;
use CSS::Prepare::Property::Values;
use CSS::Prepare::Property::Vendor;
use Digest::SHA1 qw( sha1_hex );
use FileHandle;
use File::Basename;
use File::Path;
use List::Util qw( first );
use Storable qw( dclone );
use version;
our $VERSION = qv( 0.9.2.4 );
use constant MAX_REDIRECT => 3;
use constant RE_IS_URL => qr{^ http s? : // }x;
use constant RE_MATCH_HOSTNAME => qr{^ ( http s? : // [^/]+ ) /? .* $}x;
use constant RE_MATCH_DIRECTORY => qr{^ (.*?) (?: / [^/]* )? $}x;
use constant NOT_VENDOR_PREFIX => qw(
background border empty font letter
list margin padding page table
text unicode white z
);
my @MODULES = qw(
Background
Border
BorderRadius
Color
Effects
Font
Formatting
Hacks
Generated
Margin
Padding
Tables
Text
UI
Vendor
);
sub new {
my $class = shift;
my %args = @_;
my $self = {
hacks => 1,
extended => 0,
suboptimal_threshold => 10,
http_timeout => 30,
pretty => 0,
assets_output => undef,
assets_base => undef,
location => undef,
status => \&status_to_stderr,
%args
};
bless $self, $class;
my %http_providers = (
lite => 'HTTP::Lite',
lwp => 'LWP::UserAgent',
);
# sort to prefer HTTP::Lite over LWP::UserAgent
HTTP:
foreach my $provider ( sort keys %http_providers ) {
my $module = $http_providers{ $provider };
eval "require $module";
unless ($@) {
$self->{'http_provider'} = $provider;
last HTTP;
}
}
# check for ability to use plugins
if ( $self->support_extended_syntax() ) {
eval "use Module::Pluggable require => 1;";
unless ($@) {
foreach my $plugin ( $self->plugins() ) {
$self->{'has_plugins'} = 1;
}
}
}
return $self;
}
sub get_hacks {
my $self = shift;
return $self->{'hacks'};
}
sub set_hacks {
my $self = shift;
my $hacks = shift // 0;
$self->{'hacks'} = $hacks;
}
sub support_hacks {
my $self = shift;
return $self->{'hacks'};
}
sub get_extended {
my $self = shift;
return $self->{'extended'};
}
sub set_extended {
my $self = shift;
my $extended = shift // 0;
$self->{'extended'} = $extended;
}
sub support_extended_syntax {
my $self = shift;
return $self->{'extended'};
}
sub get_suboptimal_threshold {
my $self = shift;
return $self->{'suboptimal_threshold'};
}
sub set_suboptimal_threshold {
my $self = shift;
my $suboptimal_threshold = shift // 0;
$self->{'suboptimal_threshold'} = $suboptimal_threshold;
}
sub suboptimal_threshold {
my $self = shift;
return $self->{'suboptimal_threshold'};
}
sub get_pretty {
my $self = shift;
return $self->{'pretty'};
}
sub set_pretty {
my $self = shift;
my $value = shift;
$self->{'pretty'} = $value;
}
sub pretty_output {
my $self = shift;
return $self->{'pretty'};
}
sub assets_output {
my $self = shift;
return defined $self->{'assets_output'};
}
sub location {
my $self = shift;
return $self->{'location'};
}
sub set_base_directory {
my $self = shift;
my $base = shift;
# ensure trailing slash
$base =~ s{/?$}{/};
$self->{'base_directory'} = $base;
}
sub get_base_directory {
my $self = shift;
return $self->{'base_directory'};
}
sub set_base_url {
my $self = shift;
$self->{'base_url'} = shift;
}
sub get_base_url {
my $self = shift;
return $self->{'base_url'};
}
sub get_http_timeout {
my $self = shift;
return $self->{'http_timeout'};
}
sub set_http_timeout {
my $self = shift;
$self->{'http_timeout'} = shift;
}
sub has_http {
my $self = shift;
return defined $self->{'http_provider'};
}
sub get_http_provider {
my $self = shift;
return $self->{'http_provider'};
}
sub has_plugins {
my $self = shift;
return $self->{'has_plugins'};
}
my $elements_first = sub {
my $a_element = ( $a =~ m{^[a-z]}i );
my $b_element = ( $b =~ m{^[a-z]}i );
my $element_count = $a_element + $b_element;
return ( $a_element ? -1 : 1 )
if 1 == $element_count;
return $a cmp $b;
};
sub parse_file {
my $self = shift;
my $file = shift;
my $location = shift;
my $string = $self->read_file( $file );
return $self->parse( $string, $file, $location )
if defined $string;
return;
}
sub parse_file_structure {
my $self = shift;
my $file = shift;
my $base = $self->get_base_directory();
return undef
unless defined $base && -d $base;
my $stylesheet = basename( $file );
my $directory = dirname( $file );
my @blocks;
my $path;
foreach my $section ( split m{/}, $directory ) {
$path .= "${section}/";
my $target = "${base}${path}${stylesheet}";
my @file_blocks = $self->parse_file( $target );
push @blocks, @file_blocks
if @file_blocks; # non-existent file is not an error
}
return @blocks;
}
sub parse_url {
my $self = shift;
my $url = shift;
my $location = shift;
my $string = $self->read_url( $url );
return $self->parse( $string, $url, $location )
if defined $string;
return;
}
sub parse_url_structure {
my $self = shift;
my $file = shift;
my $base = $self->get_base_url();
return undef
unless defined $base && $base =~ m{https?://};
my $stylesheet = basename( $file );
my $directory = dirname( $file );
my @blocks;
my $path;
foreach my $section ( split m{/}, $directory ) {
$path .= "${section}/";
my $target = "${base}${path}${stylesheet}";
my @file_blocks = $self->parse_url( $target );
push @blocks, @file_blocks
if @file_blocks; # non-existent url is not an error
}
return @blocks;
}
sub parse_string {
my $self = shift;
my $string = shift;
my $location = shift;
return $self->parse( $string )
}
sub parse_stylesheet {
my $self = shift;
my $stylesheet = shift;
my $location = shift;
my $target = $self->canonicalise_location( $stylesheet, $location );
return $self->parse_url( $target, $location )
if $target =~ RE_IS_URL;
return $self->parse_file( $target, $location );
}
sub canonicalise_location {
my $self = shift;
my $file = shift;
my $location = shift;
my $target;
# don't interfere with an absolute URL
if ( $file =~ RE_IS_URL ) {
$target = $file;
}
else {
if ( $file =~ m{^/} ) {
my $base = $self->get_base_directory();
if ( defined $base ) {
$target = "$base/$file";
}
else {
$target = $file;
}
if ( defined $location ) {
if ( $location =~ RE_MATCH_HOSTNAME ) {
$target = "${1}${file}";
}
}
}
else {
if ( defined $location ) {
$location =~ RE_MATCH_DIRECTORY;
$target = "${1}/${file}";
}
else {
my $base = $self->get_base_directory() || '';
$target = "${base}${file}";
}
}
}
return $target;
}
sub output_as_string {
my $self = shift;
my @data = @_;
my $output = '';
foreach my $block ( @data ) {
my $type = $block->{'type'} // '';
if ( 'at-media' eq $type || 'import' eq $type ) {
my $query = $block->{'query'};
my $string = $self->output_as_string( @{$block->{'blocks'}} );
if ( defined $query && $query ) {
$string =~ s{^}{ }gm;
$output .= "\@media ${query}{\n${string}}\n";
}
else {
$output .= $string;
}
}
elsif ( 'verbatim' eq $type ) {
$output .= $block->{'string'};
}
elsif ( 'boundary' eq $type ) {
# just skip the block
}
else {
$output .= $self->output_block_as_string( $block );
}
}
return $output;
}
sub output_block_as_string {
my $self = shift;
my $block = shift;
my $shorthands_first_hacks_last = sub {
# sort hacks after normal properties
my $a_hack = ( $a =~ m{^ \s* [_\*] }x );
my $b_hack = ( $b =~ m{^ \s* [_\*] }x );
my $hack_count = $a_hack + $b_hack;
return $a_hack ? 1 : -1
if 1 == $hack_count;
# sort properties with vendor prefixes before
# their matching properties
$a =~ m{^ \s* ( [-] \w+ - )? ( .* ) $}sx;
my $a_vendor = defined $1
&& ! defined first
{ $_ eq $1 } NOT_VENDOR_PREFIX;
$b =~ m{^ \s* ( [-] \w+ - )? ( .* ) $}sx;
my $b_vendor = defined $1
&& ! defined first
{ $_ eq $1 } NOT_VENDOR_PREFIX;
my $vendors = ( $a_vendor ) + ( $b_vendor );
return $a_vendor ? -1 : 1
if 1 == $vendors;
# sort more-specific properties after less-specific properties
$a =~ m{^ \s* ( [^:]+ ) : }x;
my $a_declaration = $1;
$b =~ m{^ \s* ( [^:]+ ) : }x;
my $b_declaration = $1;
my $a_specifics = ( $a_declaration =~ tr{-}{-} );
my $b_specifics = ( $b_declaration =~ tr{-}{-} );
return $a_specifics <=> $b_specifics
if $a_specifics != $b_specifics;
# just sort alphabetically
return $a cmp $b;
};
my %properties = $self->output_properties( $block->{'block'} );
return '' unless %properties;
# unique selectors only
my %seen;
my @selectors = grep { !$seen{$_}++ } @{$block->{'selectors'}};
my $output;
my $separator = $self->pretty_output ? ",\n" : ',';
my $selector = join $separator, sort $elements_first @selectors;
my $properties = join '', sort $shorthands_first_hacks_last
keys %properties;
return $self->pretty_output
? "${selector} \{\n${properties}\}\n"
: "${selector}\{${properties}\}\n";
}
sub output_properties {
my $self = shift;
my $block = shift;
# separate out the important rules from the normal, so that they are
# not accidentally shorthanded, despite being different values
my %normal;
my %important;
foreach my $key ( keys %{$block} ) {
if ( $key =~ m{^important-(.*)$} ) {
$important{ $1 } = $block->{ $key };
}
else {
$normal{ $key } = $block->{ $key };
}
}
my %properties;
my @outputters;
if ( $self->has_plugins() ) {
map { push @outputters, "${_}::output" }
$self->plugins();
}
map { push @outputters, "CSS::Prepare::Property::${_}::output" }
@MODULES;
foreach my $outputter ( @outputters ) {
my( @normal, @important );
eval {
no strict 'refs';
@normal = &$outputter( $self, \%normal );
@important = &$outputter( $self, \%important );
};
say STDERR $@ if $@;
foreach my $property ( @normal ) {
$properties{ $property } = 1
if defined $property;
}
foreach my $property ( @important ) {
if ( defined $property ) {
my $prefix = $self->output_separator;
$property =~ s{;$}{${prefix}!important;};
$properties{ $property } = 1;
}
}
}
return %properties;
}
sub output_format {
my $self = shift;
return $self->pretty_output
? $pretty_format
: $concise_format;
}
sub output_separator {
my $self = shift;
return $self->pretty_output
? $pretty_separator
: $concise_separator;
}
sub fetch_file {
my $self = shift;
my $file = shift;
my $location = shift;
my $target = $self->canonicalise_location( $file, $location );
return $self->read_url( $target )
if $target =~ RE_IS_URL;
return $self->read_file( $target );
}
sub read_file {
my $self = shift;
my $file = shift;
my $handle = FileHandle->new( $file );
if ( defined $handle ) {
local $/;
return <$handle>;
}
return;
}
sub read_url {
my $self = shift;
my $url = shift;
my $provider = $self->get_http_provider();
given ( $provider ) {
when ( 'lite' ) { return $self->get_url_lite( $url ); }
when ( 'lwp' ) { return $self->get_url_lwp( $url ); }
}
return;
}
sub get_url_lite {
my $self = shift;
my $url = shift;
my $depth = shift // 1;
# don't follow infinite redirections
return unless $depth <= MAX_REDIRECT;
my $http = HTTP::Lite->new();
$http->{'timeout'} = $self->get_http_timeout;
my $code = $http->request( $url );
given ( $code ) {
when ( 200 ) { return $http->body(); }
when ( 301 || 302 || 303 || 307 ) {
my $location = $http->get_header( 'Location' );
return $self->get_url_lite( $location, $depth+1 );
}
default { return; }
}
}
sub get_url_lwp {
my $self = shift;
my $url = shift;
my $http = LWP::UserAgent->new( max_redirect => MAX_REDIRECT );
$http->timeout( $self->get_http_timeout );
my $resp = $http->get( $url );
my $code = $resp->code();
given ( $code ) {
when ( 200 ) { return $resp->decoded_content(); }
default { return; }
}
}
sub copy_file_to_staging {
my $self = shift;
my $file = shift;
my $location = $self->location()
// shift;
return unless $self->assets_output;
my $content = $self->fetch_file( $file, $location );
return unless $content;
my $hex = sha1_hex $content;
my $filename = basename $file;
my $assets_file = sprintf "%s/%s/%s-%s",
$self->{'assets_base'},
substr( $hex, 0, 3 ),
substr( $hex, 4 ),
$filename;
my $output_file = sprintf "%s/%s/%s-%s",
$self->{'assets_output'},
substr( $hex, 0, 3 ),
substr( $hex, 4 ),
$filename;
my $output_dir = dirname $output_file;
mkpath $output_dir;
my $handle = FileHandle->new( $output_file, 'w' );
print {$handle} $content;
return $assets_file;
}
sub parse {
my $self = shift;
my $string = shift;
my $location = shift;
return unless defined $string;
my( $charset, $stripped ) = strip_charset( $string );
return { errors => [{ fatal => "Unsupported charset '${charset}'" }] }
unless 'UTF-8' eq $charset;
$stripped = $self->strip_comments( $stripped );
$string = escape_braces_in_strings( $stripped );
my @split = $self->split_into_statements( $string, $location );
my @statements;
my @appended;
foreach my $statement ( @split ) {
my $type = $statement->{'type'};
if ( 'appended' eq $type ) {
push @statements, @{$statement->{'content'}};
}
elsif ( 'import' eq $type ) {
push @statements, $statement;
}
elsif ( 'rulesets' eq $type ) {
my ( $rule_sets, $appended ) = $self->parse_rule_sets(
$statement->{'content'}, $location
);
push @statements, @$rule_sets;
push @split, {
type => 'appended',
content => $appended,
}
if defined $appended;
}
elsif ( 'at-media' eq $type ) {
my ( $rule_sets, $appended ) = $self->parse_rule_sets(
$statement->{'content'}, $location
);
push @{$statement->{'blocks'}}, @$rule_sets;
delete $statement->{'content'};
push @statements, $statement;
push @split, {
type => 'appended',
content => $appended,
}
if defined $appended;
}
else {
die "unknown type '${type}'";
}
}
return @statements;
}
sub parse_rule_sets {
my $self = shift;
my $styles = shift;
my $location = shift;
return []
unless defined $styles;
my @declaration_blocks
= split_into_declaration_blocks( $styles );
my @rule_sets;
my @appended;
foreach my $block ( @declaration_blocks ) {
my $type = $block->{'type'} // '';
my $preserve_as_is = defined $block->{'errors'}
|| 'verbatim' eq $type
|| 'boundary' eq $type;
if ( $preserve_as_is ) {
push @rule_sets, $block;
}
else {
# extract from the string a data structure of selectors
my( $selectors, $selectors_errors )
= parse_selectors( $block->{'selector'} );
my $declarations = {};
my $declaration_errors = [];
my $append_blocks;
# CSS2.1 4.1.6: "the whole statement should be ignored if
# there is an error anywhere in the selector"
if ( ! @$selectors_errors ) {
# extract from the string a data structure of
# declarations and their properties
( $declarations, $declaration_errors, $append_blocks )
= $self->parse_declaration_block(
$block->{'block'}, $location, $selectors
);
}
push @appended, @$append_blocks
if defined @$append_blocks;
my $is_empty = !@$selectors_errors
&& !@$declaration_errors
&& !%{$declarations};
push @rule_sets, {
original => unescape_braces( $block->{'block'} ),
selectors => $selectors,
errors => [
@$selectors_errors,
@$declaration_errors
],
block => $declarations,
}
unless $is_empty;
}
}
return \@rule_sets, \@appended;
}
sub strip_charset {
my $string = shift;
# "User agents must support at least the UTF-8 encoding."
my $charset = "UTF-8";
# "Authors using an @charset rule must place the rule at the very beginning
# of the style sheet, preceded by no characters"
if ( $string =~ s{^ \@charset \s " ([^"]+) "; }{}sx ) {
$charset = $1;
}
return ( $charset, $string );
}
sub strip_comments {
my $self = shift;
my $string = shift;
# remove CDO/CDC markers
$string =~ s{ <!-- }{}gsx;
$string =~ s{ --> }{}gsx;
if ( $self->support_extended_syntax ) {
# remove line-level comments
$string =~ s{ (?: ^ | \s ) // [^\n]* $ }{}gmx;
}
# disguise verbatim comments
$string =~ s{
\/ \* \! ( .*? ) \* \/
}{%-COMMENT-%$1%-ENDCOMMENT-%}gsx;
# disguise boundary markers
$string =~ s{
\/ \* ( \s+ \-\-+ \s+ ) \* \/
}{%-COMMENT-%$1%-ENDCOMMENT-%}gsx;
# remove CSS comments
$string =~ s{ \/ \* .*? \* \/ }{}gsx;
# reveal verbatim comments and boundary markers
$string =~ s{%-COMMENT-%}{/*}gsx;
$string =~ s{%-ENDCOMMENT-%}{*/}gsx;
return $string;
}
sub escape_braces_in_strings {
my $string = shift;
my $strip_next_string = qr{
^
( .*? ) # $1: everything before the string
( ['"] ) # $2: the string delimiter
( .*? ) # $3: the content of the string
(?<! \\ ) \2 # the string delimiter (but not escaped ones)
}sx;
# find all strings, and tokenise the braces within
my $return;
while ( $string =~ s{$strip_next_string}{}sx ) {
my $before = $1;
my $delim = $2;
my $content = $3;
$content =~ s{ \{ }{\%-LEFTBRACE-\%}gsx;
$content =~ s{ \} }{\%-RIGHTBRACE-\%}gsx;
$return .= "${before}${delim}${content}${delim}";
}
$return .= $string;
return $return;
}
sub unescape_braces {
my $string = shift;
$string =~ s{\%-LEFTBRACE-\%}{\{}gs;
$string =~ s{\%-RIGHTBRACE-\%}{\}}gs;
return $string;
}
sub split_into_statements {
my $self = shift;
my $string = shift;
my $location = shift;
# "In CSS 2.1, any @import rules must precede all other rules (except the
# @charset rule, if present)." (CSS 2.1 #6.3)
my ( $remainder, @statements )
= $self->do_import_rules( $string, $location );
my $splitter = qr{
^
( .*? ) # $1: everything before the media block
\@media \s+ ( # $2: the media query
$grammar_media_query_list
) \s*
( # $3: (used in the nested expression)
\{ (?: # the content of the media block,
(?> [^\{\}]+ ) # which is a nested recursive match...
| #
(?3) # ...triggered here ("(?3)" means use $3
)* \} # matching again)
)
}sx;
while ( $remainder =~ s{$splitter}{}sx ) {
my $before = $1;
my $query = $2;
my $block = $3;
# strip the outer braces from the media block
$block =~ s{^ \{ (.*) \} $}{$1}sx;
push @statements, {
type => 'rulesets',
content => $before,
};
push @statements, {
type => 'at-media',
query => $query,
content => $block,
};
}
push @statements, {
type => 'rulesets',
content => $remainder,
};
return @statements;
}
sub do_import_rules {
my $self = shift;
my $string = shift;
my $directory = shift;
# "In CSS 2.1, any @import rules must precede all other rules (except the
# @charset rule, if present)." (CSS 2.1 #6.3)
my $splitter = qr{
^
\s* \@import \s*
(
$string_value
|
$url_value
)
(?:
\s+
( $media_types_value )
)?
\s* \;
}x;
my @blocks;
while ( $string =~ s{$splitter}{}sx ) {
my $import = $1;
my $media = $2;
$import =~ s{^ url\( \s* (.*?) \) $}{$1}x; # strip url()
$import =~ s{^ ( ['"] ) (.*?) \1 $}{$2}x; # strip quotes
my @styles = $self->parse_stylesheet( $import, $directory );
if ( @styles ) {
push @blocks, {
type => 'import',
query => $media,
blocks => [ @styles ],
};
}
}
return $string, @blocks;
}
sub split_into_declaration_blocks {
my $string = shift;
my @blocks;
my $get_import_rule = qr{
^
\@import \s+
(?: $string_value | $url_value )
(?: \s+ ( $media_types_value ) )?
\s* \; \s*
}x;
my $get_charset_rule = qr{
^
\@charset \s \" [^"]+ \";
\s*
}x;
my $get_block = qr{
^
(?<selector> .*? ) \s*
\{ (?<block> [^\}]* ) \} \s*
}sx;
my $get_comment = qr{
^
( \/ \* (.*?) \* \/ ) \s*
}sx;
my $get_verbatim = qr{
^
\/ \* \s+ verbatim \s+ \*\/
\s* ( .*? ) \s*
\/ \* \s+ \-\-+ \s+ \*\/
}sx;
my $get_chunk_boundary = qr{
^
\/ \* \s+ \-\-+ \s+ \* \/ \s*
}sx;
while ( $string ) {
$string =~ s{^\s*}{}sx;
# check for a rogue @import rule
if ( $string =~ s{$get_import_rule}{}sx ) {
push @blocks, {
errors => [
{
error => '@import rule after statement(s) -- '
. 'ignored (CSS 2.1 #4.1.5)',
},
],
};
}
# check for a rogue @charset rule
elsif ( $string =~ s{$get_charset_rule}{}sx ) {
push @blocks, {
errors => [
{
error => '@charset rule inside stylsheet -- '
. 'ignored (CSS 2.1 #4.4)',
},
],
};
}
# check for chunk boundaries
elsif ( $string =~ s{$get_chunk_boundary}{}sx ) {
push @blocks, {
type => 'boundary',
};
}
# check for verbatim blocks
elsif ( $string =~ s{$get_verbatim}{}sx ) {
push @blocks, {
type => 'verbatim',
string => "$1\n",
};
}
# check for verbatim comments
elsif ( $string =~ s{$get_comment}{}sx ) {
push @blocks, {
type => 'verbatim',
string => "$1\n",
};
}
# try and find the next declaration
elsif ( $string =~ s{$get_block}{}sx ) {
my %match = %+;
push @blocks, \%match;
}
# give up
elsif ( $string ) {
push @blocks, {
errors => [{
error => "Unknown content:\n${string}\n",
}],
};
$string = undef;
}
}
return @blocks;
}
sub parse_selectors {
my $string = shift;
my @selectors;
my $splitter = qr{
^
\s*
( [^,]+ )
\s*
\,?
}sx;
while ( $string =~ s{$splitter}{}sx ) {
my $selector = $1;
$selector =~ s{\s+}{ }sg;
# CSS2.1 4.1.6: "the whole statement should be ignored if
# there is an error anywhere in the selector"
if ( ! is_valid_selector( $selector ) ) {
return [], [
{
error => 'ignored block - unknown selector'
. " '${selector}' (CSS 2.1 #4.1.7)",
}
];
}
else {
push @selectors, $selector;
}
}
return \@selectors, [];
}
sub parse_declaration_block {
my $self = shift;
my $block = shift;
my $location = shift;
my $selectors = shift;
# make '{' and '}' back into actual brackets again
$block = unescape_braces( $block );
my( $remainder, @declarations ) = get_declarations_from_block( $block );
my( $declarations, $append_blocks )
= $self->expand_declarations( \@declarations, $selectors );
my %canonical;
my @errors;
DECLARATION:
foreach my $declaration ( @$declarations ) {
my %match = %{$declaration};
my $star_hack = 0;
my $underscore_hack = 0;
my $important = 0;
my $has_hack = 0;
if ( $self->support_hacks ) {
$star_hack = 1
if $match{'property'} =~ s{^\*}{};
$underscore_hack = 1
if $match{'property'} =~ s{^_}{};
$has_hack = $star_hack || $underscore_hack;
}
$important = 1
if $match{'value'} =~ s{ \! \s* important $}{}x;
# strip possible extraneous whitespace
$match{'value'} =~ s{ \s+ $}{}x;
my( $parsed_as, $errors )
= $self->parse_declaration( $has_hack, $location, %match );
if ( defined $parsed_as or $errors ) {
push @errors, @$errors
if @$errors;
my %parsed;
foreach my $property ( keys %$parsed_as ) {
my $value = $parsed_as->{ $property };
$property = "_$property"
if $underscore_hack;
$property = "*$property"
if $star_hack;
$property = "important-$property"
if $important;
$parsed{ $property } = $value;
}
if ( %parsed ) {
%canonical = (
%canonical,
%parsed,
);
}
}
else {
push @errors, {
error => "invalid property: '$match{'property'}'"
};
}
}
if ( $remainder !~ m{^ \s* $}sx ) {
$remainder =~ s{^ \s* (.*?) \s* $}{$1}sx;
push @errors, {
error => "invalid property: '$remainder'",
};
}
return \%canonical, \@errors, \@$append_blocks;
}
sub get_declarations_from_block {
my $block = shift;
my $splitter = qr{
^
\s*
(?<property> [^:]+? )
\s* \: \s*
(?<value> [^;]+ )
\;?
}sx;
my @declarations;
while ( $block =~ s{$splitter}{}sx ) {
my %match = %+;
push @declarations, \%match;
}
return $block, @declarations;
}
sub parse_declaration {
my $self = shift;
my $has_hack = shift;
my $location = shift;
my %declaration = @_;
my @parsers;
map { push @parsers, "CSS::Prepare::Property::${_}::parse" }
@MODULES;
if ( $self->has_plugins() ) {
map { push @parsers, "${_}::parse" }
$self->plugins();
}
PARSER:
foreach my $module ( @parsers ) {
my $parsed_as;
my $errors;
eval {
no strict 'refs';
( $parsed_as, $errors )
= &$module( $self, $has_hack, $location, %declaration );
};
say STDERR $@ if $@;
next PARSER
unless ( defined $parsed_as || defined $errors );
return( $parsed_as, $errors )
if %$parsed_as or @$errors;
}
return;
}
sub expand_declarations {
my $self = shift;
my $declarations = shift;
my $selectors = shift;
my @filtered;
my @append;
if ( $self->has_plugins ) {
DECLARATION:
foreach my $declaration ( @$declarations ) {
my $property = $declaration->{'property'};
my $value = $declaration->{'value'};
PLUGIN:
foreach my $plugin ( $self->plugins() ) {
no strict 'refs';
my $try_with = "${plugin}::expand";
my( $filtered, $new_rulesets, $new_chunks )
= &$try_with( $self, $property, $value, $selectors );
push @filtered, @{$filtered}
if defined $filtered;
push @$declarations, @$new_rulesets
if defined $new_rulesets;
push @append, @$new_chunks
if defined $new_chunks;
next DECLARATION
if defined $filtered;
}
# if we get here, no plugin has dealt with the property
push @filtered, $declaration;
}
}
else {
@filtered = @$declarations;
}
return \@filtered, \@append;
}
sub optimise {
my $self = shift;
my @data = @_;
my @blocks;
my @complete;
while ( my $block = shift @data ) {
my $type = $block->{'type'};
my $query = $block->{'query'};
if ( defined $type ) {
# process any previously collected blocks
my( $savings, @optimised ) = $self->optimise_blocks( @blocks );
undef @blocks;
push @complete, @optimised
if @optimised;
# process this block
( $savings, @optimised )
= $self->optimise_blocks( @{$block->{'blocks'}} );
my $output_as_block = 'at-media' eq $type
|| ( 'import' eq $type && defined $query );
if ( $output_as_block ) {
push @complete, {
type => $type,
query => $block->{'query'},
blocks => [ @optimised ],
};
}
elsif ( 'verbatim' eq $type ) {
push @complete, $block;
}
elsif ( 'boundary' eq $type ) {
# nothing extra to do
}
else {
push @complete, @optimised
if @optimised;
}
}
else {
# collect block for later processing
push @blocks, $block;
}
}
# process any remaining collected blocks
my( $savings, @optimised ) = $self->optimise_blocks( @blocks );
push @complete, @optimised
if @optimised;
return @complete;
}
sub optimise_blocks {
my $self = shift;
my @blocks = @_;
return 0 unless @blocks;
my %styles = $self->sort_blocks_into_hash( @blocks );
my @properties = $self->array_of_properties( %styles );
# my $before = output_as_string( @properties );
my $declaration_count = scalar @properties;
$self->status( " Found ${declaration_count} declarations." );
my ( $savings, %state ) = $self->get_optimal_state( @properties );
my @optimised = $self->get_blocks_from_state( %state );
# my $after = output_as_string( @optimised );
# my $savings = length( $before ) - length( $after );
#
# say STDERR "Saved $savings bytes.";
# # TODO - calculate savings, even when suboptimal has been used
# my $savings = 0;
return( $savings, @optimised );
}
sub sort_blocks_into_hash {
my $self = shift;
my @data = @_;
my %styles;
foreach my $block ( @data ) {
foreach my $property ( keys %{ $block->{'block'} } ) {
my $value = $block->{'block'}{ $property };
foreach my $selector ( @{ $block->{'selectors'} } ) {
$styles{ $selector }{ $property } = $value;
}
}
}
return %styles;
}
sub array_of_properties {
my $self = shift;
my %styles = @_;
my @properties;
foreach my $selector ( keys %styles ) {
my %properties = $self->output_properties( $styles{ $selector } );
foreach my $property ( keys %properties ) {
push @properties, $selector, $property;
}
}
return @properties;
}
sub get_suboptimal_state {
my %by_property = @_;
# combine all properties by their selector -- makes a "margin:0;" property
# with an "li" selector and a "padding:0;" property with an "li" selector
# into an "li" selector with both "margin:0;" and "padding:0;" properties
my %by_selector;
foreach my $property ( keys %by_property ) {
foreach my $selector ( keys %{$by_property{ $property }} ) {
$by_selector{ $selector }{ $property } = 1;
}
}
# combine selectors by shared properties -- makes a "div" and an "li"
# which both have "margin:0;" and "padding:0;" properties into a
# "margin:0;padding:0;" property with a "div" and "li" selector
undef %by_property;
foreach my $selector ( sort keys %by_selector ) {
my $properties = join '', sort keys %{$by_selector{ $selector }};
$by_property{ $properties }{ $selector } = 1;
}
return %by_property;
}
sub get_optimal_state {
my $self = shift;
my @properties = @_;
my %by_property = get_selectors_by_property( @properties );
my $found_savings = 1;
my $total_savings = 0;
# if only one thing has that property, the only thing it can be
# successfully combined with is something with the same selector,
# so don't even bother calculating possible savings on them, just
# combine them at the end
my( %multiples, %singles );
foreach my $property ( keys %by_property ) {
my $selectors = scalar keys %{$by_property{ $property }};
if ( $selectors > 1 ) {
$multiples{ $property } = $by_property{ $property };
}
else {
$singles{ $property } = $by_property{ $property };
}
}
my $do_suboptimal_pass = 0;
if ( scalar keys %multiples ) {
my $start_time = time();
my $time_out_after = $start_time + $self->suboptimal_threshold;
my $check_for_timeout = $self->suboptimal_threshold > 0;
my $count = 0;
my %cache;
MIX:
while ( $found_savings ) {
# adopt a faster strategy if there are too many properties
# to deal with, or the code tends towards infinite
# time taken to calculate the results
my $timed_out = $check_for_timeout
&& ( time() >= $time_out_after );
if ( $timed_out ) {
$do_suboptimal_pass = 1;
$self->status( "\r Time threshold reached -- switching "
. 'to suboptimal optimisation.' );
last MIX;
}
( $found_savings, %multiples )
= mix_biggest_properties( \%cache, %multiples );
$total_savings += $found_savings;
$count++;
$self->status( " [$count] savings $total_savings", 'line' );
}
}
%by_property = (
%singles,
%multiples
);
%by_property = get_suboptimal_state( %by_property )
if $do_suboptimal_pass;
return( $total_savings, %by_property);
}
sub get_selectors_by_property {
my @properties = @_;
my %by_property;
while ( @properties ) {
my $selector = shift @properties;
my $property = shift @properties;
$by_property{ $property }{ $selector } = 1;
}
return %by_property;
}
sub mix_biggest_properties {
my $cache = shift;
my %by_property = @_;
my $num_children = sub {
my $a_children = scalar keys %{$by_property{ $a }};
my $b_children = scalar keys %{$by_property{ $b }};
return $b_children <=> $a_children;
};
my @sorted_properties = sort $num_children keys %by_property;
foreach my $property ( @sorted_properties ) {
my( $mix_with, $saving )
= get_biggest_saving_if_mixed( $property, $cache, %by_property );
if ( defined $mix_with ) {
my %properties
= mix_properties( $property, $mix_with, $cache, %by_property );
return( $saving, %properties );
}
}
return( 0, %by_property );
}
sub get_biggest_saving_if_mixed {
my $property = shift;
my $cache = shift;
my %properties = @_;
return if defined $cache->{'no_savings'}{ $property };
my $unmixed_property_length
= output_string_length( $property, keys %{$properties{ $property }} );
my $largest_value = 0;
my $largest;
EXAMINE:
foreach my $examine ( keys %properties ) {
next if $property eq $examine;
next if 1 == scalar( keys %{$properties{ $examine }} );
my( $a, $b ) = sort( $property, $examine );
my $saving = $cache->{ $a }{ $b };
if ( !defined $saving ) {
my @common_selectors
= get_common_selectors( $property, $examine, %properties );
if ( 0 == scalar @common_selectors ) {
$cache->{ $a }{ $b } = 0;
next EXAMINE;
}
my @property_remaining
= get_remaining_selectors( $examine, $property, %properties );
my @examine_remaining
= get_remaining_selectors( $property, $examine, %properties );
my $unmixed_examine_length
= output_string_length(
$examine, keys %{$properties{ $examine }} );
my $mixed_common_length
= output_string_length(
"${property},${examine}", @common_selectors );
my $mixed_selector_length
= output_string_length( $property, @property_remaining );
my $mixed_examine_length
= output_string_length( $examine, @examine_remaining );
my $unmixed = $unmixed_property_length + $unmixed_examine_length;
my $mixed = $mixed_common_length
+ $mixed_selector_length
+ $mixed_examine_length;
$saving = $unmixed - $mixed;
$cache->{ $a }{ $b } = $saving;
}
if ( $saving > $largest_value ) {
$largest_value = $saving;
$largest = $examine;
}
}
$cache->{'no_savings'}{ $property } = 1
unless $largest_value;
return( $largest, $largest_value );
}
sub output_string_length {
my $property = shift;
my @selectors = @_;
return 0
unless scalar @selectors;
my $string = sprintf '%s{%s}',
join( ',', @selectors ),
$property;
return length $string;
}
sub get_common_selectors {
my $property = shift;
my $examine = shift;
my %properties = @_;
my @common = grep {
$_ if defined $properties{ $property }{ $_};
} keys %{$properties{ $examine }};
return @common;
}
sub get_remaining_selectors {
my $property = shift;
my $examine = shift;
my %properties = @_;
my @remaining = grep {
$_ if !defined $properties{ $property }{ $_};
} keys %{$properties{ $examine }};
return @remaining;
}
sub mix_properties {
my $property = shift;
my $mix_with = shift;
my $cache = shift;
my %properties = @_;
my $mixed_property = join '', sort( $property, $mix_with );
my @common_selectors
= get_common_selectors( $property, $mix_with, %properties );
delete $cache->{ $property };
delete $cache->{'no_savings'}{ $property };
delete $cache->{ $mix_with };
delete $cache->{'no_savings'}{ $mix_with };
foreach my $selector ( @common_selectors ) {
$properties{ $mixed_property }{ $selector } = 1;
delete $properties{ $property }{ $selector };
delete $properties{ $mix_with }{ $selector };
}
delete $properties{ $property }
unless scalar keys %{$properties{ $property }};
delete $properties{ $mix_with }
unless scalar keys %{$properties{ $mix_with }};
return %properties;
}
sub get_blocks_from_state {
my $self = shift;
my %by_property = @_;
my $elements_first = sub {
my $a_element = ( $a =~ m{^[a-z]}i );
my $b_element = ( $b =~ m{^[a-z]}i );
my $element_count = $a_element + $b_element;
return ( $a_element ? -1 : 1 )
if 1 == $element_count;
return $a cmp $b;
};
my %by_selector;
foreach my $property ( keys %by_property ) {
my @selectors
= sort $elements_first keys %{$by_property{ $property }};
my $selector = join ',', @selectors;
$by_selector{ $selector }{ $property } = 1;
}
my @blocks;
foreach my $selector ( sort $elements_first keys %by_selector ) {
my @properties = sort keys %{$by_selector{ $selector }};
my $properties = join '', @properties;
my $css = "${selector}{${properties}}";
push @blocks, $self->parse_string( $css )
}
return @blocks;
}
sub is_valid_selector {
my $test = shift;
$test = lc $test;
my $nmchar = qr{ (?: [_a-z0-9-] ) }x;
my $ident = qr{ -? [_a-z] $nmchar * }x;
my $element = qr{ (?: $ident | \* ) }x;
my $hash = qr{ \# $nmchar + }x;
my $class = qr{ \. $ident }x;
my $string = qr{ (?: \' $ident \' | \" $ident \" ) }x;
my $pseudo = qr{
\:
(?:
# TODO - I am deliberately ignoring FUNCTION here for now
# FUNCTION \s* (?: $ident \s* )? \)
$ident \( .* \)
|
$ident
)
}x;
my $attrib = qr{
\[
\s* $ident \s*
(?:
(?: \= | \~\= | \|\= ) \s*
(?: $ident | $string ) \s*
)?
\s*
\]
}x;
my $parts = qr{ (?: $pseudo | $hash | $class | $attrib ) }x;
my $simple_selector = qr{ (?: $element $parts * | $parts + ) }x;
my $combinator = qr{ (?: [\+\~] \s* | \> \s* ) }x;
my $next_selector = qr{
\s* (?: $combinator )? $simple_selector \s*
}x;
while ( $test =~ s{^ $next_selector }{}x ) {
# do nothing, already validated by the regexp
}
return 0 if length $test;
return 1;
}
sub status {
my $self = shift;
my $text = shift;
my $temp = shift;
no strict 'refs';
my $status = $self->{'status'};
&$status( $text, $temp );
}
sub status_to_stderr {
my $text = shift;
my $temp = shift;
print STDERR ( $temp ? "\r" : '' ) . $text;
}
1;
__END__
=head1 NAME
B<CSS::Prepare> - pre-process cascading style sheets to make them ready for
deployment
=head1 SYNOPSIS
In your code:
my $preparer = CSS::Prepare->new( %opts );
foreach my $stylesheet ( @ARGV ) {
print process_stylesheet( $stylesheet );
}
In your build process:
% cssprepare -e -o styles/*.css > styles/combined.css
=head1 OPTIONS
The B<new()> method accepts a hash as arguments to control aspects of the
eventual output.
=over
=item hacks I<(boolean)>
Switch support for various CSS "hacks" on or off. See L<Supported CSS hacks>
in L<CSS::Prepare::Manual>. Defaults to I<true>.
=item extended I<(boolean)>
Switch support for extensions to the CSS syntax, which are incompatible with
the CSS specification (but can make life easier). See L<Extending the CSS
syntax> in L<CSS::Prepare::Manual>. Defaults to I<false>.
=item suboptimal_threshold I<(int)>
Number of seconds that CSS::Prepare will spend optimising each CSS fragment in
the more accurate way before switching to a less accurate but much faster
algorithm. See <Optimising CSS> in L<CSS::Prepare::Manual>. Defaults to I<10>.
If set to zero, it will never switch to the suboptimal method. Do note that
large style sheets with thousands of rule sets can take several minutes to
process fully, and the extra savings are quite minimal after the first few
seconds have elapsed.
=item http_timeout I<(int)>
Number of seconds that CSS::Prepare will wait whilst trying to fetch a remote
style sheet before giving up. Defaults to I<30>.
=item pretty I<(boolean)>
Switch to support pretty-printed output rather than highly compressed.
Defaults to I<false>.
Note that this only affects the amount of white space used in the output. All
comments and invalid rule sets and declarations from the source style sheets
are still dropped before output.
=item status I<(callback)>
Override how status reports are handled. The callback subroutine is given two
parameters: the text to be printed and a flag to say if it is expected to be a
temporary line (ie. can be overwritten).
The default callback is:
sub status_to_stderr {
my $text = shift;
my $temp = shift;
print STDERR ( $temp ? "\r" : '' ) . $text;
}
Status reports can be silenced by providing a null callback, like so:
my $preparer = CSS::Prepare->new( status => sub {} );
=back
=head1 REQUIREMENTS
The only fixed requirement CSS::Prepare has is that the version of the perl
interpreter must be at least 5.10.
If you wish to use C<@import url(...);> in your style sheets you will need
one of L<HTTP::Lite> or L<LWP::UserAgent> installed.
Some parts of the extended CSS syntax are implemented as optional plugins.
For these to work you will need L<Module::Pluggable> installed.
To use the C<--server> option in the C<cssprepare> script, you will need
L<Plack::Runner> installed.
=head1 SEE ALSO
=over
=item *
L<cssprepare> (command-line script)
=item *
L<CSS::Prepare::Manual>
=item *
CSS::Prepare online: L<http://cssprepare.com/>
=back
=head1 AUTHOR
Mark Norman Francis, L<norm@cackhanded.net>.
=head1 COPYRIGHT AND LICENSE
Copyright 2010 Mark Norman Francis.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.