├── .gitignore ├── .travis.yml ├── META.info ├── README ├── bin ├── lwp-download.pl └── lwp-get.pl ├── lib └── LWP │ └── Simple.pm └── t ├── 000-load-module.t ├── basic-auth.t ├── custom-headers-and-content.t ├── get-binary-camelia.t ├── get-chunked-6guts.t ├── get-perl6-org.t ├── get-unsized.t ├── get-w3-latin1-utf8.t ├── get-w3-redirect.t ├── getstore.t ├── parse-url.t ├── socket-sanity.t └── stringify-headers.t /.gitignore: -------------------------------------------------------------------------------- 1 | Makefile 2 | *.pir 3 | blib 4 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | branches: 2 | except: 3 | - gh-pages 4 | language: perl6 5 | sudo: false 6 | perl6: 7 | - latest 8 | install: 9 | - rakudobrew build-panda 10 | - panda installdeps . 11 | -------------------------------------------------------------------------------- /META.info: -------------------------------------------------------------------------------- 1 | { 2 | "name" : "LWP::Simple", 3 | "version" : "0.086", 4 | "description" : "LWP::Simple quick & dirty implementation for Rakudo Perl 6", 5 | "depends" : [ "MIME::Base64", "URI" ], 6 | "provides" : { 7 | "LWP::Simple" : "lib/LWP/Simple.pm" 8 | }, 9 | "author" : "Cosimo Streppone", 10 | "authority" : "cosimo", 11 | "source-url" : "git://github.com/cosimo/perl6-lwp-simple.git" 12 | } 13 | 14 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | Perl6 LWP::Simple 2 | ================= 3 | 4 | http://github.com/cosimo/perl6-lwp-simple/ 5 | 6 | This is a quick & dirty implementation 7 | of a LWP::Simple clone for Rakudo Perl 6. 8 | 9 | Since Perl 6 is a bit new, this LWP::Simple does both 10 | get and post requests. 11 | 12 | Dependencies 13 | ============ 14 | 15 | LWP::Simple depends on the modules MIME::Base64 and URI, 16 | which you can find at http://modules.perl6.org/ 17 | 18 | 19 | Current status 20 | ============== 21 | 22 | As of 2011-04-22, runs with all recent rakudo builds. 23 | It correctly follows redirects, but no infinite redirects 24 | detection yet. 25 | -------------------------------------------------------------------------------- /bin/lwp-download.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl6 2 | 3 | use v6; 4 | use LWP::Simple; 5 | 6 | my $url = @*ARGS[0] // "http://www.rakudo.org"; 7 | my $file = @*ARGS[1] // "tmpfile-$*PID"; 8 | 9 | my $lwp = LWP::Simple.new; 10 | $lwp.getstore($url, $file); 11 | 12 | -------------------------------------------------------------------------------- /bin/lwp-get.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl6 2 | 3 | use v6; 4 | use LWP::Simple; 5 | 6 | my $url = @*ARGS[0] // "http://www.rakudo.org"; 7 | 8 | LWP::Simple.getprint($url); 9 | 10 | -------------------------------------------------------------------------------- /lib/LWP/Simple.pm: -------------------------------------------------------------------------------- 1 | # ---------------------- 2 | # LWP::Simple for Perl 6 3 | # ---------------------- 4 | use v6; 5 | use MIME::Base64; 6 | use URI; 7 | use URI::Escape; 8 | try require IO::Socket::SSL; 9 | 10 | unit class LWP::Simple:auth:ver<0.090>; 11 | 12 | our $VERSION = '0.090'; 13 | 14 | enum RequestType ; 15 | 16 | has Str $.default_encoding = 'utf-8'; 17 | our $.class_default_encoding = 'utf-8'; 18 | 19 | # these were intended to be constant but that hit pre-compilation issue 20 | my Buf $crlf = Buf.new(13, 10); 21 | my Buf $http_header_end_marker = Buf.new(13, 10, 13, 10); 22 | my Int constant $default_stream_read_len = 2 * 1024; 23 | 24 | method base64encode ($user, $pass) { 25 | my MIME::Base64 $mime .= new(); 26 | my $encoded = $mime.encode_base64($user ~ ':' ~ $pass); 27 | return $encoded; 28 | } 29 | 30 | method get (Str $url, %headers = {}) { 31 | self.request_shell(RequestType::GET, $url) 32 | } 33 | 34 | method delete (Str $url, %headers = {}) { 35 | self.request_shell(RequestType::DELETE, $url) 36 | } 37 | 38 | method post (Str $url, %headers = {}, Any $content?) { 39 | self.request_shell(RequestType::POST, $url, %headers, $content) 40 | } 41 | 42 | method put (Str $url, %headers = {}, Any $content?) { 43 | self.request_shell(RequestType::DELETE, $url, %headers, $content) 44 | } 45 | 46 | method request_shell (RequestType $rt, Str $url, %headers = {}, Any $content?) { 47 | 48 | return unless $url; 49 | die "400 URL must be absolute \n" unless $url ~~ m/^https*\:\/\//; 50 | my $ssl; 51 | if $url ~~ m/^https\:\/\// { 52 | die "501 Protocol scheme 'https' is only supported if IO::Socket::SSL is installed \n" if ::('IO::Socket::SSL') ~~ Failure; 53 | $ssl = True; 54 | } 55 | 56 | my ($scheme, $hostname, $port, $path, $auth) = self.parse_url($url); 57 | 58 | %headers{'Connection'} = 'close'; 59 | %headers{'User-Agent'} //= "LWP::Simple/$VERSION Perl6/$*PERL.compiler.name()"; 60 | 61 | if $auth { 62 | $hostname = $auth; 63 | my $user = $auth; 64 | my $pass = $auth; 65 | my $base64enc = self.base64encode($user, $pass); 66 | %headers = "Basic $base64enc"; 67 | } 68 | 69 | %headers = $hostname; 70 | 71 | if ($rt ~~ any(RequestType::POST, RequestType::PUT) && $content.defined) { 72 | # Attach Content-Length header 73 | # as recommended in RFC2616 section 14.3. 74 | # Note: Empty content is also a content, 75 | # header value equals to zero is valid. 76 | %headers{'Content-Length'} = $content.encode.bytes; 77 | } 78 | 79 | my ($status, $resp_headers, $resp_content) = 80 | self.make_request($rt, $hostname, $port, $path, %headers, $content, :$ssl); 81 | 82 | given $status { 83 | 84 | when / 30 <[12]> / { 85 | my %resp_headers = $resp_headers.hash; 86 | my $new_url = %resp_headers; 87 | if ! $new_url { 88 | die "Redirect $status without a new URL?"; 89 | } 90 | 91 | # Watch out for too many redirects. 92 | # Need to find a way to store a class member 93 | #if $redirects++ > 10 { 94 | # say "Too many redirects!"; 95 | # return; 96 | #} 97 | 98 | return self.request_shell($rt, $new_url, %headers, $content); 99 | } 100 | 101 | when / 20 <[0..9]> / { 102 | 103 | # should be fancier about charset decoding application - someday 104 | if $resp_headers && 105 | $resp_headers ~~ 106 | / $=[<-[/;]>+] 107 | [ <[/]> $=[<-[;]>+] ]? / && 108 | ( $ eq 'text' || 109 | ( $ eq 'application' && 110 | $ ~~ /[ ecma | java ]script | json/ 111 | ) 112 | ) 113 | { 114 | my $charset = 115 | ($resp_headers ~~ /charset\=(<-[;]>*)/)[0]; 116 | $charset = $charset ?? $charset.Str !! 117 | self ?? $.default_encoding !! $.class_default_encoding; 118 | return $resp_content.decode($charset); 119 | } 120 | else { 121 | return $resp_content; 122 | } 123 | 124 | } 125 | 126 | # Response failed 127 | default { 128 | return; 129 | } 130 | } 131 | 132 | } 133 | 134 | method parse_chunks(Blob $b is rw, $sock) { 135 | my Int ($line_end_pos, $chunk_len, $chunk_start) = (0) xx 3; 136 | my Blob $content = Blob.new(); 137 | 138 | # smallest valid chunked line is 0CRLFCRLF (ascii or other 8bit like EBCDIC) 139 | while ($line_end_pos + 5 <= $b.bytes) { 140 | while ( $line_end_pos +4 <= $b.bytes && 141 | $b.subbuf($line_end_pos, 2) ne $crlf 142 | ) { 143 | $line_end_pos++ 144 | } 145 | # say "got here x0x pos ", $line_end_pos, ' bytes ', $b.bytes, ' start ', $chunk_start, ' some data ', $b.subbuf($chunk_start, $line_end_pos +2 - $chunk_start).decode('ascii'); 146 | if $line_end_pos +4 <= $b.bytes && 147 | $b.subbuf( 148 | $chunk_start, $line_end_pos + 2 - $chunk_start 149 | ).decode('ascii') ~~ /^(<.xdigit>+)[";"|\r?\n]/ 150 | { 151 | 152 | # deal with case of chunk_len is 0 153 | 154 | $chunk_len = :16($/[0].Str); 155 | # say 'got chunk len ', $/[0].Str; 156 | 157 | # test if at end of buf?? 158 | if $chunk_len == 0 { 159 | # this is a "normal" exit from the routine 160 | return True, $content; 161 | } 162 | 163 | # think 1CRLFxCRLF 164 | if $line_end_pos + $chunk_len + 4 <= $b.bytes { 165 | # say 'inner chunk'; 166 | $content ~= $b.subbuf($line_end_pos +2, $chunk_len); 167 | $line_end_pos = $chunk_start = $line_end_pos + $chunk_len +4; 168 | 169 | if $line_end_pos + 5 > $b.bytes { 170 | # we don't even have enough at the end of our buffer to 171 | # have a minimum valid chunk header. Assume this is 172 | # unfortunate coincidence and read at least enough data for 173 | # a minimal chunk header 174 | $b ~= $sock.read(5); 175 | } 176 | } 177 | else { 178 | # say 'last chunk'; 179 | # remaining chunk part len is chunk_len with CRLF 180 | # minus the length of the chunk piece at end of buffer 181 | my $last_chunk_end_len = 182 | $chunk_len +2 - ($b.bytes - $line_end_pos -2); 183 | $content ~= $b.subbuf($line_end_pos +2); 184 | if $last_chunk_end_len > 2 { 185 | $content ~= $sock.read($last_chunk_end_len -2); 186 | } 187 | # clean up CRLF after chunk 188 | $sock.read(min($last_chunk_end_len, 2)); 189 | 190 | # this is a` "normal" exit from the routine 191 | return False, $content; 192 | } 193 | } 194 | else { 195 | # say 'extend bytes ', $b.bytes, ' start ', $chunk_start, ' data ', $b.subbuf($chunk_start).decode('ascii'); 196 | # maybe odd case of buffer has just part of header at end 197 | $b ~= $sock.read(20); 198 | } 199 | } 200 | 201 | # say join ' ', $b[0 .. 100]; 202 | # say $b.subbuf(0, 100).decode('utf-8'); 203 | die "Could not parse chunk header"; 204 | } 205 | 206 | method make_request ( 207 | RequestType $rt, $host, Int() $port, $path, %headers, $content?, :$ssl 208 | ) { 209 | 210 | my $headers = self.stringify_headers(%headers); 211 | 212 | # TODO https_proxy 213 | my ($sock, Str $req_str); 214 | if %*ENV and !$ssl { 215 | 216 | my ($proxy, $proxy-port) = %*ENV.split('/').[2].split(':'); 217 | 218 | $sock = IO::Socket::INET.new(:host($proxy), :port(+($proxy-port))); 219 | 220 | $req_str = $rt.Stringy ~ " http://{$host}:{$port}{$path} HTTP/1.1\r\n" 221 | ~ $headers 222 | ~ "\r\n"; 223 | 224 | } 225 | else { 226 | $sock = $ssl ?? ::('IO::Socket::SSL').new(:$host, :$port) !! IO::Socket::INET.new(:$host, :$port); 227 | 228 | $req_str = $rt.Stringy ~ " {$path} HTTP/1.1\r\n" 229 | ~ $headers 230 | ~ "\r\n"; 231 | 232 | } 233 | 234 | # attach $content if given 235 | # (string context is forced by concatenation) 236 | $req_str ~= $content if $content.defined; 237 | 238 | $sock.print($req_str); 239 | 240 | my Blob $resp = $sock.read($default_stream_read_len); 241 | 242 | my ($status, $resp_headers, $resp_content) = self.parse_response($resp); 243 | 244 | 245 | if (($resp_headers || '') eq 'chunked') { 246 | my Bool $is_last_chunk; 247 | my Blob $resp_content_chunk; 248 | 249 | ($is_last_chunk, $resp_content) = 250 | self.parse_chunks($resp_content, $sock); 251 | while (not $is_last_chunk) { 252 | ($is_last_chunk, $resp_content_chunk) = 253 | self.parse_chunks( 254 | my Blob $next_chunk_start = $sock.read(1024), 255 | $sock 256 | ); 257 | $resp_content ~= $resp_content_chunk; 258 | } 259 | } 260 | elsif ( $resp_headers && 261 | $resp_content.bytes < $resp_headers 262 | ) { 263 | $resp_content ~= $sock.read( 264 | $resp_headers - $resp_content.bytes 265 | ); 266 | } 267 | else { # a bit hacky for now but should be ok 268 | while ($resp.bytes > 0) { 269 | $resp = $sock.read($default_stream_read_len); 270 | $resp_content ~= $resp; 271 | } 272 | } 273 | 274 | $sock.close(); 275 | 276 | return ($status, $resp_headers, $resp_content); 277 | } 278 | 279 | method parse_response (Blob $resp) { 280 | 281 | my %header; 282 | 283 | my Int $header_end_pos = 0; 284 | while ( $header_end_pos < $resp.bytes && 285 | $http_header_end_marker ne $resp.subbuf($header_end_pos, 4) ) { 286 | $header_end_pos++; 287 | } 288 | 289 | if ($header_end_pos < $resp.bytes) { 290 | my @header_lines = $resp.subbuf( 291 | 0, $header_end_pos 292 | ).decode('ascii').split(/\r\n/); 293 | my Str $status_line = @header_lines.shift; 294 | 295 | for @header_lines { 296 | my ($name, $value) = .split(': '); 297 | %header{$name} = $value; 298 | } 299 | return $status_line, %header.item, $resp.subbuf($header_end_pos +4).item; 300 | } 301 | 302 | die "could not parse headers"; 303 | # if %header.exists('Transfer-Encoding') && %header ~~ m/:i chunked/ { 304 | # @content = self.decode_chunked(@content); 305 | # } 306 | 307 | } 308 | 309 | method getprint (Str $url) { 310 | my $out = self.get($url); 311 | if $out ~~ Buf { $*OUT.write($out) } else { say $out } 312 | } 313 | 314 | method getstore (Str $url, Str $filename) { 315 | return unless defined $url; 316 | 317 | my $content = self.get($url); 318 | if ! $content { 319 | return 320 | } 321 | 322 | my $fh = open($filename, :bin, :w); 323 | if $content ~~ Buf { 324 | $fh.write($content) 325 | } 326 | else { 327 | $fh.print($content) 328 | } 329 | 330 | $fh.close; 331 | } 332 | 333 | method parse_url (Str $url) { 334 | my URI $u .= new($url); 335 | my $path = $u.path_query; 336 | my $user_info = $u.userinfo; 337 | 338 | return ( 339 | $u.scheme, 340 | $user_info ?? "{$user_info}\@{$u.host}" !! $u.host, 341 | $u.port, 342 | $path eq '' ?? '/' !! $path, 343 | $user_info ?? { 344 | host => $u.host, 345 | user => uri_unescape($user_info.split(':')[0]), 346 | password => uri_unescape($user_info.split(':')[1] || '') 347 | } !! Nil 348 | ); 349 | } 350 | 351 | method stringify_headers (%headers) { 352 | my Str $str = ''; 353 | for sort %headers.keys { 354 | $str ~= $_ ~ ': ' ~ %headers{$_} ~ "\r\n"; 355 | } 356 | return $str; 357 | } 358 | 359 | -------------------------------------------------------------------------------- /t/000-load-module.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | 4 | use LWP::Simple; 5 | 6 | plan 1; 7 | 8 | ok(1, 'LWP::Simple is loaded'); 9 | 10 | -------------------------------------------------------------------------------- /t/basic-auth.t: -------------------------------------------------------------------------------- 1 | # 2 | # Test the basic auth code path 3 | # 4 | 5 | use v6; 6 | use Test; 7 | 8 | use LWP::Simple; 9 | 10 | plan 9; 11 | 12 | my $basic-auth-url = 'https://ron:Camelia@www.software-path.com/p6-lwp-simple/basic-auth/'; 13 | my @url = LWP::Simple.parse_url($basic-auth-url); 14 | 15 | is(@url[0], 'https', 'Scheme parsed correctly'); 16 | is(@url[1], 'ron:Camelia@www.software-path.com', 'Hostname contains basic auth info'); 17 | is(@url[2], 443, 'HTTPS demands port 443'); 18 | is(@url[3], '/p6-lwp-simple/basic-auth/', 'Path extracted correctly'); 19 | 20 | is(@url[4], 'ron', 'Basic auth info extracted correctly: user'); 21 | is(@url[4], 'Camelia', 'Basic auth info extracted correctly: pass'); 22 | is(@url[4], 'www.software-path.com', 'Basic auth info extracted correctly: hostname'); 23 | 24 | # Encode test 25 | is( 26 | LWP::Simple.base64encode('someuser', 'somepass'), 27 | 'c29tZXVzZXI6c29tZXBhc3M=', 28 | 'Base64 encoding works' 29 | ); 30 | 31 | $basic-auth-url ~~ s/^https/http/; 32 | my $html = LWP::Simple.get($basic-auth-url); 33 | ok($html.match('protected'), 'Got protected url'); 34 | 35 | -------------------------------------------------------------------------------- /t/custom-headers-and-content.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | 4 | use LWP::Simple; 5 | 6 | plan 1; 7 | 8 | my $host = 'http://froggs.de/cgi-bin/test/test.cgi'; 9 | my %headers = ( 'Content-Type' => 'application/json' ); 10 | my $content = '{"method":"echo","params":["Hello from Perl6"],"id":1}'; 11 | my $html = LWP::Simple.post($host, %headers, $content); 12 | 13 | if $html { 14 | ok( 15 | $html.match('Hello from Perl6'), 16 | 'call to JSON-RPC service using headers and content params' 17 | ); 18 | } 19 | else { 20 | skip("Unable to connect to test site '$host'", 1); 21 | } 22 | 23 | -------------------------------------------------------------------------------- /t/get-binary-camelia.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | 4 | use LWP::Simple; 5 | 6 | plan 1; 7 | 8 | # don't use rakudo.org anymore, it has proven to be rather unreliable :( 9 | my $logo = LWP::Simple.get('http://www.perl6.org/camelia-logo.png'); 10 | 11 | ok( 12 | $logo.bytes == 57601 && $logo[ 57_600 ] == 130, 13 | 'Fetched Camelia Logo' 14 | ); 15 | 16 | -------------------------------------------------------------------------------- /t/get-chunked-6guts.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | 4 | use LWP::Simple; 5 | 6 | plan 1; 7 | 8 | # would really be nice to verify in headers that it's really chunked 9 | # but, for now, this is "Simple" 10 | my $html = LWP::Simple.get('http://strangelyconsistent.org/blog/youre-in-a-space-of-twisty-little-mazes-all-alike/'); 11 | 12 | ok( 13 | $html.match('masak') && $html.match('') && $html.chars > 20_000, 14 | 'Pulled down whole chunked article' 15 | ); 16 | -------------------------------------------------------------------------------- /t/get-perl6-org.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | 4 | use LWP::Simple; 5 | 6 | plan 2; 7 | 8 | # don't use rakudo.org anymore, it has proven to be rather unreliable :( 9 | my $html = LWP::Simple.get('http://www.perl6.org'); 10 | 11 | ok( 12 | $html.match('Perl'), 13 | 'homepage is downloaded and has "Perl" in it' 14 | ); 15 | 16 | # a page over 64K would be ideal but a bit slow and not really needed yet 17 | $html = LWP::Simple.get('http://doc.perl6.org/type.html'); 18 | ok( 19 | $html.match('X::Attribute::Undeclared') && 20 | $html.match(''), 21 | 'make sure we pulled down whole document for some substantial size' 22 | ); 23 | #diag("Content\n" ~ $html); 24 | -------------------------------------------------------------------------------- /t/get-unsized.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | 4 | use LWP::Simple; 5 | 6 | plan 1; 7 | 8 | # this page is, for now, delivered by a server that does not provide 9 | # a content length or do chunking 10 | my $html = LWP::Simple.get('http://rakudo.org'); 11 | 12 | ok( 13 | $html.match('Perl 6') && 14 | $html.match('') && $html.chars > 12_000, 15 | 'make sure we pulled whole document without, we believe, sizing from server' 16 | ); 17 | -------------------------------------------------------------------------------- /t/get-w3-latin1-utf8.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | 4 | use LWP::Simple; 5 | 6 | plan 2; 7 | 8 | my $html = LWP::Simple.get('http://www.w3.org/2006/11/mwbp-tests/test-encoding-8.html'); 9 | 10 | my $find_char = chr(233); # small e with acute 11 | ok( 12 | $html.match('') && $html.match($find_char), 13 | 'Got latin-1 page' 14 | ); 15 | 16 | $html = LWP::Simple.get('http://www.w3.org/2006/11/mwbp-tests/test-encoding-3.html'); 17 | ok( 18 | $html.match('') && $html.match($find_char), 19 | 'Got utf-8 page' 20 | ); 21 | #diag("Content\n" ~ $html); 22 | 23 | -------------------------------------------------------------------------------- /t/get-w3-redirect.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | 4 | use LWP::Simple; 5 | 6 | plan 1; 7 | 8 | # don't use rakudo.org anymore, it has proven to be rather unreliable :( 9 | my $html = LWP::Simple.get('http://jigsaw.w3.org/HTTP/300/301.html'); 10 | 11 | ok( 12 | $html.match('Redirect test page'), 13 | 'Was redirected to w3 redirect test page' 14 | ); 15 | 16 | #diag("Content\n" ~ $html); 17 | 18 | -------------------------------------------------------------------------------- /t/getstore.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | 4 | use LWP::Simple; 5 | 6 | plan 4; 7 | 8 | my $fname = $*SPEC.catdir($*TMPDIR, "./tmp-getstore-$*PID"); 9 | try unlink $fname; 10 | 11 | ok( 12 | LWP::Simple.getstore('http://www.opera.com', $fname), 13 | 'getstore() returned success' 14 | ); 15 | 16 | my $fh = open($fname); 17 | ok($fh, 'Opened file handle written by getstore()'); 18 | 19 | ok $fh.slurp-rest ~~ /Opera \s+ browser/, 'Found pattern in downloaded file'; 20 | 21 | ok(unlink($fname), 'Delete the temporary file'); 22 | -------------------------------------------------------------------------------- /t/parse-url.t: -------------------------------------------------------------------------------- 1 | # 2 | # Test the parse_url() method 3 | # 4 | 5 | use v6; 6 | use Test; 7 | 8 | use LWP::Simple; 9 | 10 | plan 25; 11 | 12 | my @test = ( 13 | 'Simple URL without path', 14 | 'http://www.rakudo.org', 15 | ['http', 'www.rakudo.org', 80, '/'], 16 | 17 | 'Port other than 80', 18 | 'http://www.altavista.com:81', 19 | ['http', 'www.altavista.com', 81, '/'], 20 | 21 | 'HTTPS scheme, and default port != 80', 22 | 'https://www.rakudo.org/rakudo-latest.tar.bz2', 23 | ['https', 'www.rakudo.org', 443, '/rakudo-latest.tar.bz2'], 24 | 25 | '#GH-1 http://github.com/cosimo/perl6-lwp-simple/issues/#issue/1', 26 | 'http://www.c64.com/path/with/multiple/slashes/', 27 | ['http', 'www.c64.com', 80, '/path/with/multiple/slashes/'], 28 | 29 | 'FTP url', 30 | 'ftp://get.opera.com/pub/opera/win/1054/en/Opera_1054_en_Setup.exe', 31 | ['ftp', 'get.opera.com', 21, '/pub/opera/win/1054/en/Opera_1054_en_Setup.exe'], 32 | 33 | 'HTTP URL with double-slashes', 34 | 'http://tinyurl.com/api-create.php?url=http://digg.com', 35 | ['http', 'tinyurl.com', 80, '/api-create.php?url=http://digg.com'], 36 | 37 | ); 38 | 39 | for @test -> $test, $url, $results { 40 | my ($scheme, $host, $port, $path) = LWP::Simple.parse_url($url); 41 | is($scheme, $results.[0], "Scheme for $url is $scheme"); 42 | is($host, $results.[1], "Hostname for $url is $host"); 43 | is($port, $results.[2], "Port for $url is $port"); 44 | is($path, $results.[3], "Path for $url is $path"); 45 | } 46 | 47 | # Check that port is returned as a number, 48 | # or IO::Socket::INET.open() fails 49 | my ($scheme, $host, $port, $path) = LWP::Simple.parse_url('http://localhost:5984/foo/test/'); 50 | isa-ok($port, Int, 'port is returned as a Int, to avoid problems on sock.open()'); 51 | 52 | -------------------------------------------------------------------------------- /t/socket-sanity.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | 4 | plan 2; 5 | 6 | my $s = IO::Socket::INET.new(:host('www.opera.com'), :port(80)); 7 | ok($s, 'Socket object created'); 8 | 9 | $s = IO::Socket::INET.new( 10 | host => 'www.opera.com', 11 | port => 80, 12 | ); 13 | ok($s, 'Socket object created'); 14 | 15 | # XXX Some systems seem to fail to resolve the IPv6 address 16 | #$s = IO::Socket::INET.new( 17 | # host => '2a03:2880:f001:6:face:b00c:0:2', 18 | # port => 80, 19 | # # TODO Can't get &PIO::PF_INET6 from outside of IO::Socket::INET 20 | # family => 3, 21 | #); 22 | #ok($s, 'Socket object to IPv6 address created'); 23 | -------------------------------------------------------------------------------- /t/stringify-headers.t: -------------------------------------------------------------------------------- 1 | # 2 | # Test the parse_url() method 3 | # 4 | 5 | use v6; 6 | use Test; 7 | 8 | use LWP::Simple; 9 | 10 | plan 6; 11 | 12 | my @test = ( 13 | { User-Agent => 'Opera/9.80 (WinNT; 6.0) Version/10.60' }, 14 | "User-Agent: Opera/9.80 (WinNT; 6.0) Version/10.60\r\n", 15 | { Connection => 'close' }, 16 | "Connection: close\r\n", 17 | ); 18 | 19 | for @test -> %headers, $expected_str { 20 | my $hdr_str = LWP::Simple.stringify_headers(%headers); 21 | is($hdr_str, $expected_str, 'OK - ' ~ $hdr_str); 22 | } 23 | 24 | my $hdr = LWP::Simple.stringify_headers({ 25 | User-Agent => 'Chrome/5.0', 26 | Accept-Encoding => 'gzip', 27 | Accept-Language => 'en;q=1, it;q=0.8, no-NB;q=0.5, es;q=0.6', 28 | Connection => 'keepalive', 29 | }); 30 | 31 | ok( 32 | $hdr.match('User-Agent: Chrome'), 33 | 'Composite headers are stringified correctly' 34 | ); 35 | 36 | ok( 37 | $hdr.match('Accept-Encoding: gzip'), 38 | 'Composite headers are stringified correctly' 39 | ); 40 | 41 | ok( 42 | $hdr.match('Connection: keepalive'), 43 | 'Composite headers are stringified correctly' 44 | ); 45 | 46 | ok( 47 | $hdr.match('Accept-Language: en;q=1'), 48 | 'Composite headers are stringified correctly' 49 | ); 50 | 51 | --------------------------------------------------------------------------------