Skip to content
Browse files

It's now possible to install neutro with itself

  • Loading branch information...
1 parent a3b4199 commit 62f97442a77bf9de2e276754e049624d19843134 @tadzik committed Sep 12, 2010
Showing with 621 additions and 0 deletions.
  1. +7 −0 README
  2. +34 −0 tmplib/File/Copy.pm
  3. +125 −0 tmplib/File/Find.pm
  4. +37 −0 tmplib/File/Mkdir.pm
  5. +15 −0 tmplib/File/Tools.pm
  6. +234 −0 tmplib/LWP/Simple.pm
  7. +27 −0 tmplib/MIME/Base64.pm6
  8. +90 −0 tmplib/Module/Build.pm
  9. +35 −0 tmplib/Module/Install.pm
  10. +17 −0 tmplib/Module/Test.pm
View
7 README
@@ -10,6 +10,13 @@ It probably won't work on anything besides Unixes.
Patches, ideas and criticism welcome.
+Bootstraping:
+As neutro is not dependency-free, it comes with a set of libs which
+will help it install itself. To bootstrap neutro, use something like
+this:
+
+PERL6LIB=tmplib bin/neutro i neutro
+
Usage:
./neutro l
./neutro i Acme::Meow
View
34 tmplib/File/Copy.pm
@@ -0,0 +1,34 @@
+use v6;
+
+module File::Copy;
+
+sub cp(Str $from, Str $to) is export {
+ my $f1 = open $from, :r, :bin;
+ my $f2 = open $to, :w, :bin;
+ $f2.write($f1.read(4096)) until $f1.eof;
+ $f1.close;
+ $f2.close;
+}
+
+=begin pod
+
+=head1 NAME
+
+File::Copy -- copy files
+
+=head1 SYNOPSIS
+
+ use File::Copy;
+
+ cp 'source', 'destination';
+
+=head1 DESCRIPTION
+
+C<File::Copy> exports just one subroutine, cp taking two string
+parameters: source and destination. If something comes wrong, the
+internal open() or write() calls will die, C<copy()> has no special
+error reporting.
+
+=end pod
+
+# vim: ft=perl6
View
125 tmplib/File/Find.pm
@@ -0,0 +1,125 @@
+use v6;
+
+module File::Find;
+
+class File::Find::Result is Cool {
+ has $.dir;
+ has $.name;
+
+ method Str {
+ $.dir ~ '/' ~ $.name
+ }
+}
+
+sub checkrules ($elem, %opts) {
+ if %opts<name>.defined {
+ given %opts<name> {
+ when Regex {
+ return False unless $elem ~~ %opts<name>
+ }
+ when Str {
+ return False unless $elem.name ~~ %opts<name>
+ }
+ default {
+ die "name attribute has to be either Regex or Str"
+ }
+ }
+ }
+ if %opts<type>.defined {
+ given %opts<type> {
+ when 'dir' {
+ return False unless $elem.IO ~~ :d
+ }
+ when 'file' {
+ return False unless $elem.IO ~~ :f
+ }
+ when 'symlink' {
+ return False unless $elem.IO ~~ :l
+ }
+ default {
+ die "type attribute has to be dir, file or symlink";
+ }
+ }
+ }
+ return True
+}
+
+sub find (:$dir!, :$name, :$type) is export {
+ my @targets = dir($dir).map: {
+ File::Find::Result.new(dir => $dir, name => $_);
+ };
+ my $list = gather while @targets {
+ my $elem = @targets.shift;
+ take $elem if checkrules($elem, { :$name, :$type });
+ if $elem.IO ~~ :d {
+ for dir($elem) -> $file {
+ @targets.push(
+ File::Find::Result.new(dir => $elem, name => $file)
+ );
+ }
+ }
+ }
+ return $list;
+}
+
+=begin pod
+
+=head1 NAME
+
+File::Find - Get a lazy list of a directory tree
+
+=head1 SYNOPSIS
+
+ use File::Find;
+
+ my @list := find(dir => 'foo');
+ say @list[0..3];
+
+ my $list = find(dir => 'foo');
+ say $list[0..3];
+
+=head1 DESCRIPTION
+
+C<File::Find> allows you to get the contents of the given directory,
+recursively. The only exported function, C<find()>, generates a lazy
+list of files in given directory. Every element of the list is a
+C<File::Find::Result> object, described below.
+C<find()> takes one (or more) named arguments. The C<dir> argument
+is mandatory, and sets the directory C<find()> will traverse.
+There are also few optional arguments. If more than one is passed,
+all of them must match for a file to be returned.
+
+=head2 name
+
+Specify a name of the file C<File::Find> is ought to look for. If you
+pass a string here, C<find()> will return only the files with the given
+name. When passing a regex, only the files with path matching the
+pattern will be returned.
+
+=head2 type
+
+Given a type, C<find()> will only return files being the given type.
+The available types are C<file>, C<dir> or C<symlink>.
+
+=head1 File::Find::Result
+
+C<File::Find::Result> object acts like a normal string, having two
+additional accessors, C<dir> and C<name>, holding the directory
+the file is in and the filename respectively.
+
+=head1 Perl 5's File::Find
+
+Please note, that this module is not trying to be the verbatim port of
+Perl 5's File::Find module. Its interface is closer to Perl 5's
+File::Find::Rule, and its features are planned to be similar one day.
+
+=head1 CAVEATS
+
+List assignment is eager in Perl 6, so if You assign C<find()> result
+to an array, the elements will be copied and the laziness will be
+spoiled. For a proper lazy list, use either binding (C<:=>) or assign
+a result to a scalar value (see SYNOPSIS).
+
+=end pod
+
+# vim: ft=perl6
View
37 tmplib/File/Mkdir.pm
@@ -0,0 +1,37 @@
+use v6;
+
+module File::Mkdir;
+
+multi sub mkdir(Str $name, $mode = 0o777, :$p!) is export {
+ for [\~] $name.split('/').map({"$_/"}) {
+ mkdir($_) unless .IO.d
+ }
+}
+
+=begin pod
+
+=head1 NAME
+
+File::Mkdir -- provides recursive mkdir
+
+=head1 SYNOPSIS
+
+ use File::Mkdir;
+
+ # special mkdir exported in File::Mkdir
+ mkdir '/some/directory/tree', :p;
+ # just a casual, built-in mkdir
+ mkdir 'directory';
+
+=head1 DESCRIPTION
+
+C<File::Mkdir> provides an mkdir variant, which, when provided the :p
+parameter, will create the directory tree recursively. For example,
+calling C<mkdir 'foo/bar', :p> will create the foo directory (unless
+it alredy exists), then the foo/bar directory (unless it exists).
+The standard Perl 6 C<mkdir> is still available, and will be called
+when the :p parameter is not passed.
+
+=end pod
+
+# vim: ft=perl6
View
15 tmplib/File/Tools.pm
@@ -0,0 +1,15 @@
+module File::Tools:<github:tadzik>;
+
+=begin pod
+
+This is a distribution for file-related utilities, including:
+
+=item File::Copy
+=item File::Find
+=item File::Mkdir
+
+Please refer to their documentation for more information.
+
+=end pod
+
+# vim: ft=perl6
View
234 tmplib/LWP/Simple.pm
@@ -0,0 +1,234 @@
+# ----------------------
+# 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
27 tmplib/MIME/Base64.pm6
@@ -0,0 +1,27 @@
+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;
+ }
+}
View
90 tmplib/Module/Build.pm
@@ -0,0 +1,90 @@
+use File::Find;
+
+module Module::Build;
+
+sub path-to-module-name($path) {
+ $path.subst(/^'lib/'/, '').subst(/\.pm6?$/, '').subst('/', '::', :g)
+}
+
+sub module-name-to-path($module-name) {
+ my $pm = 'lib/' ~ $module-name.subst('::', '/', :g) ~ '.pm';
+ $pm.IO ~~ :e ?? $pm !! $pm ~ '6';
+}
+
+our sub build(Str $dir = '.', Str $binary = 'perl6', :$v) {
+ if "$dir/Configure.pl".IO ~~ :f {
+ my $cwd = cwd;
+ chdir $dir;
+ run 'perl6 Configure.pl' and die "Configure.pl failed";
+ chdir $cwd;
+ }
+ if $*VM<config><osname> ne 'MSWin32'
+ && "$dir/Makefile".IO ~~ :f {
+ my $cwd = cwd;
+ chdir $dir;
+ run 'make' and die "'make' failed";
+ chdir $cwd;
+ return;
+ }
+
+ my @module-files = find(dir => "$dir/lib", name => /\.pm6?$/).list;
+
+ # To know the best order of compilation, we build a dependency
+ # graph of all the modules in lib/. %usages_of ends up containing
+ # a graph, with the keys (containing names modules) being nodes,
+ # and the values (containing arrays of names) denoting directed
+ # edges.
+
+ my @modules = map {
+ path-to-module-name($_.Str.subst(/\.\/lib\//, ''))
+ }, @module-files;
+ my %usages_of;
+ for @module-files -> $module-file {
+ my $fh = open($module-file, :r);
+ my $module = $module-file.name;
+ %usages_of{$module} = [];
+ for $fh.lines() {
+ if /^\s* 'use' \s+ (\w+ ['::' \w+]*)/ && $0 -> $used {
+ next if $used eq 'v6';
+ next if $used eq 'MONKEY_TYPING';
+
+ %usages_of{$module}.push(~$used);
+ }
+ }
+ }
+
+ my @order;
+
+ # According to "Introduction to Algorithms" by Cormen et al.,
+ # topological sort is just a depth-first search of a graph where
+ # you pay attention to the order in which you get done with the
+ # dfs-visit() for each node.
+
+ my %color_of = @modules X=> 'not yet visited';
+ for @modules -> $module {
+ if %color_of{$module} eq 'not yet visited' {
+ dfs-visit($module);
+ }
+ }
+
+ sub dfs-visit($module) {
+ %color_of{$module} = 'visited';
+ for %usages_of{$module}.list -> $used {
+ if %color_of{$used} eq 'not yet visited' {
+ dfs-visit($used);
+ }
+ }
+ push @order, $module;
+ }
+
+ for @order».&module-name-to-path -> $module {
+ my $pir = $module.subst(/\.pm6?/, ".pir");
+ next if ($pir.IO ~~ :f &&
+ $pir.IO.stat.modifytime > $module.IO.stat.modifytime);
+ my $command = "$binary --target=PIR --output=$pir $module";
+ say $command if $v.defined;
+ run $command and die "Failed building $module"
+ }
+}
+
+# vim: ft=perl6
View
35 tmplib/Module/Install.pm
@@ -0,0 +1,35 @@
+#use File::Copy;
+use File::Find;
+use File::Mkdir;
+
+module Module::Install;
+
+our sub install(Str $dir = '.', Str $dest = "%*ENV<HOME>/.perl6/", :$v) {
+ if $*VM<config><osname> ne 'MSWin32'
+ && "$dir/Makefile".IO ~~ :f {
+ my $cwd = cwd;
+ chdir $dir;
+ run 'make install' and die "'make install' failed";
+ chdir $cwd;
+ } else {
+ my @files = find(dir => "$dir/lib", name => /[\.pm6?$] | [\.pir$]/).list;
+ if "$dir/bin".IO ~~ :d {
+ for find(dir => "$dir/bin").list {
+ @files.push: $_
+ }
+ }
+ for @files -> $file {
+ my $target-dir = $file.dir.subst(/\.\//, $dest);
+ mkdir $target-dir, :p;
+ say "Installing $file" if $v.defined;
+# say "Starting copying $pmfile, sized {
+# $pmfile.Str.IO.stat.size} bytes";
+# my $t = time;
+# cp ~$file, "$target-dir/{$file.name}";
+# say "Done copying, took {time() - $t} seconds";
+ run "cp $file $target-dir/{$file.name}";
+ }
+ }
+}
+
+# vim: ft=perl6
View
17 tmplib/Module/Test.pm
@@ -0,0 +1,17 @@
+module Module::Test;
+
+our sub test(Str $dir = '.', Str $binary = 'perl6') {
+ if $*VM<config><osname> ne 'MSWin32'
+ && "$dir/Makefile".IO ~~ :f {
+ my $cwd = cwd;
+ chdir $dir;
+ run 'make test' and die "'make test' failed";
+ chdir $cwd;
+ }
+ if "$dir/t".IO ~~ :d {
+ my $command = "PERL6LIB=$dir/lib prove -e $binary -r $dir/t/";
+ run $command and die 'Testing failed';
+ }
+}
+
+# vim: ft=perl6

0 comments on commit 62f9744

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