view release on metacpan or  search on metacpan

lib/Mojo/Util.pm  view on Meta::CPAN

sub getopt {
  my ($array, $opts) = map { ref $_[0] eq 'ARRAY' ? shift : $_ } \@ARGV, [];

  my $save   = Getopt::Long::Configure(qw(default no_auto_abbrev no_ignore_case), @$opts);
  my $result = GetOptionsFromArray $array, @_;
  Getopt::Long::Configure($save);

  return $result;
}

sub gunzip {
  my $compressed = shift;
  IO::Uncompress::Gunzip::gunzip \$compressed, \my $uncompressed
    or croak "Couldn't gunzip: $IO::Uncompress::Gunzip::GzipError";
  return $uncompressed;
}

sub gzip {
  my $uncompressed = shift;
  IO::Compress::Gzip::gzip \$uncompressed, \my $compressed or croak "Couldn't gzip: $IO::Compress::Gzip::GzipError";
  return $compressed;
}

sub header_params {
  my $value = shift;

  my $params = {};
  while ($value =~ /\G[;\s]*([^=;, ]+)\s*/gc) {
    my $name = $1;

    # Quoted value
    if ($value =~ /$QUOTED_VALUE_RE/gco) { $params->{$name} //= unquote($1) }

    # Unquoted value
    elsif ($value =~ /$UNQUOTED_VALUE_RE/gco) { $params->{$name} //= $1 }
  }

  return ($params, substr($value, pos($value) // 0));
}

sub html_attr_unescape { _html(shift, 1) }
sub html_unescape      { _html(shift, 0) }

sub humanize_bytes {
  my $size = shift;

  my $prefix = $size < 0 ? '-' : '';

  return "$prefix${size}B"               if ($size = abs $size) < 1024;
  return $prefix . _round($size) . 'KiB' if ($size /= 1024) < 1024;
  return $prefix . _round($size) . 'MiB' if ($size /= 1024) < 1024;
  return $prefix . _round($size) . 'GiB' if ($size /= 1024) < 1024;
  return $prefix . _round($size /= 1024) . 'TiB';
}

sub network_contains {
  my ($cidr, $addr) = @_;
  return undef unless length $cidr && length $addr;

  # Parse inputs
  my ($net, $mask) = split m!/!, $cidr, 2;
  my $v6 = $net =~ /:/;
  return undef if $v6 xor $addr =~ /:/;

  # Convert addresses to binary
  return undef unless $net  = inet_pton($v6 ? AF_INET6 : AF_INET, $net);
  return undef unless $addr = inet_pton($v6 ? AF_INET6 : AF_INET, $addr);
  my $length = $v6 ? 128 : 32;

  # Apply mask if given
  $addr &= pack "B$length", '1' x $mask if defined $mask;

  # Compare
  return 0 == unpack "B$length", ($net ^ $addr);
}

# Direct translation of RFC 3492
sub punycode_decode {
  my $input = shift;
  use integer;

  my ($n, $i, $bias, @output) = (PC_INITIAL_N, 0, PC_INITIAL_BIAS);

  # Consume all code points before the last delimiter
  push @output, split(//, $1) if $input =~ s/(.*)\x2d//s;

  while (length $input) {
    my ($oldi, $w) = ($i, 1);

    # Base to infinity in steps of base
    for (my $k = PC_BASE; 1; $k += PC_BASE) {
      my $digit = ord substr $input, 0, 1, '';
      $digit = $digit < 0x40 ? $digit + (26 - 0x30) : ($digit & 0x1f) - 1;
      $i += $digit * $w;
      my $t = $k - $bias;
      $t = $t < PC_TMIN ? PC_TMIN : $t > PC_TMAX ? PC_TMAX : $t;
      last if $digit < $t;
      $w *= PC_BASE - $t;
    }

    $bias = _adapt($i - $oldi, @output + 1, $oldi == 0);
    $n += $i / (@output + 1);
    $i = $i % (@output + 1);
    splice @output, $i++, 0, chr $n;
  }

  return join '', @output;
}

# Direct translation of RFC 3492
sub punycode_encode {
  my $output = shift;
  use integer;

  my ($n, $delta, $bias) = (PC_INITIAL_N, 0, PC_INITIAL_BIAS);

  # Extract basic code points
  my @input = map {ord} split //, $output;
  $output =~ s/[^\x00-\x7f]+//gs;
  my $h = my $basic = length $output;
  $output .= "\x2d" if $basic > 0;