From 573e9765f6be01e751763c7985ab2507a5d05123 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tadeusz=20So=C5=9Bnierz?= Date: Tue, 9 Nov 2010 20:51:42 +0000 Subject: [PATCH] Using the ecosystem repo as a source of projects.list, got rid of LWP::Simple (sadly) and its deps --- bin/neutro | 16 ++- deps.proto | 1 - tmplib/LWP/Simple.pm | 234 ----------------------------------------- tmplib/MIME/Base64.pm6 | 27 ----- 4 files changed, 12 insertions(+), 266 deletions(-) delete mode 100644 tmplib/LWP/Simple.pm delete mode 100644 tmplib/MIME/Base64.pm6 diff --git a/bin/neutro b/bin/neutro index 148fbda..ae04fd5 100755 --- a/bin/neutro +++ b/bin/neutro @@ -1,10 +1,10 @@ #!/usr/bin/env perl6 use v6; use File::Mkdir; +use File::Copy; use Module::Build; use Module::Test; use Module::Install; -use LWP::Simple; my $home = ($*VM eq 'MSWin32') ?? %*ENV !! %*ENV; @@ -144,9 +144,17 @@ sub updatedb { notice 'Updating modules database'; chdir $CONFIGDIR; unlink 'projects.list' if 'projects.list'.IO ~~ :e; - LWP::Simple.new.getstore: - 'http://github.com/perl6/ecosystem/raw/master/projects.list', - 'projects.list'; + chdir $SRCDIR; + if "$SRCDIR/ecosystem".IO ~~ :d { + chdir 'ecosystem'; + my $res = run 'git pull -q'; + crap "Failed updating the ecosystem" if $res; + } else { + my $res = run "git clone -q git://github.com/perl6/ecosystem.git"; + crap "Failed cloning the ecosystem" if $res; + chdir 'ecosystem'; + } + cp 'projects.list', "$CONFIGDIR/projects.list"; } multi MAIN ('list') { diff --git a/deps.proto b/deps.proto index 895efd6..fd138e7 100644 --- a/deps.proto +++ b/deps.proto @@ -1,3 +1,2 @@ perl6-File-Tools perl6-Module-Tools -perl6-lwp-simple diff --git a/tmplib/LWP/Simple.pm b/tmplib/LWP/Simple.pm deleted file mode 100644 index 8538cb6..0000000 --- a/tmplib/LWP/Simple.pm +++ /dev/null @@ -1,234 +0,0 @@ -# ---------------------- -# LWP::Simple for Perl 6 -# ---------------------- -use v6; -use MIME::Base64; - -class LWP::Simple:auth:ver<0.06>; - -our $VERSION = '0.06'; - -method base64encode ($user, $pass) { - my $mime = MIME::Base64.new(); - my $encoded = $mime.encode_base64($user ~ ':' ~ $pass); - return $encoded; -} - -method default_port () { - return 80; -} - -method default_port (Str $scheme) { - given $scheme { - when "http" { return 80 } - when "https" { return 443 } - when "ftp" { return 21 } - when "ssh" { return 22 } - default { return 80 } - } -} - -method has_basic_auth (Str $host) { - - # ^ : @ $ - if $host ~~ /^ (\w+) \: (\w+) \@ (\N+) $/ { - my $host = $0.Str; - my $user = $1.Str; - my $pass = $2.Str; - return $host, $user, $pass; - } - - return; -} - -method get (Str $url) { - - return unless $url; - - my ($scheme, $hostname, $port, $path) = self.parse_url($url); - - my %headers = ( - User-Agent => "Perl6-LWP-Simple/$VERSION", - Connection => 'close', - ); - - if my @auth = self.has_basic_auth($hostname) { - $hostname = @auth[2]; - my $user = @auth[0]; - my $pass = @auth[1]; - my $base64enc = self.base64encode($user, $pass); - %headers = "Basic $base64enc"; - } - - %headers = $hostname; - - my ($status, $resp_headers, $content) = - self.make_request($hostname, $port, $path, %headers); - - # Follow redirects. Shall we? - if $status ~~ m/ 30 <[12]> / { - - my %resp_headers = $resp_headers; - my $new_url = %resp_headers; - if ! $new_url { - say "Redirect $status without a new URL?"; - return; - } - - # Watch out for too many redirects. - # Need to find a way to store a class member - #if $redirects++ > 10 { - # say "Too many redirects!"; - # return; - #} - - return self.get($new_url); - } - - # Response successful. Return the content as a scalar - if $status ~~ m/200/ { - my $page_content = $content.join("\n"); - return $page_content; - } - - # Response failed - return; -} - -# In-place removal of chunked transfer markers -method decode_chunked (@content) { - my $pos = 0; - - while @content { - - # Chunk start: length as hex word - my $length = splice(@content, $pos, 1); - - # Chunk length is hex and could contain - # chunk-extensions (RFC2616, 3.6.1). Ex.: '5f32; xxx=...' - if $length ~~ m/^ \w+ / { - $length = :16($length); - } else { - last; - } - - # Continue reading for '$length' bytes - while $length > 0 && @content.exists($pos) { - my $line = @content[$pos]; - $length -= $line.bytes; # .bytes, not .chars - $length--; # - $pos++; - } - - # Stop decoding when a zero is encountered, RFC2616 again - if $length == 0 { - # Truncate document here - splice(@content, $pos); - last; - } - - } - - return @content; -} - -method make_request ($hostname, $port, $path, %headers) { - - my $headers = self.stringify_headers(%headers); - - my $sock = IO::Socket::INET.new; - $sock.open($hostname, $port.Int, :bin); - my $req_str = "GET {$path} HTTP/1.1\r\n" - ~ $headers - ~ "\r\n"; - - $sock.send($req_str); - - my $resp = $sock.recv(); - $sock.close(); - - my ($status, $resp_headers, $content) = self.parse_response($resp); - - return ($status, $resp_headers, $content); -} - -method parse_response (Str $resp) { - - my %header; - my @content = $resp.split(/\n/); - - my $status_line = @content.shift; - - while @content { - my $line = @content.shift; - last if $line eq ''; - my ($name, $value) = $line.split(': '); - %header{$name} = $value; - } - - if %header.exists('Transfer-Encoding') && %header ~~ m/:i chunked/ { - @content = self.decode_chunked(@content); - } - - return $status_line, \%header, \@content; -} - -method getprint (Str $url) { - say self.get($url); -} - -method getstore (Str $url, Str $filename) { - return unless defined $url; - - my $content = self.get($url); - if ! $content { - return - } - - my $fh = open($filename, :bin, :w); - my $ok = $fh.print($content); - $fh.close; - - return $ok; -} - -method parse_url (Str $url) { - - my $scheme; - my $hostname; - my $port; - my @path; - my $path; - - @path = $url.split(/\/+/); - $scheme = @path.shift; - $scheme .= chop; - $hostname = @path.shift; - $path = '/' ~ @path.join('/'); - - #say 'scheme:', $scheme; - #say 'hostname:', $hostname; - #say 'port:', $port; - #say 'path:', @path; - - # rakudo: Regex with captures doesn't work here - if $hostname ~~ /^ .+ \: \d+ $/ { - ($hostname, $port) = $hostname.split(':'); - # sock.open() fails if port is a Str - $port = $port.Int; - } - else { - $port = self.default_port($scheme); - } - - return ($scheme, $hostname, $port, $path); -} - -method stringify_headers (%headers) { - my $str = ''; - for sort %headers.keys { - $str ~= $_ ~ ': ' ~ %headers{$_} ~ "\r\n"; - } - return $str; -} - diff --git a/tmplib/MIME/Base64.pm6 b/tmplib/MIME/Base64.pm6 deleted file mode 100644 index 2980f79..0000000 --- a/tmplib/MIME/Base64.pm6 +++ /dev/null @@ -1,27 +0,0 @@ -class MIME::Base64 { - - # load the MIME Base64 Parrot library to do all the hard work for us - pir::load_bytecode('MIME/Base64.pbc'); - - method encode_base64(Str $str) { - my $encoded-str = Q:PIR { - .local pmc encode - encode = get_root_global ['parrot'; 'MIME'; 'Base64'], 'encode_base64' - $P0 = find_lex '$str' - %r = encode($P0) - }; - - return $encoded-str; - } - - method decode_base64(Str $str) { - my $decoded-str = Q:PIR { - .local pmc decode - decode = get_root_global ['parrot'; 'MIME'; 'Base64'], 'decode_base64' - $P0 = find_lex '$str' - %r = decode($P0) - }; - - return $decoded-str; - } -}