improved redirect support in Mojo::UserAgent to be closer to commonly…

… used browsers
mojolicious · Aug 25, 2011 · 33f7ed9 · 33f7ed9
1 parent 9b9125b
commit 33f7ed9
Show file tree

Hide file tree

Showing 14 changed files with 668 additions and 23 deletions.
diff --git a/Changes b/Changes
@@ -1,5 +1,12 @@
 This file documents the revision history for Perl extension Mojolicious.
 
+1.91    2011-08-25 00:00:00
+        - Added EXPERIMENTAL support for cloning Mojo::Message::Request
+          objects.
+        - Improved redirect support in Mojo::UserAgent to be closer to
+          commonly used browsers.
+        - Improved documentation.
+
 1.90    2011-08-24 00:00:00
         - Improved respond_to to automatically render an empty 204 response
           for unknown formats.

diff --git a/README.pod b/README.pod
@@ -29,7 +29,9 @@ I18N, first class unicode support and much more for you to discover.
 =item *
 
 Very clean, portable and Object Oriented pure Perl API without any hidden
-magic and no requirements besides Perl 5.8.7 (although 5.12+ is recommended).
+magic and no requirements besides Perl 5.8.7 (although 5.12+ is recommended,
+and optional CPAN modules will be used to provide advanced functionality if
+they are installed).
 
 =item *
 

diff --git a/lib/Mojo/Content.pm b/lib/Mojo/Content.pm
@@ -63,6 +63,12 @@ sub build_headers {
   return $headers;
 }
 
