view release on metacpan or  search on metacpan

lib/MongoDB/_URI.pm  view on Meta::CPAN

        MongoDB::Error->throw("URI '$self' could not be parsed");
    }

    (
        $result{username}, $result{password}, $result{hostids},
        $result{db_name},  $result{options}
    ) = ( $1, $2, $3, $4, $5 );

    if ( defined $result{username} ) {
        MongoDB::Error->throw(
            "URI '$self' could not be parsed (username must be URL encoded)"
        ) if __userinfo_invalid_chars($result{username});
        $result{username} = _unescape_all( $result{username} );
    }

    if ( defined $result{password} ) {
        MongoDB::Error->throw(
            "URI '$self' could not be parsed (password must be URL encoded)"
        ) if __userinfo_invalid_chars($result{password});
        $result{password} = _unescape_all( $result{password} );
    }

    $result{hostids} = $self->_prepare_dns_hosts($result{hostids});

    if ( defined $result{db_name} ) {
        MongoDB::Error->throw(
            "URI '$self' could not be parsed (database name must be URL encoded, found unescaped '/'"
        ) if $result{db_name} =~ /\//;
        $result{db_name} = _unescape_all( $result{db_name} );
    }

    if ( defined $result{options} ) {
        $result{options} = $self->_parse_options( $self->valid_options, \%result );
    }

    for my $attr (qw/username password db_name options hostids expires/) {
        my $setter = "_set_$attr";
        $self->$setter( $result{$attr} ) if defined $result{$attr};
    }

    return;
}

sub __str_to_bool {
    my ($k, $str) = @_;
    MongoDB::UsageError->throw("cannot convert undef to bool for key '$k'")
      unless defined $str;
    my $ret = $str eq "true" ? 1 : $str eq "false" ? 0 : undef;
    warn("expected boolean string 'true' or 'false' for key '$k' but instead received '$str'. Ignoring '$k'.\n")
        unless defined $ret;
    return $ret;
}

# uri_escape borrowed from HTTP::Tiny 0.070
my %escapes = map { chr($_) => sprintf("%%%02X", $_) } 0..255;
$escapes{' '}="+";
my $unsafe_char = qr/[^A-Za-z0-9\-\._~]/;

sub __uri_escape {
    my ($str) = @_;
    if ( $] ge '5.008' ) {
        utf8::encode($str);
    }
    else {
        $str = pack("U*", unpack("C*", $str)) # UTF-8 encode a byte string
            if ( length $str == do { use bytes; length $str } );
        $str = pack("C*", unpack("C*", $str)); # clear UTF-8 flag
    }
    $str =~ s/($unsafe_char)/$escapes{$1}/ge;
    return $str;
}

# Rules for valid userinfo from RFC 3986 Section 3.2.1.
my $unreserved = q[a-z0-9._~-]; # use this class last so regex ends in '-'
my $subdelimit = q[!$&'()*+,;=];
my $allowed = "%$subdelimit$unreserved";
my $not_allowed_re = qr/[^$allowed]/i;
my $not_pct_enc_re = qr/%(?![0-9a-f]{2})/i;

sub __userinfo_invalid_chars {
    my ($str) = @_;
    return $str =~ $not_pct_enc_re || $str =~ $not_allowed_re;
}

# redact user credentials when stringifying
use overload
    '""' => sub {
        (my $s = $_[0]->uri) =~ s{^([^:]+)://[^/]+\@}{$1://[**REDACTED**]\@};
        return $s
    },
    'fallback' => 1;


1;

# vim: ts=4 sts=4 sw=4 et: