KevinMidboe/linguist
1
0
Fork 0
mirror of https://github.com/KevinMidboe/linguist.git synced 2025-10-29 09:40:21 +00:00
Code Issues Packages Projects Releases Wiki Activity

Merge branch 'master' into cut-release-v4.2.0

Browse Source 
Conflicts:
	grammars.yml
This commit is contained in:
Arfon Smith
2014-12-02 10:57:53 -06:00
parent 5e6fd11cc2 fd9275b213
commit 31d882b07e
24 changed files with 4627 additions and 4 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
grammars.yml
View File

@@ -63,6 +63,8 @@ https://github.com/Varriount/NimLime:
- source.nimrodcfg
https://github.com/alkemist/gradle.tmbundle:
- source.groovy.gradle
https://github.com/ambethia/Sublime-Loom:
- source.loomscript
https://github.com/angryant0007/VBDotNetSyntax:
- source.vbnet
https://github.com/anunayk/cool-tmbundle:

17
lib/linguist/heuristics.rb
View File

@@ -70,8 +70,10 @@ module Linguist
end
end
disambiguate "Perl", "Prolog" do |data|
if data.include?("use strict")
disambiguate "Perl", "Perl6", "Prolog" do |data|
if data.include?("use v6")
Language["Perl6"]
elsif data.include?("use strict")
Language["Perl"]
elsif data.include?(":-")
Language["Prolog"]
@@ -144,6 +146,15 @@ module Linguist
disambiguate "Gosu", "JavaScript" do |data|
Language["Gosu"] if /^uses java\./.match(data)
end
end
disambiguate "LoomScript", "LiveScript" do |data|
if /^\s*package\s*[\w\.\/\*\s]*\s*{/.match(data)
Language["LoomScript"]
else
Language["LiveScript"]
end
end
end
end

11
lib/linguist/languages.yml
View File

@@ -1492,6 +1492,12 @@ LookML:
- .lookml
tm_scope: source.yaml
LoomScript:
type: programming
extensions:
- .ls
tm_scope: source.loomscript
Lua:
type: programming
ace_mode: lua
@@ -1971,14 +1977,17 @@ Perl6:
type: programming
color: "#0298c3"
extensions:
- .p6
- .6pl
- .6pm
- .nqp
- .p6
- .p6l
- .p6m
- .pl
- .pl6
- .pm
- .pm6
- .t
interpreters:
- perl6
tm_scope: none

38
samples/LoomScript/HelloWorld.ls Normal file
View File

@@ -0,0 +1,38 @@
package
{
import loom.Application;
import loom2d.display.StageScaleMode;
import loom2d.ui.SimpleLabel;
/**
The HelloWorld app renders a label with its name on it,
and traces 'hello' to the log.
*/
public class HelloWorld extends Application
{
override public function run():void
{
stage.scaleMode = StageScaleMode.LETTERBOX;
centeredMessage(simpleLabel, this.getFullTypeName());
trace("hello");
}
// a convenience getter that generates a label and adds it to the stage
private function get simpleLabel():SimpleLabel
{
return stage.addChild(new SimpleLabel("assets/Curse-hd.fnt")) as SimpleLabel;
}
// a utility to set the label's text and then center it on the stage
private function centeredMessage(label:SimpleLabel, msg:String):void
{
label.text = msg;
label.center();
label.x = stage.stageWidth / 2;
label.y = (stage.stageHeight / 2) - (label.height / 2);
}
}
}

137
samples/LoomScript/SyntaxExercise.ls Normal file
View File

@@ -0,0 +1,137 @@
package
{
import loom.Application;
public interface I {}
public class C {}
public class B extends C implements I {}
final public class A extends B {}
delegate ToCompute(s:String, o:Object):Number;
public enum Enumeration
{
foo,
baz,
cat,
}
struct P {
public var x:Number = 0;
public var y:Number = 0;
public static operator function =(a:P, b:P):P
{
a.x = b.x;
a.y = b.y;
return a;
}
}
// single-line comment
/*
Multi-line comment
*/
/**
Doc comment
*/
public class SyntaxExercise extends Application
{
static public var classVar:String = 'class variable';
public const CONST:String = 'constant';
private var _a:A = new A();
public var _d:ToCompute;
override public function run():void
{
trace("hello");
}
private function get a():A { return _a; }
private function set a(value:A):void { _a = value; }
private function variousTypes(defaultValue:String = ''):void
{
var nil:Object = null;
var b1:Boolean = true;
var b2:Boolean = false;
var n1:Number = 0.123;
var n2:Number = 12345;
var n3:Number = 0xfed;
var s1:String = 'single-quotes with "quotes" inside';
var s2:String = "double-quotes with 'quotes' inside";
var f1:Function = function (life:String, universe:Object, ...everything):Number { return 42; };
var v1:Vector.<Number> = [1, 2];
var d1:Dictionary.<String, Number> = { 'three': 3, 'four': 4 };
_d += f1;
_d -= f1;
}
private function variousOps():void
{
var a = ((100 + 200 - 0) / 300) % 2;
var b = 100 * 30;
var d = true && (b > 301);
var e = 0x10 | 0x01;
b++; b--;
a += 300; a -= 5; a *= 4; a /= 2; a %= 7;
var castable1:Boolean = (a is B);
var castable2:Boolean = (a as B) != null;
var cast:String = B(a).toString();
var instanced:Boolean = (_a instanceof A);
}
private function variousFlow():void
{
var n:Number = Math.random();
if (n > 0.6)
trace('top 40!');
else if(n > 0.3)
trace('mid 30!');
else
trace('bottom 30');
var flip:String = (Math.random() > 0.5) ? 'heads' : 'tails';
for (var i = 0; i < 100; i++)
trace(i);
var v:Vector.<String> = ['a', 'b', 'c'];
for each (var s:String in v)
trace(s);
var d:Dictionary.<String, Number> = { 'one': 1 };
for (var key1:String in d)
trace(key1);
for (var key2:Number in v)
trace(key2);
while (i > 0)
{
i--;
if (i == 13) continue;
trace(i);
}
do
{
i++;
}
while (i < 10);
switch (Math.floor(Math.random()) * 3 + 1)
{
case 1 : trace('rock'); break;
case 2 : trace('paper'); break;
default: trace('scissors'); break;
}
}
}
}

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

9
samples/Perl6/A.pm Normal file
View 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/Perl6/ANSIColor.pm Normal file
View 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/Perl6/Bailador.pm Normal file
View 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/Perl6/ContainsUnicode.pm Normal file
View File

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

1431
samples/Perl6/Exception.pm Normal file
View File

File diff suppressed because it is too large Load Diff

146
samples/Perl6/Model.pm Normal file
View 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

317
samples/Perl6/Simple.pm Normal file
View 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/Perl6/Win32.pm Normal file
View 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/Perl6/advent2009-day16.t Normal file
View 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/Perl6/basic-open.t Normal file
View 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/Perl6/calendar.t Normal file
View 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/Perl6/for.t Normal file
View 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

76
samples/Perl6/hash.t Normal file
View File

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

630
samples/Perl6/htmlify.pl Executable file
View 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/Perl6/listquote-whitespace.t Normal file
View 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/Perl6/man-or-boy.t Normal file
View 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

7
test/test_heuristics.rb
View File

@@ -122,4 +122,11 @@ class TestHeuristcs < Test::Unit::TestCase
end
end
end
def test_ls_by_heuristics
assert_heuristics({
"LiveScript" => "LiveScript/hello.ls",
"LoomScript" => "LoomScript/HelloWorld.ls"
})
end
end