Add a bunch of Perl 6 sample files

samples/Perl6/01-dash-uppercase-i.t

@@ -0,0 +1,97 @@
+use v6;
+
+use Test;
+
+=begin pod
+
+Test handling of -I.
+
+Multiple C<-I> switches are supposed to
+prepend left-to-right:
+
+  -Ifoo -Ibar
+
+should make C<@*INC> look like:
+
+  foo
+  bar
+  ...
+
+Duplication of directories on the command line is mirrored
+in the C<@*INC> variable, so C<pugs -Ilib -Ilib> will have B<two>
+entries C<lib/> in C<@*INC>.
+
+=end pod
+
+# L<S19/Reference/"Prepend directories to">
+
+my $fragment = '-e "@*INC.perl.say"';
+
+my @tests = (
+    'foo',
+    'foo$bar',
+    'foo bar$baz',
+    'foo$foo',
+);
+
+plan @tests*2;
+
+diag "Running under $*OS";
+
+my ($pugs,$redir) = ($*EXECUTABLE_NAME, ">");
+
+if $*OS eq any <MSWin32 mingw msys cygwin> {
+  $pugs = 'pugs.exe';
+  $redir = '>';
+};
+
+sub nonce () { return (".{$*PID}." ~ (1..1000).pick) }
+
+sub run_pugs ($c) {
+  my $tempfile = "temp-ex-output" ~ nonce;
+  my $command = "$pugs $c $redir $tempfile";
+  diag $command;
+  run $command;
+  my $res = slurp $tempfile;
+  unlink $tempfile;
+  return $res;
+}
+
+for @tests -> $t {
+  my @dirs = split('$',$t);
+  my $command;
+  # This should be smarter about quoting
+  # (currently, this should work for WinNT and Unix shells)
+  $command = join " ", map { qq["-I$_"] }, @dirs;
+  my $got = run_pugs( $command ~ " $fragment" );
+  $got .= chomp;
+
+  if (substr($got,0,1) ~~ "[") {
+    # Convert from arrayref to array
+    $got = substr($got, 1, -1);
+  };
+
+  my @got = EVAL $got;
+  @got = @got[ 0..@dirs-1 ];
+  my @expected = @dirs;
+
+  is @got, @expected, "'" ~ @dirs ~ "' works";
+
+  $command = join " ", map { qq[-I "$_"] }, @dirs;
+  $got = run_pugs( $command ~ " $fragment" );
+  
+  $got .= chomp;
+  if (substr($got,0,1) ~~ "[") {
+    # Convert from arrayref to array
+    $got = substr($got, 1, -1);
+  };
+  
+  @got = EVAL $got;
+  @got = @got[ 0..@dirs-1 ];
+  @expected = @dirs;
+
+  is @got, @expected, "'" ~ @dirs ~ "' works (with a space delimiting -I)";
+}
+
+
+# vim: ft=perl6

samples/Perl6/01-parse.t

