mirror of
https://github.com/KevinMidboe/linguist.git
synced 2026-05-13 00:46:11 +00:00
John Gardner
GitHub
97
samples/Perl 6/01-dash-uppercase-i.t
Normal file
97
samples/Perl 6/01-dash-uppercase-i.t
Normal file
@@ -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
|
||||
223
samples/Perl 6/01-parse.t
Normal file
223
samples/Perl 6/01-parse.t
Normal file
@@ -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": "" \u0022 %22 0x22 034 ""}>>,
|
||||
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
|
||||
|
||||
9
samples/Perl 6/A.pm
Normal file
9
samples/Perl 6/A.pm
Normal file
@@ -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
|
||||
148
samples/Perl 6/ANSIColor.pm
Normal file
148
samples/Perl 6/ANSIColor.pm
Normal file
@@ -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
|
||||
102
samples/Perl 6/Bailador.pm
Normal file
102
samples/Perl 6/Bailador.pm
Normal file
@@ -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;
|
||||
}
|
||||
}
|
||||
7
samples/Perl 6/ContainsUnicode.pm
Normal file
7
samples/Perl 6/ContainsUnicode.pm
Normal file
@@ -0,0 +1,7 @@
|
||||
module ContainsUnicode {
|
||||
sub uc-and-join(*@things, :$separator = ', ') is export {
|
||||
@things».uc.join($separator)
|
||||
}
|
||||
}
|
||||
|
||||
# vim: ft=perl6
|
||||
1431
samples/Perl 6/Exception.pm
Normal file
1431
samples/Perl 6/Exception.pm
Normal file
File diff suppressed because it is too large
Load Diff
699
samples/Perl 6/List.pm
Normal file
699
samples/Perl 6/List.pm
Normal file
@@ -0,0 +1,699 @@
|
||||
# for our tantrums
|
||||
my class X::TypeCheck { ... }
|
||||
my role Supply { ... }
|
||||
|
||||
my sub combinations($n, $k) {
|
||||
my @result;
|
||||
my @stack;
|
||||
|
||||
return ([],) unless $k;
|
||||
|
||||
@stack.push(0);
|
||||
gather while @stack {
|
||||
my $index = @stack - 1;
|
||||
my $value = @stack.pop;
|
||||
|
||||
while $value < $n {
|
||||
@result[$index++] = $value++;
|
||||
@stack.push($value);
|
||||
if $index == $k {
|
||||
take [@result];
|
||||
$value = $n; # fake a last
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
my sub permutations(Int $n) {
|
||||
$n == 1 ?? ( [0,] ) !!
|
||||
gather for ^$n -> $i {
|
||||
my @i = grep none($i), ^$n;
|
||||
take [$i, @i[@$_]] for permutations($n - 1);
|
||||
}
|
||||
}
|
||||
|
||||
my class List does Positional { # declared in BOOTSTRAP
|
||||
# class List is Iterable is Cool
|
||||
# has Mu $!items; # VM's array of our reified elements
|
||||
# has Mu $!flattens; # true if this list flattens its parcels
|
||||
# has Mu $!nextiter; # iterator for generating remaining elements
|
||||
|
||||
method new(|) {
|
||||
my Mu $args := nqp::p6argvmarray();
|
||||
nqp::shift($args);
|
||||
|
||||
nqp::p6list($args, self.WHAT, Mu);
|
||||
}
|
||||
|
||||
multi method Bool(List:D:) { self.gimme(1).Bool }
|
||||
multi method Int(List:D:) { self.elems }
|
||||
multi method end(List:D:) { self.elems - 1 }
|
||||
multi method Numeric(List:D:) { self.elems }
|
||||
multi method Str(List:D:) { self.join(' ') }
|
||||
|
||||
# Pretend we're a Match assuming we're a list of Matches
|
||||
method to() { self.elems ?? self[self.end].to !! Nil }
|
||||
method from() { self.elems ?? self[0].from !! Nil }
|
||||
|
||||
method fmt($format = '%s', $separator = ' ') {
|
||||
self.map({ .fmt($format) }).join($separator);
|
||||
}
|
||||
|
||||
method flat() { self.flattens
|
||||
?? self
|
||||
!! nqp::p6list(nqp::list(self), List, Bool::True)
|
||||
}
|
||||
method list() { self }
|
||||
method lol() {
|
||||
self.gimme(0);
|
||||
my Mu $rpa := nqp::clone($!items);
|
||||
nqp::push($rpa, $!nextiter) if $!nextiter.defined;
|
||||
nqp::p6list($rpa, LoL, Mu);
|
||||
}
|
||||
|
||||
method flattens() { $!flattens }
|
||||
|
||||
method Capture() {
|
||||
self.gimme(*);
|
||||
my $cap := nqp::create(Capture);
|
||||
nqp::bindattr($cap, Capture, '$!list', $!items);
|
||||
$cap
|
||||
}
|
||||
|
||||
method Parcel() {
|
||||
my Mu $rpa := nqp::clone(nqp::p6listitems(self));
|
||||
nqp::push($rpa, $!nextiter) if $!nextiter.defined;
|
||||
nqp::p6parcel($rpa, Any);
|
||||
}
|
||||
|
||||
method Supply(List:D:) { Supply.from-list(self) }
|
||||
|
||||
multi method at_pos(List:D: int \pos) is rw {
|
||||
fail X::OutOfRange.new(:what<Index>,:got(pos),:range<0..Inf>)
|
||||
if nqp::islt_i(pos,0);
|
||||
self.exists_pos(pos) ?? nqp::atpos($!items,pos) !! Nil;
|
||||
}
|
||||
multi method at_pos(List:D: Int:D \pos) is rw {
|
||||
my int $pos = nqp::unbox_i(pos);
|
||||
fail X::OutOfRange.new(:what<Index>,:got(pos),:range<0..Inf>)
|
||||
if nqp::islt_i($pos,0);
|
||||
self.exists_pos($pos) ?? nqp::atpos($!items,$pos) !! Nil;
|
||||
}
|
||||
|
||||
method eager() { self.gimme(*); self }
|
||||
|
||||
method elems() {
|
||||
return 0 unless self.DEFINITE;
|
||||
return nqp::elems(nqp::p6listitems(self)) unless nqp::defined($!nextiter);
|
||||
# Get as many elements as we can. If gimme stops before
|
||||
# reaching the end of the list, assume the list is infinite.
|
||||
my $n := self.gimme(*);
|
||||
nqp::defined($!nextiter) ?? Inf !! $n
|
||||
}
|
||||
|
||||
multi method exists_pos(List:D: int $pos) {
|
||||
return False if nqp::islt_i($pos,0);
|
||||
self.gimme($pos + 1);
|
||||
nqp::p6bool(
|
||||
nqp::not_i(nqp::isnull(nqp::atpos($!items,$pos)))
|
||||
);
|
||||
}
|
||||
multi method exists_pos(List:D: Int:D $pos) {
|
||||
return False if $pos < 0;
|
||||
self.gimme($pos + 1);
|
||||
nqp::p6bool(
|
||||
nqp::not_i(nqp::isnull(nqp::atpos($!items,nqp::unbox_i($pos))))
|
||||
);
|
||||
}
|
||||
|
||||
method gimme($n, :$sink) {
|
||||
return unless self.DEFINITE;
|
||||
# loop through iterators until we have at least $n elements
|
||||
my int $count = nqp::elems(nqp::p6listitems(self));
|
||||
if nqp::istype($n, Whatever) || nqp::istype($n, Num) && nqp::istrue($n == Inf) {
|
||||
while $!nextiter.DEFINITE && !$!nextiter.infinite {
|
||||
$!nextiter.reify(*, :$sink);
|
||||
$count = nqp::elems($!items);
|
||||
}
|
||||
}
|
||||
else {
|
||||
my int $target = $n.Int;
|
||||
while nqp::isconcrete($!nextiter) && $count < $target {
|
||||
$!nextiter.reify($target - $count, :$sink);
|
||||
$count = nqp::elems($!items);
|
||||
}
|
||||
}
|
||||
|
||||
# return the number of elements we have now
|
||||
$count
|
||||
}
|
||||
|
||||
multi method infinite(List:D:) { $!nextiter.infinite }
|
||||
|
||||
method iterator() {
|
||||
# Return a reified ListIter containing our currently reified elements
|
||||
# and any subsequent iterator.
|
||||
my $iter := nqp::create(ListIter);
|
||||
nqp::bindattr($iter, ListIter, '$!nextiter', $!nextiter);
|
||||
nqp::bindattr($iter, ListIter, '$!reified', self.Parcel());
|
||||
$iter;
|
||||
}
|
||||
|
||||
method munch($n is copy) {
|
||||
$n = 0 if $n < 0;
|
||||
$n = self.gimme($n) if nqp::not_i(nqp::istype($n, Int))
|
||||
|| nqp::not_i(nqp::islist($!items))
|
||||
|| nqp::islt_i(nqp::elems($!items), nqp::unbox_i($n));
|
||||
nqp::p6parcel(
|
||||
nqp::p6shiftpush(nqp::list(), $!items, nqp::unbox_i($n)),
|
||||
Any
|
||||
)
|
||||
}
|
||||
|
||||
proto method pick(|) { * }
|
||||
multi method pick() {
|
||||
fail "Cannot .pick from infinite list" if self.infinite;
|
||||
my $elems = self.elems;
|
||||
$elems ?? self.at_pos($elems.rand.floor) !! Nil;
|
||||
}
|
||||
multi method pick($n is copy) {
|
||||
fail "Cannot .pick from infinite list" if self.infinite;
|
||||
## We use a version of Fisher-Yates shuffle here to
|
||||
## replace picked elements with elements from the end
|
||||
## of the list, resulting in an O(n) algorithm.
|
||||
my $elems = self.elems;
|
||||
return unless $elems;
|
||||
$n = Inf if nqp::istype($n, Whatever);
|
||||
$n = $elems if $n > $elems;
|
||||
return self.at_pos($elems.rand.floor) if $n == 1;
|
||||
my Mu $rpa := nqp::clone($!items);
|
||||
my $i;
|
||||
my Mu $v;
|
||||
gather while $n > 0 {
|
||||
$i = nqp::rand_I(nqp::decont($elems), Int);
|
||||
$elems--; $n--;
|
||||
$v := nqp::atpos($rpa, nqp::unbox_i($i));
|
||||
# replace selected element with last unpicked one
|
||||
nqp::bindpos($rpa, nqp::unbox_i($i),
|
||||
nqp::atpos($rpa, nqp::unbox_i($elems)));
|
||||
take-rw $v;
|
||||
}
|
||||
}
|
||||
|
||||
method pop() is parcel {
|
||||
my $elems = self.gimme(*);
|
||||
fail 'Cannot .pop from an infinite list' if $!nextiter.defined;
|
||||
$elems > 0
|
||||
?? nqp::pop($!items)
|
||||
!! fail 'Element popped from empty list';
|
||||
}
|
||||
|
||||
method shift() is parcel {
|
||||
# make sure we have at least one item, then shift+return it
|
||||
nqp::islist($!items) && nqp::existspos($!items, 0) || self.gimme(1)
|
||||
?? nqp::shift($!items)
|
||||
!! fail 'Element shifted from empty list';
|
||||
}
|
||||
|
||||
my &list_push = multi method push(List:D: *@values) {
|
||||
fail 'Cannot .push an infinite list' if @values.infinite;
|
||||
nqp::p6listitems(self);
|
||||
my $elems = self.gimme(*);
|
||||
fail 'Cannot .push to an infinite list' if $!nextiter.DEFINITE;
|
||||
|
||||
# push is always eager
|
||||
@values.gimme(*);
|
||||
|
||||
# need type checks?
|
||||
my $of := self.of;
|
||||
|
||||
unless $of =:= Mu {
|
||||
X::TypeCheck.new(
|
||||
operation => '.push',
|
||||
expected => $of,
|
||||
got => $_,
|
||||
).throw unless nqp::istype($_, $of) for @values;
|
||||
}
|
||||
|
||||
nqp::splice($!items,
|
||||
nqp::getattr(@values, List, '$!items'),
|
||||
$elems, 0);
|
||||
|
||||
self;
|
||||
}
|
||||
|
||||
multi method push(List:D: \value) {
|
||||
if nqp::iscont(value) || nqp::not_i(nqp::istype(value, Iterable)) && nqp::not_i(nqp::istype(value, Parcel)) {
|
||||
$!nextiter.DEFINITE && self.gimme(*);
|
||||
fail 'Cannot .push to an infinite list' if $!nextiter.DEFINITE;
|
||||
nqp::p6listitems(self);
|
||||
nqp::istype(value, self.of)
|
||||
?? nqp::push($!items, nqp::assign(nqp::p6scalarfromdesc(nqp::null), value))
|
||||
!! X::TypeCheck.new(
|
||||
operation => '.push',
|
||||
expected => self.of,
|
||||
got => value,
|
||||
).throw;
|
||||
self
|
||||
}
|
||||
else {
|
||||
list_push(self, value)
|
||||
}
|
||||
}
|
||||
|
||||
multi method unshift(List:D: \value) {
|
||||
if nqp::iscont(value) || !(nqp::istype(value, Iterable) || nqp::istype(value, Parcel)) {
|
||||
nqp::p6listitems(self);
|
||||
value.gimme(*) if nqp::istype(value, List); # fixes #121994
|
||||
nqp::istype(value, self.of)
|
||||
?? nqp::unshift($!items, my $ = value)
|
||||
!! X::TypeCheck.new(
|
||||
operation => '.push',
|
||||
expected => self.of,
|
||||
got => value,
|
||||
).throw;
|
||||
self
|
||||
}
|
||||
else {
|
||||
callsame();
|
||||
}
|
||||
}
|
||||
|
||||
multi method unshift(List:D: *@values) {
|
||||
fail 'Cannot .unshift an infinite list' if @values.infinite;
|
||||
nqp::p6listitems(self);
|
||||
|
||||
# don't bother with type checks
|
||||
my $of := self.of;
|
||||
if ( $of =:= Mu ) {
|
||||
nqp::unshift($!items, @values.pop) while @values;
|
||||
}
|
||||
|
||||
# we must check types
|
||||
else {
|
||||
while @values {
|
||||
my $value := @values.pop;
|
||||
if nqp::istype($value, $of) {
|
||||
nqp::unshift($!items, $value);
|
||||
}
|
||||
|
||||
# huh?
|
||||
else {
|
||||
X::TypeCheck.new(
|
||||
operation => '.unshift',
|
||||
expected => $of,
|
||||
got => $value,
|
||||
).throw;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
self
|
||||
}
|
||||
|
||||
method plan(List:D: |args) {
|
||||
nqp::p6listitems(self);
|
||||
my $elems = self.gimme(*);
|
||||
fail 'Cannot add plan to an infinite list' if $!nextiter.defined;
|
||||
|
||||
# # need type checks?
|
||||
# my $of := self.of;
|
||||
#
|
||||
# unless $of =:= Mu {
|
||||
# X::TypeCheck.new(
|
||||
# operation => '.push',
|
||||
# expected => $of,
|
||||
# got => $_,
|
||||
# ).throw unless nqp::istype($_, $of) for @values;
|
||||
# }
|
||||
|
||||
nqp::bindattr(self, List, '$!nextiter', nqp::p6listiter(nqp::list(args.list), self));
|
||||
Nil;
|
||||
}
|
||||
|
||||
proto method roll(|) { * }
|
||||
multi method roll() {
|
||||
fail "Cannot .roll from infinite list" if self.infinite;
|
||||
my $elems = self.elems;
|
||||
$elems ?? self.at_pos($elems.rand.floor) !! Nil;
|
||||
}
|
||||
multi method roll($n is copy) {
|
||||
fail "Cannot .roll from infinite list" if self.infinite;
|
||||
my $elems = self.elems;
|
||||
return unless $elems;
|
||||
$n = Inf if nqp::istype($n, Whatever);
|
||||
return self.at_pos($elems.rand.floor) if $n == 1;
|
||||
|
||||
gather while $n > 0 {
|
||||
take nqp::atpos($!items, nqp::unbox_i($elems.rand.floor.Int));
|
||||
$n--;
|
||||
}
|
||||
}
|
||||
|
||||
method reverse() {
|
||||
self.gimme(*);
|
||||
fail 'Cannot .reverse from an infinite list' if $!nextiter.defined;
|
||||
my Mu $rev := nqp::list();
|
||||
my Mu $orig := nqp::clone($!items);
|
||||
nqp::push($rev, nqp::pop($orig)) while $orig;
|
||||
my $rlist := nqp::create(self.WHAT);
|
||||
nqp::bindattr($rlist, List, '$!items', $rev);
|
||||
$rlist;
|
||||
}
|
||||
|
||||
method rotate(Int $n is copy = 1) {
|
||||
self.gimme(*);
|
||||
fail 'Cannot .rotate an infinite list' if $!nextiter.defined;
|
||||
my $items = nqp::p6box_i(nqp::elems($!items));
|
||||
return self if !$items;
|
||||
|
||||
$n %= $items;
|
||||
return self if $n == 0;
|
||||
|
||||
my Mu $res := nqp::clone($!items);
|
||||
if $n > 0 {
|
||||
nqp::push($res, nqp::shift($res)) while $n--;
|
||||
}
|
||||
elsif $n < 0 {
|
||||
nqp::unshift($res, nqp::pop($res)) while $n++;
|
||||
}
|
||||
my $rlist := nqp::create(self.WHAT);
|
||||
nqp::bindattr($rlist, List, '$!items', $res);
|
||||
$rlist;
|
||||
}
|
||||
|
||||
method splice($offset = 0, $size?, *@values) {
|
||||
self.gimme(*);
|
||||
my $o = $offset;
|
||||
my $s = $size;
|
||||
my $elems = self.elems;
|
||||
$o = $o($elems) if nqp::istype($o, Callable);
|
||||
X::OutOfRange.new(
|
||||
what => 'offset argument to List.splice',
|
||||
got => $offset,
|
||||
range => (0..^self.elems),
|
||||
).fail if $o < 0;
|
||||
$s //= self.elems - ($o min $elems);
|
||||
$s = $s(self.elems - $o) if nqp::istype($s, Callable);
|
||||
X::OutOfRange.new(
|
||||
what => 'size argument to List.splice',
|
||||
got => $size,
|
||||
range => (0..^(self.elems - $o)),
|
||||
).fail if $s < 0;
|
||||
|
||||
my @ret = self[$o..($o + $s - 1)];
|
||||
nqp::splice($!items,
|
||||
nqp::getattr(@values.eager, List, '$!items'),
|
||||
$o.Int, $s.Int);
|
||||
@ret;
|
||||
}
|
||||
|
||||
method sort($by = &infix:<cmp>) {
|
||||
fail 'Cannot .sort an infinite list' if self.infinite; #MMD?
|
||||
|
||||
# Instead of sorting elements directly, we sort a Parcel of
|
||||
# indices from 0..^$list.elems, then use that Parcel as
|
||||
# a slice into self. This is for historical reasons: on
|
||||
# Parrot we delegate to RPA.sort. The JVM implementation
|
||||
# uses a Java collection sort. MoarVM has its sort algorithm
|
||||
# implemented in NQP.
|
||||
|
||||
# nothing to do here
|
||||
my $elems := self.elems;
|
||||
return self if $elems < 2;
|
||||
|
||||
# Range is currently optimized for fast Parcel construction.
|
||||
my $index := Range.new(0, $elems, :excludes-max).reify(*);
|
||||
my Mu $index_rpa := nqp::getattr($index, Parcel, '$!storage');
|
||||
|
||||
# if $by.arity < 2, then we apply the block to the elements
|
||||
# for sorting.
|
||||
if ($by.?count // 2) < 2 {
|
||||
my $list = self.map($by).eager;
|
||||
nqp::p6sort($index_rpa, -> $a, $b { $list.at_pos($a) cmp $list.at_pos($b) || $a <=> $b });
|
||||
}
|
||||
else {
|
||||
my $list = self.eager;
|
||||
nqp::p6sort($index_rpa, -> $a, $b { $by($list.at_pos($a), $list.at_pos($b)) || $a <=> $b });
|
||||
}
|
||||
self[$index];
|
||||
}
|
||||
|
||||
multi method ACCEPTS(List:D: $topic) { self }
|
||||
|
||||
method uniq(|c) {
|
||||
DEPRECATED('unique', |<2014.11 2015.11>);
|
||||
self.unique(|c);
|
||||
}
|
||||
|
||||
proto method unique(|) {*}
|
||||
multi method unique() {
|
||||
my $seen := nqp::hash();
|
||||
my str $target;
|
||||
gather for @.list {
|
||||
$target = nqp::unbox_s($_.WHICH);
|
||||
unless nqp::existskey($seen, $target) {
|
||||
nqp::bindkey($seen, $target, 1);
|
||||
take $_;
|
||||
}
|
||||
}
|
||||
}
|
||||
multi method unique( :&as!, :&with! ) {
|
||||
my @seen = "should be Mu, but doesn't work in settings :-("
|
||||
my Mu $target;
|
||||
gather for @.list {
|
||||
$target = &as($_);
|
||||
if first( { with($target,$_) }, @seen ) =:= Nil {
|
||||
@seen.push($target);
|
||||
take $_;
|
||||
}
|
||||
};
|
||||
}
|
||||
multi method unique( :&as! ) {
|
||||
my $seen := nqp::hash();
|
||||
my str $target;
|
||||
gather for @.list {
|
||||
$target = &as($_).WHICH;
|
||||
unless nqp::existskey($seen, $target) {
|
||||
nqp::bindkey($seen, $target, 1);
|
||||
take $_;
|
||||
}
|
||||
}
|
||||
}
|
||||
multi method unique( :&with! ) {
|
||||
nextwith() if &with === &[===]; # use optimized version
|
||||
|
||||
my @seen; # should be Mu, but doesn't work in settings :-(
|
||||
my Mu $target;
|
||||
gather for @.list {
|
||||
$target := $_;
|
||||
if first( { with($target,$_) }, @seen ) =:= Nil {
|
||||
@seen.push($target);
|
||||
take $_;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
my @secret;
|
||||
proto method squish(|) {*}
|
||||
multi method squish( :&as!, :&with = &[===] ) {
|
||||
my $last = @secret;
|
||||
my str $which;
|
||||
gather for @.list {
|
||||
$which = &as($_).Str;
|
||||
unless with($which,$last) {
|
||||
$last = $which;
|
||||
take $_;
|
||||
}
|
||||
}
|
||||
}
|
||||
multi method squish( :&with = &[===] ) {
|
||||
my $last = @secret;
|
||||
gather for @.list {
|
||||
unless with($_,$last) {
|
||||
$last = $_;
|
||||
take $_;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
proto method rotor(|) {*}
|
||||
multi method rotor(1, 0) { self }
|
||||
multi method rotor($elems = 2, $overlap = 1) {
|
||||
X::OutOfRange.new(
|
||||
what => 'Overlap argument to List.rotor',
|
||||
got => $overlap,
|
||||
range => (0 .. $elems - 1),
|
||||
).fail unless 0 <= $overlap < $elems;
|
||||
X::OutOfRange.new(
|
||||
what => 'Elements argument to List.rotor',
|
||||
got => $elems,
|
||||
range => (0 .. *),
|
||||
).fail unless 0 <= $elems;
|
||||
|
||||
my $finished = 0;
|
||||
gather while $finished + $overlap < self.gimme($finished + $elems) {
|
||||
take item self[$finished ..^ $finished + $elems];
|
||||
$finished += $elems - $overlap
|
||||
}
|
||||
}
|
||||
|
||||
multi method gist(List:D:) {
|
||||
@(self).map( -> $elem {
|
||||
given ++$ {
|
||||
when 101 { '...' }
|
||||
when 102 { last }
|
||||
default { $elem.gist }
|
||||
}
|
||||
} ).join: ' ';
|
||||
}
|
||||
multi method perl(List:D \SELF:) {
|
||||
self.gimme(*);
|
||||
self.Parcel.perl ~ '.list'
|
||||
~ (nqp::iscont(SELF) ?? '.item' !! '')
|
||||
}
|
||||
|
||||
method REIFY(Parcel \parcel, Mu \nextiter) {
|
||||
nqp::splice($!items, nqp::getattr(parcel, Parcel, '$!storage'),
|
||||
nqp::elems($!items), 0);
|
||||
nqp::bindattr(self, List, '$!nextiter', nextiter);
|
||||
parcel
|
||||
}
|
||||
|
||||
method FLATTENABLE_LIST() { self.gimme(*); $!items }
|
||||
method FLATTENABLE_HASH() { nqp::hash() }
|
||||
|
||||
multi method DUMP(List:D: :$indent-step = 4, :%ctx?) {
|
||||
return DUMP(self, :$indent-step) unless %ctx;
|
||||
|
||||
my $flags := ("\x221e" if self.infinite);
|
||||
my Mu $attrs := nqp::list();
|
||||
nqp::push($attrs, '$!flattens');
|
||||
nqp::push($attrs, $!flattens );
|
||||
nqp::push($attrs, '$!items' );
|
||||
nqp::push($attrs, $!items );
|
||||
nqp::push($attrs, '$!nextiter');
|
||||
nqp::push($attrs, $!nextiter );
|
||||
self.DUMP-OBJECT-ATTRS($attrs, :$indent-step, :%ctx, :$flags);
|
||||
}
|
||||
|
||||
multi method keys(List:D:) {
|
||||
self.values.map: { (state $)++ }
|
||||
}
|
||||
multi method kv(List:D:) {
|
||||
gather for self.values {
|
||||
take (state $)++;
|
||||
take-rw $_;
|
||||
}
|
||||
}
|
||||
multi method values(List:D:) {
|
||||
my Mu $rpa := nqp::clone(nqp::p6listitems(self));
|
||||
nqp::push($rpa, $!nextiter) if $!nextiter.defined;
|
||||
nqp::p6list($rpa, List, self.flattens);
|
||||
}
|
||||
multi method pairs(List:D:) {
|
||||
self.values.map: {; (state $)++ => $_ }
|
||||
}
|
||||
|
||||
method reduce(List: &with) {
|
||||
fail('can only reduce with arity 2')
|
||||
unless &with.arity <= 2 <= &with.count;
|
||||
return unless self.DEFINITE;
|
||||
my \vals = self.values;
|
||||
my Mu $val = vals.shift;
|
||||
$val = with($val, $_) for vals;
|
||||
$val;
|
||||
}
|
||||
|
||||
method sink() {
|
||||
self.gimme(*, :sink) if self.DEFINITE && $!nextiter.DEFINITE;
|
||||
Nil;
|
||||
}
|
||||
|
||||
# this is a remnant of a previous implementation of .push(), which
|
||||
# apparently is used by LoL. Please remove when no longer necessary.
|
||||
method STORE_AT_POS(Int \pos, Mu \v) is rw {
|
||||
nqp::bindpos($!items, nqp::unbox_i(pos), v)
|
||||
}
|
||||
|
||||
proto method combinations($?) {*}
|
||||
multi method combinations( Int $of ) {
|
||||
([self[@$_]] for combinations(self.elems, $of).eager)
|
||||
}
|
||||
multi method combinations( Range $of = 0 .. * ) {
|
||||
gather for @$of {
|
||||
last if $_ > self.elems;
|
||||
take self.combinations($_);
|
||||
}
|
||||
}
|
||||
|
||||
method permutations() {
|
||||
# need block on Moar because of RT#121830
|
||||
gather { take [self[@$_]] for permutations(self.elems).eager }
|
||||
}
|
||||
}
|
||||
|
||||
sub eager(|) {
|
||||
nqp::p6parcel(nqp::p6argvmarray(), Any).eager
|
||||
}
|
||||
|
||||
sub flat(|) {
|
||||
nqp::p6list(nqp::p6argvmarray(), List, Bool::True)
|
||||
}
|
||||
|
||||
sub list(|) {
|
||||
nqp::p6list(nqp::p6argvmarray(), List, Mu)
|
||||
}
|
||||
|
||||
proto sub infix:<xx>(|) { * }
|
||||
multi sub infix:<xx>() { fail "No zero-arg meaning for infix:<xx>" }
|
||||
multi sub infix:<xx>(Mu \x) {x }
|
||||
multi sub infix:<xx>(Mu \x, $n is copy, :$thunked!) {
|
||||
$n = nqp::p6bool(nqp::istype($n, Whatever)) ?? Inf !! $n.Int;
|
||||
GatherIter.new({ take x.() while --$n >= 0; }, :infinite($n == Inf)).list
|
||||
}
|
||||
multi sub infix:<xx>(Mu \x, Whatever, :$thunked!) {
|
||||
GatherIter.new({ loop { take x.() } }, :infinite(True)).flat
|
||||
}
|
||||
multi sub infix:<xx>(Mu \x, Whatever) {
|
||||
GatherIter.new({ loop { take x } }, :infinite(True)).flat
|
||||
}
|
||||
multi sub infix:<xx>(Mu \x, $n) {
|
||||
my int $size = $n.Int;
|
||||
|
||||
my Mu $rpa := nqp::list();
|
||||
if $size > 0 {
|
||||
nqp::setelems($rpa, $size);
|
||||
nqp::setelems($rpa, 0);
|
||||
|
||||
$size = $size + 1;
|
||||
nqp::push($rpa,x) while $size = $size - 1;
|
||||
}
|
||||
|
||||
nqp::p6parcel($rpa, Any);
|
||||
}
|
||||
|
||||
proto sub pop(@) {*}
|
||||
multi sub pop(@a) { @a.pop }
|
||||
|
||||
proto sub shift(@) {*}
|
||||
multi sub shift(@a) { @a.shift }
|
||||
|
||||
proto sub unshift(|) {*}
|
||||
multi sub unshift(\a, \elem) { a.unshift: elem }
|
||||
multi sub unshift(\a, *@elems) { a.unshift: @elems }
|
||||
|
||||
proto sub push(|) {*}
|
||||
multi sub push(\a, \elem) { a.push: elem }
|
||||
multi sub push(\a, *@elems) { a.push: @elems }
|
||||
|
||||
sub reverse(*@a) { @a.reverse }
|
||||
sub rotate(@a, Int $n = 1) { @a.rotate($n) }
|
||||
sub reduce (&with, *@list) { @list.reduce(&with) }
|
||||
sub splice(@arr, $offset = 0, $size?, *@values) {
|
||||
@arr.splice($offset, $size, @values)
|
||||
}
|
||||
|
||||
multi sub infix:<cmp>(@a, @b) { (@a Zcmp @b).first(&prefix:<?>) || @a <=> @b }
|
||||
|
||||
# vim: ft=perl6 expandtab sw=4
|
||||
146
samples/Perl 6/Model.pm
Normal file
146
samples/Perl 6/Model.pm
Normal file
@@ -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
|
||||
23
samples/Perl 6/RoleQ.pm6
Normal file
23
samples/Perl 6/RoleQ.pm6
Normal file
@@ -0,0 +1,23 @@
|
||||
role q {
|
||||
token stopper { \' }
|
||||
|
||||
token escape:sym<\\> { <sym> <item=.backslash> }
|
||||
|
||||
token backslash:sym<qq> { <?before 'q'> <quote=.LANG('MAIN','quote')> }
|
||||
token backslash:sym<\\> { <text=.sym> }
|
||||
token backslash:sym<stopper> { <text=.stopper> }
|
||||
|
||||
token backslash:sym<miscq> { {} . }
|
||||
|
||||
method tweak_q($v) { self.panic("Too late for :q") }
|
||||
method tweak_qq($v) { self.panic("Too late for :qq") }
|
||||
}
|
||||
|
||||
role qq does b1 does c1 does s1 does a1 does h1 does f1 {
|
||||
token stopper { \" }
|
||||
token backslash:sym<unrec> { {} (\w) { self.throw_unrecog_backslash_seq: $/[0].Str } }
|
||||
token backslash:sym<misc> { \W }
|
||||
|
||||
method tweak_q($v) { self.panic("Too late for :q") }
|
||||
method tweak_qq($v) { self.panic("Too late for :qq") }
|
||||
}
|
||||
317
samples/Perl 6/Simple.pm
Normal file
317
samples/Perl 6/Simple.pm
Normal file
@@ -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;
|
||||
}
|
||||
|
||||
207
samples/Perl 6/Win32.pm
Normal file
207
samples/Perl 6/Win32.pm
Normal file
@@ -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;
|
||||
}
|
||||
}
|
||||
}
|
||||
75
samples/Perl 6/advent2009-day16.t
Normal file
75
samples/Perl 6/advent2009-day16.t
Normal file
@@ -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;
|
||||
48
samples/Perl 6/basic-open.t
Normal file
48
samples/Perl 6/basic-open.t
Normal file
@@ -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
|
||||
209
samples/Perl 6/calendar.t
Normal file
209
samples/Perl 6/calendar.t
Normal file
@@ -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
|
||||
586
samples/Perl 6/for.t
Normal file
586
samples/Perl 6/for.t
Normal file
@@ -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
|
||||
22
samples/Perl 6/grammar-test.p6
Normal file
22
samples/Perl 6/grammar-test.p6
Normal file
@@ -0,0 +1,22 @@
|
||||
token pod_formatting_code {
|
||||
$<code>=<[A..Z]>
|
||||
'<' { $*POD_IN_FORMATTINGCODE := 1 }
|
||||
$<content>=[ <!before '>'> <pod_string_character> ]+
|
||||
'>' { $*POD_IN_FORMATTINGCODE := 0 }
|
||||
}
|
||||
|
||||
token pod_string {
|
||||
<pod_string_character>+
|
||||
}
|
||||
|
||||
token something:sym«<» {
|
||||
<!>
|
||||
}
|
||||
|
||||
token name {
|
||||
<!>
|
||||
}
|
||||
|
||||
token comment:sym<#> {
|
||||
'#' {} \N*
|
||||
}
|
||||
75
samples/Perl 6/hash.t
Normal file
75
samples/Perl 6/hash.t
Normal file
@@ -0,0 +1,75 @@
|
||||
use v6;
|
||||
|
||||
use Test;
|
||||
|
||||
plan(5);
|
||||
|
||||
unless EVAL 'EVAL("1", :lang<perl5>)' {
|
||||
skip_rest;
|
||||
exit;
|
||||
}
|
||||
|
||||
die unless
|
||||
EVAL(q/
|
||||
package My::Hash;
|
||||
|
||||
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
|
||||
630
samples/Perl 6/htmlify.pl
Executable file
630
samples/Perl 6/htmlify.pl
Executable file
@@ -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>
|
||||
];
|
||||
}
|
||||
76
samples/Perl 6/listquote-whitespace.t
Normal file
76
samples/Perl 6/listquote-whitespace.t
Normal file
@@ -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
|
||||
32
samples/Perl 6/man-or-boy.t
Normal file
32
samples/Perl 6/man-or-boy.t
Normal file
@@ -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
|
||||
232
samples/Perl 6/test.p6
Normal file
232
samples/Perl 6/test.p6
Normal file
@@ -0,0 +1,232 @@
|
||||
#!/usr/bin/env perl6
|
||||
|
||||
use v6;
|
||||
|
||||
my $string = 'I look like a # comment!';
|
||||
|
||||
if $string eq 'foo' {
|
||||
say 'hello';
|
||||
}
|
||||
|
||||
regex http-verb {
|
||||
'GET'
|
||||
| 'POST'
|
||||
| 'PUT'
|
||||
| 'DELETE'
|
||||
| 'TRACE'
|
||||
| 'OPTIONS'
|
||||
| 'HEAD'
|
||||
}
|
||||
|
||||
# a sample comment
|
||||
|
||||
say 'Hello from Perl 6!'
|
||||
|
||||
|
||||
#`{
|
||||
multi-line comment!
|
||||
}
|
||||
|
||||
say 'here';
|
||||
|
||||
#`(
|
||||
multi-line comment!
|
||||
)
|
||||
|
||||
say 'here';
|
||||
|
||||
#`{{{
|
||||
I'm a special comment!
|
||||
}}}
|
||||
|
||||
say 'there';
|
||||
|
||||
#`{{
|
||||
I'm { even } specialer!
|
||||
}}
|
||||
|
||||
say 'there';
|
||||
|
||||
#`{{
|
||||
does {{nesting}} work?
|
||||
}}
|
||||
|
||||
#`«<
|
||||
trying mixed delimiters
|
||||
»
|
||||
|
||||
my $string = qq<Hooray, arbitrary delimiter!>;
|
||||
my $string = qq«Hooray, arbitrary delimiter!»;
|
||||
my $string = q <now with whitespace!>;
|
||||
my $string = qq<<more strings>>;
|
||||
|
||||
my %hash := Hash.new;
|
||||
|
||||
=begin pod
|
||||
|
||||
Here's some POD! Wooo
|
||||
|
||||
=end pod
|
||||
|
||||
=for Testing
|
||||
This is POD (see? role isn't highlighted)
|
||||
|
||||
say('this is not!');
|
||||
|
||||
say 'Moar code!';
|
||||
|
||||
my $don't = 16;
|
||||
|
||||
sub don't($x) {
|
||||
!$x
|
||||
}
|
||||
|
||||
say don't 'foo';
|
||||
|
||||
my %hash = (
|
||||
:foo(1),
|
||||
);
|
||||
|
||||
say %hash<foo>;
|
||||
say %hash<<foo>>;
|
||||
say %hash«foo»;
|
||||
|
||||
say %*hash<foo>;
|
||||
say %*hash<<foo>>;
|
||||
say %*hash«foo»;
|
||||
|
||||
say $<todo>;
|
||||
say $<todo>;
|
||||
|
||||
for (@A Z @B) -> $a, $b {
|
||||
say $a + $b;
|
||||
}
|
||||
|
||||
Q:PIR {
|
||||
.loadlib "somelib"
|
||||
}
|
||||
|
||||
my $longstring = q/
|
||||
lots
|
||||
of
|
||||
text
|
||||
/;
|
||||
|
||||
my $heredoc = q:to/END_SQL/;
|
||||
SELECT * FROM Users
|
||||
WHERE first_name = 'Rob'
|
||||
END_SQL
|
||||
my $hello;
|
||||
|
||||
# Fun with regexen
|
||||
|
||||
if 'food' ~~ /foo/ {
|
||||
say 'match!'
|
||||
}
|
||||
|
||||
my $re = /foo/;
|
||||
my $re2 = m/ foo /;
|
||||
my $re3 = m:i/ FOO /;
|
||||
|
||||
call-a-sub(/ foo /);
|
||||
call-a-sub(/ foo \/ bar /);
|
||||
|
||||
my $re4 = rx/something | something-else/;
|
||||
my $result = ms/regexy stuff/;
|
||||
my $sub0 = s/regexy stuff/more stuff/;
|
||||
my $sub = ss/regexy stuff/more stuff/;
|
||||
my $trans = tr/regexy stuff/more stuff/;
|
||||
|
||||
my @values = <a b c d>;
|
||||
call-sub(<a b c d>);
|
||||
call-sub <a b c d>;
|
||||
|
||||
my $result = $a < $b;
|
||||
|
||||
for <a b c d> -> $letter {
|
||||
say $letter;
|
||||
}
|
||||
|
||||
sub test-sub {
|
||||
say @_;
|
||||
say $!;
|
||||
say $/;
|
||||
say $0;
|
||||
say $1;
|
||||
say @*ARGS;
|
||||
say $*ARGFILES;
|
||||
say &?BLOCK;
|
||||
say ::?CLASS;
|
||||
say $?CLASS;
|
||||
say @=COMMENT;
|
||||
say %?CONFIG;
|
||||
say $*CWD;
|
||||
say $=data;
|
||||
say %?DEEPMAGIC;
|
||||
say $?DISTRO;
|
||||
say $*DISTRO;
|
||||
say $*EGID;
|
||||
say %*ENV;
|
||||
say $*ERR;
|
||||
say $*EUID;
|
||||
say $*EXECUTABLE_NAME;
|
||||
say $?FILE;
|
||||
say $?GRAMMAR;
|
||||
say $*GID;
|
||||
say $*IN;
|
||||
say @*INC;
|
||||
say %?LANG;
|
||||
say $*LANG;
|
||||
say $?LINE;
|
||||
say %*META-ARGS;
|
||||
say $?MODULE;
|
||||
say %*OPTS;
|
||||
say %*OPT;
|
||||
say $?KERNEL;
|
||||
say $*KERNEL;
|
||||
say $*OUT;
|
||||
say $?PACKAGE;
|
||||
say $?PERL;
|
||||
say $*PERL;
|
||||
say $*PID;
|
||||
say %=pod;
|
||||
say $*PROGRAM_NAME;
|
||||
say %*PROTOCOLS;
|
||||
say ::?ROLE;
|
||||
say $?ROLE;
|
||||
say &?ROUTINE;
|
||||
say $?SCOPE;
|
||||
say $*TZ;
|
||||
say $*UID;
|
||||
say $?USAGE;
|
||||
say $?VM;
|
||||
say $?XVM;
|
||||
}
|
||||
|
||||
say <a b c>;
|
||||
|
||||
my $perl5_re = m:P5/ fo{2} /;
|
||||
my $re5 = rx«something | something-else»;
|
||||
|
||||
my $M := %*COMPILING<%?OPTIONS><M>;
|
||||
|
||||
say $M;
|
||||
|
||||
sub regex-name { ... }
|
||||
my $pair = role-name => 'foo';
|
||||
$pair = rolesque => 'foo';
|
||||
|
||||
my sub something(Str:D $value) { ... }
|
||||
|
||||
my $s = q«<
|
||||
some
|
||||
string
|
||||
stuff
|
||||
»;
|
||||
|
||||
my $regex = m«< some chars »;
|
||||
# after
|
||||
|
||||
say $/<foo><bar>;
|
||||
|
||||
roleq;
|
||||
Reference in New Issue
Block a user