Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP

Loading…

Added convenience methods for put and delete to LWP::UserAgent #10

Merged
merged 3 commits into from

2 participants

@trcjr

I've added convenience methods for put and delete to LWP::UserAgent and updated t/local/http.t to add basic coverage for the the new methods.
I've also changed t/local/http.t to use Test::Most and given some of the tests names.

@gisle gisle merged commit 59d4026 into libwww-perl:master
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Commits on Mar 26, 2011
  1. @trcjr

    now with put and delete helpers

    trcjr authored
  2. @trcjr

    updated POD

    trcjr authored
  3. @trcjr
This page is out of date. Refresh to see the latest.
Showing with 123 additions and 32 deletions.
  1. +50 −2 lib/LWP/UserAgent.pm
  2. +73 −30 t/local/http.t
View
52 lib/LWP/UserAgent.pm
@@ -429,6 +429,22 @@ sub head {
}
+sub put {
+ require HTTP::Request::Common;
+ my($self, @parameters) = @_;
+ my @suff = $self->_process_colonic_headers(\@parameters, (ref($parameters[1]) ? 2 : 1));
+ return $self->request( HTTP::Request::Common::PUT( @parameters ), @suff );
+}
+
+
+sub delete {
+ require HTTP::Request::Common;
+ my($self, @parameters) = @_;
+ my @suff = $self->_process_colonic_headers(\@parameters,1);
+ return $self->request( HTTP::Request::Common::DELETE( @parameters ), @suff );
+}
+
+
sub _process_colonic_headers {
# Process :content_cb / :content_file / :read_size_hint headers.
my($self, $args, $start_index) = @_;
@@ -1060,8 +1076,8 @@ needs to be performed. This request is then passed to one of the
request method the UserAgent, which dispatches it using the relevant
protocol, and returns a C<HTTP::Response> object. There are
convenience methods for sending the most common request types: get(),
-head() and post(). When using these methods then the creation of the
-request object is hidden as shown in the synopsis above.
+head(), post(), put() and delete(). When using these methods then the
+creation of the request object is hidden as shown in the synopsis above.
The basic approach of the library is to use HTTP style communication
for all protocol schemes. This means that you will construct
@@ -1645,6 +1661,38 @@ This method will use the POST() function from C<HTTP::Request::Common>
to build the request. See L<HTTP::Request::Common> for a details on
how to pass form content and other advanced features.
+=item $ua->put( $url, \%form )
+
+=item $ua->put( $url, \@form )
+
+=item $ua->put( $url, \%form, $field_name => $value, ... )
+
+=item $ua->put( $url, $field_name => $value,... Content => \%form )
+
+=item $ua->put( $url, $field_name => $value,... Content => \@form )
+
+=item $ua->put( $url, $field_name => $value,... Content => $content )
+
+This method will dispatch a C<PUT> request on the given $url, with
+%form or @form providing the key/value pairs for the fill-in form
+content. Additional headers and content options are the same as for
+the get() method.
+
+This method will use the PUT() function from C<HTTP::Request::Common>
+to build the request. See L<HTTP::Request::Common> for a details on
+how to pass form content and other advanced features.
+
+=item $ua->delete( $url )
+
+=item $ua->delete( $url, $field_name => $value, ... )
+
+This method will dispatch a C<DELETE> request on the given $url. Additional
+headers and content options are the same as for the get() method.
+
+This method will use the DELETE() function from C<HTTP::Request::Common>
+to build the request. See L<HTTP::Request::Common> for a details on
+how to pass form content and other advanced features.
+
=item $ua->mirror( $url, $filename )
This method will get the document identified by $url and store it in
View
103 t/local/http.t
@@ -47,8 +47,8 @@ else {
open(DAEMON, "$perl local/http.t daemon |") or die "Can't exec daemon: $!";
}
-use Test;
-plan tests => 54;
+use Test::More;
+plan tests => 59;
my $greeting = <DAEMON>;
$greeting =~ /(<[^>]+>)/;
@@ -75,9 +75,9 @@ $req = new HTTP::Request GET => url("/not_found", $base);
$req->header(X_Foo => "Bar");
$res = $ua->request($req);
-ok($res->is_error);
-ok($res->code, 404);
-ok($res->message, qr/not\s+found/i);
+ok($res->is_error, 'is_error');
+is($res->code, 404, 'response code 404');
+like($res->message, qr/not\s+found/i, '404 message');
# we also expect a few headers
ok($res->server);
ok($res->date);
@@ -108,23 +108,23 @@ $res = $ua->request($req);
#print $res->as_string;
ok($res->is_success);
-ok($res->code, 200);
-ok($res->message, "OK");
+is($res->code, 200, 'status code 200');
+is($res->message, "OK", 'message OK');
$_ = $res->content;
@accept = /^Accept:\s*(.*)/mg;
-ok($_, qr/^From:\s*gisle\@aas\.no\n/m);
-ok($_, qr/^Host:/m);
-ok(@accept, 3);
-ok($_, qr/^Accept:\s*text\/html/m);
-ok($_, qr/^Accept:\s*text\/plain/m);
-ok($_, qr/^Accept:\s*image\/\*/m);
-ok($_, qr/^If-Modified-Since:\s*\w{3},\s+\d+/m);
-ok($_, qr/^Long-Text:\s*This.*broken between/m);
-ok($_, qr/^Foo-Bar:\s*1\n/m);
-ok($_, qr/^X-Foo:\s*Bar\n/m);
-ok($_, qr/^User-Agent:\s*Mozilla\/0.01/m);
+like($_, qr/^From:\s*gisle\@aas\.no\n/m);
+like($_, qr/^Host:/m);
+is(@accept, 3, '3 items in accept');
+like($_, qr/^Accept:\s*text\/html/m);
+like($_, qr/^Accept:\s*text\/plain/m);
+like($_, qr/^Accept:\s*image\/\*/m);
+like($_, qr/^If-Modified-Since:\s*\w{3},\s+\d+/m);
+like($_, qr/^Long-Text:\s*This.*broken between/m);
+like($_, qr/^Foo-Bar:\s*1\n/m);
+like($_, qr/^X-Foo:\s*Bar\n/m);
+like($_, qr/^User-Agent:\s*Mozilla\/0.01/m);
# Try it with the higher level 'get' interface
$res = $ua->get(url("/echo/path_info?query", $base),
@@ -134,7 +134,50 @@ $res = $ua->get(url("/echo/path_info?query", $base),
X_Foo => "Bar",
);
#$res->dump;
-ok($res->code, 200);
+is($res->code, 200, 'response code 200');
+
+#----------------------------------------------------------------
+print "UserAgent->put...\n";
+sub httpd_put_echo
+{
+ my($c, $req) = @_;
+ $c->send_basic_header(200);
+ print $c "Content-Type: message/http\015\012";
+ $c->send_crlf;
+ print $c $req->as_string;
+}
+ok($res->content, qr/^From: gisle\@aas.no$/m);
+# Try it with the higher level 'get' interface
+$res = $ua->put(url("/echo/path_info?query", $base),
+ Accept => 'text/html',
+ Accept => 'text/plain; q=0.9',
+ Accept => 'image/*',
+ X_Foo => "Bar",
+);
+#$res->dump;
+is($res->code, 200, 'response code 200');
+ok($res->content, qr/^From: gisle\@aas.no$/m);
+
+#----------------------------------------------------------------
+print "UserAgent->delete...\n";
+sub httpd_delete_echo
+{
+ my($c, $req) = @_;
+ $c->send_basic_header(200);
+ print $c "Content-Type: message/http\015\012";
+ $c->send_crlf;
+ print $c $req->as_string;
+}
+ok($res->content, qr/^From: gisle\@aas.no$/m);
+# Try it with the higher level 'get' interface
+$res = $ua->delete(url("/echo/path_info?query", $base),
+ Accept => 'text/html',
+ Accept => 'text/plain; q=0.9',
+ Accept => 'image/*',
+ X_Foo => "Bar",
+);
+#$res->dump;
+is($res->code, 200, 'response code 200');
ok($res->content, qr/^From: gisle\@aas.no$/m);
#----------------------------------------------------------------
@@ -166,7 +209,7 @@ $res = $ua->request($req);
ok($res->is_success);
ok($res->content_type, 'text/html');
-ok($res->content_length, 147);
+is($res->content_length, 147, '147 content length');
ok($res->title, 'En prøve');
ok($res->content, qr/å være/);
@@ -174,13 +217,13 @@ ok($res->content, qr/
$res = $ua->request($req);
#print $res->as_string;
ok($res->is_error);
-ok($res->code, 404); # not found
-
+is($res->code, 404, 'response code 404'); # not found
+
# Then try to list current directory
$req = new HTTP::Request GET => url("/file?name=.", $base);
$res = $ua->request($req);
#print $res->as_string;
-ok($res->code, 501); # NYI
+is($res->code, 501, 'response code 501'); # NYI
#----------------------------------------------------------------
@@ -198,7 +241,7 @@ $res = $ua->request($req);
ok($res->is_success);
ok($res->content, qr|/echo/redirect|);
ok($res->previous->is_redirect);
-ok($res->previous->code, 301);
+is($res->previous->code, 301, 'response code 301');
# Let's test a redirect loop too
sub httpd_get_redirect2 { shift->send_redirect("/redirect3/") }
@@ -210,12 +253,12 @@ $res = $ua->request($req);
#print $res->as_string;
ok($res->is_redirect);
ok($res->header("Client-Warning"), qr/loop detected/i);
-ok($res->redirects, 5);
+is($res->redirects, 5, '5 max redirects');
$ua->max_redirect(0);
$res = $ua->request($req);
-ok($res->previous, undef);
-ok($res->redirects, 0);
+is($res->previous, undef, 'undefined previous');
+is($res->redirects, 0, 'zero redirects');
$ua->max_redirect(5);
#----------------------------------------------------------------
@@ -260,7 +303,7 @@ ok($res->is_success);
# Let's try with a $ua that does not pass out credentials
$res = $ua->request($req);
-ok($res->code, 401);
+is($res->code, 401, 'respone code 401');
# Let's try to set credentials for this realm
$ua->credentials($req->uri->host_port, "libwww-perl", "ok 12", "xyzzy");
@@ -270,7 +313,7 @@ ok($res->is_success);
# Then illegal credentials
$ua->credentials($req->uri->host_port, "libwww-perl", "user", "passwd");
$res = $ua->request($req);
-ok($res->code, 401);
+is($res->code, 401, 'response code 401');
#----------------------------------------------------------------
@@ -376,5 +419,5 @@ sub httpd_get_quit
$req = new HTTP::Request GET => url("/quit", $base);
$res = $ua->request($req);
-ok($res->code, 503);
+is($res->code, 503, 'response code is 503');
ok($res->content, qr/Bye, bye/);
Something went wrong with that request. Please try again.