+sub clone {
+  my $self = shift;
+  return if $self->is_dynamic;
+  return $self->new(headers => $self->headers->clone);
+}
+
 # "Aren't we forgetting the true meaning of Christmas?
 #  You know, the birth of Santa."
 sub generate_body_chunk {
@@ -493,6 +499,13 @@ Render whole body.
 
 Render all headers.
 
+=head2 C<clone>
+
+  my $clone = $content->clone;
+
+Clone content if possible.
+Note that this method is EXPERIMENTAL and might change without warning!
+
 =head2 C<generate_body_chunk>
 
   my $chunk = $content->generate_body_chunk(0);

diff --git a/lib/Mojo/Content/MultiPart.pm b/lib/Mojo/Content/MultiPart.pm
@@ -78,6 +78,13 @@ sub build_boundary {
   return $boundary;
 }
 
+sub clone {
+  my $self = shift;
+  return unless my $clone = $self->SUPER::clone();
+  $clone->parts($self->parts);
+  return $clone;
+}
+
 sub get_body_chunk {
   my ($self, $offset) = @_;
 
@@ -285,6 +292,13 @@ Content size in bytes.
 
 Generate a suitable boundary for content.
 
+=head2 C<clone>
+
+  my $clone = $content->clone;
+
+Clone content if possible.
+Note that this method is EXPERIMENTAL and might change without warning!
+
 =head2 C<get_body_chunk>
 
   my $chunk = $content->get_body_chunk(0);

diff --git a/lib/Mojo/Content/Single.pm b/lib/Mojo/Content/Single.pm
@@ -19,6 +19,13 @@ sub body_size {
   return $self->asset->size;
 }
 
+sub clone {
+  my $self = shift;
+  return unless my $clone = $self->SUPER::clone();
+  $clone->asset($self->asset);
+  return $clone;
+}
+
 sub get_body_chunk {
   my ($self, $offset) = @_;
 
@@ -126,6 +133,13 @@ Check if content contains a specific string.
 
 Content size in bytes.
 
+=head2 C<clone>
+
+  my $clone = $content->clone;
+
+Clone content if possible.
+Note that this method is EXPERIMENTAL and might change without warning!
+
 =head2 C<get_body_chunk>
 
   my $chunk = $content->get_body_chunk(0);

diff --git a/lib/Mojo/Headers.pm b/lib/Mojo/Headers.pm
@@ -103,7 +103,16 @@ sub add {
   return $self;
 }
 
-sub cache_control       { scalar shift->header('Cache-Control'       => @_) }
+sub cache_control { scalar shift->header('Cache-Control' => @_) }
+
+sub clone {
+  my $self  = shift;
+  my $clone = $self->new;
+  $clone->{headers}->{$_} = [@{$self->{headers}->{$_}}]
+    for keys %{$self->{headers}};
+  return $clone;
+}
+
 sub connection          { scalar shift->header(Connection            => @_) }
 sub content_disposition { scalar shift->header('Content-Disposition' => @_) }
 sub content_length      { scalar shift->header('Content-Length'      => @_) }
@@ -396,6 +405,13 @@ Shortcut for the C<Authorization> header.
 
 Shortcut for the C<Cache-Control> header.
 
+=head2 C<clone>
+
+  my $clone = $headers->clone;
+
+Clone headers.
+Note that this method is EXPERIMENTAL and might change without warning!
+
 =head2 C<connection>
 
   my $connection = $headers->connection;

diff --git a/lib/Mojo/Message/Request.pm b/lib/Mojo/Message/Request.pm
@@ -25,6 +25,24 @@ my $START_LINE_RE = qr/
 # Host regex
 my $HOST_RE = qr/^([^\:]*)\:?(.*)$/;
 
+sub clone {
+  my $self = shift;
+
+  # Dynamic requests cannot be cloned
+  return unless my $content = $self->content->clone;
+  my $clone = $self->new(
+    content     => $content,
+    method      => $self->method,
+    on_progress => $self->on_progress,
+    on_finish   => $self->on_finish,
+    url         => $self->url->clone,
+    version     => $self->version
+  );
+  $clone->{proxy} = $self->{proxy}->clone if $self->{proxy};
+
+  return $clone;
+}
+
 sub cookies {
   my $self = shift;
 
@@ -434,6 +452,13 @@ HTTP request URL, defaults to a L<Mojo::URL> object.
 L<Mojo::Message::Request> inherits all methods from L<Mojo::Message> and
 implements the following new ones.
 
+=head2 C<clone>
+
+  my $clone = $req->clone;
+
+Clone request if possible.
+Note that this method is EXPERIMENTAL and might change without warning!
+
 =head2 C<cookies>
 
   my $cookies = $req->cookies;

diff --git a/lib/Mojo/UserAgent.pm b/lib/Mojo/UserAgent.pm
@@ -500,7 +500,6 @@ sub _test_server {
   return $self->{server};
 }
 
-# "Once the government approves something, it's no longer immoral!"
 sub _upgrade {
   my ($self, $id) = @_;
 

diff --git a/lib/Mojo/UserAgent/Transactor.pm b/lib/Mojo/UserAgent/Transactor.pm
@@ -185,27 +185,31 @@ sub proxy_connect {
 sub redirect {
   my ($self, $old) = @_;
 
-  # Code
+  # Commonly used codes
   my $res = $old->res;
-  return unless $res->is_status_class('300');
-  return if $res->code == 305;
+  my $code = $res->code || 0;
+  return unless $code == 301 || $code == 302 || $code == 303 || $code == 307;
 
-  # Location
+  # Fix broken location without authority and/or scheme
   return unless my $location = $res->headers->location;
   $location = Mojo::URL->new($location);
-
-  # Fix broken location without authority and/or scheme
   my $req = $old->req;
   my $url = $req->url;
   $location->authority($url->authority) unless $location->authority;
   $location->scheme($url->scheme)       unless $location->scheme;
 
-  # Method
+  # Clone request if necessary
+  my $new    = Mojo::Transaction::HTTP->new;
   my $method = $req->method;
-  $method = 'GET' unless $method =~ /^GET|HEAD$/i;
-
-  # New transaction
-  my $new = Mojo::Transaction::HTTP->new;
+  if ($code == 301 || $code == 307) {
+    return unless $req = $req->clone;
+    $new->req($req);
+    my $headers = $req->headers;
+    $headers->remove('Host');
+    $headers->remove('Cookie');
+    $headers->remove('Referer');
+  }
+  else { $method = 'GET' unless $method =~ /^GET|HEAD$/i }
   $new->req->method($method)->url($location);
   $new->previous($old);
 
@@ -343,13 +347,15 @@ Actual peer for transaction.
 
   my $tx = $t->proxy_connect($old);
 
-Build L<Mojo::Transaction::HTTP> proxy connect request for transaction.
+Build L<Mojo::Transaction::HTTP> proxy connect request for transaction if
+possible.
 
 =head2 C<redirect>
 
   my $tx = $t->redirect($old);
 
-Build L<Mojo::Transaction::HTTP> followup request for redirect response.
+Build L<Mojo::Transaction::HTTP> followup request for C<301>, C<302>, C<303>
+or C<307> redirect response if possible.
 
 =head2 C<tx>
 

diff --git a/lib/Mojolicious.pm b/lib/Mojolicious.pm
@@ -34,7 +34,7 @@ has static   => sub { Mojolicious::Static->new };
 has types    => sub { Mojolicious::Types->new };
 
 our $CODENAME = 'Smiling Face With Sunglasses';
-our $VERSION  = '1.90';
+our $VERSION  = '1.91';
 
 # "These old doomsday devices are dangerously unstable.
 #  I'll rest easier not knowing where they are."

diff --git a/lib/Mojolicious/Guides/FAQ.pod b/lib/Mojolicious/Guides/FAQ.pod
@@ -127,10 +127,6 @@ Quite possibly this oneliner.
 
   $ sudo sh -c "curl -L cpanmin.us | perl - Mojolicious"
 
-=head2 I think L<Mojolicious> is awesome, how can i support you guys?
-
-Share your success story via blog or twitter, get more people hooked! :)
-
 =head2 I think i have found a bug, what should i do now?
 
 First make sure you are using the latest version of L<Mojolicious>, it is

diff --git a/t/mojo/headers.t b/t/mojo/headers.t
@@ -2,7 +2,7 @@
 use Mojo::Base -strict;
 
 # "Remember, you can always find East by staring directly at the sun."
-use Test::More tests => 41;
+use Test::More tests => 47;
 
 # "So, have a merry Christmas, a happy Hanukkah, a kwaazy Kwanza,
 #  a tip-top Tet, and a solemn, dignified, Ramadan.
@@ -37,6 +37,23 @@ $headers->cache_control('public');
 is $headers->expires, 'Thu, 01 Dec 1994 16:00:00 GMT', 'right value';
 is $headers->cache_control, 'public', 'right value';
 
+# Clone
+$headers = Mojo::Headers->new;
+$headers->add('Connection', 'close');
+$headers->add('Connection', 'keep-alive');
+is $headers->header('Connection'), 'close, keep-alive', 'right value';
+my $clone = $headers->clone;
+$headers->connection('nothing');
+is $headers->header('Connection'), 'nothing',           'right value';
+is $clone->header('Connection'),   'close, keep-alive', 'right value';
+$headers = Mojo::Headers->new;
+$headers->expect('100-continue');
+is $headers->expect, '100-continue', 'right value';
+$clone = $headers->clone;
+$clone->expect('nothing');
+is $headers->expect, '100-continue', 'right value';
+is $clone->expect,   'nothing',      'right value';
+
 # Multiline values
 $headers = Mojo::Headers->new;
 $headers->header('X-Test', [23, 24], 'single line', [25, 26]);