Another pass at improving URI: support percent encoded URI

Changes

@@ -2,6 +2,24 @@
 
 {{ $NEXT }}
 
+  [Enhancements]
+
+  - PERL-130 improved support for connection string URI; added support for
+    options: ssl, connectTimeoutMS, w, wtimeoutMS, and journal
+
+  [Bug fixes]
+
+  - PERL-130 fixed parsing of connection string to allow for usernames containing :
+    and passwords containing @ if they are percent encoded (RFC 3986)
+
+  [Documentation]
+
+  - PERL-130 documented supported connection string options
+
+  [Testing]
+
+  - PERL-130 added tests for connection string options and percent encoded username/password
+
 v0.704.2.0 2014-07-08 12:04:02-04:00 America/New_York
 
   [Bug fixes]

lib/MongoDB/MongoClient.pm

@@ -139,7 +139,7 @@ has auto_connect => (
 );
 
 has timeout => (
-    is       => 'ro',
+    is       => 'rw',
     isa      => 'Int',
     required => 1,
     default  => 20000,
@@ -210,7 +210,7 @@ has _is_mongos => (
 );
 
 has ssl => (
-    is       => 'ro',
+    is       => 'rw',
     isa      => 'Bool',
     required => 1,
     default  => 0,
@@ -315,14 +315,23 @@ sub BUILD {
     if (%parsed_connection) {
 
         @pairs = @{$parsed_connection{hostpairs}};
-        my $options = $parsed_connection{options};
 
         # we add these things to $opts as well as self so that they get propagated when we recurse for multiple servers
         for my $k ( qw/username password db_name/ ) {
             $self->$k($opts->{$k} = $parsed_connection{$k}) if exists $parsed_connection{$k};
         }
 
-        # TODO handle standard options from $options
+        # Process options
+        my %options = %{$parsed_connection{options}} if defined $parsed_connection{options};
+
+        # Add connection options
+        $self->ssl($opts->{ssl} = _str_to_bool($options{ssl})) if exists $options{ssl};
+        $self->timeout($opts->{timeout} = $options{connectTimeoutMS}) if exists $options{connectTimeoutMS};
+
+        # Add write concern options
+        $self->w($opts->{w} = $options{w}) if exists $options{w};
+        $self->wtimeout($opts->{wtimeout} = $options{wtimeoutMS}) if exists $options{wtimeoutMS};
+        $self->j($opts->{j} = _str_to_bool($options{journal})) if exists $options{journal};
     }
     # deprecated syntax
     else {
@@ -399,6 +408,20 @@ sub BUILD {
     $self->_init_conn_holder($master);
 }
 
+sub _str_to_bool {
+    my $str = shift;
+    confess "cannot convert undef to bool" unless defined $str;
+    my $ret = $str eq "true" ? 1 : $str eq "false" ? 0 : undef;
+    return $ret unless !defined $ret;
+    confess "expected boolean string 'true' or 'false' but instead received '$str'";
+}
+
+sub _unescape_all {
+    my $str = shift;
+    $str =~ s/%([0-9a-f]{2})/chr(hex($1))/ieg;
+    return $str;
+}
+
 sub _parse_connection_string {
 
     my ($host) = @_;
@@ -416,15 +439,29 @@ sub _parse_connection_string {
 
         ($result{username}, $result{password}, $result{hostpairs}, $result{db_name}, $result{options}) = ($1, $2, $3, $4, $5);
 
+        # Decode components
+        for my $subcomponent ( qw/username password db_name/ ) {
+            $result{$subcomponent} = _unescape_all($result{$subcomponent}) unless !(defined $result{$subcomponent});
+        }
+
         $result{hostpairs} = 'localhost' unless $result{hostpairs};
-        my @pairs =  map { $_ .= ':27017' unless $_ =~ /:/ ; $_ } split ',', $result{hostpairs};
-        $result{hostpairs} = \@pairs;
+        $result{hostpairs} = [
+            map { @_ = split ':', $_; _unescape_all($_[0]).":"._unescape_all($_[1]) }
+            map { $_ .= ':27017' unless $_ =~ /:/ ; $_ } split ',', $result{hostpairs}
+        ];
+
+        $result{options} =
+            { map {
+                 my @kv = split '=', $_;
+                 confess 'expected key value pair' unless @kv == 2;
+                 ($kv[0], $kv[1]) = (_unescape_all($kv[0]), _unescape_all($kv[1]));
+                 @kv;
+              } split '&', $result{options}
+            } if defined $result{options};
 
         delete $result{username} unless defined $result{username} && length $result{username};
         delete $result{password} unless defined $result{password}; # can be empty string
         delete $result{db_name} unless defined $result{db_name} && length $result{db_name};
-
-        # TODO parse options
     }
 
     return %result;
@@ -1021,6 +1058,8 @@ is true, then connections will be re-established as needed.
 
 Core documentation on connections: L<http://docs.mongodb.org/manual/reference/connection-string/>.
 
+The currently supported connection string options are ssl, connectTimeoutMS, w, wtimeoutMS, and journal.
+
 =attr host
 
 Server or servers to connect to. Defaults to C<mongodb://localhost:27017>.

t/connection.t

@@ -131,6 +131,40 @@ SKIP: {
     $testdb->drop;
 }
 
+subtest "options" => sub {
+
+    subtest "connection" => sub {
+
+        my $ssl = "true";
+        my $timeout = 40000;
+        my $client = MongoDB::MongoClient->new({host => "mongodb://localhost/?ssl=$ssl&connectTimeoutMS=$timeout"});
+
+        is( $client->ssl, 1, "connect with ssl set" );
+        is( $client->timeout, $timeout, "connection timeout set" );
+    };
+
+    subtest "invalid option value" => sub {
+
+        like(
+            exception { MongoDB::MongoClient->new({host => "mongodb://localhost/?ssl="}) },
+            qr/expected key value pair/,
+            'key should have value'
+        );
+    };
+
+    subtest "write concern" => sub {
+
+        my $w = 2;
+        my $wtimeout = 200;
+        my $j = "true";
+        my $client = MongoDB::MongoClient->new({host => "mongodb://localhost/?w=$w&wtimeoutMS=$wtimeout&journal=$j"});
+
+        is( $client->w, $w, "write acknowledgement set" );
+        is( $client->wtimeout, $wtimeout, "write acknowledgement timeout set" );
+        is( $client->j, 1, "sync to journal" );
+    };
+};
+
 
 # query_timeout
 {

t/connection_string.t

@@ -122,4 +122,14 @@ subtest "multiple hostnames (localhost/domain)" => sub {
     is_deeply($parsed_connection{hostpairs}, \@hostpairs);
 };
 
+subtest "percent encoded username and password" => sub {
+
+    my %parsed_connection = MongoDB::MongoClient::_parse_connection_string('mongodb://dog%3Adogston:p%40ssword@localhost');
+    my @hostpairs = ('localhost:27017');
+
+    is($parsed_connection{username}, 'dog:dogston');
+    is($parsed_connection{password}, 'p@ssword');
+    is_deeply($parsed_connection{hostpairs}, \@hostpairs);
+};
+
 done_testing;