@@ -0,0 +1,223 @@
+use v6;
+BEGIN { @*INC.push('lib') };
+
+use JSON::Tiny::Grammar;
+use Test;
+
+my @t =
+    '{}',
+    '{  }',
+    ' { } ',
+    '{ "a" : "b" }',
+    '{ "a" : null }',
+    '{ "a" : true }',
+    '{ "a" : false }',
+    '{ "a" : { } }',
+    '[]',
+    '[ ]',
+    ' [ ] ',
+    # stolen from JSON::XS, 18_json_checker.t, and adapted a bit
+    Q<<[
+    "JSON Test Pattern pass1",
+    {"object with 1 member":["array with 1 element"]},
+    {},
+    []
+    ]>>,
+    Q<<[1]>>,
+    Q<<[true]>>,
+    Q<<[-42]>>,
+    Q<<[-42,true,false,null]>>,
+    Q<<{ "integer": 1234567890 }>>,
+    Q<<{ "real": -9876.543210 }>>,
+    Q<<{ "e": 0.123456789e-12 }>>,
+    Q<<{ "E": 1.234567890E+34 }>>,
+    Q<<{ "":  23456789012E66 }>>,
+    Q<<{ "zero": 0 }>>,
+    Q<<{ "one": 1 }>>,
+    Q<<{ "space": " " }>>,
+    Q<<{ "quote": "\""}>>,
+    Q<<{ "backslash": "\\"}>>,
+    Q<<{ "controls": "\b\f\n\r\t"}>>,
+    Q<<{ "slash": "/ & \/"}>>,
+    Q<<{ "alpha": "abcdefghijklmnopqrstuvwyz"}>>,
+    Q<<{ "ALPHA": "ABCDEFGHIJKLMNOPQRSTUVWYZ"}>>,
+    Q<<{ "digit": "0123456789"}>>,
+    Q<<{ "0123456789": "digit"}>>,
+    Q<<{"special": "`1~!@#$%^&*()_+-={':[,]}|;.</>?"}>>,
+    Q<<{"hex": "\u0123\u4567\u89AB\uCDEF\uabcd\uef4A"}>>,
+    Q<<{"true": true}>>,
+    Q<<{"false": false}>>,
+    Q<<{"null": null}>>,
+    Q<<{"array":[  ]}>>,
+    Q<<{"object":{  }}>>,
+    Q<<{"address": "50 St. James Street"}>>,
+    Q<<{"url": "http://www.JSON.org/"}>>,
+    Q<<{"comment": "// /* <!-- --"}>>,
+    Q<<{"# -- --> */": " "}>>,
+    Q<<{ " s p a c e d " :[1,2 , 3
+
+,
+
+4 , 5        ,          6           ,7        ],"compact":[1,2,3,4,5,6,7]}>>,
+
+    Q<<{"jsontext": "{\"object with 1 member\":[\"array with 1 element\"]}"}>>,
+    Q<<{"quotes": "&#34; \u0022 %22 0x22 034 &#x22;"}>>,
+    Q<<{    "\/\\\"\uCAFE\uBABE\uAB98\uFCDE\ubcda\uef4A\b\f\n\r\t`1~!@#$%^&*()_+-=[]{}|;:',./<>?"
+: "A key can be any string"
+    }>>,
+    Q<<[    0.5 ,98.6
+,
+99.44
+,
+
+1066,
+1e1,
+0.1e1
+    ]>>,
+    Q<<[1e-1]>>,
+    Q<<[1e00,2e+00,2e-00,"rosebud"]>>,
+    Q<<[[[[[[[[[[[[[[[[[[["Not too deep"]]]]]]]]]]]]]]]]]]]>>,
+    Q<<{
+    "JSON Test Pattern pass3": {
+        "The outermost value": "must be an object or array.",
+        "In this test": "It is an object."
+    }
+}
+>>,
+# from http://www.json.org/example.html
+    Q<<{
+    "glossary": {
+        "title": "example glossary",
+		"GlossDiv": {
+            "title": "S",
+			"GlossList": {
+                "GlossEntry": {
+                    "ID": "SGML",
+					"SortAs": "SGML",
+					"GlossTerm": "Standard Generalized Markup Language",
+					"Acronym": "SGML",
+					"Abbrev": "ISO 8879:1986",
+					"GlossDef": {
+                        "para": "A meta-markup language, used to create markup languages such as DocBook.",
+						"GlossSeeAlso": ["GML", "XML"]
+                    },
+					"GlossSee": "markup"
+                }
+            }
+        }
+    }
+}
+    >>,
+    Q<<{"menu": {
+  "id": "file",
+  "value": "File",
+  "popup": {
+    "menuitem": [
+      {"value": "New", "onclick": "CreateNewDoc()"},
+      {"value": "Open", "onclick": "OpenDoc()"},
+      {"value": "Close", "onclick": "CloseDoc()"}
+    ]
+  }
+}}>>,
+    Q<<{"widget": {
+    "debug": "on",
+    "window": {
+        "title": "Sample Konfabulator Widget",
+        "name": "main_window",
+        "width": 500,
+        "height": 500
+    },
+    "image": {
+        "src": "Images/Sun.png",
+        "name": "sun1",
+        "hOffset": 250,
+        "vOffset": 250,
+        "alignment": "center"
+    },
+    "text": {
+        "data": "Click Here",
+        "size": 36,
+        "style": "bold",
+        "name": "text1",
+        "hOffset": 250,
+        "vOffset": 100,
+        "alignment": "center",
+        "onMouseUp": "sun1.opacity = (sun1.opacity / 100) * 90;"
+    }
+}}>>,
+    ;
+
+my @n =
+    '{ ',
+    '{ 3 : 4 }',
+    '{ 3 : tru }',  # not quite true
+    '{ "a : false }', # missing quote
+    # stolen from JSON::XS, 18_json_checker.t
+    Q<<"A JSON payload should be an object or array, not a string.">>,
+    Q<<{"Extra value after close": true} "misplaced quoted value">>,
+    Q<<{"Illegal expression": 1 + 2}>>,
+    Q<<{"Illegal invocation": alert()}>>,
+    Q<<{"Numbers cannot have leading zeroes": 013}>>,
+    Q<<{"Numbers cannot be hex": 0x14}>>,
+    Q<<["Illegal backslash escape: \x15"]>>,
+    Q<<[\naked]>>,
+    Q<<["Illegal backslash escape: \017"]>>,
+# skipped: wo don't implement no stinkin' aritifical limits.
+#    Q<<[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[["Too deep"]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]>>,
+    Q<<{"Missing colon" null}>>,
+    Q<<["Unclosed array">>,
+    Q<<{"Double colon":: null}>>,
+    Q<<{"Comma instead of colon", null}>>,
+    Q<<["Colon instead of comma": false]>>,
+    Q<<["Bad value", truth]>>,
+    Q<<['single quote']>>,
+    qq<["\ttab\tcharacter	in	string	"]>,
+    Q<<["line
+break"]>>,
+    Q<<["line\
+break"]>>,
+    Q<<[0e]>>,
+    Q<<{unquoted_key: "keys must be quoted"}>>,
+    Q<<[0e+]>>,
+    Q<<[0e+-1]>>,
+    Q<<{"Comma instead if closing brace": true,>>,
+    Q<<["mismatch"}>>,
+    Q<<["extra comma",]>>,
+    Q<<["double extra comma",,]>>,
+    Q<<[   , "<-- missing value"]>>,
+    Q<<["Comma after the close"],>>,
+    Q<<["Extra close"]]>>,
+    Q<<{"Extra comma": true,}>>,
+;
+
+plan (+@t) + (+@n);
+
+my $i = 0;
+for @t -> $t {
+    my $desc = $t;
+    if $desc ~~ m/\n/ {
+        $desc .= subst(/\n.*$/, "\\n...[$i]");
+    }
+    my $parsed = 0;
+    try {
+        JSON::Tiny::Grammar.parse($t)
+            and $parsed = 1;
+    }
+    ok $parsed, "JSON string «$desc» parsed";
+    $i++;
+}
+
+for @n -> $t {
+    my $desc = $t;
+    if $desc ~~ m/\n/ {
+        $desc .= subst(/\n.*$/, "\\n...[$i]");
+    }
+    my $parsed = 0;
+    try { JSON::Tiny::Grammar.parse($t) and $parsed = 1 };
+    nok $parsed, "NOT parsed «$desc»";
+    $i++;
+}
+
+
+# vim: ft=perl6
+

samples/Perl6/A.pm

@@ -0,0 +1,9 @@
+# used in t/spec/S11-modules/nested.t 
+
+BEGIN { @*INC.push('t/spec/packages') };
+
+module A::A {
+    use A::B;
+}
+
+# vim: ft=perl6

samples/Perl6/ANSIColor.pm

@@ -0,0 +1,148 @@
+use v6;
+
+module Term::ANSIColor;
+
+# these will be macros one day, yet macros can't be exported so far
+sub RESET         is export { "\e[0m"  }
+sub BOLD          is export { "\e[1m"  }
+sub UNDERLINE     is export { "\e[4m"  }
+sub INVERSE       is export { "\e[7m"  }
+sub BOLD_OFF      is export { "\e[22m" }
+sub UNDERLINE_OFF is export { "\e[24m" }
+sub INVERSE_OFF   is export { "\e[27m" }
+
+my %attrs = 
+	reset      => "0",
+	bold       => "1",
+	underline  => "4",
+	inverse    => "7",
+	black      => "30",
+	red        => "31",
+	green      => "32",
+	yellow     => "33",
+	blue       => "34",
+	magenta    => "35",
+	cyan       => "36",
+	white      => "37",
+	default    => "39",
+	on_black   => "40",
+	on_red     => "41",
+	on_green   => "42",
+	on_yellow  => "43",
+	on_blue    => "44",
+	on_magenta => "45",
+	on_cyan    => "46",
+	on_white   => "47",
+	on_default => "49";
+
+sub color (Str $what) is export {
+	my @res;
+	my @a = $what.split(' ');
+	for @a -> $attr {
+		if %attrs.exists($attr) {
+			@res.push: %attrs{$attr}
+		} else {
+			die("Invalid attribute name '$attr'")
+		}
+	}
+	return "\e[" ~ @res.join(';') ~ "m";
+}
+
+sub colored (Str $what, Str $how) is export {
+	color($how) ~ $what ~ color('reset');
+}
+
+sub colorvalid (*@a) is export {
+	for @a -> $el {
+		return False unless %attrs.exists($el)
+	}
+	return True;
+}
+
+sub colorstrip (*@a) is export {
+	my @res;
+	for @a -> $str {
+		@res.push: $str.subst(/\e\[ <[0..9;]>+ m/, '', :g);
+	}
+	return @res.join;
+}
+
+sub uncolor (Str $what) is export {
+	my @res;
+	my @list = $what.comb(/\d+/);
+	for @list -> $elem {
+		if %attrs.reverse.exists($elem) {
+			@res.push: %attrs.reverse{$elem}
+		} else {
+			die("Bad escape sequence: {'\e[' ~ $elem ~ 'm'}")
+		}
+	}
+	return @res.join(' ');
+}
+
+=begin pod
+
+=head1 NAME
+
+Term::ANSIColor - Color screen output using ANSI escape sequences
+
+=head1 SYNOPSIS
+
+	use Term::ANSIColor;
+	say color('bold'), "this is in bold", color('reset');
+	say colored('underline red on_green', 'what a lovely colours!');
+	say BOLD, 'good to be fat!', BOLD_OFF;
+	say 'ok' if colorvalid('magenta', 'on_black', 'inverse');
+	say '\e[36m is ', uncolor('\e36m');
+	say colorstrip("\e[1mThis is bold\e[0m");
+
+=head1 DESCRIPTION
+
+Term::ANSIColor provides an interface for using colored output
+in terminals. The following functions are available:
+
+=head2 C<color()>
+
+Given a string with color names, the output produced by C<color()>
+sets the terminal output so the text printed after it will be colored
+as specified. The following color names are recognised:
+
+	reset bold underline inverse black red green yellow blue
+	magenta cyan white default on_black on_red on_green on_yellow
+	on_blue on_magenta on_cyan on_white on_default
+
+The on_* family of colors correspond to the background colors.
+
+=head2 C<colored()>
+
+C<colored()> is similar to C<color()>. It takes two Str arguments,
+where the first is the colors to be used, and the second is the string
+to be colored. The C<reset> sequence is automagically placed after
+the string.
+
+=head2 C<colorvalid()>
+
+C<colorvalid()> gets an array of color specifications (like those
+passed to C<color()>) and returns true if all of them are valid,
+false otherwise.
+
+=head2 C<colorstrip()>
+
+C<colorstrip>, given a string, removes all the escape sequences
+in it, leaving the plain text without effects.
+
+=head2 C<uncolor()>
+
+Given escape sequences, C<uncolor()> returns a string with readable
+color names. E.g. passing "\e[36;44m" will result in "cyan on_blue".
+
+=head1 Constants
+
+C<Term::ANSIColor> provides constants which are just strings of
+appropriate escape sequences. The following constants are available:
+
+	RESET BOLD UNDERLINE INVERSE BOLD_OFF UNDERLINE_OFF INVERSE_OFF
+
+=end pod
+
+# vim: ft=perl6

samples/Perl6/Bailador.pm

@@ -0,0 +1,102 @@
+use Bailador::App;
+use Bailador::Request;
+use Bailador::Response;
+use Bailador::Context;
+use HTTP::Easy::PSGI;
+
+module Bailador;
+
+my $app = Bailador::App.current;
+
+our sub import {
+    my $file = callframe(1).file;
+    my $slash = $file.rindex('/');
+    if $slash {
+        $app.location = $file.substr(0, $file.rindex('/'));
+    } else {
+        $app.location = '.';
+    }
+}
+
+sub route_to_regex($route) {
+    $route.split('/').map({
+        my $r = $_;
+        if $_.substr(0, 1) eq ':' {
+            $r = q{(<-[\/\.]>+)};
+        }
+        $r
+    }).join("'/'");
+}
+
+multi parse_route(Str $route) {
+    my $r = route_to_regex($route);
+    return "/ ^ $r \$ /".eval;
+}
+
+multi parse_route($route) {
+    # do nothing
+    $route
+}
+
+sub get(Pair $x) is export {
+    my $p = parse_route($x.key) => $x.value;
+    $app.add_route: 'GET', $p;
+    return $x;
+}
+
+sub post(Pair $x) is export {
+    my $p = parse_route($x.key) => $x.value;
+    $app.add_route: 'POST', $p;
+    return $x;
+}
+
+sub request is export { $app.context.request }
+
+sub content_type(Str $type) is export {
+    $app.response.headers<Content-Type> = $type;
+}
+
+sub header(Str $name, Cool $value) is export {
+    $app.response.headers{$name} = ~$value;
+}
+
+sub status(Int $code) is export {
+    $app.response.code = $code;
+}
+
+sub template(Str $tmpl, *@params) is export {
+    $app.template($tmpl, @params);
+}
+
+our sub dispatch_request(Bailador::Request $r) {
+    return dispatch($r.env);
+}
+
+sub dispatch($env) {
+    $app.context.env = $env;
+
+    my ($r, $match) = $app.find_route($env);
+
+    if $r {
+        status 200;
+        if $match {
+            $app.response.content = $r.value.(|$match.list);
+        } else {
+            $app.response.content = $r.value.();
+        }
+    }
+
+    return $app.response;
+}
+
+sub dispatch-psgi($env) {
+    return dispatch($env).psgi;
+}
+
+sub baile is export {
+    given HTTP::Easy::PSGI.new(port => 3000) {
+        .app(&dispatch-psgi);
+        say "Entering the development dance floor: http://0.0.0.0:3000";
+        .run;
+    }
+}

samples/Perl6/ContainsUnicode.pm

@@ -0,0 +1,7 @@
+module ContainsUnicode {
+    sub uc-and-join(*@things, :$separator = ', ') is export {
+        @things».uc.join($separator)
+    }
+}
+
+# vim: ft=perl6

samples/Perl6/Model.pm

@@ -0,0 +1,146 @@
+use v6;
+
+class Math::Model;
+
+use Math::RungeKutta;
+# TODO: only load when needed
+use SVG;
+use SVG::Plot;
+
+has %.derivatives;
+has %.variables;
+has %.initials;
+has @.captures is rw;
+
+has %!inv = %!derivatives.invert;
+# in Math::Model all variables are accessible by name
+# in contrast Math::RungeKutta uses vectors, so we need
+# to define an (arbitrary) ordering
+# @!deriv-names holds the names of the derivatives in a fixed
+# order, sod @!deriv-names[$number] turns the number into a name
+# %!deriv-keying{$name} translates a name into the corresponding index
+has @!deriv-names  =  %!inv.keys;
+has %!deriv-keying =  @!deriv-names Z=> 0..Inf;
+
+# snapshot of all variables in the current model
+has %!current-values;
+
+has %.results;
+has @.time;
+
+has $.numeric-error is rw = 0.0001;
+
+my sub param-names(&c) {
+    &c.signature.params».name».substr(1).grep({ $_ ne '_'});
+}
+
+method !params-for(&c) {
+    param-names(&c).map( {; $_ => %!current-values{$_} } ).hash;
+}
+
+method topo-sort(*@vars) {
+    my %seen;
+    my @order;
+    sub topo(*@a) {
+        for @a {
+            next if %!inv.exists($_) || %seen{$_} || $_ eq 'time';
+            die "Undeclared variable '$_' used in model"
+                unless %.variables.exists($_);
+            topo(param-names(%.variables{$_}));
+            @order.push: $_;
+            %seen{$_}++;
+        }
+    }
+    topo(@vars);
+#    say @order.perl;
+    @order;
+}
+
+
+method integrate(:$from = 0, :$to = 10, :$min-resolution = ($to - $from) / 20, :$verbose) {
+    for %.derivatives -> $d {
+        die "There must be a variable defined for each derivative, missing for '$d.key()'"
+            unless %.variables.exists($d.key) || %!inv.exists($d.key);
+        die "There must be an initial value defined for each derivative target, missing for '$d.value()'"
+            unless %.initials.exists($d.value);
+    }
+
+    %!current-values       = %.initials;
+    %!current-values<time> = $from;
+
+    my @vars-topo          = self.topo-sort(%.variables.keys);
+    sub update-current-values($time, @values) {
+        %!current-values<time>          = $time;
+        %!current-values{@!deriv-names} = @values;
+        for @vars-topo {
+            my $c = %.variables{$_};
+            %!current-values{$_} = $c.(|self!params-for($c));
+        }
+    }
+
+    my @initial = %.initials{@!deriv-names};
+
+    sub derivatives($time, @values) {
+        update-current-values($time, @values);
+        my @r;
+        for %!inv{@!deriv-names} {
+            my $v = %.variables{$_};
+            @r.push: $v.defined
+                ?? $v(|self!params-for($v))
+                !! %!current-values{$_};
+        }
+        @r;
+    }
+
+    @!time = ();
+    for @.captures {
+        %!results{$_} = [];
+    }
+
+    sub record($time, @values) {
+        update-current-values($time, @values);
+        @!time.push: $time;
+        say $time if $verbose;
+
+        for @.captures {
+            %!results{$_}.push: %!current-values{$_};;
+        }
+    }
+
+    record($from, %.initials{@!deriv-names});
+
+    adaptive-rk-integrate(
+        :$from,
+        :$to,
+        :@initial,
+        :derivative(&derivatives),
+        :max-stepsize($min-resolution),
+        :do(&record),
+        :epsilon($.numeric-error),
+    );
+    %!results;
+}
+
+method render-svg(
+            $filename,
+            :$x-axis = 'time',
+            :$width = 800,
+            :$height = 600,
+            :$title = 'Model output') {
+    my $f = open $filename, :w
+            or die "Can't open file '$filename' for writing: $!";
+    my @values = map { %!results{$_} }, @.captures.grep({ $_ ne $x-axis});
+    my @x = $x-axis eq 'time' ?? @!time !! %!results{$x-axis}.flat;
+    my $svg = SVG::Plot.new(
+        :$width,
+        :$height,
+        :@x,
+        :@values,
+        :$title,
+    ).plot(:xy-lines);
+    $f.say(SVG.serialize($svg));
+    $f.close;
+    say "Wrote ouput to '$filename'";
+}
+
+# vim: ft=perl6

samples/Perl6/Simple.pm

@@ -0,0 +1,317 @@
+# ----------------------
+# LWP::Simple for Perl 6
+# ----------------------
+use v6;
+use MIME::Base64;
+use URI;
+
+class LWP::Simple:auth<cosimo>:ver<0.085>;
+
+our $VERSION = '0.085';
+
+enum RequestType <GET POST>;
+
+has Str $.default_encoding = 'utf-8';
+our $.class_default_encoding = 'utf-8';
+
+# these were intended to be constant but that hit pre-compilation issue
+my Buf $crlf = Buf.new(13, 10);
+my Buf $http_header_end_marker = Buf.new(13, 10, 13, 10);
+my Int constant $default_stream_read_len = 2 * 1024;
+
+method base64encode ($user, $pass) {
+    my MIME::Base64 $mime .= new();
+    my $encoded = $mime.encode_base64($user ~ ':' ~ $pass);
+    return $encoded;
+}
+
+method get (Str $url) {
+    self.request_shell(RequestType::GET, $url)
+}
+
+method post (Str $url, %headers = {}, Any $content?) {
+    self.request_shell(RequestType::POST, $url, %headers, $content)
+}
+
+method request_shell (RequestType $rt, Str $url, %headers = {}, Any $content?) {
+
+    return unless $url;
+
+    my ($scheme, $hostname, $port, $path, $auth) = self.parse_url($url);
+
+    %headers{'Connection'} = 'close';
+    %headers{'User-Agent'} //= "LWP::Simple/$VERSION Perl6/$*PERL<compiler><name>";
+
+    if $auth {
+        $hostname = $auth<host>;
+        my $user = $auth<user>;
+        my $pass = $auth<password>;
+        my $base64enc = self.base64encode($user, $pass);
+        %headers<Authorization> = "Basic $base64enc";
+    }
+
+    %headers<Host> = $hostname;
+
+    if ($rt ~~ RequestType::POST && $content.defined) {
+        # Attach Content-Length header
+        # as recommended in RFC2616 section 14.3.
+        # Note: Empty content is also a content,
+        # header value equals to zero is valid.
+        %headers{'Content-Length'} = $content.encode.bytes;
+    }
+
+    my ($status, $resp_headers, $resp_content) =
+        self.make_request($rt, $hostname, $port, $path, %headers, $content);
+
+    given $status {
+
+        when / 30 <[12]> / {
+            my %resp_headers = $resp_headers.hash;
+            my $new_url = %resp_headers<Location>;
+            if ! $new_url {
+                die "Redirect $status without a new URL?";
+            }
+
+            # 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.request_shell($rt, $new_url, %headers, $content);
+        }
+
+        when /200/ {
+            # should be fancier about charset decoding application - someday
+            if  $resp_headers<Content-Type> &&
+                $resp_headers<Content-Type> ~~
+                    /   $<media-type>=[<-[/;]>+]
+                        [ <[/]> $<media-subtype>=[<-[;]>+] ]? /  &&
+                (   $<media-type> eq 'text' ||
+                    (   $<media-type> eq 'application' &&
+                        $<media-subtype> ~~ /[ ecma | java ]script | json/
+                    )
+                )
+            {
+                my $charset = 
+                    ($resp_headers<Content-Type> ~~ /charset\=(<-[;]>*)/)[0];
+                $charset = $charset ?? $charset.Str !!
+                    self ?? $.default_encoding !! $.class_default_encoding;
+                return $resp_content.decode($charset);
+            }
+            else {
+                return $resp_content;
+            }
+            
+        }
+
+        # Response failed
+        default {
+            return;
+        }
+    }
+
+}
+
+method parse_chunks(Blob $b is rw, IO::Socket::INET $sock) {
+    my Int ($line_end_pos, $chunk_len, $chunk_start) = (0) xx 3;
+    my Blob $content = Blob.new();
+
+    # smallest valid chunked line is 0CRLFCRLF (ascii or other 8bit like EBCDIC)
+    while ($line_end_pos + 5 <= $b.bytes) {
+        while ( $line_end_pos +4 <= $b.bytes  &&
+                $b.subbuf($line_end_pos, 2) ne $crlf
+        ) {
+            $line_end_pos++
+        }
+#       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');
+        if  $line_end_pos +4 <= $b.bytes &&
+            $b.subbuf(
+                $chunk_start, $line_end_pos + 2 - $chunk_start
+            ).decode('ascii') ~~ /^(<.xdigit>+)[";"|"\r\n"]/ 
+        {
+
+            # deal with case of chunk_len is 0
+
+            $chunk_len = :16($/[0].Str);
+#            say 'got chunk len ', $/[0].Str;
+
+            # test if at end of buf??
+            if $chunk_len == 0 {
+                # this is a "normal" exit from the routine
+                return True, $content;
+            }
+
+            # think 1CRLFxCRLF
+            if $line_end_pos + $chunk_len + 4 <= $b.bytes {
+#                say 'inner chunk';
+                $content ~= $b.subbuf($line_end_pos +2, $chunk_len);
+                $line_end_pos = $chunk_start = $line_end_pos + $chunk_len +4;
+            }
+            else {
+#                say 'last chunk';
+                # remaining chunk part len is chunk_len with CRLF
+                # minus the length of the chunk piece at end of buffer
+                my $last_chunk_end_len = 
+                    $chunk_len +2 - ($b.bytes - $line_end_pos -2);
+                $content ~= $b.subbuf($line_end_pos +2);
+                if $last_chunk_end_len > 2  {
+                    $content ~= $sock.read($last_chunk_end_len -2);
+                }
+                # clean up CRLF after chunk
+                $sock.read(min($last_chunk_end_len, 2));
+
+                # this is a` "normal" exit from the routine
+                return False, $content;
+            }
+        }
+        else {
+#            say 'extend bytes ', $b.bytes, ' start ', $chunk_start, ' data ', $b.subbuf($chunk_start).decode('ascii');
+            # maybe odd case of buffer has just part of header at end
+            $b ~= $sock.read(20);
+        }
+    }
+
+#    say join ' ', $b[0 .. 100];
+#    say $b.subbuf(0, 100).decode('utf-8');
+    die "Could not parse chunk header";
+}
+
+method make_request (
+    RequestType $rt, $host, $port as Int, $path, %headers, $content?
+) {
+
+    my $headers = self.stringify_headers(%headers);
+
+    my IO::Socket::INET $sock .= new(:$host, :$port);
+    my Str $req_str = $rt.Stringy ~ " {$path} HTTP/1.1\r\n"
+        ~ $headers
+        ~ "\r\n";
+
+    # attach $content if given
+    # (string context is forced by concatenation)
+    $req_str ~= $content if $content.defined;
+
+    $sock.send($req_str);
+
+    my Blob $resp = $sock.read($default_stream_read_len);
+
+    my ($status, $resp_headers, $resp_content) = self.parse_response($resp);
+
+
+    if (($resp_headers<Transfer-Encoding> || '') eq 'chunked') {
+        my Bool $is_last_chunk;
+        my Blob $resp_content_chunk;
+
+        ($is_last_chunk, $resp_content) =
+            self.parse_chunks($resp_content, $sock);
+        while (not $is_last_chunk) {
+            ($is_last_chunk, $resp_content_chunk) =
+                self.parse_chunks(
+                    my Blob $next_chunk_start = $sock.read(1024),
+                    $sock
+            );
+            $resp_content ~= $resp_content_chunk;
+        }
+    }
+    elsif ( $resp_headers<Content-Length>   &&
+            $resp_content.bytes < $resp_headers<Content-Length>
+    ) {
+        $resp_content ~= $sock.read(
+            $resp_headers<Content-Length> - $resp_content.bytes
+        );
+    }
+    else { # a bit hacky for now but should be ok
+        while ($resp.bytes > 0) {
+            $resp = $sock.read($default_stream_read_len);
+            $resp_content ~= $resp;
+        }
+    }
+
+    $sock.close();
+
+    return ($status, $resp_headers, $resp_content);
+}
+
+method parse_response (Blob $resp) {
+
+    my %header;
+
+    my Int $header_end_pos = 0;
+    while ( $header_end_pos < $resp.bytes &&
+            $http_header_end_marker ne $resp.subbuf($header_end_pos, 4)  ) {
+        $header_end_pos++;
+    }
+
+    if ($header_end_pos < $resp.bytes) {
+        my @header_lines = $resp.subbuf(
+            0, $header_end_pos
+        ).decode('ascii').split(/\r\n/);
+        my Str $status_line = @header_lines.shift;
+
+        for @header_lines {
+            my ($name, $value) = .split(': ');
+            %header{$name} = $value;
+        }
+        return $status_line, %header.item, $resp.subbuf($header_end_pos +4).item;
+    }
+
+    die "could not parse headers";
+#    if %header.exists('Transfer-Encoding') && %header<Transfer-Encoding> ~~ m/:i chunked/ {
+#        @content = self.decode_chunked(@content);
+#    }
+
+}
+
+method getprint (Str $url) {
+    my $out = self.get($url);
+    if $out ~~ Buf { $*OUT.write($out) } else { say $out }
+}
+
+method getstore (Str $url, Str $filename) {
+    return unless defined $url;
+
+    my $content = self.get($url);
+    if ! $content {
+        return
+    }
+
+    my $fh = open($filename, :bin, :w);
+    if $content ~~ Buf {
+        $fh.write($content)
+    }
+    else {
+        $fh.print($content)
+    }
+
+    $fh.close; 
+}
+
+method parse_url (Str $url) {
+    my URI $u .= new($url);
+    my $path = $u.path_query;
+    
+    my $user_info = $u.grammar.parse_result<URI_reference><URI><hier_part><authority><userinfo>;
+    
+    return (
+        $u.scheme, 
+        $user_info ?? "{$user_info}@{$u.host}" !! $u.host, 
+        $u.port, 
+        $path eq '' ?? '/' !! $path,
+        $user_info ?? {
+            host => $u.host,
+            user => ~ $user_info<likely_userinfo_component>[0],
+            password => ~ $user_info<likely_userinfo_component>[1]
+        } !! Nil
+    );    
+}
+
+method stringify_headers (%headers) {
+    my Str $str = '';
+    for sort %headers.keys {
+        $str ~= $_ ~ ': ' ~ %headers{$_} ~ "\r\n";
+    }
+    return $str;
+}
+

samples/Perl6/Win32.pm

@@ -0,0 +1,207 @@
+my class IO::Spec::Win32 is IO::Spec::Unix {
+
+    # Some regexes we use for path splitting
+    my $slash	    = regex {  <[\/ \\]> }
+    my $notslash    = regex { <-[\/ \\]> }
+    my $driveletter = regex { <[A..Z a..z]> ':' }
+    my $UNCpath     = regex { [<$slash> ** 2] <$notslash>+  <$slash>  [<$notslash>+ | $] }
+    my $volume_rx   = regex { <$driveletter> | <$UNCpath> }
+
+    method canonpath ($path, :$parent) {
+        $path eq '' ?? '' !! self!canon-cat($path, :$parent);
+    }
+
+    method catdir(*@dirs) {
+        return "" unless @dirs;
+        return self!canon-cat( "\\", |@dirs ) if @dirs[0] eq "";
+        self!canon-cat(|@dirs);
+    }
+
+    method splitdir($dir)        { $dir.split($slash)  }
+    method catfile(|c)           { self.catdir(|c)     }
+    method devnull               { 'nul'               }
+    method rootdir               { '\\'                }
+
+    method tmpdir {
+        first( { .defined && .IO.d && .IO.w },
+            %*ENV<TMPDIR>,
+            %*ENV<TEMP>,
+            %*ENV<TMP>,
+            'SYS:/temp',
+            'C:\system\temp',
+            'C:/temp',
+            '/tmp',
+            '/')
+          || self.curdir;
+    }
+
+    method path {
+       my @path = split(';', %*ENV<PATH>);
+       @path».=subst(:global, q/"/, '');
+       @path = grep *.chars, @path;
+       unshift @path, ".";
+       return @path;
+   }
+
+    method is-absolute ($path) {
+        # As of right now, this returns 2 if the path is absolute with a
+        # volume, 1 if it's absolute with no volume, 0 otherwise.
+        given $path {
+            when /^ [<$driveletter> <$slash> | <$UNCpath>]/ { 2 }
+            when /^ <$slash> /                              { 1 }
+            default                     { 0 }
+        }   #/
+    }
+
+    method split ($path as Str is copy) { 
+        $path ~~ s[ <$slash>+ $] = ''                       #=
+            unless $path ~~ /^ <$driveletter>? <$slash>+ $/;
+
+        $path ~~ 
+            m/^ ( <$volume_rx> ? )
+            ( [ .* <$slash> ]? )
+            (.*)
+             /;
+        my ($volume, $directory, $basename) = (~$0, ~$1, ~$2);
+        $directory ~~ s/ <?after .> <$slash>+ $//;
+
+
+        if all($directory, $basename) eq '' && $volume ne '' {
+            $directory = $volume ~~ /^<$driveletter>/
+                     ?? '.' !! '\\';
+        }
+        $basename = '\\'  if $directory eq any('/', '\\') && $basename eq '';
+        $directory = '.'  if $directory eq ''             && $basename ne '';
+
+        return (:$volume, :$directory, :$basename);
+    }
+
+    method join ($volume, $directory is copy, $file is copy) { 
+        $directory = '' if $directory eq '.' && $file.chars;
+        if $directory.match( /^<$slash>$/ ) && $file.match( /^<$slash>$/ ) {
+            $file = '';
+            $directory = '' if $volume.chars > 2; #i.e. UNC path
+        }
+        self.catpath($volume, $directory, $file);
+    }
+
+    method splitpath($path as Str, :$nofile = False) { 
+
+        my ($volume,$directory,$file) = ('','','');
+        if ( $nofile ) {
+            $path ~~ 
+                /^ (<$volume_rx>?) (.*) /;
+            $volume    = ~$0;
+            $directory = ~$1;
+        }
+        else {
+            $path ~~ 
+                m/^ ( <$volume_rx> ? )
+                ( [ .* <$slash> [ '.' ** 1..2 $]? ]? )
+                (.*)
+                 /;
+            $volume    = ~$0;
+            $directory = ~$1;
+            $file      = ~$2;
+        }
+
+        return ($volume,$directory,$file);
+    }
+
+    method catpath($volume is copy, $directory, $file) {
+
+        # Make sure the glue separator is present
+        # unless it's a relative path like A:foo.txt
+        if $volume.chars and $directory.chars
+           and $volume !~~ /^<$driveletter>/
+           and $volume !~~ /<$slash> $/
+           and $directory !~~ /^ <$slash>/
+            { $volume ~= '\\' }
+        if $file.chars and $directory.chars
+           and $directory !~~ /<$slash> $/
+            { $volume ~ $directory ~ '\\' ~ $file; }
+        else     { $volume ~ $directory     ~    $file; }
+    }
+
+    method rel2abs ($path is copy, $base? is copy) {
+
+        my $is_abs = self.is-absolute($path);
+
+        # Check for volume (should probably document the '2' thing...)
+        return self.canonpath( $path ) if $is_abs == 2;
+
+        if $is_abs {
+            # It's missing a volume, add one
+            my $vol;
+            $vol = self.splitpath($base)[0] if $base.defined;
+            $vol ||= self.splitpath($*CWD)[0];
+            return self.canonpath( $vol ~ $path );
+        }
+
+        if not defined $base {
+        # TODO: implement _getdcwd call ( Windows maintains separate CWD for each volume )
+        # See: http://msdn.microsoft.com/en-us/library/1e5zwe0c%28v=vs.80%29.aspx
+            #$base = Cwd::getdcwd( (self.splitpath: $path)[0] ) if defined &Cwd::getdcwd ;
+            #$base //= $*CWD ;
+            $base = $*CWD;
+        }
+        elsif ( !self.is-absolute( $base ) ) {
+            $base = self.rel2abs( $base );
+        }
+        else {
+            $base = self.canonpath( $base );
+        }
+
+        my ($path_directories, $path_file) = self.splitpath( $path )[1..2] ;
+
+        my ($base_volume, $base_directories) = self.splitpath( $base, :nofile ) ;
+
+        $path = self.catpath( 
+                    $base_volume, 
+                    self.catdir( $base_directories, $path_directories ), 
+                    $path_file
+                    ) ;
+
+        return self.canonpath( $path ) ;
+    }
+
+
+    method !canon-cat ( $first, *@rest, :$parent --> Str) {
+
+        $first ~~ /^ ([   <$driveletter> <$slash>?
+                        | <$UNCpath>
+                        | [<$slash> ** 2] <$notslash>+
+                        | <$slash> ]?)
+                       (.*)
+                   /;
+        my Str ($volume, $path) = ~$0, ~$1;
+
+        $volume.=subst(:g, '/', '\\');
+        if $volume ~~ /^<$driveletter>/ {
+            $volume.=uc;
+        }
+        elsif $volume.chars && $volume !~~ / '\\' $/ {
+            $volume ~= '\\';
+        }
+
+        $path = join "\\", $path, @rest.flat;
+        $path ~~ s:g/ <$slash>+ /\\/;                              # /xx\\yy   --> \xx\yy
+        $path ~~ s:g/[ ^ | '\\']   '.'  '\\.'*  [ '\\' | $ ]/\\/;  # xx/././yy --> xx/yy
+        if $parent {
+            while $path ~~ s:g { [^ | <?after '\\'>] <!before '..\\'> <-[\\]>+ '\\..' ['\\' | $ ] } = '' { };
+        }
+        $path ~~ s/^ '\\'+ //;        # \xx --> xx  NOTE: this is *not* root
+        $path ~~ s/ '\\'+ $//;        # xx\ --> xx
+        if $volume ~~ / '\\' $ / {    # <vol>\.. --> <vol>\ 
+            $path ~~ s/ ^  '..'  '\\..'*  [ '\\' | $ ] //;
+        }
+
+        if $path eq '' {        # \\HOST\SHARE\ --> \\HOST\SHARE
+            $volume ~~ s/<?after '\\\\' .*> '\\' $ //;
+            $volume || '.';
+        }
+	else {
+            $volume ~ $path;
+        }
+    }
+}

samples/Perl6/advent2009-day16.t

@@ -0,0 +1,75 @@
+# http://perl6advent.wordpress.com/2009/12/16/day-16-we-call-it-the-old-switcheroo/
+
+use v6;
+use Test;
+
+
+sub weather($weather) {
+    given $weather {
+      when 'sunny'  { return 'Aah! ☀'                    }
+      when 'cloudy' { return 'Meh. ☁'                    }
+      when 'rainy'  { return 'Where is my umbrella? ☂'   }
+      when 'snowy'  { return 'Yippie! ☃'                 }
+      default       { return 'Looks like any other day.' }
+    }
+}
+is weather(Any), 'Looks like any other day.', 'Weather given/when';
+
+{
+    sub probability($probability) {
+        given $probability {
+          when     1.00 { return 'A certainty'   }
+          when * > 0.75 { return 'Quite likely'  }
+          when * > 0.50 { return 'Likely'        }
+          when * > 0.25 { return 'Unlikely'      }
+          when * > 0.00 { return 'Very unlikely' }
+          when     0.00 { return 'Fat chance'  }
+        }
+    }
+    is probability(0.80), 'Quite likely', 'Probability given/when';
+
+    sub fib(Int $_) {
+      when * < 2 { 1 }
+      default { fib($_ - 1) + fib($_ - 2) }
+    }
+    is fib(5), 8, '6th fibonacci number';
+}
+
+class Card {
+    method bend()     { return "Card bent" }
+    method fold()     { return "Card folded" }
+    method mutilate() { return "Card mutilated" }
+}
+my Card $punch-card .= new;
+
+my $actions;
+given $punch-card {
+  $actions ~= .bend;
+  $actions ~= .fold;
+  $actions ~= .mutilate;
+}
+is $actions, 'Card bentCard foldedCard mutilated', 'Given as a sort of once-only for loop.';
+
+
+my @list = 1, 2, 3, 4, 5;
+my $castle = 'phantom';
+my $full-of-vowels = 'aaaooouuuiiee';
+is (.[0] + .[1] + .[2] given @list), 6, 'Statement ending given';
+
+{
+    is ("My God, it's full of vowels!" when $full-of-vowels ~~ /^ <[aeiou]>+ $/), "My God, it's full of vowels!", 'Statement ending when';
+    is ('Boo!' when /phantom/ given $castle), 'Boo!', 'Nesting when inside given';
+}
+
+{
+    #Test DNA one liner at the end
+    my $result;
+    for ^20 {my ($a,$b)=<AT CG>.pick.comb.pick(*); my ($c,$d)=sort map({6+4*sin($_/2)},($_,$_+4)); $result ~= sprintf "%{$c}s%{$d-$c}s\n",$a,$b}
+    is $result.chars , 169 , 'We got a bunch of DNA';
+    is $result.split("\n").Int , 21 , 'On 20 line';
+    is $result.subst(/\s/ , '' , :g).chars , 40 , 'Containing 20 pairs';
+}
+
+eval_lives_ok 'for ^20 {my ($a,$b)=<AT CG>.pick.comb.pick(*); my ($c,$d)=sort map {6+4*sin($_/2)},$_,$_+4; sprintf "%{$c}s%{$d-$c}s\n",$a,$b}' , 'Can handle "map {...} ,$x,$y"';
+
+done;

samples/Perl6/basic-open.t

@@ -0,0 +1,48 @@
+use v6;
+use Test;
+
+plan 9;
+
+sub test_lines(@lines) {
+    #!rakudo todo 'line counts'
+    is @lines.elems, 3, 'Three lines read';
+    is @lines[0],
+       "Please do not remove this file, used by S16-io/basic-open.t",
+       'Retrieved first line';
+    is @lines[2],
+       "This is a test line.",
+       'Retrieved last line';
+}
+
+#?niecza skip 'TextReader.eof NYI'
+{
+    my $fh = open('t/spec/S16-io/test-data');
+    my $count = 0;
+    while !$fh.eof {
+        my $x = $fh.get;
+        $count++ if $x.defined;
+    }
+    is $count, 3, 'Read three lines with while !$hanlde.eof';
+}
+
+# test that we can interate over $fh.lines
+{
+    my $fh =  open('t/spec/S16-io/test-data');
+
+    ok defined($fh), 'Could open test file';
+    my @lines;
+    for $fh.lines -> $x {
+        push @lines, $x;
+    }
+    test_lines(@lines);
+}
+
+# test that we can get all items in list context:
+{
+    my $fh =  open('t/spec/S16-io/test-data');
+    ok defined($fh), 'Could open test file (again)';
+    my @lines = $fh.lines;
+    test_lines(@lines);
+}
+
+# vim: ft=perl6

samples/Perl6/calendar.t

@@ -0,0 +1,209 @@
+use v6;
+use Test;
+
+# calendar.t: tests some calendar-related methods common to
+# Date and DateTime
+
+plan 130;
+
+sub date($year, $month, $day) {
+    Date.new(:$year, :$month, :$day)
+}
+
+sub dtim($year, $month, $day) {
+    DateTime.new(:$year, :$month, :$day,
+        :hour(17), :minute(33), :second(2.9))
+}
+
+# --------------------------------------------------------------------
+# L<S32::Temporal/C<DateTime>/'truncated-to'>
+# --------------------------------------------------------------------
+
+is ~date(1969, 7, 20).truncated-to(month), '1969-07-01', 'Date.truncated-to(month)';
+is ~dtim(1969, 7, 20).truncated-to(month), '1969-07-01T00:00:00Z', 'DateTime.truncated-to(month)';
+is ~date(1969, 7, 20).truncated-to(year), '1969-01-01', 'Date.truncated-to(year)';
+is ~dtim(1969, 7, 20).truncated-to(year), '1969-01-01T00:00:00Z', 'DateTime.truncated-to(year)';
+
+is ~date(1999, 1, 18).truncated-to(week), '1999-01-18', 'Date.truncated-to(week) (no change in day)';
+is ~date(1999, 1, 19).truncated-to(week), '1999-01-18', 'Date.truncated-to(week) (short jump)';
+is ~date(1999, 1, 17).truncated-to(week), '1999-01-11', 'Date.truncated-to(week) (long jump)';
+is ~dtim(1999, 1, 17).truncated-to(week), '1999-01-11T00:00:00Z', 'DateTime.truncated-to(week) (long jump)';
+is ~date(1999, 4,  2).truncated-to(week), '1999-03-29', 'Date.truncated-to(week) (changing month)';
+is ~date(1999, 1,  3).truncated-to(week), '1998-12-28', 'Date.truncated-to(week) (changing year)';
+is ~dtim(1999, 1,  3).truncated-to(week), '1998-12-28T00:00:00Z', 'DateTime.truncated-to(week) (changing year)';
+is ~date(2000, 3,  1).truncated-to(week), '2000-02-28', 'Date.truncated-to(week) (skipping over Feb 29)';
+is ~dtim(2000, 3,  1).truncated-to(week), '2000-02-28T00:00:00Z', 'DateTime.truncated-to(week) (skipping over Feb 29)';
+is ~date(1988, 3,  3).truncated-to(week), '1988-02-29', 'Date.truncated-to(week) (landing on Feb 29)';
+is ~dtim(1988, 3,  3).truncated-to(week), '1988-02-29T00:00:00Z', 'DateTime.truncated-to(week) (landing on Feb 29)';
+
+# Verify .gist
+# Example taken from S32 specs documentation.
+#?niecza skip 'Undeclared routine: hour'
+{
+    my $dt = DateTime.new('2005-02-01T15:20:35Z');
+    my $truncated = $dt.truncated-to(hour);
+
+    is $truncated.gist, "2005-02-01T15:00:00Z", "validate .gist output";
+}
+
+# --------------------------------------------------------------------
+# L<S32::Temporal/Accessors/'the synonym day-of-month'>
+# --------------------------------------------------------------------
+
+is date(2003, 3, 18).day-of-month, 18, 'Date.day can be spelled as Date.day-of-month';
+is dtim(2003, 3, 18).day-of-month, 18, 'DateTime.day can be spelled as DateTime.day-of-month';
+
+# --------------------------------------------------------------------
+# L<S32::Temporal/Accessors/'day-of-week method'>
+# --------------------------------------------------------------------
+
+# much of this is blatantly stolen from the Date::Simple test suite
+# and redistributed under the terms of the Artistic License 2.0 with
+# permission of the original authors (John Tobey, Marty Pauly).
+
+is date(1966, 10, 15).day-of-week, 6, 'Date.day-of-week (1966-10-15)';
+is dtim(1966, 10, 15).day-of-week, 6, 'DateTime.day-of-week (1966-10-15)';
+is date(2401,  3,  1).day-of-week, 4, 'Date.day-of-week (2401-03-01)';
+is date(2401,  2, 28).day-of-week, 3, 'Date.day-of-week (2401-02-28)';
+is date(2400,  3,  1).day-of-week, 3, 'Date.day-of-week (2400-03-01)';
+is date(2400,  2, 29).day-of-week, 2, 'Date.day-of-week (2400-02-29)';
+is date(2400,  2, 28).day-of-week, 1, 'Date.day-of-week (2400-02-28)';
+is date(2101,  3,  1).day-of-week, 2, 'Date.day-of-week (2101-03-01)';
+is date(2101,  2, 28).day-of-week, 1, 'Date.day-of-week (2101-02-28)';
+is date(2100,  3,  1).day-of-week, 1, 'Date.day-of-week (2100-03-01)';
+is dtim(2100,  3,  1).day-of-week, 1, 'DateTime.day-of-week (2100-03-01)';
+is date(2100,  2, 28).day-of-week, 7, 'Date.day-of-week (2100-02-28)';
+is dtim(2100,  2, 28).day-of-week, 7, 'DateTime.day-of-week (2100-02-28)';
+is date(2001,  3,  1).day-of-week, 4, 'Date.day-of-week (2001-03-01)';
+is date(2001,  2, 28).day-of-week, 3, 'Date.day-of-week (2001-02-28)';
+is date(2000,  3,  1).day-of-week, 3, 'Date.day-of-week (2000-03-01)';
+is date(2000,  2, 29).day-of-week, 2, 'Date.day-of-week (2000-02-29)';
+is date(2000,  2, 28).day-of-week, 1, 'Date.day-of-week (2000-02-28)';
+is date(1901,  3,  1).day-of-week, 5, 'Date.day-of-week (1901-03-01)';
+is date(1901,  2, 28).day-of-week, 4, 'Date.day-of-week (1901-02-28)';
+is date(1900,  3,  1).day-of-week, 4, 'Date.day-of-week (1900-03-01)';
+is date(1900,  2, 28).day-of-week, 3, 'Date.day-of-week (1900-02-28)';
+is date(1801,  3,  1).day-of-week, 7, 'Date.day-of-week (1801-03-01)';
+is date(1801,  2, 28).day-of-week, 6, 'Date.day-of-week (1801-02-28)';
+is date(1800,  3,  1).day-of-week, 6, 'Date.day-of-week (1800-03-01)';
+is dtim(1800,  3,  1).day-of-week, 6, 'DateTime.day-of-week (1800-03-01)';
+is date(1800,  2, 28).day-of-week, 5, 'Date.day-of-week (1800-02-28)';
+is dtim(1800,  2, 28).day-of-week, 5, 'DateTime.day-of-week (1800-02-28)';
+is date(1701,  3,  1).day-of-week, 2, 'Date.day-of-week (1701-03-01)';
+is date(1701,  2, 28).day-of-week, 1, 'Date.day-of-week (1701-02-28)';
+is date(1700,  3,  1).day-of-week, 1, 'Date.day-of-week (1700-03-01)';
+is date(1700,  2, 28).day-of-week, 7, 'Date.day-of-week (1700-02-28)';
+is date(1601,  3,  1).day-of-week, 4, 'Date.day-of-week (1601-03-01)';
+is dtim(1601,  3,  1).day-of-week, 4, 'DateTime.day-of-week (1601-03-01)';
+is date(1601,  2, 28).day-of-week, 3, 'Date.day-of-week (1601-02-28)';
+is dtim(1601,  2, 28).day-of-week, 3, 'DateTime.day-of-week (1601-02-28)';
+is date(1600,  3,  1).day-of-week, 3, 'Date.day-of-week (1600-03-01)';
+is date(1600,  2, 29).day-of-week, 2, 'Date.day-of-week (1600-02-29)';
+is date(1600,  2, 28).day-of-week, 1, 'Date.day-of-week (1600-02-28)';
+
+# --------------------------------------------------------------------
+# L<S32::Temporal/Accessors/'The method week'>
+# --------------------------------------------------------------------
+
+is date(1977, 8, 20).week.join(' '), '1977 33', 'Date.week (1977-8-20)';
+is dtim(1977, 8, 20).week.join(' '), '1977 33', 'DateTime.week (1977-8-20)';
+is date(1977, 8, 20).week-year, 1977, 'Date.week (1977-8-20)';
+is dtim(1977, 8, 20).week-year, 1977, 'DateTime.week (1977-8-20)';
+is date(1977, 8, 20).week-number, 33, 'Date.week-number (1977-8-20)';
+is dtim(1977, 8, 20).week-number, 33, 'DateTime.week-number (1977-8-20)';
+is date(1987, 12, 18).week.join(' '), '1987 51', 'Date.week (1987-12-18)';
+is date(2020, 5, 4).week.join(' '), '2020 19', 'Date.week (2020-5-4)';
+
+# From http://en.wikipedia.org/w/index.php?title=ISO_week_dtim&oldid=370553706#Examples
+
+is date(2005, 01, 01).week.join(' '), '2004 53', 'Date.week (2005-01-01)';
+is date(2005, 01, 02).week.join(' '), '2004 53', 'Date.week (2005-01-02)';
+is date(2005, 12, 31).week.join(' '), '2005 52', 'Date.week (2005-12-31)';
+is date(2007, 01, 01).week.join(' '), '2007 1',  'Date.week (2007-01-01)';
+is date(2007, 12, 30).week.join(' '), '2007 52', 'Date.week (2007-12-30)';
+is dtim(2007, 12, 30).week.join(' '), '2007 52', 'DateTime.week (2007-12-30)';
+is date(2007, 12, 30).week-year, 2007, 'Date.week (2007-12-30)';
+is dtim(2007, 12, 30).week-year, 2007, 'DateTime.week (2007-12-30)';
+is date(2007, 12, 30).week-number, 52, 'Date.week-number (2007-12-30)';
+is dtim(2007, 12, 30).week-number, 52, 'DateTime.week-number (2007-12-30)';
+is date(2007, 12, 31).week.join(' '), '2008 1',  'Date.week (2007-12-31)';
+is date(2008, 01, 01).week.join(' '), '2008 1',  'Date.week (2008-01-01)';
+is date(2008, 12, 29).week.join(' '), '2009 1',  'Date.week (2008-12-29)';
+is date(2008, 12, 31).week.join(' '), '2009 1',  'Date.week (2008-12-31)';
+is date(2009, 01, 01).week.join(' '), '2009 1',  'Date.week (2009-01-01)';
+is date(2009, 12, 31).week.join(' '), '2009 53', 'Date.week (2009-12-31)';
+is date(2010, 01, 03).week.join(' '), '2009 53', 'Date.week (2010-01-03)';
+is dtim(2010, 01, 03).week.join(' '), '2009 53', 'DateTime.week (2010-01-03)';
+is date(2010, 01, 03).week-year, 2009, 'Date.week-year (2010-01-03)';
+is dtim(2010, 01, 03).week-year, 2009, 'DateTime.week-year (2010-01-03)';
+is date(2010, 01, 03).week-number, 53, 'Date.week-number (2010-01-03)';
+is dtim(2010, 01, 03).week-number, 53, 'DateTime.week-number (2010-01-03)';
+
+# day-of-week is tested each time show-dt is called.
+
+# --------------------------------------------------------------------
+# L<S32::Temporal/Accessors/'The weekday-of-month method'>
+# --------------------------------------------------------------------
+
+is date(1982, 2,  1).weekday-of-month, 1, 'Date.weekday-of-month (1982-02-01)';
+is dtim(1982, 2,  1).weekday-of-month, 1, 'DateTime.weekday-of-month (1982-02-01)';
+is date(1982, 2,  7).weekday-of-month, 1, 'Date.weekday-of-month (1982-02-07)';
+is date(1982, 2,  8).weekday-of-month, 2, 'Date.weekday-of-month (1982-02-08)';
+is date(1982, 2, 18).weekday-of-month, 3, 'Date.weekday-of-month (1982-02-18)';
+is date(1982, 2, 28).weekday-of-month, 4, 'Date.weekday-of-month (1982-02-28)';
+is dtim(1982, 2, 28).weekday-of-month, 4, 'DateTime.weekday-of-month (1982-02-28)';
+is date(1982, 4,  4).weekday-of-month, 1, 'Date.weekday-of-month (1982-04-04)';
+is date(1982, 4,  7).weekday-of-month, 1, 'Date.weekday-of-month (1982-04-07)';
+is date(1982, 4,  8).weekday-of-month, 2, 'Date.weekday-of-month (1982-04-08)';
+is date(1982, 4, 13).weekday-of-month, 2, 'Date.weekday-of-month (1982-04-13)';
+is date(1982, 4, 30).weekday-of-month, 5, 'Date.weekday-of-month (1982-04-30)';
+is dtim(1982, 4, 30).weekday-of-month, 5, 'DateTime.weekday-of-month (1982-04-30)';
+
+# --------------------------------------------------------------------
+# L<S32::Temporal/Accessors/'The days-in-month method'>
+# --------------------------------------------------------------------
+
+is date(1999,  5,  5).days-in-month, 31, 'Date.days-in-month (May 1999)';
+is date(1999,  6,  5).days-in-month, 30, 'Date.days-in-month (Jun 1999)';
+is date(1999,  2,  5).days-in-month, 28, 'Date.days-in-month (Feb 1999)';
+is dtim(1999,  2,  5).days-in-month, 28, 'DateTime.days-in-month (Feb 1999)';
+is date(2000,  2,  5).days-in-month, 29, 'Date.days-in-month (Feb 2000)';
+is dtim(2000,  2,  5).days-in-month, 29, 'DateTime.days-in-month (Feb 2000)';
+
+# --------------------------------------------------------------------
+# L<S32::Temporal/Accessors/'The day-of-year method'>
+# --------------------------------------------------------------------
+
+is date(1975,  1,  1).day-of-year,   1, 'Date.day-of-year (1975-01-01)';
+is dtim(1975,  1,  1).day-of-year,   1, 'DateTime.day-of-year (1975-01-01)';
+is date(1977,  5,  5).day-of-year, 125, 'Date.day-of-year (1977-05-05)';
+is date(1983, 11, 27).day-of-year, 331, 'Date.day-of-year (1983-11-27)';
+is date(1999,  2, 28).day-of-year,  59, 'Date.day-of-year (1999-02-28)';
+is dtim(1999,  2, 28).day-of-year,  59, 'DateTime.day-of-year (1999-02-28)';
+is date(1999,  3,  1).day-of-year,  60, 'Date.day-of-year (1999-03-01)';
+is dtim(1999,  3,  1).day-of-year,  60, 'DateTime.day-of-year (1999-03-01)';
+is date(1999, 12, 31).day-of-year, 365, 'Date.day-of-year (1999-12-31)';
+is date(2000,  2, 28).day-of-year,  59, 'Date.day-of-year (2000-02-28)';
+is dtim(2000,  2, 28).day-of-year,  59, 'DateTime.day-of-year (2000-02-28)';
+is date(2000,  2, 29).day-of-year,  60, 'Date.day-of-year (2000-02-29)';
+is dtim(2000,  2, 29).day-of-year,  60, 'DateTime.day-of-year (2000-02-29)';
+is date(2000,  3,  1).day-of-year,  61, 'Date.day-of-year (2000-03-01)';
+is date(2000, 12, 31).day-of-year, 366, 'Date.day-of-year (2000-12-31)';
+
+# --------------------------------------------------------------------
+# L<S32::Temporal/Accessors/'The method is-leap-year'>
+# --------------------------------------------------------------------
+
+nok date(1800,  1,  1).is-leap-year, 'Date.is-leap-year (1800)';
+nok date(1801,  1,  1).is-leap-year, 'Date.is-leap-year (1801)';
+ok  date(1804,  1,  1).is-leap-year, 'Date.is-leap-year (1804)';
+nok date(1900,  1,  1).is-leap-year, 'Date.is-leap-year (1900)';
+nok dtim(1900,  1,  1).is-leap-year, 'DateTime.is-leap-year (1900)';
+ok  date(1996,  1,  1).is-leap-year, 'Date.is-leap-year (1996)';
+nok date(1999,  1,  1).is-leap-year, 'Date.is-leap-year (1999)';
+ok  date(2000,  1,  1).is-leap-year, 'Date.is-leap-year (2000)';
+ok  dtim(2000,  1,  1).is-leap-year, 'DateTime.is-leap-year (2000)';
+
+done;
+
+# vim: ft=perl6

samples/Perl6/for.t

@@ -0,0 +1,586 @@
+use v6;
+
+#?pugs emit #
+use MONKEY_TYPING;
+
+use Test;
+
+=begin description
+
+Tests the "for" statement
+
+This attempts to test as many variations of the
+for statement as possible
+
+=end description
+
+plan 77;
+
+## No foreach
+# L<S04/The C<for> statement/"no foreach statement any more">
+{
+    my $times_run = 0;
+    eval_dies_ok 'foreach 1..10 { $times_run++ }; 1', "foreach is gone";
+    eval_dies_ok 'foreach (1..10) { $times_run++}; 1',
+        "foreach is gone, even with parens";
+    is $times_run, 0, "foreach doesn't work";
+}
+
+## for with plain old range operator w/out parens
+
+{
+    my $a = "";
+    for 0 .. 5 { $a = $a ~ $_; };
+    is($a, '012345', 'for 0..5 {} works');
+}
+
+# ... with pointy blocks
+
+{
+    my $b = "";
+    for 0 .. 5 -> $_ { $b = $b ~ $_; };
+    is($b, '012345', 'for 0 .. 5 -> {} works');
+}
+
+#?pugs todo 'slice context'
+#?niecza skip 'slice context'
+{
+    my $str;
+    my @a = 1..3;
+    my @b = 4..6;
+    for zip(@a; @b) -> $x, $y {
+        $str ~= "($x $y)";
+    }
+    is $str, "(1 4)(2 5)(3 6)", 'for zip(@a; @b) -> $x, $y works';
+}
+
+# ... with referential sub
+{
+    my $d = "";
+    for -2 .. 2 { $d ~= .sign };
+    is($d, '-1-1011', 'for 0 .. 5 { .some_sub } works');
+}
+
+## and now with parens around the range operator
+{
+    my $e = "";
+    for (0 .. 5) { $e = $e ~ $_; };
+    is($e, '012345', 'for () {} works');
+}
+
+# ... with pointy blocks
+{
+    my $f = "";
+    for (0 .. 5) -> $_ { $f = $f ~ $_; };
+    is($f, '012345', 'for () -> {} works');
+}
+
+# ... with implicit topic
+
+{
+    $_ = "GLOBAL VALUE";
+    for "INNER VALUE" {
+        is( .lc, "inner value", "Implicit default topic is seen by lc()");
+    };
+    is($_,"GLOBAL VALUE","After the loop the implicit topic gets restored");
+}
+
+{
+    # as statement modifier
+    $_ = "GLOBAL VALUE";
+    is( .lc, "inner value", "Implicit default topic is seen by lc()" )
+        for "INNER VALUE";
+    #?pugs todo
+    is($_,"GLOBAL VALUE","After the loop the implicit topic gets restored");
+}
+
+## and now for with 'topical' variables
+
+# ... w/out parens
+
+my $i = "";
+for 0 .. 5 -> $topic { $i = $i ~ $topic; };
+is($i, '012345', 'for 0 .. 5 -> $topic {} works');
+
+# ... with parens
+
+my $j = "";
+for (0 .. 5) -> $topic { $j = $j ~ $topic; };
+is($j, '012345', 'for () -> $topic {} works');
+
+
+## for with @array operator w/out parens
+
+my @array_k = (0 .. 5);
+my $k = "";
+for @array_k { $k = $k ~ $_; };
+is($k, '012345', 'for @array {} works');
+
+# ... with pointy blocks
+
+my @array_l = (0 .. 5);
+my $l = "";
+for @array_l -> $_ { $l = $l ~ $_; };
+is($l, '012345', 'for @array -> {} works');
+
+## and now with parens around the @array
+
+my @array_o = (0 .. 5);
+my $o = "";
+for (@array_o) { $o = $o ~ $_; };
+is($o, '012345', 'for (@array) {} works');
+
+# ... with pointy blocks
+{
+    my @array_p = (0 .. 5);
+    my $p = "";
+    for (@array_p) -> $_ { $p = $p ~ $_; };
+    is($p, '012345', 'for (@array) -> {} works');
+}
+
+my @elems = <a b c d e>;
+
+{
+    my @a;
+    for (@elems) {
+        push @a, $_;
+    }
+    my @e = <a b c d e>;
+    is(@a, @e, 'for (@a) { ... $_ ... } iterates all elems');
+}
+
+{
+    my @a;
+        for (@elems) -> $_ { push @a, $_ };
+    my @e = @elems;
+    is(@a, @e, 'for (@a)->$_ { ... $_ ... } iterates all elems' );
+}
+
+{
+    my @a;
+    for (@elems) { push @a, $_, $_; }
+    my @e = <a a b b c c d d e e>;
+    is(@a, @e, 'for (@a) { ... $_ ... $_ ... } iterates all elems, not just odd');
+}
+
+# "for @a -> $var" is ro by default.
+#?pugs skip 'parsefail'
+{
+    my @a = <1 2 3 4>;
+
+    eval_dies_ok('for @a -> $elem {$elem = 5}', '-> $var is ro by default');
+
+    for @a <-> $elem {$elem++;}
+    is(@a, <2 3 4 5>, '<-> $var is rw');
+
+    for @a <-> $first, $second {$first++; $second++}
+    is(@a, <3 4 5 6>, '<-> $var, $var2 works');
+}
+
+# for with "is rw"
+{
+    my @array_s = (0..2);
+    my @s = (1..3);
+    for @array_s { $_++ };
+    is(@array_s, @s, 'for @array { $_++ }');
+}
+
+{
+  my @array = <a b c d>;
+  for @array { $_ ~= "c" }
+  is ~@array, "ac bc cc dc",
+    'mutating $_ in for works';
+}
+
+{
+    my @array_t = (0..2);
+    my @t = (1..3);
+    for @array_t -> $val is rw { $val++ };
+    is(@array_t, @t, 'for @array -> $val is rw { $val++ }');
+}
+
+#?pugs skip "Can't modify const item"
+{
+    my @array_v = (0..2);
+    my @v = (1..3);
+    for @array_v.values -> $val is rw { $val++ };
+    is(@array_v, @v, 'for @array.values -> $val is rw { $val++ }');
+}
+
+#?pugs skip "Can't modify const item"
+{
+    my @array_kv = (0..2);
+    my @kv = (1..3);
+    for @array_kv.kv -> $key, $val is rw { $val++ };
+    is(@array_kv, @kv, 'for @array.kv -> $key, $val is rw { $val++ }');
+}
+
+#?pugs skip "Can't modify const item"
+{
+    my %hash_v = ( a => 1, b => 2, c => 3 );
+    my %v = ( a => 2, b => 3, c => 4 );
+    for %hash_v.values -> $val is rw { $val++ };
+    is(%hash_v, %v, 'for %hash.values -> $val is rw { $val++ }');
+}
+
+#?pugs todo
+{
+    my %hash_kv = ( a => 1, b => 2, c => 3 );
+    my %kv = ( a => 2, b => 3, c => 4 );
+    try { for %hash_kv.kv -> $key, $val is rw { $val++ }; };
+    is( %hash_kv, %kv, 'for %hash.kv -> $key, $val is rw { $val++ }');
+}
+
+# .key //= ++$i for @array1;
+class TestClass{ has $.key is rw  };
+
+{
+   my @array1 = (TestClass.new(:key<1>),TestClass.new());
+   my $i = 0;
+   for @array1 { .key //= ++$i }
+   my $sum1 = [+] @array1.map: { $_.key };
+   is( $sum1, 2, '.key //= ++$i for @array1;' );
+
+}
+
+# .key = 1 for @array1;
+{
+   my @array1 = (TestClass.new(),TestClass.new(:key<2>));
+
+   .key = 1 for @array1;
+   my $sum1 = [+] @array1.map: { $_.key };
+   is($sum1, 2, '.key = 1 for @array1;');
+}
+
+# $_.key = 1 for @array1;
+{
+   my @array1 = (TestClass.new(),TestClass.new(:key<2>));
+
+   $_.key = 1 for @array1;
+   my $sum1 = [+] @array1.map: { $_.key };
+   is( $sum1, 2, '$_.key = 1 for @array1;');
+
+}
+
+# rw scalars
+#L<S04/The C<for> statement/implicit parameter to block read/write "by default">
+{
+    my ($a, $b, $c) = 0..2;
+    try { for ($a, $b, $c) { $_++ } };
+    is( [$a,$b,$c], [1,2,3], 'for ($a,$b,$c) { $_++ }');
+
+    ($a, $b, $c) = 0..2;
+    try { for ($a, $b, $c) -> $x is rw { $x++ } };
+    is( [$a,$b,$c], [1,2,3], 'for ($a,$b,$c) -> $x is rw { $x++ }');
+}
+
+# list context
+
+{
+    my $a = '';
+    my $b = '';
+    for 1..3, 4..6 { $a ~= $_.WHAT.gist ; $b ~= Int.gist };
+    is($a, $b, 'List context');
+
+    $a = '';
+    for [1..3, 4..6] { $a ~= $_.WHAT.gist };
+    is($a, Array.gist, 'List context');
+
+    $a = '';
+    $b = '';
+    for [1..3], [4..6] { $a ~= $_.WHAT.gist ; $b ~= Array.gist };
+    is($a, $b, 'List context');
+}
+
+{
+    # this was a rakudo bug with mixed 'for' and recursion, which seems to 
+    # confuse some lexical pads or the like, see RT #58392
+    my $gather = '';
+    sub f($l) {
+        if $l <= 0 {
+            return $l;
+        }
+        $gather ~= $l;
+        for 1..3 {
+        f($l-1);
+            $gather ~= '.';
+        }
+    }
+    f(2);
+
+    is $gather, '21....1....1....', 'Can mix recursion and for';
+}
+
+# another variation
+{
+    my $t = '';
+    my $c;
+    sub r($x) {
+        my $h = $c++;
+        r $x-1 if $x;
+        for 1 { $t ~= $h };
+    };
+    r 3;
+    is $t, '3210', 'can mix recursion and for (RT 103332)';
+}
+
+# grep and sort in for - these were pugs bugs once, so let's
+# keep them as regression tests
+
+{
+  my @array = <1 2 3 4>;
+  my $output = '';
+
+  for (grep { 1 }, @array) -> $elem {
+    $output ~= "$elem,";
+  }
+
+  is $output, "1,2,3,4,", "grep works in for";
+}
+
+{
+  my @array = <1 2 3 4>;
+  my $output = '';
+
+  for @array.sort -> $elem {
+    $output ~= "$elem,";
+  }
+
+  is $output, "1,2,3,4,", "sort works in for";
+}
+
+{
+  my @array = <1 2 3 4>;
+  my $output = '';
+
+  for (grep { 1 }, @array.sort) -> $elem {
+    $output ~= "$elem,";
+  }
+
+  is $output, "1,2,3,4,", "grep and sort work in for";
+}
+
+# L<S04/Statement parsing/keywords require whitespace>
+eval_dies_ok('for(0..5) { }','keyword needs at least one whitespace after it');
+
+# looping with more than one loop variables
+{
+  my @a = <1 2 3 4>;
+  my $str = '';
+  for @a -> $x, $y { 
+    $str ~= $x+$y;
+  }
+  is $str, "37", "for loop with two variables";
+}
+
+{
+  #my $str = '';
+  eval_dies_ok('for 1..5 ->  $x, $y { $str ~= "$x$y" }', 'Should throw exception, no value for parameter $y');
+  #is $str, "1234", "loop ran before throwing exception";
+  #diag ">$str<";
+}
+
+#?rakudo skip 'optional variable in for loop (RT #63994)'
+#?niecza 2 todo 'NYI'
+{
+  my $str = '';
+  for 1..5 -> $x, $y? {
+    $str ~= " " ~ $x*$y;
+  }
+  is $str, " 2 12 0";
+}
+
+{
+  my $str = '';
+  for 1..5 -> $x, $y = 7 {
+    $str ~= " " ~ $x*$y;
+  }
+  is $str, " 2 12 35", 'default values in for-loops';
+}
+
+#?pugs todo
+{
+  my @a = <1 2 3>;
+  my @b = <4 5 6>;
+  my $res = '';
+  for @a Z @b -> $x, $y {
+    $res ~= " " ~ $x * $y;
+  }
+  is $res, " 4 10 18", "Z -ed for loop";
+}
+
+#?pugs todo
+{
+  my @a = <1 2 3>;
+  my $str = '';
+
+  for @a Z @a Z @a Z @a Z @a -> $q, $w, $e, $r, $t {
+    $str ~= " " ~ $q*$w*$e*$r*$t;
+  }
+  is $str, " 1 {2**5} {3**5}", "Z-ed for loop with 5 arrays";
+}
+
+{
+  eval_dies_ok 'for 1.. { };', "Please use ..* for indefinite range";
+  eval_dies_ok 'for 1... { };', "1... does not exist";
+}
+
+{
+  my $c;
+  for 1..8 {
+    $c = $_;
+    last if $_ == 6;
+  }
+  is $c, 6, 'for loop ends in time using last';
+}
+
+{
+  my $c;
+  for 1..* {
+    $c = $_;
+    last if $_ == 6;
+  }
+  is $c, 6, 'infinte for loop ends in time using last';
+}
+
+{
+  my $c;
+  for 1..Inf {
+    $c = $_;
+    last if $_ == 6;
+  }
+  is $c, 6, 'infinte for loop ends in time using last';
+}
+
+# RT #62478
+#?pugs todo
+{
+    try { EVAL('for (my $ii = 1; $ii <= 3; $ii++) { say $ii; }') };
+    ok "$!" ~~ /C\-style/,   'mentions C-style';
+    ok "$!" ~~ /for/,        'mentions for';
+    ok "$!" ~~ /loop/,       'mentions loop';
+}
+
+# RT #65212
+#?pugs todo
+{
+    my $parsed = 0;
+    try { EVAL '$parsed = 1; for (1..3)->$n { last }' };
+    ok ! $parsed, 'for (1..3)->$n   fails to parse';
+}
+
+# RT #71268
+{
+    sub rt71268 { for ^1 {} }
+    #?pugs todo
+    lives_ok { ~(rt71268) }, 'can stringify "for ^1 {}" without death';
+    #?pugs skip 'Cannot cast from VList to VCode'
+    ok rt71268() ~~ (), 'result of "for ^1 {}" is ()';
+}
+
+# RT 62478
+{
+    eval_dies_ok 'for (my $i; $i <=3; $i++) { $i; }', 'Unsupported use of C-style "for (;;)" loop; in Perl 6 please use "loop (;;)"';
+}
+
+#?pugs todo
+{
+    try { EVAL 'for (my $x; $x <=3; $x++) { $i; }'; diag($!) };
+    ok $! ~~ / 'C-style' /, 'Sensible error message';
+}
+
+# RT #64886
+#?rakudo skip 'maybe bogus, for loops are not supposed to be lazy?'
+{
+    my $a = 0;
+    for 1..10000000000 {
+        $a++;
+        last;
+    }
+    is $a, 1, 'for on Range with huge max value is lazy and enters block';
+}
+
+# RT #60780
+lives_ok {
+    for 1 .. 5 -> $x, $y? { }
+}, 'Iteration variables do not need to add up if one is optional';
+
+# RT #78232
+{
+    my $a = 0;
+    for 1, 2, 3 { sub foo {}; $a++ }
+    is $a, 3, 'RT #78232';
+}
+
+# http://irclog.perlgeek.de/perl6/2011-12-29#i_4892285
+# (Niecza bug)
+{
+    my $x = 0;
+    for 1 .. 2 -> $a, $b { $x = $b } #OK not used
+    is $x, 2, 'Lazy lists interact properly with multi-element for loops';
+}
+
+# RT #71270
+# list comprehension
+#?pugs skip 'Cannot cast from VList to VCode'
+{
+    sub f() { for ^1 { } };
+    is ~f(), '', 'empty for-loop returns empty list';
+}
+
+# RT #74060
+# more list comprehension
+#?pugs skip 'parsefail'
+#?niecza todo "https://github.com/sorear/niecza/issues/180"
+{
+    my @s = ($_ * 2 if $_ ** 2 > 3 for 0 .. 5);
+    is ~@s, '4 6 8 10', 'Can use statement-modifying "for" in list comprehension';
+}
+
+# RT 113026
+#?rakudo todo 'RT 113026 array iterator does not track a growing array'
+#?niecza todo 'array iterator does not track a growing array'
+#?pugs todo
+{
+    my @rt113026 = 1 .. 10;
+    my $iter = 0;
+    for @rt113026 -> $n {
+	$iter++;
+	if $iter % 2 {
+	    @rt113026.push: $n;
+	}
+    }
+    is $iter, 20, 'iterating over an expanding list';
+    is @rt113026, <1 2 3 4 5 6 7 8 9 10 1 3 5 7 9 1 5 9 5 5>,
+       'array expanded in for loop is expanded';
+}
+
+# RT #78406
+{
+    my $c = 0;
+    dies_ok { for ^8 { .=fmt('%03b'); $c++ } }, '$_ is read-only here';
+    is $c, 0, '... and $_ is *always* read-only here';
+}
+
+dies_ok
+    {
+        my class Foo {
+            has @.items;
+            method check_items { for @.items -> $item { die "bad" if $item == 2 } }
+            method foo { self.check_items; .say for @.items }
+        }
+        Foo.new(items => (1, 2, 3, 4)).foo
+    }, 'for in called method runs (was a sink context bug)';
+
+# RT #77460
+#?pugs todo
+{
+    my @a = 1;
+    for 1..10 {
+        my $last = @a[*-1];
+        push @a, (sub ($s) { $s + 1 })($last)
+    };
+    is @a, [1, 2, 3, 4, 5, 6, 7, 8,9, 10, 11];
+}
+
+# vim: ft=perl6

samples/Perl6/hash.t

@@ -0,0 +1,76 @@
+use v6;
+
+use Test;
+
+plan(5);
+
+unless EVAL 'EVAL("1", :lang<perl5>)' {
+    skip_rest;
+    exit;
+}
+
+die unless
+EVAL(q/
+package My::Hash;
+use strict;
+
+sub new {
+    my ($class, $ref) = @_;
+    bless \$ref, $class;
+}
+
+sub hash {
+    my $self = shift;
+    return $$self;
+}
+
+sub my_keys {
+    my $self = shift;
+    return keys %{$$self};
+}
+
+sub my_exists {
+    my ($self, $idx) = @_;
+    return exists $$self->{$idx};
+}
+
+sub fetch {
+    my ($self, $idx) = @_;
+    return $$self->{$idx};
+}
+
+sub store {
+    my ($self, $idx, $val) = @_;
+    $$self->{$idx} = $val;
+}
+
+sub push {
+    my ($self, $val) = @_;
+}
+
+1;
+/, :lang<perl5>);
+
+my $p5ha = EVAL('sub { My::Hash->new($_[0]) }', :lang<perl5>);
+my %hash = (5 => 'a', 6 => 'b', 7 => 'c', 8 => 'd');
+my $p5hash = $p5ha(\%hash);
+
+my $rethash = $p5hash.hash;
+my @keys = %hash.keys.sort;
+my @p5keys;
+try {
+    @p5keys = $p5hash.my_keys; # this doesn't even pass lives_ok ??
+    @p5keys .= sort;
+};
+
+is("{ @keys }", "{ @p5keys }");
+
+ok($p5hash.store(9, 'e'), 'can store');
+is(%hash{9}, 'e', 'store result');
+
+is($p5hash.fetch(5), 'a', 'fetch result');
+is($p5hash.my_exists(5), %hash<5>:exists, 'exists');
+#?pugs todo 'bug'
+is($p5hash.my_exists(12), %hash<12>:exists, 'nonexists fail');
+
+# vim: ft=perl6

samples/Perl6/htmlify.pl

@@ -0,0 +1,630 @@
+#!/usr/bin/env perl6
+use v6;
+
+# This script isn't in bin/ because it's not meant to be installed.
+
+BEGIN say 'Initializing ...';
+
+use Pod::To::HTML;
+use URI::Escape;
+use lib 'lib';
+use Perl6::TypeGraph;
+use Perl6::TypeGraph::Viz;
+use Perl6::Documentable::Registry;
+
+my $*DEBUG = False;
+
+my $tg;
+my %methods-by-type;
+my $footer = footer-html;
+my $head   = q[
+<link rel="icon" href="/favicon.ico" type="favicon.ico" />
+<link rel="stylesheet" type="text/css" href="/style.css" media="screen" title="default" />
+];
+
+
+sub url-munge($_) {
+    return $_ if m{^ <[a..z]>+ '://'};
+    return "/type/$_" if m/^<[A..Z]>/;
+    return "/routine/$_" if m/^<[a..z]>/;
+    # poor man's <identifier>
+    if m/ ^ '&'( \w <[[\w'-]>* ) $/ {
+        return "/routine/$0";
+    }
+    return $_;
+}
+
+sub p2h($pod) {
+    pod2html($pod, :url(&url-munge), :$footer, :$head);
+}
+
+sub pod-gist(Pod::Block $pod, $level = 0) {
+    my $leading = ' ' x $level;
+    my %confs;
+    my @chunks;
+    for <config name level caption type> {
+        my $thing = $pod.?"$_"();
+        if $thing {
+            %confs{$_} = $thing ~~ Iterable ?? $thing.perl !! $thing.Str;
+        }
+    }
+    @chunks = $leading, $pod.^name, (%confs.perl if %confs), "\n";
+    for $pod.content.list -> $c {
+        if $c ~~ Pod::Block {
+            @chunks.push: pod-gist($c, $level + 2);
+        }
+        elsif $c ~~ Str {
+            @chunks.push: $c.indent($level + 2), "\n";
+        } elsif $c ~~ Positional {
+            @chunks.push: $c.map: {
+                if $_ ~~ Pod::Block {
+                    *.&pod-gist
+                } elsif $_ ~~ Str {
+                    $_
+                }
+            }
+        }
+    }
+    @chunks.join;
+}
+
+sub recursive-dir($dir) {
+    my @todo = $dir;
+    gather while @todo {
+        my $d = @todo.shift;
+        for dir($d) -> $f {
+            if $f.f {
+                take $f;
+            }
+            else {
+                @todo.push($f.path);
+            }
+        }
+    }
+}
+
+sub first-code-block(@pod) {
+    if @pod[1] ~~ Pod::Block::Code {
+        return @pod[1].content.grep(Str).join;
+    }
+    '';
+}
+
+sub MAIN(Bool :$debug, Bool :$typegraph = False) {
+    $*DEBUG = $debug;
+
+    say 'Creating html/ subdirectories ...';
+    for '', <type language routine images op op/prefix op/postfix op/infix
+             op/circumfix op/postcircumfix op/listop> {
+        mkdir "html/$_" unless "html/$_".IO ~~ :e;
+    }
+
+    say 'Reading lib/ ...';
+    my @source  = recursive-dir('lib').grep(*.f).grep(rx{\.pod$});
+       @source .= map: {; .path.subst('lib/', '').subst(rx{\.pod$}, '').subst(:g, '/', '::') => $_ };
+
+    say 'Reading type graph ...';
+    $tg = Perl6::TypeGraph.new-from-file('type-graph.txt');
+    {
+        my %h = $tg.sorted.kv.flat.reverse;
+        @source .= sort: { %h{.key} // -1 };
+    }
+
+    my $dr = Perl6::Documentable::Registry.new;
+
+    say 'Processing Pod files ...';
+    for (0..* Z @source) -> $num, $_ {
+        my $podname  = .key;
+        my $file     = .value;
+        my $what     = $podname ~~ /^<[A..Z]> | '::'/  ?? 'type' !! 'language';
+        printf "% 4d/%d: % -40s => %s\n", $num, +@source, $file.path, "$what/$podname";
+
+        my $pod  = eval slurp($file.path) ~ "\n\$=pod";
+           $pod .= [0];
+
+        if $what eq 'language' {
+            write-language-file(:$dr, :$what, :$pod, :$podname);
+        }
+        else {
+            say pod-gist($pod[0]) if $*DEBUG;
+            write-type-file(:$dr, :$what, :pod($pod[0]), :$podname);
+        }
+    }
+
+    say 'Composing doc registry ...';
+    $dr.compose;
+
+    write-disambiguation-files($dr);
+    write-op-disambiguation-files($dr);
+    write-operator-files($dr);
+    write-type-graph-images(:force($typegraph));
+    write-search-file($dr);
+    write-index-file($dr);
+
+    say 'Writing per-routine files ...';
+    my %routine-seen;
+    for $dr.lookup('routine', :by<kind>).list -> $d {
+        next if %routine-seen{$d.name}++;
+        write-routine-file($dr, $d.name);
+        print '.'
+    }
+    say '';
+
+    say 'Processing complete.';
+}
+
+sub write-language-file(:$dr, :$what, :$pod, :$podname) {
+    spurt "html/$what/$podname.html", p2h($pod);
+    if $podname eq 'operators' {
+        my @chunks = chunks-grep($pod.content,
+                                 :from({ $_ ~~ Pod::Heading and .level == 2}),
+                                 :to({  $^b ~~ Pod::Heading and $^b.level <= $^a.level}),
+                                );
+        for @chunks -> $chunk {
+            my $heading = $chunk[0].content[0].content[0];
+            next unless $heading ~~ / ^ [in | pre | post | circum | postcircum ] fix | listop /;
+            my $what = ~$/;
+            my $operator = $heading.split(' ', 2)[1];
+            $dr.add-new(
+                        :kind<operator>,
+                        :subkind($what),
+                        :name($operator),
+                        :pod($chunk),
+                        :!pod-is-complete,
+                       );
+        }
+    }
+    $dr.add-new(
+                :kind<language>,
+                :name($podname),
+                :$pod,
+                :pod-is-complete,
+               );
+}
+
+sub write-type-file(:$dr, :$what, :$pod, :$podname) {
+    my @chunks = chunks-grep($pod.content,
+                             :from({ $_ ~~ Pod::Heading and .level == 2}),
+                             :to({  $^b ~~ Pod::Heading and $^b.level <= $^a.level}),
+                            );
+
+    if $tg.types{$podname} -> $t {
+        $pod.content.push: Pod::Block::Named.new(
+            name    => 'Image',
+            content => [ "/images/type-graph-$podname.png"],
+        );
+        $pod.content.push: pod-link(
+            'Full-size type graph image as SVG',
+            "/images/type-graph-$podname.svg",
+        );
+
+        my @mro = $t.mro;
+           @mro.shift; # current type is already taken care of
+
+        for $t.roles -> $r {
+            next unless %methods-by-type{$r};
+            $pod.content.push:
+                pod-heading("Methods supplied by role $r"),
+                pod-block(
+                    "$podname does role ",
+                    pod-link($r.name, "/type/$r"),
+                    ", which provides the following methods:",
+                ),
+                %methods-by-type{$r}.list,
+                ;
+        }
+        for @mro -> $c {
+            next unless %methods-by-type{$c};
+            $pod.content.push:
+                pod-heading("Methods supplied by class $c"),
+                pod-block(
+                    "$podname inherits from class ",
+                    pod-link($c.name, "/type/$c"),
+                    ", which provides the following methods:",
+                ),
+                %methods-by-type{$c}.list,
+                ;
+            for $c.roles -> $r {
+                next unless %methods-by-type{$r};
+                $pod.content.push:
+                    pod-heading("Methods supplied by role $r"),
+                    pod-block(
+                        "$podname inherits from class ",
+                        pod-link($c.name, "/type/$c"),
+                        ", which does role ",
+                        pod-link($r.name, "/type/$r"),
+                        ", which provides the following methods:",
+                    ),
+                    %methods-by-type{$r}.list,
+                    ;
+            }
+        }
+    }
+    my $d = $dr.add-new(
+        :kind<type>,
+        # TODO: subkind
+        :$pod,
+        :pod-is-complete,
+        :name($podname),
+    );
+
+    for @chunks -> $chunk {
+        my $name = $chunk[0].content[0].content[0];
+        say "$podname.$name" if $*DEBUG;
+        next if $name ~~ /\s/;
+        %methods-by-type{$podname}.push: $chunk;
+        # determine whether it's a sub or method
+        my Str $subkind;
+        {
+            my %counter;
+            for first-code-block($chunk).lines {
+                if ms/^ 'multi'? (sub|method)»/ {
+                    %counter{$0}++;
+                }
+            }
+            if %counter == 1 {
+                ($subkind,) = %counter.keys;
+            }
+            if %counter<method> {
+                write-qualified-method-call(
+                    :$name,
+                    :pod($chunk),
+                    :type($podname),
+                );
+            }
+        }
+
+        $dr.add-new(
+            :kind<routine>,
+            :$subkind,
+            :$name,
+            :pod($chunk),
+            :!pod-is-complete,
+            :origin($d),
+        );
+    }
+
+    spurt "html/$what/$podname.html", p2h($pod);
+}
+
+sub chunks-grep(:$from!, :&to!, *@elems) {
+    my @current;
+
+    gather {
+        for @elems -> $c {
+            if @current && ($c ~~ $from || to(@current[0], $c)) {
+                take [@current];
+                @current = ();
+                @current.push: $c if $c ~~ $from;
+            }
+            elsif @current or $c ~~ $from {
+                @current.push: $c;
+            }
+        }
+        take [@current] if @current;
+    }
+}
+
+sub pod-with-title($title, *@blocks) {
+    Pod::Block::Named.new(
+        name => "pod",
+        content => [
+            Pod::Block::Named.new(
+                name => "TITLE",
+                content => Array.new(
+                    Pod::Block::Para.new(
+                        content => [$title],
+                    )
+                )
+            ),
+            @blocks.flat,
+        ]
+    );
+}
+
+sub pod-block(*@content) {
+    Pod::Block::Para.new(:@content);
+}
+
+sub pod-link($text, $url) {
+    Pod::FormattingCode.new(
+        type    => 'L',
+        content => [
+            join('|', $text, $url),
+        ],
+    );
+}
+
+sub pod-item(*@content, :$level = 1) {
+    Pod::Item.new(
+        :$level,
+        :@content,
+    );
+}
+
+sub pod-heading($name, :$level = 1) {
+    Pod::Heading.new(
+        :$level,
+        :content[pod-block($name)],
+    );
+}
+
+sub write-type-graph-images(:$force) {
+    unless $force {
+        my $dest = 'html/images/type-graph-Any.svg'.path;
+        if $dest.e && $dest.modified >= 'type-graph.txt'.path.modified {
+            say "Not writing type graph images, it seems to be up-to-date";
+            say "To force writing of type graph images, supply the --typegraph";
+            say "option at the command line, or delete";
+            say "file 'html/images/type-graph-Any.svg'";
+            return;
+        }
+    }
+    say 'Writing type graph images to html/images/ ...';
+    for $tg.sorted -> $type {
+        my $viz = Perl6::TypeGraph::Viz.new-for-type($type);
+        $viz.to-file("html/images/type-graph-{$type}.svg", format => 'svg');
+        $viz.to-file("html/images/type-graph-{$type}.png", format => 'png', size => '8,3');
+        print '.'
+    }
+    say '';
+
+    say 'Writing specialized visualizations to html/images/ ...';
+    my %by-group = $tg.sorted.classify(&viz-group);
+    %by-group<Exception>.push: $tg.types< Exception Any Mu >;
+    %by-group<Metamodel>.push: $tg.types< Any Mu >;
+
+    for %by-group.kv -> $group, @types {
+        my $viz = Perl6::TypeGraph::Viz.new(:types(@types),
+                                            :dot-hints(viz-hints($group)),
+                                            :rank-dir('LR'));
+        $viz.to-file("html/images/type-graph-{$group}.svg", format => 'svg');
+        $viz.to-file("html/images/type-graph-{$group}.png", format => 'png', size => '8,3');
+    }
+}
+
+sub viz-group ($type) {
+    return 'Metamodel' if $type.name ~~ /^ 'Perl6::Metamodel' /;
+    return 'Exception' if $type.name ~~ /^ 'X::' /;
+    return 'Any';
+}
+
+sub viz-hints ($group) {
+    return '' unless $group eq 'Any';
+
+    return '
+    subgraph "cluster: Mu children" {
+        rank=same;
+        style=invis;
+        "Any";
+        "Junction";
+    }
+    subgraph "cluster: Pod:: top level" {
+        rank=same;
+        style=invis;
+        "Pod::Config";
+        "Pod::Block";
+    }
+    subgraph "cluster: Date/time handling" {
+        rank=same;
+        style=invis;
+        "Date";
+        "DateTime";
+        "DateTime-local-timezone";
+    }
+    subgraph "cluster: Collection roles" {
+        rank=same;
+        style=invis;
+        "Positional";
+        "Associative";
+        "Baggy";
+    }
+';
+}
+
+sub write-search-file($dr) {
+    say 'Writing html/search.html ...';
+    my $template = slurp("search_template.html");
+    my @items;
+    my sub fix-url ($raw) { $raw.substr(1) ~ '.html' };
+    @items.push: $dr.lookup('language', :by<kind>).sort(*.name).map({
+        "\{ label: \"Language: {.name}\", value: \"{.name}\", url: \"{ fix-url(.url) }\" \}"
+    });
+    @items.push: $dr.lookup('type', :by<kind>).sort(*.name).map({
+        "\{ label: \"Type: {.name}\", value: \"{.name}\", url: \"{ fix-url(.url) }\" \}"
+    });
+    my %seen;
+    @items.push: $dr.lookup('routine', :by<kind>).grep({!%seen{.name}++}).sort(*.name).map({
+        "\{ label: \"{ (.subkind // 'Routine').tclc }: {.name}\", value: \"{.name}\", url: \"{ fix-url(.url) }\" \}"
+    });
+    sub escape(Str $s) {
+        $s.trans([</ \\ ">] => [<\\/ \\\\ \\">]);
+    }
+    @items.push: $dr.lookup('operator', :by<kind>).map({
+        qq[\{ label: "$_.human-kind() {escape .name}", value: "{escape .name}", url: "{ fix-url .url }"\}]
+    });
+
+    my $items = @items.join(",\n");
+    spurt("html/search.html", $template.subst("ITEMS", $items));
+}
+
+my %operator_disambiguation_file_written;
+
+sub write-disambiguation-files($dr) {
+    say 'Writing disambiguation files ...';
+    for $dr.grouped-by('name').kv -> $name, $p is copy {
+        print '.';
+        my $pod = pod-with-title("Disambiguation for '$name'");
+        if $p.elems == 1 {
+            $p.=[0] if $p ~~ Array;
+            if $p.origin -> $o {
+                $pod.content.push:
+                    pod-block(
+                        pod-link("'$name' is a $p.human-kind()", $p.url),
+                        ' from ',
+                        pod-link($o.human-kind() ~ ' ' ~ $o.name, $o.url),
+                    );
+            }
+            else {
+                $pod.content.push:
+                    pod-block(
+                        pod-link("'$name' is a $p.human-kind()", $p.url)
+                    );
+            }
+        }
+        else {
+            $pod.content.push:
+                pod-block("'$name' can be anything of the following"),
+                $p.map({
+                    if .origin -> $o {
+                        pod-item(
+                            pod-link(.human-kind, .url),
+                            ' from ',
+                            pod-link($o.human-kind() ~ ' ' ~ $o.name, $o.url),
+                        )
+                    }
+                    else {
+                        pod-item( pod-link(.human-kind, .url) )
+                    }
+                });
+        }
+        my $html = p2h($pod);
+        spurt "html/$name.html", $html;
+        if all($p>>.kind) eq 'operator' {
+            spurt "html/op/$name.html", $html;
+            %operator_disambiguation_file_written{$p[0].name} = 1;
+        }
+    }
+    say '';
+}
+
+sub write-op-disambiguation-files($dr) {
+    say 'Writing operator disambiguation files ...';
+    for $dr.lookup('operator', :by<kind>).classify(*.name).kv -> $name, @ops {
+        next unless %operator_disambiguation_file_written{$name};
+        my $pod = pod-with-title("Disambiguation for '$name'");
+        if @ops == 1 {
+            my $p = @ops[0];
+            if $p.origin -> $o {
+                $pod.content.push:
+                    pod-block(
+                        pod-link("'$name' is a $p.human-kind()", $p.url),
+                        ' from ',
+                        pod-link($o.human-kind() ~ ' ' ~ $o.name, $o.url),
+                    );
+            }
+            else {
+                $pod.content.push:
+                    pod-block(
+                        pod-link("'$name' is a $p.human-kind()", $p.url)
+                    );
+            }
+        }
+        else {
+            $pod.content.push:
+                pod-block("'$name' can be anything of the following"),
+                @ops.map({
+                    if .origin -> $o {
+                        pod-item(
+                            pod-link(.human-kind, .url),
+                            ' from ',
+                            pod-link($o.human-kind() ~ ' ' ~ $o.name, $o.url),
+                        )
+                    }
+                    else {
+                        pod-item( pod-link(.human-kind, .url) )
+                    }
+                });
+        }
+        my $html = p2h($pod);
+        spurt "html/$name.html", $html;
+    }
+
+}
+
+sub write-operator-files($dr) {
+    say 'Writing operator files ...';
+    for $dr.lookup('operator', :by<kind>).list -> $doc {
+        my $what  = $doc.subkind;
+        my $op    = $doc.name;
+        my $pod   = pod-with-title(
+            "$what.tclc() $op operator",
+            pod-block(
+                "Documentation for $what $op, extracted from ",
+                pod-link("the operators language documentation", "/language/operators")
+            ),
+            @($doc.pod),
+        );
+        spurt "html/op/$what/$op.html", p2h($pod);
+    }
+}
+
+sub write-index-file($dr) {
+    say 'Writing html/index.html ...';
+    my %routine-seen;
+    my $pod = pod-with-title('Perl 6 Documentation',
+        Pod::Block::Para.new(
+            content => ['Official Perl 6 documentation'],
+        ),
+        # TODO: add more
+        pod-heading("Language Documentation"),
+        $dr.lookup('language', :by<kind>).sort(*.name).map({
+            pod-item( pod-link(.name, .url) )
+        }),
+        pod-heading('Types'),
+        $dr.lookup('type', :by<kind>).sort(*.name).map({
+            pod-item(pod-link(.name, .url))
+        }),
+        pod-heading('Routines'),
+        $dr.lookup('routine', :by<kind>).sort(*.name).map({
+            next if %routine-seen{.name}++;
+            pod-item(pod-link(.name, .url))
+        }),
+    );
+    spurt 'html/index.html', p2h($pod);
+}
+
+sub write-routine-file($dr, $name) {
+    say 'Writing html/routine/$name.html ...' if $*DEBUG;
+    my @docs = $dr.lookup($name, :by<name>).grep(*.kind eq 'routine');
+    my $subkind = 'routine';
+    {
+        my @subkinds = @docs>>.subkind;
+        $subkind = @subkinds[0] if all(@subkinds>>.defined) && [eq] @subkinds;
+    }
+    my $pod = pod-with-title("Documentation for $subkind $name",
+        pod-block("Documentation for $subkind $name, assembled from the
+            following types:"),
+        @docs.map({
+            pod-heading(.origin.name ~ '.' ~ .name),
+            pod-block("From ", pod-link(.origin.name, .origin.url ~ '#' ~ .name)),
+            .pod.list,
+        })
+    );
+    spurt "html/routine/$name.html", p2h($pod);
+}
+
+sub write-qualified-method-call(:$name!, :$pod!, :$type!) {
+    my $p = pod-with-title(
+        "Documentation for method $type.$name",
+        pod-block('From ', pod-link($type, "/type/{$type}#$name")),
+        @$pod,
+    );
+    spurt "html/{$type}.{$name}.html", p2h($p);
+}
+
+sub footer-html() {
+    state $dt = ~DateTime.now;
+    qq[
+    <div id="footer">
+        <p>
+            Generated on $dt from the sources at
+            <a href="https://github.com/perl6/doc">perl6/doc on github</a>.
+        </p>
+        <p>
+            This is a work in progress to document Perl 6, and known to be
+            incomplete. Your contribution is appreciated.
+        </p>
+    </div>
+    ];
+}

samples/Perl6/listquote-whitespace.t

@@ -0,0 +1,76 @@
+use v6;
+
+use Test;
+
+# L<S02/Whitespace and Comments>
+
+=begin kwid
+
+= DESCRIPTION
+
+Tests that the List quoting parser properly
+ignores whitespace in lists. This becomes important
+if your line endings are \x0d\x0a.
+
+Characters that should be ignored are:
+
+    \t
+    \r
+    \n
+    \x20
+
+Most likely there are more. James tells me that
+the maximum Unicode char is \x10FFFF , so maybe
+we should simply (re)construct the whitespace
+list via IsSpace or \s on the fly.
+
+Of course, in the parsed result, no item should
+contain whitespace.
+
+C<\xA0> is specifically an I<nonbreaking> whitespace
+character and thus should B<not> break the list.
+
+=end kwid
+
+#?pugs emit if $?PUGS_BACKEND ne "BACKEND_PUGS" {
+#?pugs emit   skip_rest "PIL2JS and PIL-Run do not support EVAL() yet.";
+#?pugs emit   exit;
+#?pugs emit }
+
+my @list = <a b c d>;
+my @separators = ("\t","\r","\n"," ");
+my @nonseparators = (",","/","\\",";","\xa0");
+
+plan +@separators + @nonseparators + 3;
+
+for @separators -> $sep {
+  my $str = "<$sep" ~ @list.join("$sep$sep") ~ "$sep>";
+  my @res = EVAL $str;
+
+  my $vis = sprintf "%02x", ord $sep;
+  is( @res, @list, "'\\x$vis\\x$vis' is properly parsed as list whitespace")
+};
+
+for @nonseparators -> $sep {
+  my $ex = @list.join($sep);
+  my $str = "<" ~$ex~ ">";
+  my @res = EVAL $str;
+
+  my $vis = sprintf "%02x", ord $sep;
+  #?rakudo emit if $sep eq "\xa0" {
+  #?rakudo emit      todo('\xa0 should not be a separator for list quotes');
+  #?rakudo emit };
+  #?niecza emit if $sep eq "\xa0" {
+  #?niecza emit      todo('\xa0 should not be a separator for list quotes');
+  #?niecza emit };
+  is( @res, [@list.join($sep)], "'\\x$vis' does not split in a whitespace quoted list")
+};
+
+is < foo  
+	    >, 'foo', 'various combinations of whitespaces are stripped';
+
+# RT #73772
+isa_ok < >, Parcel, '< > (only whitespaces) is empty Parcel';
+is < >.elems, 0, ".. and it's really empty";
+
+# vim: ft=perl6

samples/Perl6/man-or-boy.t

@@ -0,0 +1,32 @@
+use Test;
+
+# stress test for lexicals and lexical subs
+# See 
+# http://en.wikipedia.org/w/index.php?title=Man_or_boy_test&oldid=249795453#Perl
+
+my @results = 1, 0, -2, 0, 1, 0, 1, -1, -10, -30;
+
+# if we want to *really* stress-test, we can use a few more tests:
+# my @results = 1, 0, -2, 0, 1, 0, 1, -1, -10, -30, -67, -138
+# -291, -642, -1446, -3250, -7244, -16065, -35601, -78985;
+
+plan +@results;
+
+sub A($k is copy, &x1, &x2, &x3, &x4, &x5) {
+    my $B;
+    $B = sub (*@) { A(--$k, $B, &x1, &x2, &x3, &x4) };
+    if ($k <= 0) {
+        return    x4($k, &x1, &x2, &x3, &x4, &x5)
+                + x5($k, &x1, &x2, &x3, &x4, &x5);
+    }
+    return $B();
+};
+
+for 0 .. (@results-1) -> $i {
+    is A($i, sub (*@) {1}, sub (*@) {-1}, sub (*@) {-1}, sub (*@) {1}, sub (*@) {0}),
+       @results[$i],
+       "man-or-boy test for start value $i";
+}
+
+
+# vim: ft=perl6