HTTP::Headers::ContentType

HTTP::Negotiateの存在を知らずに自分でネゴシエーション処理しようと思ったら，Content-Typeって意外と扱いにくい感じがしたので勢いで書いた．
今となっては…

=head1 NAME

HTTP::Headers::ContentType

=head1 SYNOPSIS

    use HTTP::Headers::ContentType;

    my $field = 'application/atom+xml; type=entry; charset=utf-8';
    my $ct = HTTP::Headers::ContentType->new($field);

    $ct->mimetype;  # application/atom+xml
    $ct->mediatype; # application
    $ct->subtype;   # atom+xml

    my $attrs = $ct->parameters;
    $attrs->{charset}; # utf-8
    $attrs->{type};    # entry

    $ct->extension; # atom

    $ct->as_string; # application/atom+xml; type=entry; charset=utf-8

    ### override HTTP::Headers
    use HTTP::Headers;
    use HTTP::Headers::ContentType;

    my $h = HTTP::Headers->new;
    $h->content_type('application/atom+xml; type=entry; charset=utf-8');

    $h->content_type->mimetype;
    $h->content_type->mediatype;
    # ...
    print $h->content_type; # application/atom+xml; type=entry; charset=utf-8

=cut

package HTTP::Headers::ContentType;

use strict;
use warnings;
use base qw(Class::Accessor::Fast);
use overload '""' => \&as_string, fallback => 1;
use Email::MIME::ContentType ();
use File::MimeInfo::Magic ();
use HTTP::Headers;
use List::MoreUtils qw(uniq);
use MIME::Types;
use Scalar::Util ();

__PACKAGE__->mk_accessors(qw( mediatype subtype parameters ));

*params = \&parameters;

my %types;

sub register_types {
    my $class = shift;

    my %maps = ref $_[0] eq 'ARRAY' ? @{ $_[0] }
             : ref $_[0] eq 'HASH'  ? %{ $_[0] }
             : @_;

    while (my ($ext, $types) = each %maps) {
        ref $types or $types = [$types];
        $types{$ext} ||= [];
        @{ $types{$ext} } = uniq @{ $types{$ext} }, @$types;
    }
}

sub new {
    my ($class, $type) = @_;

    my $data = Email::MIME::ContentType::parse_content_type($type);

    my $self = $class->SUPER::new({
        mediatype  => $data->{discrete},
        subtype    => $data->{composite},
        parameters => $data->{attributes},
    });

    return $self;
}

sub typeof {
    my ($class, $extension) = @_;

    if (my $types = $types{$extension}) {
        return $class->new($types->[0]);
    }

    my $filename = "*.$extension";
    # File::MimeInfo::Magic, MIME::Types
    my $mimetype = File::MimeInfo::Magic::mimetype($filename)
                || MIME::Types->new->mimeTypeOf($filename);

    return $mimetype ? $class->new($mimetype) : undef;
}

sub mimetype {
    my $self = shift;
    return join '/' => $self->mediatype, $self->subtype;
}

sub extension {
    my $self = shift;

    while (my ($ext, $types) = each %types) {
        return $ext if grep { $self->mimetype eq $_ } @$types;
    }

    # File::MimeInfo::Magic
    if (my $extension = File::MimeInfo::Magic::extensions($self->mimetype)) {
        return $extension;
    }

    # MIME::Types
    my $type = MIME::Types->new->type($self->mimetype);
    if ($type and scalar $type->extensions) {
        return ($type->extensions)[0];
    }

    return;
    #return ($self->subtype =~ /(.+)\+xml/)   ? lc $1
    #     : ($self->subtype =~ /x[\-\.](.+)/) ? lc $1
    #     : undef;
}

sub as_string {
    my $self = shift;

    my $ct = $self->mimetype;
    while (my ($name, $value) = each %{ $self->params }) {
        $ct .= "; $name=$value";
    }

    return $ct;
}

{ # override HTTP::Headers::content_type
    no warnings 'redefine';

    *HTTP::Headers::content_type = sub {
        my $self = shift;

        if (@_) {
            my $ct = HTTP::Headers::ContentType->new(shift);
            $self->_header('Content-Type' => $ct);
        }

        my $ct = ($self->_header('Content-Type'))[0] or return;

        unless (Scalar::Util::blessed($ct)) {
            $ct = HTTP::Headers::ContentType->new($ct);
        }

        return $ct;
    };
}

1;