File Coverage

blib/lib/HTTP/Headers/Fancy.pm

Criterion	Covered	Total	%
statement	121	128	94.5
branch	59	70	84.2
condition	10	14	71.4
subroutine	19	20	95.0
pod	14	14	100.0
total	223	246	90.6

use strictures 2;

package HTTP::Headers::Fancy;

use Exporter qw(import);
use Scalar::Util qw(blessed);

# ABSTRACT: Fancy naming schema of HTTP headers

our $VERSION = '1.000';    # VERSION

our @EXPORT_OK = qw(
  decode_key
  encode_key
  decode_hash
  encode_hash
  split_field_hash
  split_field_list
  build_field_hash
  build_field_list
);

our %EXPORT_TAGS = ( all => \@EXPORT_OK, );

sub _self {
    my @args = @_;
    if ( blessed $args[0] and $args[0]->isa(__PACKAGE__) ) {
        return @args;
    }
    elsif ( defined $args[0] and not ref $args[0] and $args[0] eq __PACKAGE__ )
    {
        return @args;
    }
    else {
        return ( __PACKAGE__, @args );
    }
}

sub _encode_hash_deeply {
    my ( $self, @args ) = _self(@_);
    if ( ref $args[0] ) {
        return { $self->_encode_hash_deeply( %{ $args[0] } ) };
    }
    my %hash = $self->encode_hash(@args);
    foreach my $key ( keys %hash ) {
        if ( ref $hash{$key} ) {
            $hash{$key} = $self->build( $hash{$key} );
        }
    }
    return %hash;
}

sub decode_key {
    my ( $self, $k ) = _self(@_);
    $k =~ s{^([^-]+)}{ucfirst(lc($1))}se;
    $k =~ s{-+([^-]+)}{ucfirst(lc($1))}sge;
    $k =~ s{^X([A-Z])}{-$1}s;
    return ucfirst($k);
}

sub decode_hash {
    my ( $self, @args ) = _self(@_);
    my %headers = @args == 1 ? %{ $args[0] } : @args;
    foreach my $old ( keys %headers ) {
        my $new = decode_key($old);
        if ( $old ne $new ) {
            $headers{$new} = delete $headers{$old};
        }
    }
    wantarray ? %headers : \%headers;
}

sub encode_key {
    my ( $self, $k ) = _self(@_);
    $k =~ s{_}{-}sg;
    $k =~ s{-+}{-}sg;
    $k =~ s{^-(.)}{'X'.uc($1)}se;
    $k =~ s{([^-])([A-Z])}{$1-$2}s while $k =~ m{([^-])([A-Z])}s;
    return lc($k);
}

sub encode_hash {
    my ( $self, @args ) = _self(@_);
    my %headers = @args == 1 ? %{ $args[0] } : @args;
    foreach my $old ( keys %headers ) {
        delete $headers{$old} unless defined $headers{$old};
        my $new = encode_key($old);
        if ( $old ne $new ) {
            $headers{$new} = delete $headers{$old};
        }
    }
    wantarray ? %headers : \%headers;
}

sub split_field_hash {
    my ( $self, $value, @rest ) = _self(@_);
    return () unless defined $value;
    if ( ref $value eq 'HASH' ) {
        foreach my $key (@rest) {
            $value->{$key} = { $self->split_field_hash( $value->{$key} ) };
        }
        return $value;
    }
    pos($value) = 0;
    my %data;
    $value .= ',';
    while ( $value =~
m{ \G \s* (? [^=,]+? ) \s* (?: \s* = \s* (?: (?: " (? [^"]*? ) " ) | (? [^,]*? ) ) )? \s* ,+ \s* }gsx
      )
    {
        $data{ decode_key( $+{key} ) } = $+{value};
    }
    return %data;
}

sub split_field_list {
    my ( $self, $value, @rest ) = _self(@_);
    return () unless defined $value;
    if ( ref $value eq 'HASH' ) {
        foreach my $key (@rest) {
            $value->{$key} = [ $self->split_field_list( $value->{$key} ) ];
        }
        return $value;
    }
    pos($value) = 0;
    my @data;
    $value .= ',';
    while ( $value =~
        m{ \G \s* (? W/ )? " (? [^"]*? ) " \s* ,+ \s* }gsix )
    {
        my $value = $+{value};
        push @data => $+{weak} ? \$value : $value;
    }
    return @data;
}

sub build_field_hash {
    my ( $self, @args ) = _self(@_);
    if ( ref $args[0] eq 'HASH' ) {
        return $self->build_field_hash( %{ $args[0] } );
    }
    my %data = @args;
    return join ', ', sort map {
        $self->encode_key($_)
          . (
            defined( $data{$_} )
            ? '='
              . (
                ( $data{$_} =~ m{[=,]} )
                ? '"' . $data{$_} . '"'
                : $data{$_}
              )
            : ''
          )
    } keys %data;
}

sub build_field_list {
    my ( $self, @args ) = _self(@_);
    if ( ref $args[0] eq 'ARRAY' ) {
        return $self->build_field_list( @{ $args[0] } );
    }
    return join ', ', map { ref($_) ? 'W/"' . $$_ . '"' : qq{"$_"} } @args;
}

sub new {
    my $class = shift // __PACKAGE__;
    return bless {@_} => ref $class || $class;
}

sub encode {
    my $self = shift;
    return unless @_;
    if ( @_ > 1 ) {
        return $self->_encode_hash_deeply(@_);
    }
    elsif ( ref $_[0] eq 'HASH' ) {
        return $self->_encode_hash_deeply( $_[0] );
    }
    else {
        return $self->encode_key( $_[0] );
    }
}

sub decode {
    my $self = shift;
    return unless @_;
    if ( @_ > 1 ) {
        return $self->decode_hash(@_);
    }
    elsif ( ref $_[0] eq 'HASH' ) {
        return $self->decode_hash( $_[0] );
    }
    else {
        return $self->decode_key( $_[0] );
    }
}

sub split {
    my $self = shift;
    return unless @_;
    my $val = shift;
    if ( $val =~ m{^ \s* ( W/ ) ? " }six ) {
        return $self->split_field_list($val);
    }
    elsif ( not ref $val ) {
        return $self->split_field_hash($val);
    }
    elsif ( ref $val eq 'HASH' ) {
        foreach my $key (@_) {
            next unless $val->{$key};
            if ( $val->{$key} =~ m{^ \s* ( W/ )? " }six ) {
                $val->{$key} = [ $self->split_field_list( $val->{$key} ) ];
            }
            else {
                $val->{$key} = { $self->split_field_hash( $val->{$key} ) };
            }
        }
        return $val;
    }
}

sub build {
    my $self = shift;
    if ( ref $_[0] eq 'HASH' ) {
        return $self->build_field_hash(@_);
    }
    elsif ( ref $_[0] eq 'ARRAY' ) {
        return $self->build_field_list(@_);
    }
    else {
        return $self->build_field_hash(@_);
    }
}

sub etags {
    my $self = shift;
    return $self->build_field_list(@_);
}

1;

__END__