view release on metacpan or  search on metacpan

lib/Web/ComposableRequest/Util.pm  view on Meta::CPAN

}

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 (;$$) {