File Coverage

blib/lib/File/Assets/Util.pm

Criterion	Covered	Total	%
statement	103	115	89.5
branch	37	56	66.0
condition	23	33	69.7
subroutine	20	21	95.2
pod	0	9	0.0
total	183	234	78.2

package File::Assets::Util;

use strict;
use warnings;

use File::Assets::Carp;

use MIME::Types();
use Scalar::Util qw/blessed/;
use Module::Pluggable search_path => q/File::Assets::Filter/, require => 1, sub_name => q/filter_load/;
use Digest;
use File::Assets::Asset;

{
    my $types;
    sub types {
        return $types ||= MIME::Types->new(only_complete => 1);
    }
}

sub digest {
    return Digest->new("MD5");
}

sub parse_name {
    my $class = shift;
    my $name = shift;
    $name = "" unless defined $name;
    $name = $name."";
    return undef unless length $name;
    return $name;
}

sub same_type {
    no warnings 'uninitialized';
    my $class = shift;
    my $aa = $class->parse_type($_[0]) or confess "Couldn't parse: $_[0]";
    my $bb = $class->parse_type($_[1]) or confess "Couldn't parse: $_[1]";

    return $aa->simplified eq $bb->simplified;
}

sub type_extension {
    my $class = shift;
    my $type = $class->parse_type($_[0]);
    croak "Couldn't parse @_" unless $type;
    return ($type->extensions)[0];
}

sub parse_type {
    no warnings 'uninitialized';
    my $class = shift;
    my $type = shift;
    return unless defined $type;
    return $type if blessed $type && $type->isa("MIME::Type");
    $type = ".$type" if $type !~ m/\W+/;
    # Make sure we get stringified version of $type, whatever it is
    $type .= "";
    $type = "application/javascript" if $type =~ m{^text/javascript$}i;
    $type = lc $type;
    return $class->types->mimeTypeOf($type) || $class->types->type($type);
}

sub parse_rsc {
    my $class = shift;
    my $resource = shift;
    my ($uri, $dir, $path) = @_;
    if (ref $resource eq "ARRAY") {
        ($uri, $dir, $path) = @$resource;
    }
    elsif (ref $resource eq "HASH") {
        ($uri, $dir, $path) = @$resource{qw/uri dir path/};
    }
    elsif (blessed $resource) {
        if ($resource->isa("Path::Resource")) {
            return $resource->clone;
        }
        elsif ($resource->isa("URI::ToDisk")) {
            $uri = $resource->URI;
            $dir = $resource->path;
        }
    }
    return Path::Resource->new(uri => $uri, dir => $dir, path => $path);
}

my @_filters;
sub _filters {
    return @_filters ||
        grep { ! m/::SUPER$/ } reverse sort  __PACKAGE__->filter_load();
}

sub parse_filter {
    my $class = shift;
    my $filter = shift;

    my $_filter;
    for my $possible ($class->_filters) {
        last if $_filter = $possible->new_parse($filter, @_);
    }

    return $_filter;
}

sub _substitute($$$;$$) {
    my $target = shift;
    my $character = shift;
    my $value = shift;
    my $deprecated = shift;
    my $original_path = shift;

    $value = "" unless defined $value;

    my $found;
    $found ||= $$target =~ s/\%$character/$value/g;
    $found ||= $$target =~ s/\%\.$character/$value ? "\.$value" : ""/ge;
    $found ||= $$target =~ s/\%\-$character/$value ? "\-$value" : ""/ge;
    $found ||= $$target =~ s/\%\/$character/$value ? "\/$value" : ""/ge;

    carp "\%$character is deprecated as a path pattern (in \"$original_path\")" if $found && $deprecated;
}

sub build_output_path {
    my $class = shift;
    my $template = shift;
    my $filter = shift;

    my $path = $template;
    $path = $path->{path} if ref $path eq "HASH";

    return $$path if ref $path eq "SCALAR";

    $path = '%n%-l%-f.%e' unless $path;
    $path = "$path/" if blessed $path && $path->isa("Path::Class::Dir");
    $path .= '%n%-l%-f.%e' if $path && $path =~ m/\/$/;
    $path .= '.%e' if $path =~ m/(?:^|\/)[^.]+$/;

    local %_;
    if (ref $filter eq "HASH") {
        %_ = %$filter;
    }
    else {
        %_ = (
            fingerprint => $filter->fingerprint,
            name => $filter->assets->name,
            kind => $filter->kind->kind,
            head => $filter->kind->head,
            tail => $filter->kind->tail,
            extension => $filter->kind->extension,
        );
    }

    my $original_path = $path;

    $path =~ s/%b/%-l/g and carp "\%b is deprecated as a path pattern (in \"$original_path\")";

    _substitute \$path, e => $_{extension};
    _substitute \$path, f => $_{fingerprint};
    _substitute \$path, n => $_{name};
    _substitute \$path, k => $_{kind};
    _substitute \$path, h => $_{head};
    _substitute \$path, l => $_{tail};

    _substitute \$path, d => $_{fingerprint}, 1 => $original_path;
    _substitute \$path, D => $_{fingerprint}, 1 => $original_path;
    _substitute \$path, a => $_{tail}, 1 => $original_path;

    $path =~ s/%%/%/g;

    return $path;
}

1;