File Coverage

blib/lib/Atomik/MediaType.pm

Criterion	Covered	Total	%
statement	12	27	44.4
branch	0	6	0.0
condition			n/a
subroutine	4	6	66.6
pod			n/a
total	16	39	41.0

# $Id: /mirror/coderepos/lang/perl/Atomik/trunk/lib/Atomik/MediaType.pm 67588 2008-07-31T05:00:38.496278Z daisuke  $

package Atomik::MediaType;
use Moose;
use Moose::Util::TypeConstraints qw(coerce from via);

use overload
    '""' => \&as_string,
    fallback => 1
;

coerce 'Atomik::MediaType'
    => from 'Str'
    => via {
        Atom::MediaType->from_string( $_ );
    }
;

has 'type' => (
    is => 'rw',
    isa => 'Str',
    required => 1,
);

has 'subtype_major' => (
    is => 'rw',
    isa => 'Str',
);

has 'subtype_minor' => (
    is => 'rw',
    isa => 'Maybe[Str]',
);

has 'parameters' => (
    is => 'rw',
    isa => 'Maybe[Str]'
);

__PACKAGE__->meta->make_immutable;

no Moose;

sub BUILDARGS {
    my ($class, %args) = @_;

    if (my $subtype = delete $args{subtype}) {
        my ($subtype_major, $subtype_minor);
        if ($subtype =~ /^([^\+]+)\+(.+)$/) {
            $subtype_major = $1;
            $subtype_minor = $2;
        } else {
            $subtype_major = $subtype;
        }

        $args{subtype_major} = $subtype_major;
        $args{subtype_minor} = $subtype_minor;
    }

    return { %args };
}

sub subtype {
    my $self = shift;
    my @subtype = ( $self->subtype_major );
    if (my $minor = $self->subtype_minor) {
        push @subtype, $minor;
    }
    return join('+', @subtype);
}

# XXX - bad naming.
sub assert_subtype_of {
    my ($self, $other) = @_;

    if (! blessed $other) {
        $other = Atomik::MediaType->from_string($other);
    }

    if (! $self->is_subtype($other)) {
        confess "$other is not a subtype of $self";
    }
}

sub from_string {
    my ($class, $string) = @_;
    if ($string !~ /^([^\/]+)\/([^;]+)\s*(?:;\s*(.*))?$/) {
        confess "Could not parse '$string' as a media type";
    }
    my ($type, $subtype, $parameters) = ($1, $2, $3);

    my $obj = $class->new(
        type       => $type,
        subtype    => $subtype,
        parameters => $parameters,
    );
    return $obj;
}

sub as_string {
    my $self = shift;

    my @components = ($self->type);
    if (my $subtype = $self->subtype) {
        push @components, $subtype;
    }

    if (my $parameters = $self->parameters) {
        push @components, $parameters;
    }

    if (@components == 3) {
        return sprintf('%s/%s;%s', @components);
    } elsif (@components == 2) {
        return sprintf('%s/%s', @components);
    } else {
        return $components[0];
    }
}

sub is_subtype {
    my ($self, $other) = @_;

    # wild card against something is always true
    if ( $self->type eq '*' ) {
        return 1;
    }

    # if the main types do not match, then this is false
    if ( $self->type ne $other->type ) {
        return 0;
    }

    if ( $self->subtype eq '*' ) {
        return 1;
    }

    if (! $other->subtype_minor) {
        if ($self->subtype_major ne $other->subtype_major) {
            return 0;
        }
    } elsif ( $self->subtype ne $other->subtype ) {
        return 0;
    }

    # if parameters exist, they must be compared iff BOTH medias
    # have a parameter list
    if ( ! $self->parameters || ! $other->parameters) {
        return 1;
    }

    return $self->parameters eq $other->parameters;
}

# pre-defined types.
# this is placed last so that we can safely use class methods at BEGIN time
our $INITIALIZED;
if (! $INITIALIZED) {
    my %TYPES = (
        entry    => 'application/atom+xml;type=entry',
        feed     => 'application/atom+xml;type=feed',
        service  => 'application/atomsvc+xml',
        category => 'application/atomcat+xml',
    );
    require constant;
    while ( my ($name, $type) = each %TYPES ) {
        my $obj = __PACKAGE__->from_string($type) ;
        constant->import( uc $name => $obj );
    }
    $INITIALIZED = 1;
}
use Sub::Exporter -setup => {
    exports => [ qw(ENTRY FEED SERVICE CATEGORY) ]
};

1;