From cbfee961233c1f0e0c1479797a013c4cd6373b06 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Fran=C3=A7ois=20Perrad?= <francois.perrad@gadz.org>
Date: Mon, 17 May 2010 13:58:39 +0000
Subject: [PATCH] [LWP] request POST (step 1)

git-svn-id: https://svn.parrot.org/parrot/trunk@46738 d31e2699-5ff4-0310-a27c-f18f2fbe73fe
---
 runtime/parrot/library/HTTP/Message.pir | 166 ++++++++++++++++++++++--
 1 file changed, 154 insertions(+), 12 deletions(-)

diff --git a/runtime/parrot/library/HTTP/Message.pir b/runtime/parrot/library/HTTP/Message.pir
index 9f73080b47..7c0ddd513a 100644
--- a/runtime/parrot/library/HTTP/Message.pir
+++ b/runtime/parrot/library/HTTP/Message.pir
@@ -80,8 +80,6 @@ see http://search.cpan.org/~gaas/libwww-perl/
 .sub 'init' :vtable :method
     $P0 = new ['HTTP';'Headers']
     setattribute self, 'headers', $P0
-    $P0 = box ''
-    setattribute self, 'content', $P0
 .end
 
 =item protocol
@@ -153,6 +151,8 @@ see http://search.cpan.org/~gaas/libwww-perl/
 
 .namespace ['HTTP';'Request']
 
+.include 'cclass.pasm'
+
 .sub '' :init :load :anon
     load_bytecode 'URI.pir'
     $P0 = subclass ['HTTP';'Message'], ['HTTP';'Request']
@@ -223,9 +223,56 @@ see http://search.cpan.org/~gaas/libwww-perl/
 =cut
 
 .sub 'POST'
-    .param pmc args :slurpy
-    .param pmc kv :slurpy :named
-    .tailcall _simple_req('POST', args :flat, kv :flat :named)
+    .param string url
+    .param pmc contents :slurpy
+    .param pmc headers :slurpy :named
+    .local pmc req
+    req = new ['HTTP';'Request']
+    $P0 = box 'POST'
+    setattribute req, 'method', $P0
+    $P0 = get_hll_global ['URI'], 'new_from_string'
+    $P0 = $P0(url)
+    setattribute req, 'uri', $P0
+    $P0 = iter headers
+  L1:
+    unless $P0 goto L2
+    $S0 = shift $P0
+    $S1 = headers[$S0]
+    req.'push_header'($S0, $S1)
+    goto L1
+  L2:
+    .local string ct
+    ct = req.'get_header'('Content-Type')
+    unless ct == '' goto L3
+    ct = 'application/x-www-form-urlencoded'
+    goto L4
+  L3:
+    unless ct == 'form-data' goto L4
+    ct = 'multipart/form-data'
+  L4:
+
+    $I0 = index ct, 'multipart/form-data'
+    if $I0 < 0 goto L5
+    .local string content, boundary
+    (content, boundary) = form_data(contents, req)
+    ct .= '; boundary='
+    ct .= boundary
+    goto L11
+  L5:
+
+    # work in progress
+
+  L11:
+
+    req.'push_header'('Content-Type', ct)
+    $I0 = 0
+    if content == '' goto L12
+    $P0 = box content
+    setattribute req, 'content', $P0
+    $I0 = length content
+  L12:
+    req.'push_header'('Content-Length', $I0)
+    .return (req)
 .end
 
 .sub '_simple_req'
@@ -238,8 +285,8 @@ see http://search.cpan.org/~gaas/libwww-perl/
     $P0 = box method
     setattribute req, 'method', $P0
     $P0 = get_hll_global ['URI'], 'new_from_string'
-    $P1 = $P0(url)
-    setattribute req, 'uri', $P1
+    $P0 = $P0(url)
+    setattribute req, 'uri', $P0
     $P0 = iter headers
   L1:
     unless $P0 goto L2
@@ -249,24 +296,119 @@ see http://search.cpan.org/~gaas/libwww-perl/
     goto L1
   L2:
     $P0 = iter contents
+    $P1 = new 'StringBuilder'
     unless $P0 goto L3
-    .local pmc content
-    content = getattribute req, 'content'
   L4:
     unless $P0 goto L5
     $S0 = shift $P0
-    content .= $S0
+    push $P1, $S0
     goto L4
   L5:
+    .local string content
+    content = $P1
+    $P0 = box content
+    setattribute req, 'content', $P0
     $S0 = req.'get_header'('Content-Length')
     unless $S0 == '' goto L3
-    $S0 = content
-    $I0 = length $S0
+    $I0 = length content
     req.'push_header'('Content-Length', $I0)
   L3:
     .return (req)
 .end
 
+.sub 'form_data'
+    .param pmc contents
+    .param pmc req
+    .const string CRLF = "\r\n"
+    .local pmc parts
+    parts = new 'ResizableStringArray'
+    $P0 = iter contents
+  L1:
+    unless $P0 goto L2
+    .local pmc k
+    k = shift $P0
+    unless $P0 goto L2
+    .local pmc v
+    v = shift $P0
+    $I0 = does v, 'string'
+    unless $I0 goto L3
+    $P1 = new 'StringBuilder'
+    push $P1, 'Content-Disposition: form-data; name="'
+    push $P1, k
+    push $P1, '"'
+    push $P1, CRLF
+    push $P1, CRLF
+    push $P1, v
+    $S0 = $P1
+    push parts, $S0
+    goto L1
+  L3:
+
+    # work in progress
+
+    goto L1
+  L2:
+
+    .local string _boundary
+    _boundary = boundary(10)
+    $P0 = iter parts
+    $P1 = new 'StringBuilder'
+  L11:
+    unless $P0 goto L12
+    $S0 = shift $P0
+    push $P1, '--'
+    push $P1, _boundary
+    push $P1, CRLF
+    push $P1, $S0
+    push $P1, CRLF
+    goto L11
+  L12:
+    push $P1, '--'
+    push $P1, _boundary
+    push $P1, CRLF
+    $S0 = $P1
+    .return ($S0, _boundary)
+.end
+
+.sub 'boundary'
+    .param int size
+    load_bytecode 'MIME/Base64.pbc'
+    load_bytecode 'Math/Rand.pbc'
+    .local pmc srand
+    srand = get_hll_global ['Math';'Rand'], 'srand'
+    time $I0
+    srand($I0)
+    .local pmc rand
+    rand = get_hll_global ['Math';'Rand'], 'rand'
+    $P0 = new 'StringBuilder'
+    $I0 = size * 3
+  L1:
+    unless $I0 goto L2
+    dec $I0
+    $I1 = rand()
+    $I1 %= 256
+    $S0 = chr $I1
+    push $P0, $S0
+    goto L1
+  L2:
+    $S0 = $P0
+    .local pmc encode
+    encode = get_hll_global  ['MIME';'Base64'], 'encode_base64'
+    $S0 = encode($S0)
+    $I1 = length $S0
+    $I0 = 0
+  L3:
+    unless $I0 < $I1 goto L4
+    $I2 = is_cclass .CCLASS_ALPHANUMERIC , $S0, $I0
+    if $I2 goto L5
+    $S0 = replace $S0, $I0, 1, 'X'
+  L5:
+    inc $I0
+    goto L3
+  L4:
+    .return ($S0)
+.end
+
 =back
 
 =head3 Class HTTP;Response