Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

add an LWP library (first step: protocole file)

git-svn-id: https://svn.parrot.org/parrot/trunk@46614 d31e2699-5ff4-0310-a27c-f18f2fbe73fe
  • Loading branch information...
commit 9de3d96955d8305b11ff23cb3e29586922427aa9 1 parent 2d3600e
@fperrad fperrad authored
View
5 MANIFEST
@@ -1,7 +1,7 @@
# ex: set ro:
# $Id$
#
-# generated by tools/dev/mk_manifest_and_skip.pl Fri May 14 07:19:07 2010 UT
+# generated by tools/dev/mk_manifest_and_skip.pl Fri May 14 15:26:02 2010 UT
#
# See below for documentation on the format of this file.
#
@@ -1138,8 +1138,10 @@ runtime/parrot/library/Data/Dumper/Default.pir [library]
runtime/parrot/library/Digest/MD5.pir [library]
runtime/parrot/library/Getopt/Obj.pir [library]
runtime/parrot/library/HTTP/Daemon.pir [library]
+runtime/parrot/library/HTTP/Message.pir [library]
runtime/parrot/library/Iter.pir [library]
runtime/parrot/library/JSON.pir [library]
+runtime/parrot/library/LWP.pir [library]
runtime/parrot/library/MIME/Base64.pir [library]
runtime/parrot/library/Math/Rand.pir [library]
runtime/parrot/library/NCI/Utils.pir [library]
@@ -1655,6 +1657,7 @@ t/library/dumper.t [test]
t/library/getopt_obj.t [test]
t/library/hllmacros.t [test]
t/library/iter.t [test]
+t/library/lwp.t [test]
t/library/md5.t [test]
t/library/mime_base64.t [test]
t/library/osutils.t [test]
View
2  MANIFEST.generated
@@ -229,8 +229,10 @@ runtime/parrot/library/Digest/MD5.pbc [main]
runtime/parrot/library/Getopt/Obj.pbc [main]
runtime/parrot/library/HLL.pbc [main]
runtime/parrot/library/HTTP/Daemon.pbc [main]
+runtime/parrot/library/HTTP/Message.pbc [main]
runtime/parrot/library/Iter.pbc [main]
runtime/parrot/library/JSON.pbc [main]
+runtime/parrot/library/LWP.pbc [main]
runtime/parrot/library/MIME/Base64.pbc [main]
runtime/parrot/library/Math/Rand.pbc [main]
runtime/parrot/library/NCI/call_toolkit_init.pbc [main]
View
2  config/gen/makefiles/root.in
@@ -271,8 +271,10 @@ GEN_LIBRARY = \
$(LIBRARY_DIR)/dumper.pbc \
$(LIBRARY_DIR)/yaml_dumper.pbc \
$(LIBRARY_DIR)/Getopt/Obj.pbc \
+ $(LIBRARY_DIR)/HTTP/Message.pbc \
$(LIBRARY_DIR)/Iter.pbc \
$(LIBRARY_DIR)/JSON.pbc \
+ $(LIBRARY_DIR)/LWP.pbc \
$(LIBRARY_DIR)/Math/Rand.pbc \
$(LIBRARY_DIR)/MIME/Base64.pbc \
$(LIBRARY_DIR)/NCI/Utils.pbc \
View
385 runtime/parrot/library/HTTP/Message.pir
@@ -0,0 +1,385 @@
+# Copyright (C) 2010, Parrot Foundation.
+# $Id$
+
+=head1 NAME
+
+LWP - The World-Wide Web library for Parrot
+
+=head2 DESCRIPTION
+
+Simplified port of LWP (version 5.834)
+see http://search.cpan.org/~gaas/libwww-perl/
+
+=head3 HTTP;Date
+
+=over 4
+
+=cut
+
+.namespace ['HTTP';'Date']
+
+.include 'tm.pasm'
+
+.sub 'time2str'
+ .param int time
+ $P0 = decodetime time
+ $P1 = new 'FixedPMCArray'
+ set $P1, 7
+ $I0 = $P0[.TM_WDAY]
+ $P2 = split ' ', 'Sun Mon Tue Wed Thu Fri Sat'
+ $S0 = $P2[$I0]
+ $P1[0] = $S0
+ $I0 = $P0[.TM_MDAY]
+ $P1[1] = $I0
+ $I0 = $P0[.TM_MON]
+ $P3 = split ' ', 'Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec'
+ dec $I0
+ $S0 = $P3[$I0]
+ $P1[2] = $S0
+ $I0 = $P0[.TM_YEAR]
+ $P1[3] = $I0
+ $I0 = $P0[.TM_HOUR]
+ $P1[4] = $I0
+ $I0 = $P0[.TM_MIN]
+ $P1[5] = $I0
+ $I0 = $P0[.TM_SEC]
+ $P1[6] = $I0
+ $S0 = sprintf "%s, %02d %s %04d %02d:%02d:%02d GMT", $P1
+ .return ($S0)
+.end
+
+=head3 Class HTTP;Headers
+
+=over 4
+
+=cut
+
+.namespace ['HTTP';'Headers']
+
+.sub '' :init :load :anon
+ $P0 = subclass 'Hash', ['HTTP';'Headers']
+.end
+
+=back
+
+=head3 Class HTTP;Message
+
+=over 4
+
+=cut
+.namespace ['HTTP';'Message']
+
+.sub '' :init :load :anon
+ $P0 = newclass ['HTTP';'Message']
+ $P0.'add_attribute'('headers')
+ $P0.'add_attribute'('content')
+.end
+
+.sub 'init' :vtable :method
+ $P0 = new ['HTTP';'Headers']
+ setattribute self, 'headers', $P0
+ $P0 = box ''
+ setattribute self, 'content', $P0
+.end
+
+=item headers
+
+=cut
+
+.sub 'headers' :method
+ $P0 = getattribute self, 'headers'
+ .return ($P0)
+.end
+
+=item push_header
+
+=cut
+
+.sub 'push_header' :method
+ .param string key
+ .param string value
+ $P0 = getattribute self, 'headers'
+ $P0[key] = value
+.end
+
+=item get_header
+
+=cut
+
+.sub 'get_header' :method
+ .param string key
+ $P0 = getattribute self, 'headers'
+ $S0 = $P0[key]
+ .return ($S0)
+.end
+
+=item content
+
+=cut
+
+.sub 'content' :method
+ $P0 = getattribute self, 'content'
+ .return ($P0)
+.end
+
+=back
+
+=head3 Class HTTP;Request
+
+=over 4
+
+=cut
+
+.namespace ['HTTP';'Request']
+
+.sub '' :init :load :anon
+ load_bytecode 'URI.pir'
+ $P0 = subclass ['HTTP';'Message'], ['HTTP';'Request']
+ $P0.'add_attribute'('method')
+ $P0.'add_attribute'('uri')
+.end
+
+=item method
+
+=cut
+
+.sub 'method' :method
+ $P0 = getattribute self, 'method'
+ .return ($P0)
+.end
+
+=item uri
+
+=cut
+
+.sub 'uri' :method
+ $P0 = getattribute self, 'uri'
+ .return ($P0)
+.end
+
+=item GET
+
+=cut
+
+.sub 'GET'
+ .param pmc args :slurpy
+ .param pmc kv :slurpy :named
+ .tailcall _simple_req('GET', args :flat, kv :flat :named)
+.end
+
+=item HEAD
+
+=cut
+
+.sub 'HEAD'
+ .param pmc args :slurpy
+ .param pmc kv :slurpy :named
+ .tailcall _simple_req('HEAD', args :flat, kv :flat :named)
+.end
+
+=item PUT
+
+=cut
+
+.sub 'PUT'
+ .param pmc args :slurpy
+ .param pmc kv :slurpy :named
+ .tailcall _simple_req('PUT', args :flat, kv :flat :named)
+.end
+
+=item DELETE
+
+=cut
+
+.sub 'DELETE'
+ .param pmc args :slurpy
+ .param pmc kv :slurpy :named
+ .tailcall _simple_req('DELETE', args :flat, kv :flat :named)
+.end
+
+=item POST
+
+=cut
+
+.sub 'POST'
+ .param pmc args :slurpy
+ .param pmc kv :slurpy :named
+ .tailcall _simple_req('POST', args :flat, kv :flat :named)
+.end
+
+.sub '_simple_req'
+ .param string method
+ .param string url
+ .param pmc contents :slurpy
+ .param pmc headers :slurpy :named
+ .local pmc req
+ req = new ['HTTP';'Request']
+ $P0 = box method
+ setattribute req, 'method', $P0
+ $P0 = get_hll_global ['URI'], 'new_from_string'
+ $P1 = $P0(url)
+ setattribute req, 'uri', $P1
+ $P0 = iter headers
+ L1:
+ unless $P0 goto L2
+ $S0 = shift $P0
+ $S1 = headers[$S0]
+ req.'push_headers'($S0, $S1)
+ goto L1
+ L2:
+ $P0 = iter contents
+ unless $P0 goto L3
+ .local pmc content
+ content = getattribute req, 'content'
+ L4:
+ unless $P0 goto L5
+ $S0 = shift $P0
+ content .= $S0
+ goto L4
+ L5:
+ $S0 = req.'get_header'('Content-Length')
+ unless $S0 == '' goto L3
+ $S0 = content
+ $I0 = length $S0
+ req.'push_header'('Content-Length', $I0)
+ L3:
+ .return (req)
+.end
+
+=back
+
+=head3 Class HTTP;Response
+
+=over 4
+
+=cut
+
+.namespace ['HTTP';'Response']
+
+.sub '' :init :load :anon
+ $P0 = subclass ['HTTP';'Message'], ['HTTP';'Response']
+ $P0.'add_attribute'('code')
+ $P0.'add_attribute'('message')
+ $P0.'add_attribute'('request')
+.end
+
+=item code
+
+=cut
+
+.sub 'code' :method
+ $P0 = getattribute self, 'code'
+ .return ($P0)
+.end
+
+=item message
+
+=cut
+
+.sub 'message' :method
+ $P0 = getattribute self, 'message'
+ .return ($P0)
+.end
+
+=item request
+
+=cut
+
+.sub 'request' :method
+ $P0 = getattribute self, 'request'
+ .return ($P0)
+.end
+
+=item status_line
+
+=cut
+
+.sub 'status_line' :method
+ $P0 = getattribute self, 'code'
+ $S0 = $P0
+ $P0 = getattribute self, 'message'
+ if null $P0 goto L1
+ $S1 = $P0
+ $S0 .= ' '
+ $S0 .= $S1
+ L1:
+ .return ($S0)
+.end
+
+=item is_info
+
+=cut
+
+.sub 'is_info' :method
+ $P0 = getattribute self, 'code'
+ .local int code
+ code = $P0
+ $I0 = 0
+ unless code >= 100 goto L1
+ unless code < 200 goto L1
+ $I0 = 1
+ L1:
+ .return ($I0)
+.end
+
+=item is_success
+
+=cut
+
+.sub 'is_success' :method
+ $P0 = getattribute self, 'code'
+ .local int code
+ code = $P0
+ $I0 = 0
+ unless code >= 200 goto L1
+ unless code < 300 goto L1
+ $I0 = 1
+ L1:
+ .return ($I0)
+.end
+
+=item is_redirect
+
+=cut
+
+.sub 'is_redirect' :method
+ $P0 = getattribute self, 'code'
+ .local int code
+ code = $P0
+ $I0 = 0
+ unless code >= 300 goto L1
+ unless code < 400 goto L1
+ $I0 = 1
+ L1:
+ .return ($I0)
+.end
+
+=item is_error
+
+=cut
+
+.sub 'is_error' :method
+ $P0 = getattribute self, 'code'
+ .local int code
+ code = $P0
+ $I0 = 0
+ unless code >= 400 goto L1
+ unless code < 600 goto L1
+ $I0 = 1
+ L1:
+ .return ($I0)
+.end
+
+=back
+
+=head1 AUTHOR
+
+Francois Perrad
+
+=cut
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
View
469 runtime/parrot/library/LWP.pir
@@ -0,0 +1,469 @@
+# Copyright (C) 2010, Parrot Foundation.
+# $Id$
+
+=head1 NAME
+
+LWP - The World-Wide Web library for Parrot
+
+=head2 DESCRIPTION
+
+Simplified port of LWP (version 5.834)
+see http://search.cpan.org/~gaas/libwww-perl/
+
+=head3 Class LWP;UserAgent
+
+=over 4
+
+=cut
+
+.namespace ['LWP';'UserAgent']
+
+.sub '' :init :load :anon
+ load_bytecode 'HTTP/Message.pir'
+ $P0 = newclass ['LWP';'UserAgent']
+ $P0.'add_attribute'('show_progress')
+ $P0.'add_attribute'('progress_start')
+ $P0.'add_attribute'('progress_lastp')
+ $P0.'add_attribute'('progress_ani')
+ .globalconst int RC_OK = 200
+ .globalconst int RC_BAD_REQUEST = 400
+ .globalconst int RC_NOT_FOUND = 404
+ .globalconst int RC_INTERNAL_SERVER_ERROR = 500
+ .globalconst int RC_NOT_IMPLEMENTED = 501
+.end
+
+.sub 'send_request' :method
+ .param pmc request
+ .local string method
+ method = request.'method'()
+ .local pmc url
+ url = request.'uri'()
+ .local string scheme
+ scheme = url.'scheme'()
+ self.'progress'('begin', request)
+ .local pmc protocol, response
+ $P0 =get_hll_global ['LWP';'Protocol'], 'create'
+ protocol = $P0(scheme, self)
+ unless null protocol goto L1
+ response = _new_response(request, RC_NOT_IMPLEMENTED, 'Not Implemented')
+ goto L2
+ L1:
+ response = protocol.'request'(request)
+ setattribute response, 'request', request
+ $P0 = get_hll_global ['HTTP';'Date'], 'time2str'
+ $I0 = time
+ $S0 = $P0($I0)
+ response.'push_header'('Client-Date', $S0)
+ L2:
+ self.'progress'('end', response)
+ .return (response)
+.end
+
+.sub 'simple_request' :method
+ .param pmc request
+ unless null request goto L1
+ die "No request object passed in"
+ L1:
+ $I0 = isa request, ['HTTP';'Request']
+ if $I0 goto L2
+ die "You need a ['HTTP';'Request']"
+ L2:
+ .tailcall self.'send_request'(request)
+.end
+
+.sub 'request' :method
+ .param pmc request
+ .local pmc response
+ response = self.'simple_request'(request)
+ .local int code
+ code = response.'code'()
+ .return (response)
+.end
+
+=item get
+
+=cut
+
+.sub 'get' :method
+ .param pmc args :slurpy
+ .param pmc kv :slurpy :named
+ .local pmc request
+ $P0 = get_hll_global ['HTTP';'Request'], 'GET'
+ request = $P0(args :flat, kv :flat :named)
+ .tailcall self.'request'(request)
+.end
+
+=item post
+
+=cut
+
+.sub 'post' :method
+ .param pmc args :slurpy
+ .param pmc kv :slurpy :named
+ .local pmc request
+ $P0 = get_hll_global ['HTTP';'Request'], 'POST'
+ request = $P0(args :flat, kv :flat :named)
+ .tailcall self.'request'(request)
+.end
+
+=item delete
+
+=cut
+
+.sub 'delete' :method
+ .param pmc args :slurpy
+ .param pmc kv :slurpy :named
+ .local pmc request
+ $P0 = get_hll_global ['HTTP';'Request'], 'DELETE'
+ request = $P0(args :flat, kv :flat :named)
+ .tailcall self.'request'(request)
+.end
+
+.sub 'progress' :method
+ .param string status
+ .param pmc msg
+ $P0 = getattribute self, 'show_progress'
+ if null $P0 goto L1
+ unless $P0 goto L1
+ unless status == 'begin' goto L2
+ printerr "** "
+ $P0 = getattribute msg, 'method'
+ printerr $P0
+ printerr " "
+ $P0 = getattribute msg, 'uri'
+ printerr $P0
+ printerr " ==> "
+ $N1 = time
+ $P0 = box $N1
+ setattribute self, 'progress_start', $P0
+ $P0 = box ''
+ setattribute self, 'progress_lastp', $P0
+ $P0 = box 0
+ setattribute self, 'progress_ani', $P0
+ goto L1
+ L2:
+ unless status == 'end' goto L3
+ $P0 = getattribute self, 'progress_start'
+ $N1 = $P0
+ $N2 = time
+ null $P0
+ setattribute self, 'progress_start', $P0
+ setattribute self, 'progress_lastp', $P0
+ setattribute self, 'progress_ani', $P0
+ $S0 = msg.'status_line'()
+ printerr $S0
+ $N0 =$N2 - $N1
+ $I0 = $N0
+ unless $I0 goto L4
+ printerr " ("
+ printerr $I0
+ printerr "s)"
+ L4:
+ printerr "\n"
+ goto L1
+ L3:
+ unless status == 'tick' goto L5
+
+ # work in progress
+
+ goto L1
+ L5:
+
+ # work in progress
+
+ L1:
+.end
+
+=item show_progress
+
+=cut
+
+.sub 'show_progress' :method
+ .param pmc val
+ setattribute self, 'show_progress', val
+.end
+
+=item env_provy
+
+=cut
+
+.sub 'env_proxy' :method
+ $P0 = new 'Env'
+ $P1 = iter $P0
+ L1:
+ unless $P1 goto L2
+ $S0 = shift $P1
+ $S1 = downcase $S0
+
+ # work in progress
+
+ goto L1
+ L2:
+.end
+
+.sub '_new_response'
+ .param pmc request
+ .param pmc code
+ .param pmc message
+ $P0 = new ['HTTP';'Response']
+ setattribute $P0, 'code', code
+ setattribute $P0, 'message', message
+ setattribute $P0, 'request', request
+ $P0 = get_hll_global ['HTTP';'Date'], 'time2str'
+ $I0 = time
+ $S0 = $P0($I0)
+ $P0.'push_header'('Client-Date', $S0)
+ $P0.'push_header'('Client-Warning', "Internal response")
+ $P0.'push_header'('Content-Type', 'text/plain')
+ $S0 = code
+ $S0 .= ' '
+ $S1 = message
+ $S0 .= $S1
+ $S0 .= "\n"
+ $P0 = box $S0
+ setattribute $P0, 'content', $P0
+ .return ($P0)
+.end
+
+=back
+
+=head3 Class LWP;Protocol
+
+=over 4
+
+=cut
+
+.namespace ['LWP';'Protocol']
+
+.sub '' :init :load :anon
+ $P0 = newclass ['LWP';'Protocol']
+ $P0.'add_attribute'('scheme')
+ $P0.'add_attribute'('ua')
+.end
+
+=item create
+
+=cut
+
+.sub 'create'
+ .param string scheme
+ .param pmc ua
+ $P1 = new 'Key'
+ set $P1, 'LWP'
+ $P2 = new 'Key'
+ set $P2, 'Protocol'
+ push $P1, $P2
+ $P3 = new 'Key'
+ set $P3, scheme
+ push $P1, $P3
+ $P0 = get_class $P1
+ unless null $P0 goto L1
+ .return ($P0)
+ L1:
+ $P0 = new $P0
+ $P1 = box scheme
+ setattribute $P0, 'scheme', $P1
+ setattribute $P0, 'ua', ua
+ .return ($P0)
+.end
+
+.sub 'request' :method
+ .param pmc args :slurpy
+ die 'LWP::Protocol::request() needs to be overridden in subclasses'
+.end
+
+=back
+
+=head3 Class LWP;Protocol;file
+
+=cut
+
+.namespace ['LWP';'Protocol';'file']
+
+.include 'stat.pasm'
+
+.sub '' :init :load :anon
+ load_bytecode 'osutils.pbc'
+ $P0 = subclass ['LWP';'Protocol'], ['LWP';'Protocol';'file']
+.end
+
+.sub 'request' :method
+ .param pmc request
+ .local string method
+ method = request.'method'()
+ $P0 = get_hll_global ['LWP';'Protocol';'file'], method
+ unless null $P0 goto L1
+ $P0 = new ['HTTP';'Response']
+ $P1 = box RC_BAD_REQUEST
+ setattribute $P0, 'code', $P1
+ $S0 = "Library does not allow method " . method
+ $S0 .= " for 'file:' URLs"
+ $P1 = box $S0
+ setattribute $P0, 'message', $P1
+ .return ($P0)
+ L1:
+ .local pmc url
+ url = request.'uri'()
+ .local string scheme
+ scheme = url.'scheme'()
+ if scheme == 'file' goto L2
+ $P0 = new ['HTTP';'Response']
+ $P1 = box RC_INTERNAL_SERVER_ERROR
+ setattribute $P0, 'code', $P1
+ $S0 = "LWP::Protocol::file::request called for '" . scheme
+ $S0 .= "'"
+ $P1 = box $S0
+ setattribute $P0, 'message', $P1
+ .return ($P0)
+ L2:
+ .tailcall $P0(self, request)
+.end
+
+.sub 'HEAD' :method :nsentry
+ .param pmc request
+ .tailcall self.'GET'(request)
+.end
+
+.sub 'GET' :method :nsentry
+ .param pmc request
+ .local pmc response
+ response = new ['HTTP';'Response']
+ .local string method
+ method = request.'method'()
+ .local pmc url
+ url = request.'uri'()
+ .local string path
+ path = url.'path'()
+
+ $I0 = stat path, .STAT_EXISTS
+ if $I0 goto L1
+ $P0 = box RC_NOT_FOUND
+ setattribute response, 'code', $P0
+ $S0 = "File `" . path
+ $S0 .= "' does not exist"
+ $P0 = box $S0
+ setattribute response, 'message', $P0
+ .return (response)
+ L1:
+
+ .local int mtime
+ mtime = stat path, .STAT_MODIFYTIME
+ $P0 = get_hll_global ['HTTP';'Date'], 'time2str'
+ $S0 = $P0(mtime)
+ response.'push_header'('Last-Modified', $S0)
+ .local int filesize
+ filesize = stat path, .STAT_FILESIZE
+ response.'push_header'('Content-Length', filesize)
+
+ if method == 'HEAD' goto L2
+ push_eh _handler
+ $S0 = slurp(path)
+ pop_eh
+ $P0 = box $S0
+ setattribute response, 'content', $P0
+ L2:
+ $P0 = box RC_OK
+ setattribute response, 'code', $P0
+ .return (response)
+
+ _handler:
+ .local pmc ex
+ .get_results (ex)
+ $P0 = box RC_INTERNAL_SERVER_ERROR
+ setattribute response, 'code', $P0
+ $S0 = ex
+ $P0 = box $S0
+ setattribute response, 'message', $P0
+ .return (response)
+.end
+
+.sub 'POST' :method :nsentry
+ .param pmc request
+ .local pmc response
+ response = new ['HTTP';'Response']
+ .local pmc url
+ url = request.'uri'()
+ .local string path
+ path = url.'path'()
+ .local string content
+ content = request.'content'()
+
+ push_eh _handler
+ $S0 = spew(path, content)
+ pop_eh
+
+ $P0 = box RC_OK
+ setattribute response, 'code', $P0
+ .return (response)
+
+ _handler:
+ .local pmc ex
+ .get_results (ex)
+ $P0 = box RC_INTERNAL_SERVER_ERROR
+ setattribute response, 'code', $P0
+ $S0 = ex
+ $P0 = box $S0
+ setattribute response, 'message', $P0
+ .return (response)
+.end
+
+.sub 'DELETE' :method :nsentry
+ .param pmc request
+ .local pmc response
+ response = new ['HTTP';'Response']
+ .local pmc url
+ url = request.'uri'()
+ .local string path
+ path = url.'path'()
+
+ $I0 = stat path, .STAT_EXISTS
+ if $I0 goto L1
+ $P0 = box RC_NOT_FOUND
+ setattribute response, 'code', $P0
+ $S0 = "File `" . path
+ $S0 .= "' does not exist"
+ $P0 = box $S0
+ setattribute response, 'message', $P0
+ .return (response)
+ L1:
+
+ push_eh _handler
+ $S0 = unlink(path)
+ pop_eh
+
+ $P0 = box RC_OK
+ setattribute response, 'code', $P0
+ .return (response)
+
+ _handler:
+ .local pmc ex
+ .get_results (ex)
+ $P0 = box RC_INTERNAL_SERVER_ERROR
+ setattribute response, 'code', $P0
+ $S0 = ex
+ $P0 = box $S0
+ setattribute response, 'message', $P0
+ .return (response)
+.end
+
+=head3 Class LWP;Protocol;http
+
+=cut
+
+.namespace ['LWP';'Protocol';'http']
+
+.sub '' :init :load :anon
+ $P0 = subclass ['LWP';'Protocol'], ['LWP';'Protocol';'http']
+.end
+
+=head1 AUTHOR
+
+Francois Perrad
+
+=cut
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:
View
141 t/library/lwp.t
@@ -0,0 +1,141 @@
+#!./parrot
+# Copyright (C) 2010, Parrot Foundation.
+# $Id$
+
+=head1 NAME
+
+t/library/lwp.t
+
+=head1 DESCRIPTION
+
+Test the LWP library
+
+=head1 SYNOPSIS
+
+ % prove t/library/lwp.t
+
+=cut
+
+.sub 'main' :main
+ .include 'test_more.pir'
+
+ load_bytecode 'LWP.pir'
+
+ plan(30)
+ test_new()
+ test_file_not_found()
+ test_file()
+ test_file_post_delete()
+.end
+
+.sub 'test_new'
+ $P0 = new ['LWP';'UserAgent']
+ $I0 = isa $P0, ['LWP';'UserAgent']
+ ok($I0, "new ['LWP';'UserAgent']")
+
+ $P0 = new ['LWP';'Protocol';'file']
+ $I0 = isa $P0, ['LWP';'Protocol';'file']
+ ok($I0, "new ['LWP';'Protocol';'file']")
+ $I0 = isa $P0, ['LWP';'Protocol']
+ ok($I0, "isa ['LWP';'Protocol']")
+
+ $P0 = new ['LWP';'Protocol';'http']
+ $I0 = isa $P0, ['LWP';'Protocol';'http']
+ ok($I0, "new ['LWP';'Protocol';'http']")
+ $I0 = isa $P0, ['LWP';'Protocol']
+ ok($I0, "isa ['LWP';'Protocol']")
+
+ $P0 = new ['HTTP';'Request']
+ $I0 = isa $P0, ['HTTP';'Request']
+ ok($I0, "new ['HTTP';'Request']")
+ $I0 = isa $P0, ['HTTP';'Message']
+ ok($I0, "isa ['HTTP';'Message']")
+ $P0 = new ['HTTP';'Response']
+ $I0 = isa $P0, ['HTTP';'Response']
+ ok($I0, "new ['HTTP';'Response']")
+ $I0 = isa $P0, ['HTTP';'Message']
+ ok($I0, "isa ['HTTP';'Message']")
+.end
+
+.sub 'test_file_not_found'
+ unlink('t/no_file')
+ .local pmc ua, response
+ ua = new ['LWP';'UserAgent']
+ response = ua.'get'('file:t/no_file')
+ $I0 = isa response, ['HTTP';'Response']
+ ok($I0, "GET file:t/no_file")
+ $I0 = response.'code'()
+ is($I0, 404, "code")
+ $S0 = response.'message'()
+ is($S0, "File `t/no_file' does not exist", "message")
+ $I0 = response.'is_error'()
+ ok($I0, "is error")
+.end
+
+.sub 'test_file'
+ .local pmc ua, response
+ ua = new ['LWP';'UserAgent']
+ response = ua.'get'('file:t/library/lwp.t')
+ $I0 = isa response, ['HTTP';'Response']
+ ok($I0, "GET file:t/library/lwp.t")
+ $I0 = response.'code'()
+ is($I0, 200, "code")
+ $I0 = response.'is_success'()
+ ok($I0, "is success")
+ $S0 = response.'content'()
+ $I0 = index $S0, 'Test the LWP library'
+ $I0 = $I0 > 0
+ ok($I0, "content looks good")
+ $I0 = response.'get_header'('Content-Length')
+ $I0 = $I0 > 2000
+ ok($I0, "Content-Length")
+ $S0 = response.'get_header'('Last-Modified')
+ diag($S0)
+ $I0 = index $S0, 'GMT'
+ $I0 = $I0 > 0
+ ok($I0, "Last-Modified contains GMT")
+.end
+
+.sub 'test_file_post_delete'
+ .const string data = "the file contains some text"
+ .const string filename = 't/library/file.txt'
+ .const string url = 'file:t/library/file.txt'
+ unlink(filename)
+
+ .local pmc ua, response
+ ua = new ['LWP';'UserAgent']
+
+ response = ua.'post'(url, data)
+ $I0 = isa response, ['HTTP';'Response']
+ ok($I0, "POST file:t/library/file.txt")
+ $I0 = response.'code'()
+ is($I0, 200, "code")
+ $I0 = response.'is_success'()
+ ok($I0, "is success")
+ $S0 = slurp(filename)
+ is($S0, data, "file content comparison")
+
+ response = ua.'delete'(url)
+ $I0 = isa response, ['HTTP';'Response']
+ ok($I0, "DELETE file:t/library/file.txt")
+ $I0 = response.'code'()
+ is($I0, 200, "code")
+ $I0 = response.'is_success'()
+ ok($I0, "is success")
+
+ response = ua.'delete'(url)
+ $I0 = isa response, ['HTTP';'Response']
+ ok($I0, "DELETE file:t/library/file.txt")
+ $I0 = response.'code'()
+ is($I0, 404, "code")
+ $S0 = response.'message'()
+ is($S0, "File `t/library/file.txt' does not exist", "message")
+ $I0 = response.'is_error'()
+ ok($I0, "is error")
+.end
+
+# Local Variables:
+# mode: pir
+# fill-column: 100
+# End:
+# vim: expandtab shiftwidth=4 ft=pir:

0 comments on commit 9de3d96

Please sign in to comment.
Something went wrong with that request. Please try again.