File Coverage

lib/Web/ComposableRequest/Util.pm

Criterion	Covered	Total	%
statement	115	115	100.0
branch	24	32	75.0
condition	17	26	65.3
subroutine	34	34	100.0
pod	20	20	100.0
total	210	227	92.5

package Web::ComposableRequest::Util;

use strictures;
use parent 'Exporter::Tiny';

use Digest::MD5   qw( md5 md5_hex );
use Encode        qw( decode );
use English       qw( -no_match_vars );
use List::Util    qw( first );
use Scalar::Util  qw( blessed );
use Subclass::Of;
use Sys::Hostname qw( hostname );
use URI::Escape   qw( );
use URI::http;
use URI::https;
use Web::ComposableRequest::Constants qw( EXCEPTION_CLASS LANG );

our @EXPORT_OK  = qw( add_config_role base64_decode_ns base64_encode_ns bson64id
                      bson64id_time compose_class decode_array decode_hash
                      extract_lang first_char is_arrayref is_hashref is_member
                      list_config_roles merge_attributes new_uri trim thread_id
                      throw uri_escape );

my $bson_id_count  = 0;
my $bson_prev_time = 0;
my $class_stash    = {};
my @config_roles   = ();
my $host_id        = substr md5( hostname ), 0, 3;
my $reserved       = q(;/?:@&=+$,[]);
my $mark           = q(-_.!~*'());                                   #'; emacs
my $unreserved     = "A-Za-z0-9\Q${mark}\E%\#";
my $uric           = quotemeta( $reserved ) . '\p{isAlpha}' . $unreserved;

# Private functions
my $_base64_char_set = sub {
   return [ 0 .. 9, 'A' .. 'Z', '_', 'a' .. 'z', '~', '+' ];
};

my $_index64 = sub {
   return [ qw(XX XX XX XX  XX XX XX XX  XX XX XX XX  XX XX XX XX
               XX XX XX XX  XX XX XX XX  XX XX XX XX  XX XX XX XX
               XX XX XX XX  XX XX XX XX  XX XX XX 64  XX XX XX XX
                0  1  2  3   4  5  6  7   8  9 XX XX  XX XX XX XX
               XX 10 11 12  13 14 15 16  17 18 19 20  21 22 23 24
               25 26 27 28  29 30 31 32  33 34 35 XX  XX XX XX 36
               XX 37 38 39  40 41 42 43  44 45 46 47  48 49 50 51
               52 53 54 55  56 57 58 59  60 61 62 XX  XX XX 63 XX

               XX XX XX XX  XX XX XX XX  XX XX XX XX  XX XX XX XX
               XX XX XX XX  XX XX XX XX  XX XX XX XX  XX XX XX XX
               XX XX XX XX  XX XX XX XX  XX XX XX XX  XX XX XX XX
               XX XX XX XX  XX XX XX XX  XX XX XX XX  XX XX XX XX
               XX XX XX XX  XX XX XX XX  XX XX XX XX  XX XX XX XX
               XX XX XX XX  XX XX XX XX  XX XX XX XX  XX XX XX XX
               XX XX XX XX  XX XX XX XX  XX XX XX XX  XX XX XX XX
               XX XX XX XX  XX XX XX XX  XX XX XX XX  XX XX XX XX) ];
};

my $_base64_decode_ns = sub {
   my $x = shift; defined $x or return; my @x = split q(), $x;

   my $index = $_index64->(); my $j = 0; my $k = 0;

   my $len = length $x; my $pad = 64; my @y = ();

 ROUND: {
    while ($j < $len) {
       my @c = (); my $i = 0;

       while ($i < 4) {
          my $uc = $index->[ ord $x[ $j++ ] ];

          $uc ne 'XX' and $c[ $i++ ] = 0 + $uc; $j == $len or next;

          if ($i < 4) {
             $i < 2 and last ROUND; $i == 2 and $c[ 2 ] = $pad; $c[ 3 ] = $pad;
          }

          last;
       }

      ($c[ 0 ]   == $pad || $c[ 1 ] == $pad) and last;
       $y[ $k++ ] = ( $c[ 0 ] << 2) | (($c[ 1 ] & 0x30) >> 4);
       $c[ 2 ]   == $pad and last;
       $y[ $k++ ] = (($c[ 1 ] & 0x0F) << 4) | (($c[ 2 ] & 0x3C) >> 2);
       $c[ 3 ]   == $pad and last;
       $y[ $k++ ] = (($c[ 2 ] & 0x03) << 6) | $c[ 3 ];
    }
 }

   return join q(), map { chr $_ } @y;
};

my $_base64_encode_ns = sub {
   my $x = shift; defined $x or return; my @x = split q(), $x;

   my $basis = $_base64_char_set->(); my $len = length $x; my @y = ();

   for (my $i = 0, my $j = 0; $len > 0; $len -= 3, $i += 3) {
      my $c1 = ord $x[ $i ]; my $c2 = $len > 1 ? ord $x[ $i + 1 ] : 0;

      $y[ $j++ ] = $basis->[ $c1 >> 2 ];
      $y[ $j++ ] = $basis->[ (($c1 & 0x3) << 4) | (($c2 & 0xF0) >> 4) ];

      if ($len > 2) {
         my $c3 = ord $x[ $i + 2 ];

         $y[ $j++ ] = $basis->[ (($c2 & 0xF) << 2) | (($c3 & 0xC0) >> 6) ];
         $y[ $j++ ] = $basis->[ $c3 & 0x3F ];
      }
      elsif ($len == 2) {
         $y[ $j++ ] = $basis->[ ($c2 & 0xF) << 2 ];
         $y[ $j++ ] = $basis->[ 64 ];
      }
      else { # len == 1
         $y[ $j++ ] = $basis->[ 64 ];
         $y[ $j++ ] = $basis->[ 64 ];
      }
   }

   return join q(), @y;
};

my $_bsonid_inc = sub {
   my $now = shift; $bson_id_count++;

   $now > $bson_prev_time and $bson_id_count = 0; $bson_prev_time = $now;

   return (pack 'n', thread_id() % 0xFFFF ).(pack 'n', $bson_id_count % 0xFFFF);
};

my $_bsonid_time = sub {
   my $now = shift;

   return (substr pack( 'N', $now >> 32 ), 2, 2).(pack 'N', $now % 0xFFFFFFFF);
};

my $_bson_id = sub {
   my $now = time; my $pid = pack 'n', $PID % 0xFFFF;

   return $_bsonid_time->( $now ).$host_id.$pid.$_bsonid_inc->( $now );
};

# Exported functions
sub add_config_role ($) {
   my $role = shift; return push @config_roles, $role;
}

sub base64_decode_ns ($) {
   return $_base64_decode_ns->( $_[ 0 ] );
}

sub base64_encode_ns (;$) {
   return $_base64_encode_ns->( $_[ 0 ] );
}

sub bson64id (;$) {
   return $_base64_encode_ns->( $_bson_id->() );
}

sub bson64id_time ($) {
   return unpack 'N', substr $_base64_decode_ns->( $_[ 0 ] ), 2, 4;
}

sub compose_class ($$;@) {
   my ($base, $params, %options) = @_;

   my @params = keys %{ $params // {} }; @params > 0 or return $base;

   my $class = "${base}::".(substr md5_hex( join q(), @params ), 0, 8);

   exists $class_stash->{ $class } and return $class_stash->{ $class };

   my $is = $options{is} // 'ro'; my @attrs;

   for my $name (@params) {
      my ($type, $default) = @{ $params->{ $name } };
      my $props            = [ is => $is, isa => $type ];

      defined $default and push @{ $props }, 'default', $default;
      push @attrs, $name, $props;
   }

   return $class_stash->{ $class } = subclass_of
      ( $base, -package => $class, -has => [ @attrs ] );
}

sub decode_array ($$) {
   my ($enc, $param) = @_;

   (not defined $param->[ 0 ] or blessed $param->[ 0 ]) and return;

   for (my $i = 0, my $len = @{ $param }; $i < $len; $i++) {
      $param->[ $i ] = decode( $enc, $param->[ $i ] );
   }

   return;
}

sub decode_hash ($$) {
   my ($enc, $param) = @_; my @keys = keys %{ $param };

   for my $k (@keys) {
      my $v = delete $param->{ $k };

      $param->{ decode( $enc, $k ) }
         = is_arrayref( $v ) ? [ map { decode( $enc, $_ ) } @{ $v } ]
                             :         decode( $enc, $v );
   }

   return;
}

sub extract_lang ($) {
   my $v = shift; return $v ? (split m{ _ }mx, $v)[ 0 ] : LANG;
}

sub first_char ($) {
   return substr $_[ 0 ], 0, 1;
}

sub is_arrayref (;$) {
   return $_[ 0 ] && ref $_[ 0 ] eq 'ARRAY' ? 1 : 0;
}

sub is_hashref (;$) {
   return $_[ 0 ] && ref $_[ 0 ] eq 'HASH' ? 1 : 0;
}

sub is_member (;@) {
   my ($candidate, @args) = @_; $candidate or return;

   is_arrayref $args[ 0 ] and @args = @{ $args[ 0 ] };

   return (first { $_ eq $candidate } @args) ? 1 : 0;
}

sub list_config_roles () {
   return @config_roles;
}

sub merge_attributes ($@) {
   my ($dest, @args) = @_;

   my $attr = is_arrayref( $args[ -1 ] ) ? pop @args : [];

   for my $k (grep { not exists $dest->{ $_ } or not defined $dest->{ $_ } }
                  @{ $attr }) {
      my $i = 0; my $v;

      while (not defined $v and defined( my $src = $args[ $i++ ] )) {
         my $class = blessed $src;

         $v = $class ? ($src->can( $k ) ? $src->$k() : undef) : $src->{ $k };
      }

      defined $v and $dest->{ $k } = $v;
   }

   return $dest;
}

sub new_uri ($$) {
   my $v = uri_escape( $_[ 1 ] ); return bless \$v, 'URI::'.$_[ 0 ];
}

sub thread_id () {
   return exists $INC{ 'threads.pm' } ? threads->tid() : 0;
}

sub throw (;@) {
   EXCEPTION_CLASS->throw( @_ );
}

sub trim (;$$) {
   my $chs = $_[ 1 ] // " \t"; (my $v = $_[ 0 ] // q()) =~ s{ \A [$chs]+ }{}mx;

   chomp $v; $v =~ s{ [$chs]+ \z }{}mx; return $v;
}

sub uri_escape ($;$) {
   my ($v, $pattern) = @_; $pattern //= $uric;

   $v =~ s{([^$pattern])}{ URI::Escape::uri_escape_utf8($1) }ego;
   utf8::downgrade( $v );
   return $v;
}

1;

__END__