[svn:parrot] r46704 - in trunk: runtime/parrot/library runtime/parrot/library/HTTP t/library
fperrad at svn.parrot.org
fperrad at svn.parrot.org
Sun May 16 15:33:27 UTC 2010
Author: fperrad
Date: Sun May 16 15:33:26 2010
New Revision: 46704
URL: https://trac.parrot.org/parrot/changeset/46704
Log:
[LWP] "GET http://www.parrot.org HTTP/1.1" works
Modified:
trunk/runtime/parrot/library/HTTP/Message.pir
trunk/runtime/parrot/library/LWP.pir
trunk/t/library/lwp.t
Modified: trunk/runtime/parrot/library/HTTP/Message.pir
==============================================================================
--- trunk/runtime/parrot/library/HTTP/Message.pir Sun May 16 15:30:53 2010 (r46703)
+++ trunk/runtime/parrot/library/HTTP/Message.pir Sun May 16 15:33:26 2010 (r46704)
@@ -74,6 +74,7 @@
$P0 = newclass ['HTTP';'Message']
$P0.'add_attribute'('headers')
$P0.'add_attribute'('content')
+ $P0.'add_attribute'('protocol')
.end
.sub 'init' :vtable :method
@@ -83,6 +84,15 @@
setattribute self, 'content', $P0
.end
+=item protocol
+
+=cut
+
+.sub 'protocol' :method
+ $P0 = getattribute self, 'protocol'
+ .return ($P0)
+.end
+
=item headers
=cut
@@ -275,6 +285,40 @@
$P0.'add_attribute'('request')
.end
+.sub 'parse' :method
+ .param string str
+ $P0 = split "\r\n\r\n", str
+ $S0 = shift $P0
+ $P1 = split "\r\n", $S0
+ .local string status_line
+ status_line = shift $P1
+ $P2 = split " ", status_line
+ $S0 = shift $P2
+ $P3 = box $S0
+ setattribute self, 'protocol', $P3
+ $S0 = shift $P2
+ $P3 = box $S0
+ setattribute self, 'code', $P3
+ $S0 = join " ", $P2
+ $P3 = box $S0
+ setattribute self, 'message', $P3
+ $P3 = new ['HTTP';'Headers']
+ L1:
+ unless $P1 goto L2
+ $S0 = shift $P1
+ $P2 = split ": ", $S0
+ $S1 = shift $P2
+ $S2 = shift $P2
+ $P3[$S1] = $S2
+ goto L1
+ L2:
+ setattribute self, 'headers', $P3
+ .local string content
+ content = shift $P0
+ $P3 = box content
+ setattribute self, 'content', $P3
+.end
+
=item code
=cut
Modified: trunk/runtime/parrot/library/LWP.pir
==============================================================================
--- trunk/runtime/parrot/library/LWP.pir Sun May 16 15:30:53 2010 (r46703)
+++ trunk/runtime/parrot/library/LWP.pir Sun May 16 15:33:26 2010 (r46704)
@@ -21,6 +21,7 @@
.sub '' :init :load :anon
load_bytecode 'HTTP/Message.pir'
$P0 = newclass ['LWP';'UserAgent']
+ $P0.'add_attribute'('def_headers')
$P0.'add_attribute'('show_progress')
$P0.'add_attribute'('progress_start')
$P0.'add_attribute'('progress_lastp')
@@ -38,6 +39,9 @@
.end
.sub 'init' :vtable :method
+ $P0 = new ['HTTP';'Headers']
+ $P0['User-Agent'] = 'libwww-parrot'
+ setattribute self, 'def_headers', $P0
$P0 = box 7
setattribute self, 'max_redirect', $P0
.end
@@ -69,6 +73,31 @@
.return (response)
.end
+.sub 'prepare_request' :method
+ .param pmc request
+ $P0 = request.'method'()
+ unless null $P0 goto L1
+ die "Method missing"
+ L1:
+ $P0 = request.'uri'()
+ unless null $P0 goto L2
+ die "URL missing"
+ L2:
+ $S0 = $P0.'scheme'()
+ unless $S0 == '' goto L3
+ die "URL must be absolute"
+ L3:
+ $P0 = getattribute self, 'def_headers'
+ $P1 = iter $P0
+ L4:
+ unless $P1 goto L5
+ $S0 = shift $P1
+ $S1 = $P0[$S0]
+ request.'push_header'($S0, $S1)
+ goto L4
+ L5:
+.end
+
.sub 'simple_request' :method
.param pmc request
unless null request goto L1
@@ -78,6 +107,7 @@
if $I0 goto L2
die "You need a ['HTTP';'Request']"
L2:
+ self.'prepare_request'(request)
.tailcall self.'send_request'(request)
.end
@@ -170,6 +200,19 @@
.tailcall self.'request'(request)
.end
+=item put
+
+=cut
+
+.sub 'put' :method
+ .param pmc args :slurpy
+ .param pmc kv :slurpy :named
+ .local pmc request
+ $P0 = get_hll_global ['HTTP';'Request'], 'PUT'
+ request = $P0(args :flat, kv :flat :named)
+ .tailcall self.'request'(request)
+.end
+
=item delete
=cut
@@ -263,6 +306,16 @@
setattribute self, 'show_progress', val
.end
+=item agent
+
+=cut
+
+.sub 'agent' :method
+ .param string val
+ $P0 = getattribute self, 'def_headers'
+ $P0['User-Agent'] = val
+.end
+
=item env_provy
=cut
@@ -459,7 +512,7 @@
.return (response)
.end
-.sub 'POST' :method :nsentry
+.sub 'PUT' :method :nsentry
.param pmc request
.local pmc response
response = new ['HTTP';'Response']
@@ -534,10 +587,97 @@
.namespace ['LWP';'Protocol';'http']
+.include 'socket.pasm'
+
.sub '' :init :load :anon
$P0 = subclass ['LWP';'Protocol'], ['LWP';'Protocol';'http']
.end
+.sub '_new_socket' :method
+ .param string host
+ .param int port
+ .local pmc sock, addr
+ sock = new 'Socket'
+ sock.'socket'(.PIO_PF_INET, .PIO_SOCK_STREAM, .PIO_PROTO_TCP)
+ addr = sock.'sockaddr'(host, port)
+ sock.'connect'(addr)
+ .return (sock)
+.end
+
+.sub '_fixup_header' :method
+ .param pmc headers
+ .param pmc url
+ .local string host
+ host = url.'authority'()
+ headers['Host'] = host
+.end
+
+.sub '_format_request'
+ .param string method
+ .param string uri
+ .param pmc headers
+ .param string content
+ .const string CRLF = "\r\n"
+ $P0 = new 'StringBuilder'
+ push $P0, method
+ push $P0, ' '
+ push $P0, uri
+ push $P0, ' HTTP/1.1'
+ push $P0, CRLF
+ $P1 = iter headers
+ L1:
+ unless $P1 goto L2
+ $S0 = shift $P1
+ $S1 = headers[$S0]
+ push $P0, $S0
+ push $P0, ': '
+ push $P0, $S1
+ push $P0, CRLF
+ goto L1
+ L2:
+ push $P0, CRLF
+ push $P0, content
+ .return ($P0)
+.end
+
+.sub 'request' :method
+ .param pmc request
+
+ .local string method
+ method = request.'method'()
+ .local pmc url
+ url = request.'uri'()
+ .local string host, port, fullpath
+ host = url.'host'()
+ port = url.'port'()
+ fullpath = url.'path_query'()
+ $I0 = index fullpath, '/'
+ if $I0 == 0 goto L1
+ fullpath = '/' . fullpath
+ L1:
+
+ # connect to remote site
+ .local pmc sock
+ sock = self.'_new_socket'(host, port)
+
+ .local pmc request_headers
+ request_headers = request.'headers'()
+ self.'_fixup_header'(request_headers, url)
+
+ .local string content
+ content = request.'content'()
+
+ $S0 = _format_request(method, url, request_headers, content)
+ sock.'send'($S0)
+ $S1 = sock.'recv'()
+ sock.'close'()
+
+ .local pmc response
+ response = new ['HTTP';'Response']
+ response.'parse'($S1)
+ .return (response)
+.end
+
=head1 AUTHOR
Francois Perrad
Modified: trunk/t/library/lwp.t
==============================================================================
--- trunk/t/library/lwp.t Sun May 16 15:30:53 2010 (r46703)
+++ trunk/t/library/lwp.t Sun May 16 15:33:26 2010 (r46704)
@@ -22,9 +22,10 @@
load_bytecode 'LWP.pir'
load_bytecode 'osutils.pbc'
- plan(34)
+ plan(38)
test_new()
test_unknown_protocol()
+ test_bad_request()
test_file_not_found()
test_file()
test_file_post_delete()
@@ -73,6 +74,20 @@
ok($I0, "is error")
.end
+.sub 'test_bad_request'
+ .local pmc ua, response
+ ua = new ['LWP';'UserAgent']
+ response = ua.'post'('file:foo/bar')
+ $I0 = isa response, ['HTTP';'Response']
+ ok($I0, "GET unk:foo/bar")
+ $I0 = response.'code'()
+ is($I0, 400, "code bad request")
+ $S0 = response.'message'()
+ is($S0, "Library does not allow method POST for 'file:' URLs", "message")
+ $I0 = response.'is_error'()
+ ok($I0, "is error")
+.end
+
.sub 'test_file_not_found'
unlink('t/no_file')
.local pmc ua, response
@@ -121,7 +136,7 @@
.local pmc ua, response
ua = new ['LWP';'UserAgent']
- response = ua.'post'(url, data)
+ response = ua.'put'(url, data)
$I0 = isa response, ['HTTP';'Response']
ok($I0, "POST file:t/library/file.txt")
$I0 = response.'code'()
More information about the parrot-commits
mailing list