Permalink
Browse files

Using the ecosystem repo as a source of projects.list, got rid of LWP…

…::Simple (sadly) and its deps
  • Loading branch information...
1 parent 471b7bd commit 573e9765f6be01e751763c7985ab2507a5d05123 @tadzik committed Nov 9, 2010
Showing with 12 additions and 266 deletions.
  1. +12 −4 bin/neutro
  2. +0 −1 deps.proto
  3. +0 −234 tmplib/LWP/Simple.pm
  4. +0 −27 tmplib/MIME/Base64.pm6
View
@@ -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<config><osname> eq 'MSWin32')
?? %*ENV<HOMEPATH> !! %*ENV<HOME>;
@@ -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') {
View
@@ -1,3 +1,2 @@
perl6-File-Tools
perl6-Module-Tools
-perl6-lwp-simple
View
@@ -1,234 +0,0 @@
-# ----------------------
-# LWP::Simple for Perl 6
-# ----------------------
-use v6;
-use MIME::Base64;
-
-class LWP::Simple:auth<cosimo>: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) {
-
- # ^ <username> : <password> @ <hostname> $
- 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<Authorization> = "Basic $base64enc";
- }
-
- %headers<Host> = $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<Location>;
- 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--; # <CR>
- $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<Transfer-Encoding> ~~ 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;
-}
-
View
@@ -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;
- }
-}

0 comments on commit 573e976

Please sign in to comment.