File Coverage

blib/lib/Proquint.pm

Criterion	Covered	Total	%
statement	76	77	98.7
branch	16	26	61.5
condition	18	51	35.2
subroutine	13	13	100.0
pod	0	6	0.0
total	123	173	71.1

package Proquint;
use strict;
use warnings;
use Carp ();
use Exporter::Tiny;
use Socket (qw/inet_pton inet_ntop AF_INET AF_INET6/);

our $VERSION   = '1.0.0_2';
our @ISA       = 'Exporter::Tiny';
our @EXPORT_OK = (
    qw/
      uint32proquint proquint32uint
      hex2proquint proquint2hex
      ip2proquint proquint2ip
      /
);
our @EXPORT_TAGS = ( all => \@EXPORT_OK );

my @UINT_TO_CONSONANT = (qw/ b d f g h j k l m n p r s t v z /);
my @UINT_TO_VOWEL     = (qw/ a i o u /);
my $CHARS_PER_CHUNK   = 5;
my $MASK_LAST2        = 0x3;
my $MASK_LAST4        = 0xF;
my $SEPARATOR         = '-';

my %CONSONANT_TO_UINT = do {
    my $i = 0;
    map { $_ => $i++ } @UINT_TO_CONSONANT;
};

my %VOWEL_TO_UINT = do {
    my $i = 0;
    map { $_ => $i++ } @UINT_TO_VOWEL;
};

sub _uint16_to_chunk {
    my $in  = shift // Carp::croak 'usage: _uint16_to_chunk($INTEGER)';
    my $out = '';

    foreach my $i ( 1 .. $CHARS_PER_CHUNK ) {
        if ( $i & 1 ) {
            $out .= $UINT_TO_CONSONANT[ $in & $MASK_LAST4 ];
            $in >>= 4;
        }
        else {
            $out .= $UINT_TO_VOWEL[ $in & $MASK_LAST2 ];
            $in >>= 2;
        }
    }
    scalar reverse $out;
}

sub _chunk_to_uint16 {
    my $in = shift // Carp::croak 'usage: _chunk_to_uint16($INTEGER)';

    Carp::croak 'invalid chunk: ' . $in unless length($in) == $CHARS_PER_CHUNK;

    my $res = 0;
    foreach my $c ( split //, $in ) {
        if ( exists $CONSONANT_TO_UINT{$c} ) {
            $res <<= 4;
            $res += $CONSONANT_TO_UINT{$c};
        }
        elsif ( exists $VOWEL_TO_UINT{$c} ) {
            $res <<= 2;
            $res += $VOWEL_TO_UINT{$c};
        }
        else {
            Carp::croak 'invalid quint char: ' . $c;
        }
    }

    $res;
}

# uint32proquint(0x7f000001) eq 'lusab-babad';
sub uint32proquint {
    my $in  = shift // Carp::croak 'usage: uint32proquint($INTEGER)';
    my $sep = shift // $SEPARATOR;

    Carp::croak('input out of range 0-0xFFFFFFFF')
      if $in < 0 or $in > 0xffffffff;

    _uint16_to_chunk( $in >> 16 ) . $sep . _uint16_to_chunk($in);
}

# proquint32uint('lusab-babad') == 0x7f000001;
sub proquint32uint {
    my $in  = shift // Carp::croak 'usage: proquint32uint($QUINT)';
    my $sep = shift // $SEPARATOR;

    $in =~ s/$sep//g;
    Carp::croak 'invalid quint: ' . $in
      unless not length($in) % $CHARS_PER_CHUNK;

    my @chunks = $in =~ m/(.{$CHARS_PER_CHUNK})/gx;
    Carp::croak 'invalid quint: ' . $in unless @chunks == 2;

    my $out = _chunk_to_uint16( $chunks[0] );
    $out <<= 16;
    $out += _chunk_to_uint16( $chunks[1] );
    $out;
}

# hex2proquint('7f00001') eq 'lusab-babad'
sub hex2proquint {
    my $in  = shift // Carp::croak 'usage: hex2proquint($HEXIDECIMAL)';
    my $sep = shift // $SEPARATOR;

    $in =~ s/^0[xX]//;

    Carp::croak 'input must be multiple of 4-characters'
      unless not length($in) % 4;

    join( $sep,
        map { _uint16_to_chunk( hex( '0x' . $_ ) ) } $in =~ m/(.{4})/g );
}

# proquint2hex('lusab-babad') eq '7f000001';
sub proquint2hex {
    my $in  = shift // Carp::croak 'usage: proquint2hex($QUINT)';
    my $sep = shift // $SEPARATOR;

    $in =~ s/$sep//g;
    Carp::croak 'invalid quint: ' . $in
      unless not length($in) % $CHARS_PER_CHUNK;

    my @chunks = $in =~ m/(.{$CHARS_PER_CHUNK})/g;
    Carp::croak 'invalid quint: ' . $in unless @chunks;

    join( '', map { sprintf( '%04x', _chunk_to_uint16($_) ) } @chunks );
}

# ip2proquint('127.0.0.1') eq 'lusab-babad'
sub ip2proquint {
    my $in  = shift // Carp::croak 'usage: ip2proquint($ADDRESS)';
    my $sep = shift // $SEPARATOR;

    my $ip = inet_pton( AF_INET6, $in ) // inet_pton( AF_INET, $in )
      // Carp::croak sprintf q{invalid IP address '%s'}, $in;

    join( $sep, map { _uint16_to_chunk($_) } unpack 'n*', $ip );
}

# proquint2ip('lusab-babad') eq '127.0.0.1'
sub proquint2ip {
    my $in  = shift // Carp::croak 'usage: proquint2ip($ADDRESS)';
    my $sep = shift // $SEPARATOR;

    $in =~ s/$sep//g;
    Carp::croak 'invalid quint: ' . $in
      unless not length($in) % $CHARS_PER_CHUNK;

    my @chunks = $in =~ m/(.{$CHARS_PER_CHUNK})/g;
    Carp::croak 'invalid quint: ' . $in unless @chunks;

    my $ip = pack 'n*', map { _chunk_to_uint16($_) } @chunks;
    return inet_ntop( 2 == @chunks ? AF_INET : AF_INET6, $ip );
}

1;

__END__